3589 lines
119 KiB
Perl
3589 lines
119 KiB
Perl
|
# TWiki Enterprise Collaboration Platform, http://TWiki.org/
|
||
|
|
#
|
||
|
|
# Copyright (C) 1999-2007 Peter Thoeny, peter@thoeny.org
|
||
|
|
# and TWiki Contributors. All Rights Reserved. TWiki Contributors
|
||
|
|
# are listed in the AUTHORS file in the root of this distribution.
|
||
|
|
# NOTE: Please extend that file, not this notice.
|
||
|
|
#
|
||
|
|
# Additional copyrights apply to some or all of the code in this
|
||
|
|
# file as follows:
|
||
|
|
#
|
||
|
|
# Based on parts of Ward Cunninghams original Wiki and JosWiki.
|
||
|
|
# Copyright (C) 1998 Markus Peter - SPiN GmbH (warpi@spin.de)
|
||
|
|
# Some changes by Dave Harris (drh@bhresearch.co.uk) incorporated
|
||
|
|
#
|
||
|
|
# This program is free software; you can redistribute it and/or
|
||
|
|
# modify it under the terms of the GNU General Public License
|
||
|
|
# as published by the Free Software Foundation; either version 2
|
||
|
|
# of the License, or (at your option) any later version. For
|
||
|
|
# more details read LICENSE in the root of this distribution.
|
||
|
|
#
|
||
|
|
# This program is distributed in the hope that it will be useful,
|
||
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||
|
|
#
|
||
|
|
# As per the GPL, removal of this notice is prohibited.
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---+ package TWiki
|
||
|
|
|
||
|
|
TWiki operates by creating a singleton object (known as the Session
|
||
|
|
object) that acts as a point of reference for all the different
|
||
|
|
modules in the system. This package is the class for this singleton,
|
||
|
|
and also contains the vast bulk of the basic constants and the per-
|
||
|
|
site configuration mechanisms.
|
||
|
|
|
||
|
|
Global variables are avoided wherever possible to avoid problems
|
||
|
|
with CGI accelerators such as mod_perl.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
package TWiki;
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use Assert;
|
||
|
|
use Error qw( :try );
|
||
|
|
|
||
|
|
require 5.005; # For regex objects and internationalisation
|
||
|
|
|
||
|
|
# Site configuration constants
|
||
|
|
use vars qw( %cfg );
|
||
|
|
|
||
|
|
# Uncomment this and the __END__ to enable AutoLoader
|
||
|
|
#use AutoLoader 'AUTOLOAD';
|
||
|
|
# You then need to autosplit TWiki.pm:
|
||
|
|
# cd lib
|
||
|
|
# perl -e 'use AutoSplit; autosplit("TWiki.pm", "auto")'
|
||
|
|
|
||
|
|
# Other computed constants
|
||
|
|
use vars qw(
|
||
|
|
$TranslationToken
|
||
|
|
$twikiLibDir
|
||
|
|
%regex
|
||
|
|
%constantTags
|
||
|
|
%functionTags
|
||
|
|
%contextFreeSyntax
|
||
|
|
%restDispatch
|
||
|
|
$VERSION $RELEASE
|
||
|
|
$TRUE
|
||
|
|
$FALSE
|
||
|
|
$sharedSandbox
|
||
|
|
);
|
||
|
|
|
||
|
|
# Token character that must not occur in any normal text - converted
|
||
|
|
# to a flag character if it ever does occur (very unlikely)
|
||
|
|
# TWiki uses $TranslationToken to mark points in the text. This is
|
||
|
|
# normally \0, which is not a useful character in any 8-bit character
|
||
|
|
# set we can find, nor in UTF-8. But if you *do* encounter problems
|
||
|
|
# with it, the workaround is to change $TranslationToken to something
|
||
|
|
# longer that is unlikely to occur in your text - for example
|
||
|
|
# muRfleFli5ble8leep (do *not* use punctuation characters or whitspace
|
||
|
|
# in the string!)
|
||
|
|
# See Codev.NationalCharTokenClash for more.
|
||
|
|
$TranslationToken= "\0";
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod getTWikiLibDir() -> $path
|
||
|
|
|
||
|
|
STATIC method.
|
||
|
|
|
||
|
|
Returns the full path of the directory containing TWiki.pm
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub getTWikiLibDir {
|
||
|
|
if( $twikiLibDir ) {
|
||
|
|
return $twikiLibDir;
|
||
|
|
}
|
||
|
|
|
||
|
|
# FIXME: Should just use $INC{"TWiki.pm"} to get path used to load this
|
||
|
|
# module.
|
||
|
|
my $dir = '';
|
||
|
|
foreach $dir ( @INC ) {
|
||
|
|
if( $dir && -e "$dir/TWiki.pm" ) {
|
||
|
|
$twikiLibDir = $dir;
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# fix path relative to location of called script
|
||
|
|
if( $twikiLibDir =~ /^\./ ) {
|
||
|
|
print STDERR "WARNING: TWiki lib path $twikiLibDir is relative; you should make it absolute, otherwise some scripts may not run from the command line.";
|
||
|
|
my $bin;
|
||
|
|
if( $ENV{SCRIPT_FILENAME} &&
|
||
|
|
$ENV{SCRIPT_FILENAME} =~ /^(.+)\/[^\/]+$/ ) {
|
||
|
|
# CGI script name
|
||
|
|
$bin = $1;
|
||
|
|
} elsif ( $0 =~ /^(.*)\/.*?$/ ) {
|
||
|
|
# program name
|
||
|
|
$bin = $1;
|
||
|
|
} else {
|
||
|
|
# last ditch; relative to current directory.
|
||
|
|
require Cwd;
|
||
|
|
import Cwd qw( cwd );
|
||
|
|
$bin = cwd();
|
||
|
|
}
|
||
|
|
$twikiLibDir = "$bin/$twikiLibDir/";
|
||
|
|
# normalize "/../" and "/./"
|
||
|
|
while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) {
|
||
|
|
};
|
||
|
|
$twikiLibDir =~ s|([\\/])\.[\\/]|$1|g;
|
||
|
|
}
|
||
|
|
$twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/"
|
||
|
|
$twikiLibDir =~ s|[\\/]$||; # cut trailing "/"
|
||
|
|
|
||
|
|
return $twikiLibDir;
|
||
|
|
}
|
||
|
|
|
||
|
|
BEGIN {
|
||
|
|
|
||
|
|
use TWiki::Sandbox; # system command sandbox
|
||
|
|
use TWiki::Configure::Load; # read configuration files
|
||
|
|
|
||
|
|
$TRUE = 1;
|
||
|
|
$FALSE = 0;
|
||
|
|
|
||
|
|
if( DEBUG ) {
|
||
|
|
# If ASSERTs are on, then warnings are errors. Paranoid,
|
||
|
|
# but the only way to be sure we eliminate them all.
|
||
|
|
# Look out also for $cfg{WarningsAreErrors}, below, which
|
||
|
|
# is another way to install this handler without enabling
|
||
|
|
# ASSERTs
|
||
|
|
# ASSERTS are turned on by defining the environment variable
|
||
|
|
# TWIKI_ASSERTS. If ASSERTs are off, this is assumed to be a
|
||
|
|
# production environment, and no stack traces or paths are
|
||
|
|
# output to the browser.
|
||
|
|
$SIG{'__WARN__'} = sub { die @_ };
|
||
|
|
$Error::Debug = 1; # verbose stack traces, please
|
||
|
|
} else {
|
||
|
|
$Error::Debug = 0; # no verbose stack traces
|
||
|
|
}
|
||
|
|
|
||
|
|
# DO NOT CHANGE THE FORMAT OF $VERSION
|
||
|
|
# automatically expanded on checkin of this module
|
||
|
|
$VERSION = '$Date: 2007-01-16 05:04:44 +0100 (Tue, 16 Jan 2007) $ $Rev: 12567 $ ';
|
||
|
|
$RELEASE = 'TWiki-4.1.0';
|
||
|
|
$VERSION =~ s/^.*?\((.*)\).*: (\d+) .*?$/$RELEASE, $1, build $2/;
|
||
|
|
|
||
|
|
# Default handlers for different %TAGS%
|
||
|
|
%functionTags = (
|
||
|
|
ALLVARIABLES => \&_ALLVARIABLES,
|
||
|
|
ATTACHURL => \&_ATTACHURL,
|
||
|
|
ATTACHURLPATH => \&_ATTACHURLPATH,
|
||
|
|
DATE => \&_DATE,
|
||
|
|
DISPLAYTIME => \&_DISPLAYTIME,
|
||
|
|
ENCODE => \&_ENCODE,
|
||
|
|
FORMFIELD => \&_FORMFIELD,
|
||
|
|
GMTIME => \&_GMTIME,
|
||
|
|
GROUPS => \&_GROUPS,
|
||
|
|
HTTP_HOST => \&_HTTP_HOST,
|
||
|
|
HTTP => \&_HTTP,
|
||
|
|
HTTPS => \&_HTTPS,
|
||
|
|
ICON => \&_ICON,
|
||
|
|
ICONURL => \&_ICONURL,
|
||
|
|
ICONURLPATH => \&_ICONURLPATH,
|
||
|
|
IF => \&_IF,
|
||
|
|
INCLUDE => \&_INCLUDE,
|
||
|
|
INTURLENCODE => \&_INTURLENCODE,
|
||
|
|
LANGUAGES => \&_LANGUAGES,
|
||
|
|
MAKETEXT => \&_MAKETEXT,
|
||
|
|
META => \&_META,
|
||
|
|
METASEARCH => \&_METASEARCH,
|
||
|
|
NOP => \&_NOP,
|
||
|
|
PLUGINVERSION => \&_PLUGINVERSION,
|
||
|
|
PUBURL => \&_PUBURL,
|
||
|
|
PUBURLPATH => \&_PUBURLPATH,
|
||
|
|
QUERYPARAMS => \&_QUERYPARAMS,
|
||
|
|
QUERYSTRING => \&_QUERYSTRING,
|
||
|
|
RELATIVETOPICPATH => \&_RELATIVETOPICPATH,
|
||
|
|
REMOTE_ADDR => \&_REMOTE_ADDR,
|
||
|
|
REMOTE_PORT => \&_REMOTE_PORT,
|
||
|
|
REMOTE_USER => \&_REMOTE_USER,
|
||
|
|
REVINFO => \&_REVINFO,
|
||
|
|
SCRIPTNAME => \&_SCRIPTNAME,
|
||
|
|
SCRIPTURL => \&_SCRIPTURL,
|
||
|
|
SCRIPTURLPATH => \&_SCRIPTURLPATH,
|
||
|
|
SEARCH => \&_SEARCH,
|
||
|
|
SEP => \&_SEP,
|
||
|
|
SERVERTIME => \&_SERVERTIME,
|
||
|
|
SPACEDTOPIC => \&_SPACEDTOPIC, # deprecated, use SPACEOUT
|
||
|
|
SPACEOUT => \&_SPACEOUT,
|
||
|
|
'TMPL:P' => \&_TMPLP,
|
||
|
|
TOPICLIST => \&_TOPICLIST,
|
||
|
|
URLENCODE => \&_ENCODE,
|
||
|
|
URLPARAM => \&_URLPARAM,
|
||
|
|
LANGUAGE => \&_LANGUAGE,
|
||
|
|
USERINFO => \&_USERINFO,
|
||
|
|
USERNAME => \&_USERNAME_deprecated,
|
||
|
|
VAR => \&_VAR,
|
||
|
|
WEBLIST => \&_WEBLIST,
|
||
|
|
WIKINAME => \&_WIKINAME_deprecated,
|
||
|
|
WIKIUSERNAME => \&_WIKIUSERNAME_deprecated
|
||
|
|
);
|
||
|
|
$contextFreeSyntax{IF} = 1;
|
||
|
|
|
||
|
|
# Constant tag strings _not_ dependent on config
|
||
|
|
%constantTags = (
|
||
|
|
ENDSECTION => '',
|
||
|
|
WIKIVERSION => $VERSION,
|
||
|
|
STARTSECTION => '',
|
||
|
|
|
||
|
|
STARTINCLUDE => '',
|
||
|
|
STOPINCLUDE => '',
|
||
|
|
);
|
||
|
|
|
||
|
|
unless( ( $TWiki::cfg{DetailedOS} = $^O ) ) {
|
||
|
|
require Config;
|
||
|
|
$TWiki::cfg{DetailedOS} = $Config::Config{'osname'};
|
||
|
|
}
|
||
|
|
$TWiki::cfg{OS} = 'UNIX';
|
||
|
|
if ($TWiki::cfg{DetailedOS} =~ /darwin/i) { # MacOS X
|
||
|
|
$TWiki::cfg{OS} = 'UNIX';
|
||
|
|
} elsif ($TWiki::cfg{DetailedOS} =~ /Win/i) {
|
||
|
|
$TWiki::cfg{OS} = 'WINDOWS';
|
||
|
|
} elsif ($TWiki::cfg{DetailedOS} =~ /vms/i) {
|
||
|
|
$TWiki::cfg{OS} = 'VMS';
|
||
|
|
} elsif ($TWiki::cfg{DetailedOS} =~ /bsdos/i) {
|
||
|
|
$TWiki::cfg{OS} = 'UNIX';
|
||
|
|
} elsif ($TWiki::cfg{DetailedOS} =~ /dos/i) {
|
||
|
|
$TWiki::cfg{OS} = 'DOS';
|
||
|
|
} elsif ($TWiki::cfg{DetailedOS} =~ /^MacOS$/i) { # MacOS 9 or earlier
|
||
|
|
$TWiki::cfg{OS} = 'MACINTOSH';
|
||
|
|
} elsif ($TWiki::cfg{DetailedOS} =~ /os2/i) {
|
||
|
|
$TWiki::cfg{OS} = 'OS2';
|
||
|
|
}
|
||
|
|
|
||
|
|
# Validate and untaint Apache's SERVER_NAME Environment variable
|
||
|
|
# for use in referencing virtualhost-based paths for separate data/ and templates/ instances, etc
|
||
|
|
if ( $ENV{SERVER_NAME} &&
|
||
|
|
$ENV{SERVER_NAME} =~ /^(([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6})$/ ) {
|
||
|
|
$ENV{SERVER_NAME} =
|
||
|
|
TWiki::Sandbox::untaintUnchecked( $ENV{SERVER_NAME} );
|
||
|
|
}
|
||
|
|
|
||
|
|
# readConfig is defined in TWiki::Configure::Load to allow overriding it
|
||
|
|
TWiki::Configure::Load::readConfig();
|
||
|
|
|
||
|
|
if( $TWiki::cfg{WarningsAreErrors} ) {
|
||
|
|
# Note: Warnings are always errors if ASSERTs are enabled
|
||
|
|
$SIG{'__WARN__'} = sub { die @_ };
|
||
|
|
}
|
||
|
|
|
||
|
|
if( $TWiki::cfg{UseLocale} ) {
|
||
|
|
require locale;
|
||
|
|
import locale();
|
||
|
|
}
|
||
|
|
|
||
|
|
# Constant tags dependent on the config
|
||
|
|
$constantTags{AUTHREALM} = $TWiki::cfg{AuthRealm};
|
||
|
|
$constantTags{HOMETOPIC} = $TWiki::cfg{HomeTopicName};
|
||
|
|
$constantTags{MAINWEB} = $TWiki::cfg{UsersWebName};
|
||
|
|
$constantTags{TRASHWEB} = $TWiki::cfg{TrashWebName};
|
||
|
|
$constantTags{NOTIFYTOPIC} = $TWiki::cfg{NotifyTopicName};
|
||
|
|
$constantTags{SCRIPTSUFFIX} = $TWiki::cfg{ScriptSuffix};
|
||
|
|
$constantTags{LOCALSITEPREFS} = $TWiki::cfg{LocalSitePreferences};
|
||
|
|
$constantTags{STATISTICSTOPIC} = $TWiki::cfg{Stats}{TopicName};
|
||
|
|
$constantTags{TWIKIWEB} = $TWiki::cfg{SystemWebName};
|
||
|
|
$constantTags{WEBPREFSTOPIC} = $TWiki::cfg{WebPrefsTopicName};
|
||
|
|
$constantTags{DEFAULTURLHOST} = $TWiki::cfg{DefaultUrlHost};
|
||
|
|
$constantTags{WIKIPREFSTOPIC} = $TWiki::cfg{SitePrefsTopicName};
|
||
|
|
$constantTags{WIKIUSERSTOPIC} = $TWiki::cfg{UsersTopicName};
|
||
|
|
$constantTags{WIKIWEBMASTER} = $TWiki::cfg{WebMasterEmail};
|
||
|
|
$constantTags{WIKIWEBMASTERNAME} = $TWiki::cfg{WebMasterName};
|
||
|
|
if( $TWiki::cfg{NoFollow} ) {
|
||
|
|
$constantTags{NOFOLLOW} = 'rel='.$TWiki::cfg{NoFollow};
|
||
|
|
}
|
||
|
|
$constantTags{ALLOWLOGINNAME} = $TWiki::cfg{Register}{AllowLoginName} || 0;
|
||
|
|
|
||
|
|
# locale setup
|
||
|
|
#
|
||
|
|
#
|
||
|
|
# Note that 'use locale' must be done in BEGIN block for regexes and
|
||
|
|
# sorting to
|
||
|
|
# work properly, although regexes can still work without this in
|
||
|
|
# 'non-locale regexes' mode.
|
||
|
|
|
||
|
|
if ( $TWiki::cfg{UseLocale} ) {
|
||
|
|
# Set environment variables for grep
|
||
|
|
$ENV{LC_CTYPE} = $TWiki::cfg{Site}{Locale};
|
||
|
|
|
||
|
|
# Load POSIX for I18N support.
|
||
|
|
require POSIX;
|
||
|
|
import POSIX qw( locale_h LC_CTYPE );
|
||
|
|
|
||
|
|
# SMELL: mod_perl compatibility note: If TWiki is running under Apache,
|
||
|
|
# won't this play with the Apache process's locale settings too?
|
||
|
|
# What effects would this have?
|
||
|
|
setlocale(&LC_CTYPE, $TWiki::cfg{Site}{Locale});
|
||
|
|
}
|
||
|
|
|
||
|
|
$constantTags{CHARSET} = $TWiki::cfg{Site}{CharSet};
|
||
|
|
$constantTags{SHORTLANG} = $TWiki::cfg{Site}{Lang};
|
||
|
|
$constantTags{LANG} = $TWiki::cfg{Site}{FullLang};
|
||
|
|
|
||
|
|
# Set up pre-compiled regexes for use in rendering. All regexes with
|
||
|
|
# unchanging variables in match should use the '/o' option.
|
||
|
|
# In the regex hash, all precompiled REs have "Regex" at the
|
||
|
|
# end of the name. Anything else is a string, either intended
|
||
|
|
# for use as a character class, or as a sub-expression in
|
||
|
|
# another compiled RE.
|
||
|
|
|
||
|
|
# Build up character class components for use in regexes.
|
||
|
|
# Depends on locale mode and Perl version, and finally on
|
||
|
|
# whether locale-based regexes are turned off.
|
||
|
|
if ( not $TWiki::cfg{UseLocale} or $] < 5.006
|
||
|
|
or not $TWiki::cfg{Site}{LocaleRegexes} ) {
|
||
|
|
|
||
|
|
# No locales needed/working, or Perl 5.005, so just use
|
||
|
|
# any additional national characters defined in TWiki.cfg
|
||
|
|
$regex{upperAlpha} = 'A-Z'.$TWiki::cfg{UpperNational};
|
||
|
|
$regex{lowerAlpha} = 'a-z'.$TWiki::cfg{LowerNational};
|
||
|
|
$regex{numeric} = '\d';
|
||
|
|
$regex{mixedAlpha} = $regex{upperAlpha}.$regex{lowerAlpha};
|
||
|
|
} else {
|
||
|
|
# Perl 5.006 or higher with working locales
|
||
|
|
$regex{upperAlpha} = '[:upper:]';
|
||
|
|
$regex{lowerAlpha} = '[:lower:]';
|
||
|
|
$regex{numeric} = '[:digit:]';
|
||
|
|
$regex{mixedAlpha} = '[:alpha:]';
|
||
|
|
}
|
||
|
|
$regex{mixedAlphaNum} = $regex{mixedAlpha}.$regex{numeric};
|
||
|
|
$regex{lowerAlphaNum} = $regex{lowerAlpha}.$regex{numeric};
|
||
|
|
$regex{upperAlphaNum} = $regex{upperAlpha}.$regex{numeric};
|
||
|
|
|
||
|
|
# Compile regexes for efficiency and ease of use
|
||
|
|
# Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl
|
||
|
|
# book at http://regex.info/.
|
||
|
|
|
||
|
|
$regex{linkProtocolPattern} =
|
||
|
|
$TWiki::cfg{LinkProtocolPattern};
|
||
|
|
|
||
|
|
# Header patterns based on '+++'. The '###' are reserved for numbered
|
||
|
|
# headers
|
||
|
|
# '---++ Header', '---## Header'
|
||
|
|
$regex{headerPatternDa} = qr/^---+(\++|\#+)(.*)$/m;
|
||
|
|
# '<h6>Header</h6>
|
||
|
|
$regex{headerPatternHt} = qr/^<h([1-6])>(.+?)<\/h\1>/mi;
|
||
|
|
# '---++!! Header' or '---++ Header %NOTOC% ^top'
|
||
|
|
$regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)';
|
||
|
|
|
||
|
|
# TWiki concept regexes
|
||
|
|
$regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlphaNum}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/o;
|
||
|
|
$regex{webNameBaseRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}_]*/o;
|
||
|
|
$regex{webNameRegex} = qr/$regex{webNameBaseRegex}(?:(?:[\.\/]$regex{webNameBaseRegex})+)*/o;
|
||
|
|
$regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/o;
|
||
|
|
$regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/o;
|
||
|
|
$regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/o;
|
||
|
|
|
||
|
|
# Simplistic email regex, e.g. for WebNotify processing - no i18n
|
||
|
|
# characters allowed
|
||
|
|
$regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_]+\@[A-Za-z0-9\.\-]+)/;
|
||
|
|
|
||
|
|
# Filename regex, for attachments
|
||
|
|
$regex{filenameRegex} = qr/[$regex{mixedAlphaNum}\.]+/o;
|
||
|
|
|
||
|
|
# Multi-character alpha-based regexes
|
||
|
|
$regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/o;
|
||
|
|
|
||
|
|
# %TAG% name
|
||
|
|
$regex{tagNameRegex} = '['.$regex{mixedAlpha}.']['.$regex{mixedAlphaNum}.'_:]*';
|
||
|
|
|
||
|
|
# Set statement in a topic
|
||
|
|
$regex{bulletRegex} = '^(?:\t| )+\*';
|
||
|
|
$regex{setRegex} = $regex{bulletRegex}.'\s+(Set|Local)\s+';
|
||
|
|
$regex{setVarRegex} = $regex{setRegex}.'('.$regex{tagNameRegex}.')\s*=\s*(.*)$';
|
||
|
|
|
||
|
|
# Character encoding regexes
|
||
|
|
|
||
|
|
# 7-bit ASCII only
|
||
|
|
$regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o;
|
||
|
|
|
||
|
|
# Regex to match only a valid UTF-8 character, taking care to avoid
|
||
|
|
# security holes due to overlong encodings by excluding the relevant
|
||
|
|
# gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode
|
||
|
|
# Encodings section. Tested against Markus Kuhn's UTF-8 test file
|
||
|
|
# at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
|
||
|
|
$regex{validUtf8CharRegex} = qr{
|
||
|
|
# Single byte - ASCII
|
||
|
|
[\x00-\x7F]
|
||
|
|
|
|
||
|
|
|
||
|
|
# 2 bytes
|
||
|
|
[\xC2-\xDF][\x80-\xBF]
|
||
|
|
|
|
||
|
|
|
||
|
|
# 3 bytes
|
||
|
|
|
||
|
|
# Avoid illegal codepoints - negative lookahead
|
||
|
|
(?!\xEF\xBF[\xBE\xBF])
|
||
|
|
|
||
|
|
# Match valid codepoints
|
||
|
|
(?:
|
||
|
|
([\xE0][\xA0-\xBF])|
|
||
|
|
([\xE1-\xEC\xEE-\xEF][\x80-\xBF])|
|
||
|
|
([\xED][\x80-\x9F])
|
||
|
|
)
|
||
|
|
[\x80-\xBF]
|
||
|
|
|
|
||
|
|
|
||
|
|
# 4 bytes
|
||
|
|
(?:
|
||
|
|
([\xF0][\x90-\xBF])|
|
||
|
|
([\xF1-\xF3][\x80-\xBF])|
|
||
|
|
([\xF4][\x80-\x8F])
|
||
|
|
)
|
||
|
|
[\x80-\xBF][\x80-\xBF]
|
||
|
|
}xo;
|
||
|
|
|
||
|
|
$regex{validUtf8StringRegex} =
|
||
|
|
qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo;
|
||
|
|
|
||
|
|
# Check for unsafe search regex mode (affects filtering in) - default
|
||
|
|
# to safe mode
|
||
|
|
$TWiki::cfg{ForceUnsafeRegexes} = 0 unless defined $TWiki::cfg{ForceUnsafeRegexes};
|
||
|
|
|
||
|
|
# initialize lib directory early because of later 'cd's
|
||
|
|
getTWikiLibDir();
|
||
|
|
|
||
|
|
# "shared" between mod_perl instances
|
||
|
|
$sharedSandbox = new TWiki::Sandbox(
|
||
|
|
$TWiki::cfg{OS}, $TWiki::cfg{DetailedOS} );
|
||
|
|
};
|
||
|
|
|
||
|
|
use TWiki::Access; # access control
|
||
|
|
use TWiki::Attach; # file attachments
|
||
|
|
use TWiki::Attrs; # tag attribute handling
|
||
|
|
use TWiki::Client; # client session handling
|
||
|
|
use TWiki::Form; # forms
|
||
|
|
use TWiki::Net; # SMTP, get URL
|
||
|
|
use TWiki::Plugins; # plugins handler
|
||
|
|
use TWiki::Prefs; # preferences
|
||
|
|
use TWiki::Render; # HTML generation
|
||
|
|
use TWiki::Search; # search engine
|
||
|
|
use TWiki::Store; # file I/O and rcs related functions
|
||
|
|
use TWiki::Templates; # TWiki template language
|
||
|
|
use TWiki::Time; # date/time conversions
|
||
|
|
use TWiki::Users; # user handler
|
||
|
|
use TWiki::I18N; # i18n handler
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod UTF82SiteCharSet( $utf8 ) -> $ascii
|
||
|
|
|
||
|
|
Auto-detect UTF-8 vs. site charset in string, and convert UTF-8 into site
|
||
|
|
charset.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub UTF82SiteCharSet {
|
||
|
|
my( $this, $text ) = @_;
|
||
|
|
|
||
|
|
# Detect character encoding of the full topic name from URL
|
||
|
|
return undef if( $text =~ $regex{validAsciiStringRegex} );
|
||
|
|
|
||
|
|
# If not UTF-8 - assume in site character set, no conversion required
|
||
|
|
return undef unless( $text =~ $regex{validUtf8StringRegex} );
|
||
|
|
|
||
|
|
# If site charset is already UTF-8, there is no need to convert anything:
|
||
|
|
if ( $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) {
|
||
|
|
# warn if using Perl older than 5.8
|
||
|
|
if( $] < 5.008 ) {
|
||
|
|
$this->writeWarning( 'UTF-8 not supported on Perl '.$].
|
||
|
|
' - use Perl 5.8 or higher..' );
|
||
|
|
}
|
||
|
|
|
||
|
|
# SMELL: is this true yet?
|
||
|
|
$this->writeWarning( 'UTF-8 not yet supported as site charset -'.
|
||
|
|
'TWiki is likely to have problems' );
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Convert into ISO-8859-1 if it is the site charset
|
||
|
|
if ( $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?15?$/i ) {
|
||
|
|
# ISO-8859-1 maps onto first 256 codepoints of Unicode
|
||
|
|
# (conversion from 'perldoc perluniintro')
|
||
|
|
$text =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) /
|
||
|
|
chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F )
|
||
|
|
/egx;
|
||
|
|
} else {
|
||
|
|
# Convert from UTF-8 into some other site charset
|
||
|
|
if( $] >= 5.008 ) {
|
||
|
|
require Encode;
|
||
|
|
import Encode qw(:fallbacks);
|
||
|
|
# Map $TWiki::cfg{Site}{CharSet} into real encoding name
|
||
|
|
my $charEncoding =
|
||
|
|
Encode::resolve_alias( $TWiki::cfg{Site}{CharSet} );
|
||
|
|
if( not $charEncoding ) {
|
||
|
|
$this->writeWarning
|
||
|
|
( 'Conversion to "'.$TWiki::cfg{Site}{CharSet}.
|
||
|
|
'" not supported, or name not recognised - check '.
|
||
|
|
'"perldoc Encode::Supported"' );
|
||
|
|
} else {
|
||
|
|
# Convert text using Encode:
|
||
|
|
# - first, convert from UTF8 bytes into internal
|
||
|
|
# (UTF-8) characters
|
||
|
|
$text = Encode::decode('utf8', $text);
|
||
|
|
# - then convert into site charset from internal UTF-8,
|
||
|
|
# inserting \x{NNNN} for characters that can't be converted
|
||
|
|
$text =
|
||
|
|
Encode::encode( $charEncoding, $text,
|
||
|
|
&FB_PERLQQ() );
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
require Unicode::MapUTF8; # Pre-5.8 Perl versions
|
||
|
|
my $charEncoding = $TWiki::cfg{Site}{CharSet};
|
||
|
|
if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) {
|
||
|
|
$this->writeWarning
|
||
|
|
( 'Conversion to "'.$TWiki::cfg{Site}{CharSet}.
|
||
|
|
'" not supported, or name not recognised - check '.
|
||
|
|
'"perldoc Unicode::MapUTF8"' );
|
||
|
|
} else {
|
||
|
|
# Convert text
|
||
|
|
$text =
|
||
|
|
Unicode::MapUTF8::from_utf8({
|
||
|
|
-string => $text,
|
||
|
|
-charset => $charEncoding
|
||
|
|
});
|
||
|
|
# FIXME: Check for failed conversion?
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod writeCompletePage( $text, $pageType, $contentType )
|
||
|
|
|
||
|
|
Write a complete HTML page with basic header to the browser.
|
||
|
|
* =$text= is the text of the page body (<html> to </html> if it's HTML)
|
||
|
|
* =$pageType= - May be "edit", which will cause headers to be generated that force
|
||
|
|
caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused
|
||
|
|
data loss with IE5 and IE6.
|
||
|
|
* =$contentType= - page content type | text/html
|
||
|
|
|
||
|
|
This method removes noautolink and nop tags before outputting the page unless
|
||
|
|
$contentType is text/plain.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub writeCompletePage {
|
||
|
|
my ( $this, $text, $pageType, $contentType ) = @_;
|
||
|
|
$contentType ||= 'text/html';
|
||
|
|
|
||
|
|
if( $contentType ne 'text/plain' ) {
|
||
|
|
# Remove <nop> and <noautolink> tags
|
||
|
|
$text =~ s/([\t ]?)[ \t]*<\/?(nop|noautolink)\/?>/$1/gis;
|
||
|
|
$text .= "\n" unless $text =~ /\n$/s;
|
||
|
|
|
||
|
|
my $htmlHeader = join(
|
||
|
|
"\n",
|
||
|
|
map { '<!--'.$_.'-->'.$this->{htmlHeaders}{$_} }
|
||
|
|
keys %{$this->{htmlHeaders}} );
|
||
|
|
$text =~ s!(</head>)!$htmlHeader$1!i if $htmlHeader;
|
||
|
|
chomp($text);
|
||
|
|
}
|
||
|
|
|
||
|
|
unless( $this->inContext('command_line')) {
|
||
|
|
# can't use simple length() in case we have UNICODE
|
||
|
|
# see perldoc -f length
|
||
|
|
my $len = do { use bytes; length( $text ); };
|
||
|
|
$this->writePageHeader( undef, $pageType, $contentType, $len );
|
||
|
|
}
|
||
|
|
print $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod writePageHeader( $query, $pageType, $contentType, $contentLength )
|
||
|
|
|
||
|
|
All parameters are optional.
|
||
|
|
|
||
|
|
* =$query= CGI query object | Session CGI query (there is no good reason to set this)
|
||
|
|
* =$pageType= - May be "edit", which will cause headers to be generated that force caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused data loss with IE5 and IE6.
|
||
|
|
* =$contentType= - page content type | text/html
|
||
|
|
* =$contentLength= - content-length | no content-length will be set if this is undefined, as required by HTTP1.1
|
||
|
|
|
||
|
|
Implements the post-Dec2001 release plugin API, which requires the
|
||
|
|
writeHeaderHandler in plugin to return a string of HTTP headers, CR/LF
|
||
|
|
delimited. Filters any illegal headers. Plugin headers will override
|
||
|
|
core settings.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub writePageHeader {
|
||
|
|
my( $this, $query, $pageType, $contentType, $contentLength ) = @_;
|
||
|
|
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
|
||
|
|
$query = $this->{cgiQuery} unless $query;
|
||
|
|
|
||
|
|
# Handle Edit pages - future versions will extend to caching
|
||
|
|
# of other types of page, with expiry time driven by page type.
|
||
|
|
my( $pluginHeaders, $coreHeaders );
|
||
|
|
|
||
|
|
my $hopts = {};
|
||
|
|
|
||
|
|
# Add a content-length if one has been provided. HTTP1.1 says a
|
||
|
|
# content-length should _not_ be specified unless the length is
|
||
|
|
# known. There is a bug in Netscape such that it interprets a
|
||
|
|
# 0 content-length as "download until disconnect" but that is
|
||
|
|
# a bug. The correct way is to not set a content-length.
|
||
|
|
$hopts->{'Content-Length'} = $contentLength if $contentLength;
|
||
|
|
|
||
|
|
if ($pageType && $pageType eq 'edit') {
|
||
|
|
# Get time now in HTTP header format
|
||
|
|
my $lastModifiedString =
|
||
|
|
TWiki::Time::formatTime(time, '$http', 'gmtime');
|
||
|
|
|
||
|
|
# Expiry time is set high to avoid any data loss. Each instance of
|
||
|
|
# Edit page has a unique URL with time-string suffix (fix for
|
||
|
|
# RefreshEditPage), so this long expiry time simply means that the
|
||
|
|
# browser Back button always works. The next Edit on this page
|
||
|
|
# will use another URL and therefore won't use any cached
|
||
|
|
# version of this Edit page.
|
||
|
|
my $expireHours = 24;
|
||
|
|
my $expireSeconds = $expireHours * 60 * 60;
|
||
|
|
|
||
|
|
# and cache control headers, to ensure edit page
|
||
|
|
# is cached until required expiry time.
|
||
|
|
$hopts->{'last-modified'} = $lastModifiedString;
|
||
|
|
$hopts->{expires} = "+${expireHours}h";
|
||
|
|
$hopts->{'cache-control'} = "max-age=$expireSeconds";
|
||
|
|
}
|
||
|
|
|
||
|
|
# DEPRECATED plugins header handler. Plugins should use
|
||
|
|
# modifyHeaderHandler instead.
|
||
|
|
$pluginHeaders = $this->{plugins}->writeHeaderHandler( $query ) || '';
|
||
|
|
if( $pluginHeaders ) {
|
||
|
|
foreach ( split /\r\n/, $pluginHeaders ) {
|
||
|
|
if ( m/^([\-a-z]+): (.*)$/i ) {
|
||
|
|
$hopts->{$1} = $2;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$contentType = 'text/html' unless $contentType;
|
||
|
|
if(defined($TWiki::cfg{Site}{CharSet})) {
|
||
|
|
$contentType .= '; charset='.$TWiki::cfg{Site}{CharSet};
|
||
|
|
}
|
||
|
|
|
||
|
|
# use our version of the content type
|
||
|
|
$hopts->{'Content-Type'} = $contentType;
|
||
|
|
|
||
|
|
# New (since 1.026)
|
||
|
|
$this->{plugins}->modifyHeaderHandler( $hopts, $this->{cgiQuery} );
|
||
|
|
|
||
|
|
# add cookie(s)
|
||
|
|
$this->{loginManager}->modifyHeader( $hopts );
|
||
|
|
|
||
|
|
my $hdr = CGI::header( $hopts );
|
||
|
|
|
||
|
|
print $hdr;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod redirect( $url, $passthrough )
|
||
|
|
|
||
|
|
Redirects the request to =$url=, *unless*
|
||
|
|
1 It is overridden by a plugin declaring a =redirectCgiQueryHandler=.
|
||
|
|
1 =$session->{cgiQuery}= is =undef= or
|
||
|
|
1 $query->param('noredirect') is set to a true value.
|
||
|
|
Thus a redirect is only generated when in a CGI context.
|
||
|
|
|
||
|
|
Normally this method will ignore parameters to the current query.
|
||
|
|
If $passthrough is set, then it will pass all parameters that were passed
|
||
|
|
to the current query on to the redirect target. If the request_method was
|
||
|
|
GET, then all parameters can be passed in the URL. If the
|
||
|
|
request_method was POST then it caches the form data and passes over a
|
||
|
|
cache reference in the redirect GET.
|
||
|
|
|
||
|
|
Passthrough is only meaningful if the redirect target is on the same server.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub redirect {
|
||
|
|
my( $this, $url, $passthru ) = @_;
|
||
|
|
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
|
||
|
|
my $query = $this->{cgiQuery};
|
||
|
|
# if we got here without a query, there's not much more we can do
|
||
|
|
return unless $query;
|
||
|
|
# if noredirect is set, don't generate the redirect, throw an exception instead.
|
||
|
|
# This is a HACK used to support TWikiDrawPlugin. It is deprecated and must be
|
||
|
|
# replaced by REST handlers in the plugin.
|
||
|
|
if( $query->param( 'noredirect' )) {
|
||
|
|
die "ERROR: $url";
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($passthru) {
|
||
|
|
$url =~ s/\?(.*)$//;
|
||
|
|
my $existing = $1;
|
||
|
|
if ($ENV{REQUEST_METHOD} eq 'POST') {
|
||
|
|
# Redirecting from a port to a get
|
||
|
|
my $cache = $this->cacheQuery();
|
||
|
|
if ($cache) {
|
||
|
|
$url .= "?$cache";
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$url .= '?'.$query->query_string();
|
||
|
|
$url .= (($url =~ /\?/) ? ';' : '?').$existing if $existing;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return if( $this->{plugins}->redirectCgiQueryHandler( $query, $url ) );
|
||
|
|
return if( $this->{loginManager}->redirectCgiQuery( $query, $url ) );
|
||
|
|
die "Login manager returned 0 from redirectCgiQuery";
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod cacheQuery() -> $queryString
|
||
|
|
|
||
|
|
Caches the current query in the params cache, and returns a rewritten
|
||
|
|
query string for the cache to be picked up again on the other side of a
|
||
|
|
redirect.
|
||
|
|
|
||
|
|
We can't encode post params into a redirect, because they may exceed the
|
||
|
|
size of the GET request. So we cache the params, and reload them when the
|
||
|
|
redirect target is reached.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cacheQuery {
|
||
|
|
my $this = shift;
|
||
|
|
my $query = $this->{cgiQuery};
|
||
|
|
|
||
|
|
return '' unless (scalar($query->param()));
|
||
|
|
# Don't double-cache
|
||
|
|
return '' if ($query->param('twiki_redirect_cache'));
|
||
|
|
|
||
|
|
require Digest::MD5;
|
||
|
|
my $md5 = new Digest::MD5();
|
||
|
|
$md5->add($$, time(), rand(time));
|
||
|
|
my $uid = $TWiki::cfg{PassthroughDir}.'/passthru_'.$md5->hexdigest();
|
||
|
|
open(F, ">$uid") || die "{PassthroughDir} cache not writable $!";
|
||
|
|
$query->save(\*F);
|
||
|
|
close(F);
|
||
|
|
return 'twiki_redirect_cache='.$uid;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod isValidWikiWord( $name ) -> $boolean
|
||
|
|
|
||
|
|
Check for a valid WikiWord or WikiName
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub isValidWikiWord {
|
||
|
|
my $name = shift || '';
|
||
|
|
return ( $name =~ m/^$regex{wikiWordRegex}$/o )
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod isValidTopicName( $name ) -> $boolean
|
||
|
|
|
||
|
|
Check for a valid topic name
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub isValidTopicName {
|
||
|
|
my( $name ) = @_;
|
||
|
|
|
||
|
|
return isValidWikiWord( @_ ) || isValidAbbrev( @_ );
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod isValidAbbrev( $name ) -> $boolean
|
||
|
|
|
||
|
|
Check for a valid ABBREV (acronym)
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub isValidAbbrev {
|
||
|
|
my $name = shift || '';
|
||
|
|
return ( $name =~ m/^$regex{abbrevRegex}$/o )
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod isValidWebName( $name, $system ) -> $boolean
|
||
|
|
|
||
|
|
STATIC Check for a valid web name. If $system is true, then
|
||
|
|
system web names are considered valid (names starting with _)
|
||
|
|
otherwise only user web names are valid
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub isValidWebName {
|
||
|
|
my $name = shift || '';
|
||
|
|
my $sys = shift;
|
||
|
|
return 1 if ( $sys && $name =~ m/^$regex{defaultWebNameRegex}$/o );
|
||
|
|
return ( $name =~ m/^$regex{webNameRegex}$/o )
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod readOnlyMirrorWeb( $theWeb ) -> ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote )
|
||
|
|
|
||
|
|
If this is a mirrored web, return information about the mirror. The info
|
||
|
|
is returned in a quadruple:
|
||
|
|
|
||
|
|
| site name | URL | link | note |
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub readOnlyMirrorWeb {
|
||
|
|
my( $this, $theWeb ) = @_;
|
||
|
|
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
|
||
|
|
my @mirrorInfo = ( '', '', '', '' );
|
||
|
|
if( $TWiki::cfg{SiteWebTopicName} ) {
|
||
|
|
my $mirrorSiteName =
|
||
|
|
$this->{prefs}->getWebPreferencesValue( 'MIRRORSITENAME', $theWeb );
|
||
|
|
if( $mirrorSiteName && $mirrorSiteName ne $TWiki::cfg{SiteWebTopicName} ) {
|
||
|
|
my $mirrorViewURL =
|
||
|
|
$this->{prefs}->getWebPreferencesValue( 'MIRRORVIEWURL', $theWeb );
|
||
|
|
my $mirrorLink = $this->{templates}->readTemplate( 'mirrorlink' );
|
||
|
|
$mirrorLink =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
|
||
|
|
$mirrorLink =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
|
||
|
|
$mirrorLink =~ s/\s*$//g;
|
||
|
|
my $mirrorNote = $this->{templates}->readTemplate( 'mirrornote' );
|
||
|
|
$mirrorNote =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
|
||
|
|
$mirrorNote =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
|
||
|
|
$mirrorNote = $this->{renderer}->getRenderedVersion
|
||
|
|
( $mirrorNote, $theWeb, $TWiki::cfg{HomeTopic} );
|
||
|
|
$mirrorNote =~ s/\s*$//g;
|
||
|
|
@mirrorInfo = ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return @mirrorInfo;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod getSkin () -> $string
|
||
|
|
|
||
|
|
Get the currently requested skin path
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub getSkin {
|
||
|
|
my $this = shift;
|
||
|
|
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
|
||
|
|
my $skinpath = $this->{prefs}->getPreferencesValue( 'SKIN' ) || '';
|
||
|
|
|
||
|
|
if( $this->{cgiQuery} ) {
|
||
|
|
my $resurface = $this->{cgiQuery}->param( 'skin' );
|
||
|
|
$skinpath = $resurface if $resurface;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $epidermis = $this->{prefs}->getPreferencesValue( 'COVER' );
|
||
|
|
$skinpath = $epidermis.','.$skinpath if $epidermis;
|
||
|
|
|
||
|
|
if( $this->{cgiQuery} ) {
|
||
|
|
$epidermis = $this->{cgiQuery}->param( 'cover' );
|
||
|
|
$skinpath = $epidermis.','.$skinpath if $epidermis;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $skinpath;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod getScriptUrl( $absolute, $script, $web, $topic, ... ) -> $scriptURL
|
||
|
|
|
||
|
|
Returns the URL to a TWiki script, providing the web and topic as
|
||
|
|
"path info" parameters. The result looks something like this:
|
||
|
|
"http://host/twiki/bin/$script/$web/$topic".
|
||
|
|
* =...= - an arbitrary number of name,value parameter pairs that will be url-encoded and added to the url. The special parameter name '#' is reserved for specifying an anchor. e.g. <tt>getScriptUrl('x','y','view','#'=>'XXX',a=>1,b=>2)</tt> will give <tt>.../view/x/y?a=1&b=2#XXX</tt>
|
||
|
|
|
||
|
|
If $absolute is set, generates an absolute URL. $absolute is advisory only;
|
||
|
|
TWiki can decide to generate absolute URLs (for example when run from the
|
||
|
|
command-line) even when relative URLs have been requested.
|
||
|
|
|
||
|
|
The default script url is taken from {ScriptUrlPath}, unless there is
|
||
|
|
an exception defined for the given script in {ScriptUrlPaths}. Both
|
||
|
|
{ScriptUrlPath} and {ScriptUrlPaths} may be absolute or relative URIs. If
|
||
|
|
they are absolute, then they will always generate absolute URLs. if they
|
||
|
|
are relative, then they will be converted to absolute when required (e.g.
|
||
|
|
when running from the command line, or when generating rss). If
|
||
|
|
$script is not given, absolute URLs will always be generated.
|
||
|
|
|
||
|
|
If either the web or the topic is defined, will generate a full url (including web and topic). Otherwise will generate only up to the script name. An undefined web will default to the main web name.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub getScriptUrl {
|
||
|
|
my( $this, $absolute, $script, $web, $topic, @params ) = @_;
|
||
|
|
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
$absolute ||= ($this->inContext( 'command_line' ) ||
|
||
|
|
$this->inContext( 'rss' ) ||
|
||
|
|
$this->inContext( 'absolute_urls' ));
|
||
|
|
|
||
|
|
# SMELL: topics and webs that contain spaces?
|
||
|
|
|
||
|
|
my $url;
|
||
|
|
if( defined $TWiki::cfg{ScriptUrlPaths} && $script) {
|
||
|
|
$url = $TWiki::cfg{ScriptUrlPaths}{$script};
|
||
|
|
}
|
||
|
|
unless( defined( $url )) {
|
||
|
|
$url = $TWiki::cfg{ScriptUrlPath};
|
||
|
|
if( $script ) {
|
||
|
|
$url .= '/' unless $url =~ /\/$/;
|
||
|
|
$url .= $script;
|
||
|
|
$url .= $TWiki::cfg{ScriptSuffix} if $script;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if( $absolute && $url !~ /^[a-z]+:/ ) {
|
||
|
|
# See http://www.ietf.org/rfc/rfc2396.txt for the definition of
|
||
|
|
# "absolute URI". TWiki bastardises this definition by assuming
|
||
|
|
# that all relative URLs lack the <authority> component as well.
|
||
|
|
$url = $this->{urlHost}.$url;
|
||
|
|
}
|
||
|
|
|
||
|
|
if( $web || $topic ) {
|
||
|
|
( $web, $topic ) =
|
||
|
|
$this->normalizeWebTopicName( $web, $topic );
|
||
|
|
|
||
|
|
$url .= urlEncode( '/'.$web.'/'.$topic );
|
||
|
|
|
||
|
|
$url .= _make_params(0, @params);
|
||
|
|
}
|
||
|
|
|
||
|
|
return $url;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _make_params {
|
||
|
|
my ( $notfirst, @args ) = @_;
|
||
|
|
my $url = '';
|
||
|
|
my $ps = '';
|
||
|
|
my $anchor = '';
|
||
|
|
while( my $p = shift @args ) {
|
||
|
|
if( $p eq '#' ) {
|
||
|
|
$anchor .= '#' . shift( @args );
|
||
|
|
} else {
|
||
|
|
$ps .= ';' . $p.'='.urlEncode(shift( @args )||'');
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if( $ps ) {
|
||
|
|
$ps =~ s/^;/?/ unless $notfirst;
|
||
|
|
$url .= $ps;
|
||
|
|
}
|
||
|
|
$url .= $anchor;
|
||
|
|
return $url;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod getPubUrl($absolute, $web, $topic, $attachment) -> $url
|
||
|
|
|
||
|
|
Composes a pub url. If $absolute is set, returns an absolute URL.
|
||
|
|
If $absolute is set, generates an absolute URL. $absolute is advisory only;
|
||
|
|
TWiki can decide to generate absolute URLs (for example when run from the
|
||
|
|
command-line) even when relative URLs have been requested.
|
||
|
|
|
||
|
|
$web, $topic and $attachment are optional. A partial URL path will be
|
||
|
|
generated if one or all is not given.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub getPubUrl {
|
||
|
|
my( $this, $absolute, $web, $topic, $attachment ) = @_;
|
||
|
|
|
||
|
|
$absolute ||= ($this->inContext( 'command_line' ) ||
|
||
|
|
$this->inContext( 'rss' ) ||
|
||
|
|
$this->inContext( 'absolute_urls' ));
|
||
|
|
|
||
|
|
my $url = '';
|
||
|
|
$url .= $TWiki::cfg{PubUrlPath};
|
||
|
|
if( $absolute && $url !~ /^[a-z]+:/ ) {
|
||
|
|
# See http://www.ietf.org/rfc/rfc2396.txt for the definition of
|
||
|
|
# "absolute URI". TWiki bastardises this definition by assuming
|
||
|
|
# that all relative URLs lack the <authority> component as well.
|
||
|
|
$url = $this->{urlHost}.$url;
|
||
|
|
}
|
||
|
|
if( $web || $topic || $attachment ) {
|
||
|
|
( $web, $topic ) =
|
||
|
|
$this->normalizeWebTopicName( $web, $topic );
|
||
|
|
|
||
|
|
my $path = '/'.$web.'/'.$topic;
|
||
|
|
$path .= '/'.$attachment if $attachment;
|
||
|
|
$url .= urlEncode( $path );
|
||
|
|
}
|
||
|
|
|
||
|
|
return $url;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod getIconUrl( $absolute, $iconName ) -> $iconURL
|
||
|
|
|
||
|
|
Map an icon name to a URL path.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub getIconUrl {
|
||
|
|
my( $this, $absolute, $iconName ) = @_;
|
||
|
|
|
||
|
|
my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
|
||
|
|
my( $web, $topic) = $this->normalizeWebTopicName(
|
||
|
|
$this->{webName}, $iconTopic );
|
||
|
|
$iconName =~ s/^.*\.(.*?)$/$1/;
|
||
|
|
return $this->getPubUrl( $absolute, $web, $topic, $iconName.'.gif' );
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod mapToIconFileName( $fileName, $default ) -> $fileName
|
||
|
|
|
||
|
|
Maps from a filename (or just the extension) to the name of the
|
||
|
|
file that contains the image for that file type.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub mapToIconFileName {
|
||
|
|
my( $this, $fileName, $default ) = @_;
|
||
|
|
|
||
|
|
my @bits = ( split( /\./, $fileName ) );
|
||
|
|
my $fileExt = lc $bits[$#bits];
|
||
|
|
|
||
|
|
unless( $this->{_ICONMAP} ) {
|
||
|
|
my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
|
||
|
|
my( $web, $topic) = $this->normalizeWebTopicName(
|
||
|
|
$this->{webName}, $iconTopic );
|
||
|
|
local $/ = undef;
|
||
|
|
try {
|
||
|
|
my $icons = $this->{store}->getAttachmentStream(
|
||
|
|
undef, $web, $topic, '_filetypes.txt' );
|
||
|
|
%{$this->{_ICONMAP}} = split( /\s+/, <$icons> );
|
||
|
|
close( $icons );
|
||
|
|
} catch Error::Simple with {
|
||
|
|
%{$this->{_ICONMAP}} = ();
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
return $this->{_ICONMAP}->{$fileExt} || $default || 'else';
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod getOopsUrl( $template, @options ) -> $absoluteOopsURL
|
||
|
|
|
||
|
|
Composes a URL for an "oops" error page. The @options consists of a list
|
||
|
|
of key => value pairs. The following keys are used:
|
||
|
|
* =-web= - web name
|
||
|
|
* =-topic= - topic name
|
||
|
|
* =-def= - optional template def within the main template file
|
||
|
|
* =-params= - a single parameter, or a reference to an array of parameters These are passed in the URL as '¶m1=' etc.
|
||
|
|
|
||
|
|
Do _not_ include the "oops" part in front of the template name.
|
||
|
|
|
||
|
|
Alternatively you can pass a reference to an OopsException in place of the template. All other parameters will be ignored.
|
||
|
|
|
||
|
|
The returned URL ends up looking something like this:
|
||
|
|
"http://host/twiki/bin/oops/$web/$topic?template=$template¶m1=$scriptParams[0]..."
|
||
|
|
|
||
|
|
Note: if {keep} is true in the params, then they will also be pushed into the
|
||
|
|
current query.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub getOopsUrl {
|
||
|
|
my $this = shift;
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
my $template = shift;
|
||
|
|
my $params;
|
||
|
|
my $keep;
|
||
|
|
my $query;
|
||
|
|
|
||
|
|
if( $template->isa('TWiki::OopsException') ) {
|
||
|
|
# The parameters were provided when the exception was thrown
|
||
|
|
$params = $template;
|
||
|
|
$template = $params->{template};
|
||
|
|
} else {
|
||
|
|
# The params are in the parameter array
|
||
|
|
$params = { @_ };
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($params->{keep}) {
|
||
|
|
$query = $this->{cgiQuery};
|
||
|
|
$keep = 1;
|
||
|
|
}
|
||
|
|
delete($params->{keep});
|
||
|
|
|
||
|
|
my $web = $params->{web} || $this->{webName};
|
||
|
|
my $topic = $params->{topic} || $this->{topicName};
|
||
|
|
my $def = $params->{def};
|
||
|
|
my $PARAMS = $params->{params};
|
||
|
|
|
||
|
|
# Build a query string for the new URL.
|
||
|
|
# Push all URL params into the current query as well if {keep} is
|
||
|
|
# set, because if it is, GET params will be ignored when it is
|
||
|
|
# restored.
|
||
|
|
my @urlParams = ( template => 'oops'.$template );
|
||
|
|
$query->param(-name => "template", -value => 'oops'.$template ) if $keep;
|
||
|
|
|
||
|
|
if ($def) {
|
||
|
|
push( @urlParams, def => $def );
|
||
|
|
$query->param(-name => "def", -value => $def ) if $keep;
|
||
|
|
}
|
||
|
|
|
||
|
|
if( ref($PARAMS) eq "ARRAY" ) {
|
||
|
|
my $n = 1;
|
||
|
|
foreach my $p ( @$PARAMS ) {
|
||
|
|
$p = '' unless defined $p;
|
||
|
|
push( @urlParams, "param$n" => $p );
|
||
|
|
$query->param(-name => "param$n", -value => $p ) if $keep;
|
||
|
|
$n++;
|
||
|
|
}
|
||
|
|
} elsif( defined $PARAMS ) {
|
||
|
|
push( @urlParams, param1 => $PARAMS );
|
||
|
|
$query->param(-name => "param1", -value => $PARAMS ) if $keep;
|
||
|
|
}
|
||
|
|
|
||
|
|
$this->enterContext( 'absolute_urls' );
|
||
|
|
my $url = $this->getScriptUrl( 0, 'oops', $web, $topic, @urlParams );
|
||
|
|
$this->leaveContext( 'absolute_urls' );
|
||
|
|
|
||
|
|
return $url;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod normalizeWebTopicName( $theWeb, $theTopic ) -> ( $theWeb, $theTopic )
|
||
|
|
|
||
|
|
Normalize a Web<nop>.<nop>TopicName
|
||
|
|
|
||
|
|
See TWikiFuncDotPm for a full specification of the expansion (not duplicated here)
|
||
|
|
|
||
|
|
*WARNING* if there is no web specification (in the web or topic parameters) the web
|
||
|
|
defaults to $TWiki::cfg{UsersWebName}. If there is no topic specification, or the topic
|
||
|
|
is '0', the topic defaults to the web home topic name.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub normalizeWebTopicName {
|
||
|
|
my( $this, $web, $topic ) = @_;
|
||
|
|
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
ASSERT(defined $topic) if DEBUG;
|
||
|
|
|
||
|
|
if( $topic =~ m|^(.*)[./](.*?)$| ) {
|
||
|
|
$web = $1;
|
||
|
|
$topic = $2;
|
||
|
|
}
|
||
|
|
$web ||= $cfg{UsersWebName};
|
||
|
|
$topic ||= $cfg{HomeTopicName};
|
||
|
|
$web =~ s/%((MAIN|TWIKI|USERS|SYSTEM|DOC)WEB)%/$this->_expandTagOnTopicRendering($1)||''/e;
|
||
|
|
$web =~ s#\.#/#go;
|
||
|
|
return( $web, $topic );
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ClassMethod new( $loginName, $query, \%initialContext )
|
||
|
|
|
||
|
|
Constructs a new TWiki object. Parameters are taken from the query object.
|
||
|
|
|
||
|
|
* =$loginName= is the username of the user you want to be logged-in if none is
|
||
|
|
available from a session or browser. Used mainly for side scripts and debugging.
|
||
|
|
* =$query= the CGI query (may be undef, in which case an empty query is used)
|
||
|
|
* =\%initialContext= - reference to a hash containing context name=value pairs
|
||
|
|
to be pre-installed in the context hash
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub new {
|
||
|
|
my( $class, $loginName, $query, $initialContext ) = @_;
|
||
|
|
|
||
|
|
$query ||= new CGI( {} );
|
||
|
|
my $this = bless( {}, $class );
|
||
|
|
|
||
|
|
$this->{htmlHeaders} = {};
|
||
|
|
$this->{context} = $initialContext || {};
|
||
|
|
|
||
|
|
# create the various sub-objects
|
||
|
|
$this->{sandbox} = $sharedSandbox;
|
||
|
|
$this->{plugins} = new TWiki::Plugins( $this );
|
||
|
|
$this->{net} = new TWiki::Net( $this );
|
||
|
|
$this->{store} = new TWiki::Store( $this );
|
||
|
|
$this->{search} = new TWiki::Search( $this );
|
||
|
|
$this->{templates} = new TWiki::Templates( $this );
|
||
|
|
$this->{attach} = new TWiki::Attach( $this );
|
||
|
|
$this->{loginManager} = TWiki::Client::makeLoginManager( $this );
|
||
|
|
# cache CGI information in the session object
|
||
|
|
$this->{cgiQuery} = $query;
|
||
|
|
|
||
|
|
$this->{users} = new TWiki::Users( $this );
|
||
|
|
|
||
|
|
# Make %ENV safer, preventing hijack of the search path
|
||
|
|
# SMELL: can this be done in a BEGIN block? Or is the environment
|
||
|
|
# set per-query?
|
||
|
|
if( $TWiki::cfg{SafeEnvPath} ) {
|
||
|
|
$ENV{'PATH'} = $TWiki::cfg{SafeEnvPath};
|
||
|
|
}
|
||
|
|
delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };
|
||
|
|
|
||
|
|
$this->{security} = new TWiki::Access( $this );
|
||
|
|
|
||
|
|
my $web = '';
|
||
|
|
my $topic = $query->param( 'topic' );
|
||
|
|
if( $topic ) {
|
||
|
|
if( $topic =~ /^$regex{linkProtocolPattern}\:\/\//o &&
|
||
|
|
$this->{cgiQuery} ) {
|
||
|
|
# redirect to URI
|
||
|
|
if ($TWiki::cfg{AllowRedirectUrl}) {
|
||
|
|
print $this->redirect( $topic );
|
||
|
|
return;
|
||
|
|
} else {
|
||
|
|
# for security, ignore redirect to URL
|
||
|
|
$topic = '';
|
||
|
|
}
|
||
|
|
} elsif( $topic =~ /((?:.*[\.\/])+)(.*)/ ) {
|
||
|
|
# is 'bin/script?topic=Webname.SomeTopic'
|
||
|
|
$web = $1;
|
||
|
|
$topic = $2;
|
||
|
|
$web =~ s/\./\//go;
|
||
|
|
$web =~ s/\/$//o;
|
||
|
|
# jump to WebHome if 'bin/script?topic=Webname.'
|
||
|
|
$topic = $TWiki::cfg{HomeTopicName} if( $web && ! $topic );
|
||
|
|
}
|
||
|
|
# otherwise assume 'bin/script/Webname?topic=SomeTopic'
|
||
|
|
} else {
|
||
|
|
$topic = '';
|
||
|
|
}
|
||
|
|
|
||
|
|
# SMELL: "The Microsoft Internet Information Server is broken with
|
||
|
|
# respect to additional path information. If you use the Perl DLL
|
||
|
|
# library, the IIS server will attempt to execute the additional
|
||
|
|
# path information as a Perl script. If you use the ordinary file
|
||
|
|
# associations mapping, the path information will be present in the
|
||
|
|
# environment, but incorrect. The best thing to do is to avoid using
|
||
|
|
# additional path information."
|
||
|
|
|
||
|
|
# Clean up PATH_INFO problems, e.g. Support.CobaltRaqInstall. A valid
|
||
|
|
# PATH_INFO is '/Main/WebHome', i.e. the text after the script name;
|
||
|
|
# invalid PATH_INFO is often a full path starting with '/cgi-bin/...'.
|
||
|
|
my $pathInfo = $query->path_info();
|
||
|
|
my $cgiScriptName = $ENV{'SCRIPT_NAME'} || '';
|
||
|
|
$pathInfo =~ s!$cgiScriptName/!/!i;
|
||
|
|
|
||
|
|
# Get the web and topic names from PATH_INFO
|
||
|
|
if( $pathInfo =~ /\/((?:.*[\.\/])+)(.*)/ ) {
|
||
|
|
# is 'bin/script/Webname/SomeTopic' or 'bin/script/Webname/'
|
||
|
|
$web = $1 unless $web;
|
||
|
|
$topic = $2 unless $topic;
|
||
|
|
$web =~ s/\./\//go;
|
||
|
|
$web =~ s/\/$//o;
|
||
|
|
} elsif( $pathInfo =~ /\/(.*)/ ) {
|
||
|
|
# is 'bin/script/Webname' or 'bin/script/'
|
||
|
|
$web = $1 unless $web;
|
||
|
|
}
|
||
|
|
|
||
|
|
# All roads lead to WebHome
|
||
|
|
$topic = $TWiki::cfg{HomeTopicName} if ( $topic =~ /\.\./ );
|
||
|
|
$topic =~ s/$TWiki::cfg{NameFilter}//go;
|
||
|
|
$topic = $TWiki::cfg{HomeTopicName} unless $topic;
|
||
|
|
$this->{topicName} = TWiki::Sandbox::untaintUnchecked( $topic );
|
||
|
|
|
||
|
|
$web =~ s/$TWiki::cfg{NameFilter}//go;
|
||
|
|
$this->{requestedWebName} = TWiki::Sandbox::untaintUnchecked( $web ); #can be an empty string
|
||
|
|
$web = $TWiki::cfg{UsersWebName} unless $web;
|
||
|
|
$this->{webName} = TWiki::Sandbox::untaintUnchecked( $web );
|
||
|
|
|
||
|
|
# Convert UTF-8 web and topic name from URL into site charset
|
||
|
|
# if necessary - no effect if URL is not in UTF-8
|
||
|
|
# handle topic and web names seperately; encoding is not necessarily shared
|
||
|
|
my $webNameTemp = $this->UTF82SiteCharSet( $this->{webName} );
|
||
|
|
if ( $webNameTemp ) {
|
||
|
|
$this->{webName} = $webNameTemp;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $topicNameTemp = $this->UTF82SiteCharSet( $this->{topicName} );
|
||
|
|
if ( $topicNameTemp ) {
|
||
|
|
$this->{topicName} = $topicNameTemp;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Item3270 - here's the appropriate place to enforce TWiki spec:
|
||
|
|
# All topic name sources are evaluated, site charset applied
|
||
|
|
$this->{topicName} =
|
||
|
|
TWiki::Sandbox::untaintUnchecked(ucfirst $this->{topicName});
|
||
|
|
|
||
|
|
$this->{scriptUrlPath} = $TWiki::cfg{ScriptUrlPath};
|
||
|
|
|
||
|
|
my $url = $query->url();
|
||
|
|
if( $url && $url =~ m!^([^:]*://[^/]*)(.*)/.*$! && $2 ) {
|
||
|
|
$this->{urlHost} = $1;
|
||
|
|
# If the urlHost in the url is localhost, this is a lot less
|
||
|
|
# useful than the default url host. This is because new CGI("")
|
||
|
|
# assigns this host by default - it's a default setting, used
|
||
|
|
# when there is nothing better available.
|
||
|
|
if( $this->{urlHost} eq 'http://localhost' ) {
|
||
|
|
$this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
|
||
|
|
} elsif( $TWiki::cfg{RemovePortNumber} ) {
|
||
|
|
$this->{urlHost} =~ s/\:[0-9]+$//;
|
||
|
|
}
|
||
|
|
if( $TWiki::cfg{GetScriptUrlFromCgi} ) {
|
||
|
|
# SMELL: this is a really dangerous hack. It will fail
|
||
|
|
# spectacularly with mod_perl.
|
||
|
|
# SMELL: why not just use $query->script_name?
|
||
|
|
$this->{scriptUrlPath} = $2;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
|
||
|
|
}
|
||
|
|
|
||
|
|
# setup the cgi session, from a cookie or the url. this may return
|
||
|
|
# the login, but even if it does, plugins will get the chance to override
|
||
|
|
# it below.
|
||
|
|
my $login = $this->{loginManager}->loadSession($loginName);
|
||
|
|
my $prefs = new TWiki::Prefs( $this );
|
||
|
|
$this->{prefs} = $prefs;
|
||
|
|
|
||
|
|
# Push global preferences from TWiki.TWikiPreferences
|
||
|
|
$prefs->pushGlobalPreferences();
|
||
|
|
|
||
|
|
my $plogin = $this->{plugins}->load( $TWiki::cfg{DisableAllPlugins} );
|
||
|
|
$login = $plogin if $plogin;
|
||
|
|
$login ||= $TWiki::cfg{DefaultUserLogin};
|
||
|
|
unless( $login =~ /$TWiki::cfg{LoginNameFilterIn}/) {
|
||
|
|
die "Illegal format for login name '$login' (does not match ".$TWiki::cfg{LoginNameFilterIn}.")";
|
||
|
|
}
|
||
|
|
$login = TWiki::Sandbox::untaintUnchecked( $login );
|
||
|
|
|
||
|
|
my $user = $this->{users}->findUser( $login );
|
||
|
|
$this->{user} = $user;
|
||
|
|
|
||
|
|
# Static session variables that can be expanded in topics when they
|
||
|
|
# are enclosed in % signs
|
||
|
|
# SMELL: should collapse these into one. The duplication is pretty
|
||
|
|
# pointless. Could get rid of the SESSION_TAGS hash, might be
|
||
|
|
# the easiest thing to do, but then that would allow other
|
||
|
|
# upper-case named fields in the object to be accessed as well...
|
||
|
|
$this->{SESSION_TAGS}{BASEWEB} = $this->{webName};
|
||
|
|
$this->{SESSION_TAGS}{BASETOPIC} = $this->{topicName};
|
||
|
|
$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $this->{topicName};
|
||
|
|
$this->{SESSION_TAGS}{INCLUDINGWEB} = $this->{webName};
|
||
|
|
|
||
|
|
# Push plugin settings
|
||
|
|
$this->{plugins}->settings();
|
||
|
|
|
||
|
|
# Now the rest of the preferences
|
||
|
|
$prefs->pushGlobalPreferencesSiteSpecific();
|
||
|
|
|
||
|
|
$prefs->pushPreferences(
|
||
|
|
$TWiki::cfg{UsersWebName}, $user->wikiName(),
|
||
|
|
'USER '.$user->wikiName() );
|
||
|
|
|
||
|
|
$prefs->pushWebPreferences( $this->{webName} );
|
||
|
|
|
||
|
|
$prefs->pushPreferences(
|
||
|
|
$this->{webName}, $this->{topicName}, 'TOPIC' );
|
||
|
|
|
||
|
|
$prefs->pushPreferenceValues( 'SESSION',
|
||
|
|
$this->{loginManager}->getSessionValues() );
|
||
|
|
|
||
|
|
# requires preferences (such as NEWTOPICBGCOLOR)
|
||
|
|
$this->{renderer} = new TWiki::Render( $this );
|
||
|
|
|
||
|
|
# Finish plugin initialization - register handlers
|
||
|
|
$this->{plugins}->enable();
|
||
|
|
|
||
|
|
# language information; must be loaded after
|
||
|
|
# *all possible preferences sources* are available
|
||
|
|
$this->{i18n} = TWiki::I18N::get( $this );
|
||
|
|
|
||
|
|
return $this;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Uncomment when enabling AutoLoader
|
||
|
|
#__END__
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod finish
|
||
|
|
|
||
|
|
Complete processing after the client's HTTP request has been responded
|
||
|
|
to. Right now this does two things:
|
||
|
|
1 calling TWiki::Client to flushing the user's session (if any) to disk,
|
||
|
|
2 breaking circular references to allow garbage collection in persistent
|
||
|
|
environments
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub finish {
|
||
|
|
my $this = shift;
|
||
|
|
$this->{loginManager}->finish();
|
||
|
|
|
||
|
|
# use Data::Dumper;
|
||
|
|
# $Data::Dumper::Indent = 1;
|
||
|
|
# warn "prepared to finish";
|
||
|
|
# warn Dumper($this);
|
||
|
|
|
||
|
|
$this->{prefs}->finish();
|
||
|
|
$this->{users}->finish();
|
||
|
|
$this->{store}->finish();
|
||
|
|
|
||
|
|
%$this = ();
|
||
|
|
}
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod writeLog( $action, $webTopic, $extra, $user )
|
||
|
|
|
||
|
|
* =$action= - what happened, e.g. view, save, rename
|
||
|
|
* =$wbTopic= - what it happened to
|
||
|
|
* =$extra= - extra info, such as minor flag
|
||
|
|
* =$user= - user who did the saving (user object or string user name)
|
||
|
|
Write the log for an event to the logfile
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub writeLog {
|
||
|
|
my $this = shift;
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
my $action = shift || '';
|
||
|
|
my $webTopic = shift || '';
|
||
|
|
my $extra = shift || '';
|
||
|
|
my $user = shift;
|
||
|
|
|
||
|
|
$user = $this->{user} unless $user;
|
||
|
|
if( ref($user) && $user->isa('TWiki::User')) {
|
||
|
|
$user = $user->wikiName();
|
||
|
|
}
|
||
|
|
if( $user eq $cfg{DefaultUserWikiName} ) {
|
||
|
|
my $cgiQuery = $this->{cgiQuery};
|
||
|
|
if( $cgiQuery ) {
|
||
|
|
my $agent = $cgiQuery->user_agent();
|
||
|
|
if( $agent ) {
|
||
|
|
$agent =~ m/([\w]+)/;
|
||
|
|
$extra .= ' '.$1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
my $remoteAddr = $ENV{'REMOTE_ADDR'} || '';
|
||
|
|
my $text = "$user | $action | $webTopic | $extra | $remoteAddr |";
|
||
|
|
|
||
|
|
$this->_writeReport( $TWiki::cfg{LogFileName}, $text );
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod writeWarning( $text )
|
||
|
|
|
||
|
|
Prints date, time, and contents $text to $TWiki::cfg{WarningFileName}, typically
|
||
|
|
'warnings.txt'. Use for warnings and errors that may require admin
|
||
|
|
intervention. Use this for defensive programming warnings (e.g. assertions).
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub writeWarning {
|
||
|
|
my $this = shift;
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
$this->_writeReport( $TWiki::cfg{WarningFileName}, @_ );
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod writeDebug( $text )
|
||
|
|
|
||
|
|
Prints date, time, and contents of $text to $TWiki::cfg{DebugFileName}, typically
|
||
|
|
'debug.txt'. Use for debugging messages.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub writeDebug {
|
||
|
|
my $this = shift;
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
$this->_writeReport( $TWiki::cfg{DebugFileName}, @_ );
|
||
|
|
}
|
||
|
|
|
||
|
|
# Concatenates date, time, and $text to a log file.
|
||
|
|
# The logfilename can optionally use a %DATE% variable to support
|
||
|
|
# logs that are rotated once a month.
|
||
|
|
# | =$log= | Base filename for log file |
|
||
|
|
# | =$message= | Message to print |
|
||
|
|
sub _writeReport {
|
||
|
|
my ( $this, $log, $message ) = @_;
|
||
|
|
|
||
|
|
if ( $log ) {
|
||
|
|
my $time =
|
||
|
|
TWiki::Time::formatTime( time(), '$year$mo', 'servertime');
|
||
|
|
$log =~ s/%DATE%/$time/go;
|
||
|
|
$time = TWiki::Time::formatTime( time(), undef, 'servertime' );
|
||
|
|
|
||
|
|
if( open( FILE, ">>$log" ) ) {
|
||
|
|
print FILE "| $time | $message\n";
|
||
|
|
close( FILE );
|
||
|
|
} else {
|
||
|
|
print STDERR 'Could not write "'.$message.'" to '."$log: $!\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _removeNewlines {
|
||
|
|
my( $theTag ) = @_;
|
||
|
|
$theTag =~ s/[\r\n]+/ /gs;
|
||
|
|
return $theTag;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Convert relative URLs to absolute URIs
|
||
|
|
sub _rewriteURLInInclude {
|
||
|
|
my( $theHost, $theAbsPath, $url ) = @_;
|
||
|
|
|
||
|
|
# leave out an eventual final non-directory component from the absolute path
|
||
|
|
$theAbsPath =~ s/(.*?)[^\/]*$/$1/;
|
||
|
|
|
||
|
|
if( $url =~ /^\// ) {
|
||
|
|
# fix absolute URL
|
||
|
|
$url = $theHost.$url;
|
||
|
|
} elsif( $url =~ /^\./ ) {
|
||
|
|
# fix relative URL
|
||
|
|
$url = $theHost.$theAbsPath.'/'.$url;
|
||
|
|
} elsif( $url =~ /^$regex{linkProtocolPattern}\:/o ) {
|
||
|
|
# full qualified URL, do nothing
|
||
|
|
} elsif( $url =~ /^#/ ) {
|
||
|
|
# anchor. This needs to be left relative to the including topic
|
||
|
|
# so do nothing
|
||
|
|
} elsif( $url ) {
|
||
|
|
# FIXME: is this test enough to detect relative URLs?
|
||
|
|
$url = $theHost.$theAbsPath.'/'.$url;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $url;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _fixIncludeLink {
|
||
|
|
my( $theWeb, $theLink, $theLabel ) = @_;
|
||
|
|
|
||
|
|
# [[...][...]] link
|
||
|
|
if( $theLink =~ /^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}\:|\/)/o ) {
|
||
|
|
if ( $theLabel ) {
|
||
|
|
return "[[$theLink][$theLabel]]";
|
||
|
|
} else {
|
||
|
|
return "[[$theLink]]";
|
||
|
|
}
|
||
|
|
} elsif ( $theLabel ) {
|
||
|
|
return "[[$theWeb.$theLink][$theLabel]]";
|
||
|
|
} else {
|
||
|
|
return "[[$theWeb.$theLink][$theLink]]";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Clean-up HTML text so that it can be shown embedded in a topic
|
||
|
|
sub _cleanupIncludedHTML {
|
||
|
|
my( $text, $host, $path, $options ) = @_;
|
||
|
|
|
||
|
|
# FIXME: Make aware of <base> tag
|
||
|
|
|
||
|
|
$text =~ s/^.*?<\/head>//is
|
||
|
|
unless ( $options->{disableremoveheaders} ); # remove all HEAD
|
||
|
|
$text =~ s/<script.*?<\/script>//gis
|
||
|
|
unless ( $options->{disableremovescript} ); # remove all SCRIPTs
|
||
|
|
$text =~ s/^.*?<body[^>]*>//is
|
||
|
|
unless ( $options->{disableremovebody} ); # remove all to <BODY>
|
||
|
|
$text =~ s/(?:\n)<\/body>.*//is
|
||
|
|
unless ( $options->{disableremovebody} ); # remove </BODY>
|
||
|
|
$text =~ s/(?:\n)<\/html>.*//is
|
||
|
|
unless ( $options->{disableremoveheaders} ); # remove </HTML>
|
||
|
|
$text =~ s/(<[^>]*>)/_removeNewlines($1)/ges
|
||
|
|
unless ( $options->{disablecompresstags} ); # replace newlines in html tags with space
|
||
|
|
$text =~ s/(\s(?:href|src|action)=(["']))(.*?)\2/$1._rewriteURLInInclude( $host, $path, $3 ).$2/geois
|
||
|
|
unless ( $options->{disablerewriteurls} );
|
||
|
|
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod applyPatternToIncludedText( $text, $pattern ) -> $text
|
||
|
|
|
||
|
|
Apply a pattern on included text to extract a subset
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub applyPatternToIncludedText {
|
||
|
|
my( $theText, $thePattern ) = @_;
|
||
|
|
$thePattern =~ s/([^\\])([\$\@\%\&\#\'\`\/])/$1\\$2/g; # escape some special chars
|
||
|
|
$thePattern = TWiki::Sandbox::untaintUnchecked( $thePattern );
|
||
|
|
$theText = '' unless( $theText =~ s/$thePattern/$1/is );
|
||
|
|
return $theText;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Fetch content from a URL for inclusion by an INCLUDE
|
||
|
|
sub _includeUrl {
|
||
|
|
my( $this, $url, $pattern, $web, $topic, $raw, $options, $warn ) = @_;
|
||
|
|
my $text = '';
|
||
|
|
|
||
|
|
# For speed, read file directly if URL matches an attachment directory
|
||
|
|
if( $url =~ /^$this->{urlHost}$TWiki::cfg{PubUrlPath}\/([^\/\.]+)\/([^\/\.]+)\/([^\/]+)$/ ) {
|
||
|
|
my $incWeb = $1;
|
||
|
|
my $incTopic = $2;
|
||
|
|
my $incAtt = $3;
|
||
|
|
# FIXME: Check for MIME type, not file suffix
|
||
|
|
if( $incAtt =~ m/\.(txt|html?)$/i ) {
|
||
|
|
unless( $this->{store}->attachmentExists(
|
||
|
|
$incWeb, $incTopic, $incAtt )) {
|
||
|
|
return $this->_includeWarning( $warn, 'bad_attachment', $url );
|
||
|
|
}
|
||
|
|
if( $incWeb ne $web || $incTopic ne $topic ) {
|
||
|
|
# CODE_SMELL: Does not account for not yet authenticated user
|
||
|
|
unless( $this->{security}->checkAccessPermission(
|
||
|
|
'view', $this->{user}, undef, undef, $incTopic, $incWeb ) ) {
|
||
|
|
return $this->_includeWarning( $warn, 'access_denied',
|
||
|
|
"$incWeb.$incTopic" );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$text = $this->{store}->readAttachment( undef, $incWeb, $incTopic,
|
||
|
|
$incAtt );
|
||
|
|
$text = _cleanupIncludedHTML( $text, $this->{urlHost},
|
||
|
|
$TWiki::cfg{PubUrlPath}, $options )
|
||
|
|
unless $raw;
|
||
|
|
$text = applyPatternToIncludedText( $text, $pattern )
|
||
|
|
if( $pattern );
|
||
|
|
$text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
# fall through; try to include file over http based on MIME setting
|
||
|
|
}
|
||
|
|
|
||
|
|
return $this->_includeWarning( $warn, 'urls_not_allowed' )
|
||
|
|
unless $TWiki::cfg{INCLUDE}{AllowURLs};
|
||
|
|
|
||
|
|
# SMELL: should use the URI module from CPAN to parse the URL
|
||
|
|
# SMELL: but additional CPAN adds to code bloat
|
||
|
|
my $path = $url;
|
||
|
|
unless ($path =~ s!^(https?)://!!) {
|
||
|
|
$text = $this->_includeWarning( $warn, 'bad_protocol', $url );
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
my $protocol = $1;
|
||
|
|
my ( $user, $pass );
|
||
|
|
if ($path =~ s!([^/\@:]+)(?::([^/\@:]+))?@!!) {
|
||
|
|
( $user, $pass ) = ( $1, $2 );
|
||
|
|
}
|
||
|
|
unless ($path =~ s!([^:/]+)(?::([0-9]+))?!! ) {
|
||
|
|
return $this->_includeWarning( $warn, 'geturl_failed', $url );
|
||
|
|
}
|
||
|
|
my( $host, $port ) = ( $1, $2 );
|
||
|
|
|
||
|
|
try {
|
||
|
|
$text = $this->{net}->getUrl( $protocol, $host, $port, $path, $user, $pass );
|
||
|
|
$text =~ s/\r\n/\n/gs;
|
||
|
|
$text =~ s/\r/\n/gs;
|
||
|
|
$text =~ s/^(.*?\n)\n//s;
|
||
|
|
my $httpHeader = $1;
|
||
|
|
# Trap 4xx and 5xx
|
||
|
|
die $text if ($httpHeader =~ /^HTTP\/[\d.]+\s[45]\d\d\s/s);
|
||
|
|
my $contentType = '';
|
||
|
|
if( $httpHeader =~ /content\-type\:\s*([^\n]*)/ois ) {
|
||
|
|
$contentType = $1;
|
||
|
|
}
|
||
|
|
if( $contentType =~ /^text\/html/ ) {
|
||
|
|
$path =~ s/[#?].*$//;
|
||
|
|
$host = $protocol.'://'.$host;
|
||
|
|
$host .= ":$port" if $port;
|
||
|
|
$text = _cleanupIncludedHTML( $text, $host, $path, $options )
|
||
|
|
unless $raw;
|
||
|
|
} elsif( $contentType =~ /^text\/(plain|css)/ ) {
|
||
|
|
# do nothing
|
||
|
|
} else {
|
||
|
|
$text = $this->_includeWarning(
|
||
|
|
$warn, 'bad_content', $contentType );
|
||
|
|
}
|
||
|
|
$text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
|
||
|
|
$text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
|
||
|
|
} catch Error::Simple with {
|
||
|
|
my $e = shift;
|
||
|
|
$text = $this->_includeWarning( $warn, 'geturl_failed', $url );
|
||
|
|
};
|
||
|
|
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# SMELL: this is _not_ a tag handler in the sense of other builtin tags,
|
||
|
|
# because it requires far more context information (the text of the topic)
|
||
|
|
# than any handler.
|
||
|
|
# SMELL: as a tag handler that also semi-renders the topic to extract the
|
||
|
|
# headings, this handler would be much better as a preRenderingHandler in
|
||
|
|
# a plugin (where head, script and verbatim sections are already protected)
|
||
|
|
#
|
||
|
|
# * $text : ref to the text of the current topic
|
||
|
|
# * $topic : the topic we are in
|
||
|
|
# * $web : the web we are in
|
||
|
|
# * $args : 'Topic' [web='Web'] [depth='N']
|
||
|
|
# Return value: $tableOfContents
|
||
|
|
# Handles %<nop>TOC{...}% syntax. Creates a table of contents
|
||
|
|
# using TWiki bulleted
|
||
|
|
# list markup, linked to the section headings of a topic. A section heading is
|
||
|
|
# entered in one of the following forms:
|
||
|
|
# * $headingPatternSp : \t++... spaces section heading
|
||
|
|
# * $headingPatternDa : ---++... dashes section heading
|
||
|
|
# * $headingPatternHt : <h[1-6]> HTML section heading </h[1-6]>
|
||
|
|
sub _TOC {
|
||
|
|
my ( $this, $text, $defaultTopic, $defaultWeb, $args ) = @_;
|
||
|
|
|
||
|
|
my $params = new TWiki::Attrs( $args );
|
||
|
|
# get the topic name attribute
|
||
|
|
my $topic = $params->{_DEFAULT} || $defaultTopic;
|
||
|
|
|
||
|
|
# get the web name attribute
|
||
|
|
$defaultWeb =~ s#/#.#g;
|
||
|
|
my $web = $params->{web} || $defaultWeb;
|
||
|
|
|
||
|
|
my $isSameTopic = $web eq $defaultWeb && $topic eq $defaultTopic;
|
||
|
|
|
||
|
|
$web =~ s#/#\.#g;
|
||
|
|
my $webPath = $web;
|
||
|
|
$webPath =~ s/\./\//g;
|
||
|
|
|
||
|
|
# get the depth limit attribute
|
||
|
|
my $depth = $params->{depth} || 6;
|
||
|
|
|
||
|
|
# get the title attribute
|
||
|
|
my $title = $params->{title} || '';
|
||
|
|
$title = CGI::span( { class => 'twikiTocTitle' }, $title ) if( $title );
|
||
|
|
|
||
|
|
if( $web ne $defaultWeb || $topic ne $defaultTopic ) {
|
||
|
|
unless( $this->{security}->checkAccessPermission
|
||
|
|
( 'view', $this->{user}, undef, undef, $topic, $web ) ) {
|
||
|
|
return $this->inlineAlert( 'alerts', 'access_denied',
|
||
|
|
$web, $topic );
|
||
|
|
}
|
||
|
|
my $meta;
|
||
|
|
( $meta, $text ) =
|
||
|
|
$this->{store}->readTopic( $this->{user}, $web, $topic );
|
||
|
|
}
|
||
|
|
|
||
|
|
my $insidePre = 0;
|
||
|
|
my $insideVerbatim = 0;
|
||
|
|
my $highest = 99;
|
||
|
|
my $result = '';
|
||
|
|
my $verbatim = {};
|
||
|
|
$text = $this->{renderer}->takeOutBlocks( $text, 'verbatim',
|
||
|
|
$verbatim);
|
||
|
|
$text = $this->{renderer}->takeOutBlocks( $text, 'pre',
|
||
|
|
$verbatim);
|
||
|
|
|
||
|
|
# Find URL parameters
|
||
|
|
my $query = $this->{cgiQuery};
|
||
|
|
my @qparams = ();
|
||
|
|
foreach my $name ( $query->param ) {
|
||
|
|
next if ($name eq 'keywords');
|
||
|
|
next if ($name eq 'topic');
|
||
|
|
push @qparams, $name => $query->param($name);
|
||
|
|
}
|
||
|
|
|
||
|
|
# SMELL: this handling of <pre> is archaic.
|
||
|
|
# SMELL: use forEachLine
|
||
|
|
foreach my $line ( split( /\r?\n/, $text ) ) {
|
||
|
|
my $level;
|
||
|
|
if ( $line =~ m/$regex{headerPatternDa}/o ) {
|
||
|
|
$line = $2;
|
||
|
|
$level = length $1;
|
||
|
|
} elsif ( $line =~ m/$regex{headerPatternHt}/io ) {
|
||
|
|
$line = $2;
|
||
|
|
$level = $1;
|
||
|
|
} else {
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
|
||
|
|
if( $line && $level <= $depth ) {
|
||
|
|
# cut TOC exclude '---+ heading !! exclude this bit'
|
||
|
|
$line =~ s/\s*$regex{headerPatternNoTOC}.+$//go;
|
||
|
|
next unless $line;
|
||
|
|
my $anchor = $this->{renderer}->makeAnchorName( $line );
|
||
|
|
$highest = $level if( $level < $highest );
|
||
|
|
my $tabs = "\t" x $level;
|
||
|
|
# Remove *bold*, _italic_ and =fixed= formatting
|
||
|
|
$line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
|
||
|
|
$line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
|
||
|
|
$line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
|
||
|
|
# Prevent WikiLinks
|
||
|
|
$line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g; # '[[...][...]]'
|
||
|
|
$line =~ s/\[\[(.*?)\]\]/$1/ge; # '[[...]]'
|
||
|
|
$line =~ s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1<nop>$3/go; # 'Web.TopicName'
|
||
|
|
$line =~ s/([\s\(])($regex{wikiWordRegex})/$1<nop>$2/go; # 'TopicName'
|
||
|
|
$line =~ s/([\s\(])($regex{abbrevRegex})/$1<nop>$2/go; # 'TLA'
|
||
|
|
$line =~ s/([\s\-\*\(])([$regex{mixedAlphaNum}]+\:)/$1<nop>$2/go; # 'Site:page' Interwiki link
|
||
|
|
# Prevent manual links
|
||
|
|
$line =~ s/<[\/]?a\b[^>]*>//gi;
|
||
|
|
# create linked bullet item, using a relative link to anchor
|
||
|
|
my $target = $isSameTopic ?
|
||
|
|
_make_params(0, '#'=>$anchor,@qparams) :
|
||
|
|
$this->getScriptUrl(0,'view',$web,$topic,'#'=>$anchor,@qparams);
|
||
|
|
$line = $tabs.'* ' . CGI::a({href=>$target},$line);
|
||
|
|
$result .= "\n".$line;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if( $result ) {
|
||
|
|
if( $highest > 1 ) {
|
||
|
|
# left shift TOC
|
||
|
|
$highest--;
|
||
|
|
$result =~ s/^\t{$highest}//gm;
|
||
|
|
}
|
||
|
|
return CGI::div( { class=>'twikiToc' }, "$title$result\n" );
|
||
|
|
} else {
|
||
|
|
return '';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod inlineAlert($template, $def, ... ) -> $string
|
||
|
|
|
||
|
|
Format an error for inline inclusion in rendered output. The message string
|
||
|
|
is obtained from the template 'oops'.$template, and the DEF $def is
|
||
|
|
selected. The parameters (...) are used to populate %PARAM1%..%PARAMn%
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub inlineAlert {
|
||
|
|
my $this = shift;
|
||
|
|
my $template = shift;
|
||
|
|
my $def = shift;
|
||
|
|
|
||
|
|
my $text = $this->{templates}->readTemplate( 'oops'.$template,
|
||
|
|
$this->getSkin() );
|
||
|
|
if( $text ) {
|
||
|
|
my $blah = $this->{templates}->expandTemplate( $def );
|
||
|
|
$text =~ s/%INSTANTIATE%/$blah/;
|
||
|
|
# web and topic can be anything; they are not used
|
||
|
|
$text = $this->handleCommonTags( $text, $this->{webName},
|
||
|
|
$this->{topicName} );
|
||
|
|
my $n = 1;
|
||
|
|
while( defined( my $param = shift )) {
|
||
|
|
$text =~ s/%PARAM$n%/$param/g;
|
||
|
|
$n++;
|
||
|
|
}
|
||
|
|
|
||
|
|
} else {
|
||
|
|
$text = CGI::h1('TWiki Installation Error')
|
||
|
|
. 'Template "'.$template.'" not found.'.CGI::p()
|
||
|
|
. 'Check the configuration setting for {TemplateDir}';
|
||
|
|
}
|
||
|
|
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod parseSections($text) -> ($string,$sectionlistref)
|
||
|
|
|
||
|
|
Generic parser for sections within a topic. Sections are delimited
|
||
|
|
by STARTSECTION and ENDSECTION, which may be nested, overlapped or
|
||
|
|
otherwise abused. The parser builds an array of sections, which is
|
||
|
|
ordered by the order of the STARTSECTION within the topic. It also
|
||
|
|
removes all the SECTION tags from the text, and returns the text
|
||
|
|
and the array of sections.
|
||
|
|
|
||
|
|
Each section is a =TWiki::Attrs= object, which contains the attributes
|
||
|
|
{type, name, start, end}
|
||
|
|
where start and end are character offsets in the
|
||
|
|
string *after all section tags have been removed*. All sections
|
||
|
|
are required to be uniquely named; if a section is unnamed, it
|
||
|
|
will be given a generated name. Sections may overlap or nest.
|
||
|
|
|
||
|
|
See test/unit/Fn_SECTION.pm for detailed testcases that
|
||
|
|
round out the spec.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
sub parseSections {
|
||
|
|
#my( $text _ = @_;
|
||
|
|
my %sections;
|
||
|
|
my @list = ();
|
||
|
|
|
||
|
|
my $seq = 0;
|
||
|
|
my $ntext = '';
|
||
|
|
my $offset = 0;
|
||
|
|
foreach my $bit (split(/(%(?:START|END)SECTION(?:{.*?})?%)/, $_[0] )) {
|
||
|
|
if( $bit =~ /^%STARTSECTION(?:{(.*)})?%$/) {
|
||
|
|
my $attrs = new TWiki::Attrs( $1 );
|
||
|
|
$attrs->{type} ||= 'section';
|
||
|
|
$attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} ||
|
||
|
|
'_SECTION'.$seq++;
|
||
|
|
delete $attrs->{_DEFAULT};
|
||
|
|
my $id = $attrs->{type}.':'.$attrs->{name};
|
||
|
|
if( $sections{$id} ) {
|
||
|
|
# error, this named section already defined, ignore
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
# close open unnamed sections of the same type
|
||
|
|
foreach my $s ( @list ) {
|
||
|
|
if( $s->{end} < 0 && $s->{type} eq $attrs->{type} &&
|
||
|
|
$s->{name} =~ /^_SECTION\d+$/ ) {
|
||
|
|
$s->{end} = $offset;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$attrs->{start} = $offset;
|
||
|
|
$attrs->{end} = -1; # open section
|
||
|
|
$sections{$id} = $attrs;
|
||
|
|
push( @list, $attrs );
|
||
|
|
} elsif( $bit =~ /^%ENDSECTION(?:{(.*)})?%$/ ) {
|
||
|
|
my $attrs = new TWiki::Attrs( $1 );
|
||
|
|
$attrs->{type} ||= 'section';
|
||
|
|
$attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} || '';
|
||
|
|
delete $attrs->{_DEFAULT};
|
||
|
|
unless( $attrs->{name} ) {
|
||
|
|
# find the last open unnamed section of this type
|
||
|
|
foreach my $s ( reverse @list ) {
|
||
|
|
if( $s->{end} == -1 &&
|
||
|
|
$s->{type} eq $attrs->{type} &&
|
||
|
|
$s->{name} =~ /^_SECTION\d+$/ ) {
|
||
|
|
$attrs->{name} = $s->{name};
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# ignore it if no matching START found
|
||
|
|
next unless $attrs->{name};
|
||
|
|
}
|
||
|
|
my $id = $attrs->{type}.':'.$attrs->{name};
|
||
|
|
if( !$sections{$id} || $sections{$id}->{end} >= 0 ) {
|
||
|
|
# error, no such open section, ignore
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
$sections{$id}->{end} = $offset;
|
||
|
|
} else {
|
||
|
|
$ntext .= $bit;
|
||
|
|
$offset = length( $ntext );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# close open sections
|
||
|
|
foreach my $s ( @list ) {
|
||
|
|
$s->{end} = $offset if $s->{end} < 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
return( $ntext, \@list );
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod expandVariablesOnTopicCreation ( $text, $user ) -> $text
|
||
|
|
|
||
|
|
* =$text= - text to expand
|
||
|
|
* =$user= - reference to user object. This is the user expanded in e.g. %USERNAME. Optional, defaults to logged-in user.
|
||
|
|
Expand limited set of variables during topic creation. These are variables
|
||
|
|
expected in templates that must be statically expanded in new content.
|
||
|
|
|
||
|
|
# SMELL: no plugin handler
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub expandVariablesOnTopicCreation {
|
||
|
|
my ( $this, $text, $user ) = @_;
|
||
|
|
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
$user ||= $this->{user};
|
||
|
|
ASSERT($user->isa( 'TWiki::User')) if DEBUG;
|
||
|
|
|
||
|
|
# Chop out templateonly sections
|
||
|
|
my( $ntext, $sections ) = parseSections( $text );
|
||
|
|
|
||
|
|
if( scalar( @$sections )) {
|
||
|
|
# Note that if named templateonly sections overlap, the behaviour is undefined.
|
||
|
|
foreach my $s ( reverse @$sections ) {
|
||
|
|
if( $s->{type} eq 'templateonly' ) {
|
||
|
|
$ntext = substr($ntext, 0, $s->{start}).
|
||
|
|
substr($ntext, $s->{end}, length($ntext));
|
||
|
|
} else {
|
||
|
|
# put back non-templateonly sections
|
||
|
|
my $start = $s->remove('start');
|
||
|
|
my $end = $s->remove('end');
|
||
|
|
$ntext = substr($ntext, 0, $start).
|
||
|
|
'%STARTSECTION{'.$s->stringify().'}%'.
|
||
|
|
substr($ntext, $start, $end - $start).
|
||
|
|
'%ENDSECTION{'.$s->stringify().'}%'.
|
||
|
|
substr($ntext, $end, length($ntext));
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$text = $ntext;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Make sure func works, for registered tag handlers
|
||
|
|
$TWiki::Plugins::SESSION = $this;
|
||
|
|
|
||
|
|
# Note: it may look dangerous to override the user this way, but
|
||
|
|
# it's actually quite safe, because only a subset of tags are
|
||
|
|
# expanded during topic creation. if the set of tags expanded is
|
||
|
|
# extended, then the impact has to be considered.
|
||
|
|
my $safe = $this->{user};
|
||
|
|
$this->{user} = $user;
|
||
|
|
$text = $this->_processTags( $text, \&_expandTagOnTopicCreation, 16 );
|
||
|
|
# kill markers used to prevent variable expansion
|
||
|
|
$text =~ s/%NOP%//g;
|
||
|
|
$this->{user} = $safe;
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod entityEncode( $text, $extras ) -> $encodedText
|
||
|
|
|
||
|
|
Escape special characters to HTML numeric entities. This is *not* a generic
|
||
|
|
encoding, it is tuned specifically for use in TWiki.
|
||
|
|
|
||
|
|
HTML4.0 spec:
|
||
|
|
"Certain characters in HTML are reserved for use as markup and must be
|
||
|
|
escaped to appear literally. The "<" character may be represented with
|
||
|
|
an <em>entity</em>, <strong class=html>&lt;</strong>. Similarly, ">"
|
||
|
|
is escaped as <strong class=html>&gt;</strong>, and "&" is escaped
|
||
|
|
as <strong class=html>&amp;</strong>. If an attribute value contains a
|
||
|
|
double quotation mark and is delimited by double quotation marks, then the
|
||
|
|
quote should be escaped as <strong class=html>&quot;</strong>.</p>
|
||
|
|
|
||
|
|
Other entities exist for special characters that cannot easily be entered
|
||
|
|
with some keyboards..."
|
||
|
|
|
||
|
|
This method encodes HTML special and any non-printable ascii
|
||
|
|
characters (except for \n and \r) using numeric entities.
|
||
|
|
|
||
|
|
FURTHER this method also encodes characters that are special in TWiki
|
||
|
|
meta-language.
|
||
|
|
|
||
|
|
$extras is an optional param that may be used to include *additional*
|
||
|
|
characters in the set of encoded characters. It should be a string
|
||
|
|
containing the additional chars.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub entityEncode {
|
||
|
|
my( $text, $extra) = @_;
|
||
|
|
$extra ||= '';
|
||
|
|
|
||
|
|
# encode all non-printable 7-bit chars (< \x1f),
|
||
|
|
# except \n (\xa) and \r (\xd)
|
||
|
|
# encode HTML special characters '>', '<', '&', ''' and '"'.
|
||
|
|
# encode TML special characters '%', '|', '[', ']', '@', '_',
|
||
|
|
# '*', and '='
|
||
|
|
$text =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|$extra])/'&#'.ord($1).';'/ge;
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod entityDecode ( $encodedText ) -> $text
|
||
|
|
|
||
|
|
Decodes all numeric entities (e.g. &#123;). _Does not_ decode
|
||
|
|
named entities such as &amp; (use HTML::Entities for that)
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub entityDecode {
|
||
|
|
my $text = shift;
|
||
|
|
|
||
|
|
$text =~ s/&#(\d+);/chr($1)/ge;
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod urlEncode( $string ) -> encoded string
|
||
|
|
|
||
|
|
Encode by converting characters that are illegal in URLs to
|
||
|
|
their %NN equivalents. This method is used for encoding
|
||
|
|
strings that must be embedded _verbatim_ in URLs; it cannot
|
||
|
|
be applied to URLs themselves, as it escapes reserved
|
||
|
|
characters such as = and ?.
|
||
|
|
|
||
|
|
RFC 1738, Dec. '94:
|
||
|
|
<verbatim>>
|
||
|
|
...Only alphanumerics [0-9a-zA-Z], the special
|
||
|
|
characters $-_.+!*'(), and reserved characters used for their
|
||
|
|
reserved purposes may be used unencoded within a URL.
|
||
|
|
</verbatim>
|
||
|
|
Reserved characters are $&+,/:;=?@ - these are _also_ encoded by
|
||
|
|
this method.
|
||
|
|
|
||
|
|
SMELL: For non-ISO-8859-1 $TWiki::cfg{Site}{CharSet}, need to convert to
|
||
|
|
UTF-8 before URL encoding. This encoding only supports 8-bit
|
||
|
|
character codes.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub urlEncode {
|
||
|
|
my $text = shift;
|
||
|
|
|
||
|
|
$text =~ s/([^0-9a-zA-Z-_.:~!*'()\/%])/'%'.sprintf('%02x',ord($1))/ge;
|
||
|
|
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod urlDecode( $string ) -> decoded string
|
||
|
|
|
||
|
|
Reverses the encoding done in urlEncode.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub urlDecode {
|
||
|
|
my $text = shift;
|
||
|
|
|
||
|
|
$text =~ s/%([\da-f]{2})/chr(hex($1))/gei;
|
||
|
|
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod isTrue( $value, $default ) -> $boolean
|
||
|
|
|
||
|
|
Returns 1 if =$value= is true, and 0 otherwise. "true" means set to
|
||
|
|
something with a Perl true value, with the special cases that "off",
|
||
|
|
"false" and "no" (case insensitive) are forced to false. Leading and
|
||
|
|
trailing spaces in =$value= are ignored.
|
||
|
|
|
||
|
|
If the value is undef, then =$default= is returned. If =$default= is
|
||
|
|
not specified it is taken as 0.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub isTrue {
|
||
|
|
my( $value, $default ) = @_;
|
||
|
|
|
||
|
|
$default ||= 0;
|
||
|
|
|
||
|
|
return $default unless defined( $value );
|
||
|
|
|
||
|
|
$value =~ s/^\s*(.*?)\s*$/$1/gi;
|
||
|
|
$value =~ s/off//gi;
|
||
|
|
$value =~ s/no//gi;
|
||
|
|
return ( $value ) ? 1 : 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod spaceOutWikiWord( $word, $sep ) -> $string
|
||
|
|
|
||
|
|
Spaces out a wiki word by inserting a string (default: one space) between each word component.
|
||
|
|
With parameter $sep any string may be used as separator between the word components; if $sep is undefined it defaults to a space.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub spaceOutWikiWord {
|
||
|
|
my $word = shift || '';
|
||
|
|
my $sep = shift || ' ';
|
||
|
|
$word =~ s/([$regex{lowerAlpha}])([$regex{upperAlpha}$regex{numeric}]+)/$1$sep$2/go;
|
||
|
|
$word =~ s/([$regex{numeric}])([$regex{upperAlpha}])/$1$sep$2/go;
|
||
|
|
return $word;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Expands variables by replacing the variables with their
|
||
|
|
# values. Some example variables: %<nop>TOPIC%, %<nop>SCRIPTURL%,
|
||
|
|
# %<nop>WIKINAME%, etc.
|
||
|
|
# $web and $incs are passed in for recursive include expansion. They can
|
||
|
|
# safely be undef.
|
||
|
|
# The rules for tag expansion are:
|
||
|
|
# 1 Tags are expanded left to right, in the order they are encountered.
|
||
|
|
# 1 Tags are recursively expanded as soon as they are encountered - the algorithm is inherently single-pass
|
||
|
|
# 1 A tag is not "encountered" until the matching }% has been seen, by which time all tags in parameters will have been expanded
|
||
|
|
# 1 Tag expansions that create new tags recursively are limited to a set number of hierarchical levels of expansion
|
||
|
|
#
|
||
|
|
# Formerly known as handleInternalTags, but renamed when it was rewritten
|
||
|
|
# because the old name clashes with the namespace of handlers.
|
||
|
|
sub _expandAllTags {
|
||
|
|
my $this = shift;
|
||
|
|
my $text = shift; # reference
|
||
|
|
my ( $topic, $web ) = @_;
|
||
|
|
$web =~ s#\.#/#go;
|
||
|
|
|
||
|
|
# push current context
|
||
|
|
my $memTopic = $this->{SESSION_TAGS}{TOPIC};
|
||
|
|
my $memWeb = $this->{SESSION_TAGS}{WEB};
|
||
|
|
|
||
|
|
$this->{SESSION_TAGS}{TOPIC} = $topic;
|
||
|
|
$this->{SESSION_TAGS}{WEB} = $web;
|
||
|
|
|
||
|
|
# Escape ' !%VARIABLE%'
|
||
|
|
$$text =~ s/(?<=\s)!%($regex{tagNameRegex})/%$1/g;
|
||
|
|
|
||
|
|
# Make sure func works, for registered tag handlers
|
||
|
|
$TWiki::Plugins::SESSION = $this;
|
||
|
|
|
||
|
|
# NOTE TO DEBUGGERS
|
||
|
|
# The depth parameter in the following call controls the maximum number
|
||
|
|
# of levels of expansion. If it is set to 1 then only tags in the
|
||
|
|
# topic will be expanded; tags that they in turn generate will be
|
||
|
|
# left unexpanded. If it is set to 2 then the expansion will stop after
|
||
|
|
# the first recursive inclusion, and so on. This is incredible useful
|
||
|
|
# when debugging. The default is set to 16
|
||
|
|
# to match the original limit on search expansion, though this of
|
||
|
|
# course applies to _all_ tags and not just search.
|
||
|
|
$$text = $this->_processTags( $$text, \&_expandTagOnTopicRendering,
|
||
|
|
16, @_ );
|
||
|
|
|
||
|
|
# restore previous context
|
||
|
|
$this->{SESSION_TAGS}{TOPIC} = $memTopic;
|
||
|
|
$this->{SESSION_TAGS}{WEB} = $memWeb;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Process TWiki %TAGS{}% by parsing the input tokenised into
|
||
|
|
# % separated sections. The parser is a simple stack-based parse,
|
||
|
|
# sufficient to ensure nesting of tags is correct, but no more
|
||
|
|
# than that.
|
||
|
|
# $depth limits the number of recursive expansion steps that
|
||
|
|
# can be performed on expanded tags.
|
||
|
|
sub _processTags {
|
||
|
|
my $this = shift;
|
||
|
|
my $text = shift;
|
||
|
|
my $tagf = shift;
|
||
|
|
|
||
|
|
return '' unless defined( $text );
|
||
|
|
|
||
|
|
my $depth = shift;
|
||
|
|
|
||
|
|
# my( $topic, $web ) = @_;
|
||
|
|
|
||
|
|
unless ( $depth ) {
|
||
|
|
my $mess = "Max recursive depth reached: $text";
|
||
|
|
$this->writeWarning( $mess );
|
||
|
|
# prevent recursive expansion that just has been detected
|
||
|
|
# from happening in the error message
|
||
|
|
$text =~ s/%(.*?)%/$1/go;
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $verbatim = {};
|
||
|
|
$text = $this->{renderer}->takeOutBlocks( $text, 'verbatim',
|
||
|
|
$verbatim);
|
||
|
|
|
||
|
|
# See Item1442
|
||
|
|
#my $percent = ($TranslationToken x 3).'%'.($TranslationToken x 3);
|
||
|
|
|
||
|
|
my @queue = split( /(%)/, $text );
|
||
|
|
my @stack;
|
||
|
|
my $stackTop = ''; # the top stack entry. Done this way instead of
|
||
|
|
# referring to the top of the stack for efficiency. This var
|
||
|
|
# should be considered to be $stack[$#stack]
|
||
|
|
|
||
|
|
#my $tell = 1; # uncomment all tell lines set this to 1 to print debugging
|
||
|
|
|
||
|
|
while ( scalar( @queue )) {
|
||
|
|
my $token = shift( @queue );
|
||
|
|
#print STDERR ' ' x $tell,"PROCESSING $token \n" if $tell;
|
||
|
|
|
||
|
|
# each % sign either closes an existing stacked context, or
|
||
|
|
# opens a new context.
|
||
|
|
if ( $token eq '%' ) {
|
||
|
|
#print STDERR ' ' x $tell,"CONSIDER $stackTop\n" if $tell;
|
||
|
|
# If this is a closing }%, try to rejoin the previous
|
||
|
|
# tokens until we get to a valid tag construct. This is
|
||
|
|
# a bit of a hack, but it's hard to think of a better
|
||
|
|
# way to do this without a full parse that takes % signs
|
||
|
|
# in tag parameters into account.
|
||
|
|
if ( $stackTop =~ /}$/s ) {
|
||
|
|
while ( scalar( @stack) &&
|
||
|
|
$stackTop !~ /^%($regex{tagNameRegex}){.*}$/so ) {
|
||
|
|
my $top = $stackTop;
|
||
|
|
#print STDERR ' ' x $tell,"COLLAPSE $top \n" if $tell;
|
||
|
|
$stackTop = pop( @stack ) . $top;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# /s so you can have newlines in parameters
|
||
|
|
if ( $stackTop =~ m/^%(($regex{tagNameRegex})(?:{(.*)})?)$/so ) {
|
||
|
|
my( $expr, $tag, $args ) = ( $1, $2, $3 );
|
||
|
|
#print STDERR ' ' x $tell,"POP $tag\n" if $tell;
|
||
|
|
my $e = &$tagf( $this, $tag, $args, @_ );
|
||
|
|
|
||
|
|
if ( defined( $e )) {
|
||
|
|
#print STDERR ' ' x $tell--,"EXPANDED $tag -> $e\n" if $tell;
|
||
|
|
$stackTop = pop( @stack );
|
||
|
|
# Recursively expand tags in the expansion of $tag
|
||
|
|
$stackTop .= $this->_processTags($e, $tagf, $depth-1, @_ );
|
||
|
|
} else { # expansion failed
|
||
|
|
#print STDERR ' ' x $tell++,"EXPAND $tag FAILED\n" if $tell;
|
||
|
|
# To handle %NOP
|
||
|
|
# correctly, we have to handle the %VAR% case differently
|
||
|
|
# to the %VAR{}% case when a variable expansion fails.
|
||
|
|
# This is so that recursively define variables e.g.
|
||
|
|
# %A%B%D% expand correctly, but at the same time we ensure
|
||
|
|
# that a mismatched }% can't accidentally close a context
|
||
|
|
# that was left open when a tag expansion failed.
|
||
|
|
# However Cairo didn't do this, so for compatibility
|
||
|
|
# we have to accept that %NOP can never be fixed. if it
|
||
|
|
# could, then we could uncomment the following:
|
||
|
|
|
||
|
|
#if( $stackTop =~ /}$/ ) {
|
||
|
|
# # %VAR{...}% case
|
||
|
|
# # We need to push the unexpanded expression back
|
||
|
|
# # onto the stack, but we don't want it to match the
|
||
|
|
# # tag expression again. So we protect the %'s
|
||
|
|
# $stackTop = $percent.$expr.$percent;
|
||
|
|
#} else
|
||
|
|
{
|
||
|
|
# %VAR% case.
|
||
|
|
# In this case we *do* want to match the tag expression
|
||
|
|
# again, as an embedded %VAR% may have expanded to
|
||
|
|
# create a valid outer expression. This is directly
|
||
|
|
# at odds with the %VAR{...}% case.
|
||
|
|
push( @stack, $stackTop );
|
||
|
|
$stackTop = '%'; # open new context
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
push( @stack, $stackTop );
|
||
|
|
$stackTop = '%'; # push a new context
|
||
|
|
#$tell++ if ( $tell );
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$stackTop .= $token;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Run out of input. Gather up everything in the stack.
|
||
|
|
while ( scalar( @stack )) {
|
||
|
|
my $expr = $stackTop;
|
||
|
|
$stackTop = pop( @stack );
|
||
|
|
$stackTop .= $expr;
|
||
|
|
}
|
||
|
|
|
||
|
|
#$stackTop =~ s/$percent/%/go;
|
||
|
|
|
||
|
|
$this->{renderer}->putBackBlocks( \$stackTop, $verbatim, 'verbatim' );
|
||
|
|
|
||
|
|
#print STDERR "FINAL $stackTop\n" if $tell;
|
||
|
|
|
||
|
|
return $stackTop;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Handle expansion of a tag during topic rendering
|
||
|
|
# $tag is the tag name
|
||
|
|
# $args is the bit in the {} (if there are any)
|
||
|
|
# $topic and $web should be passed for dynamic tags (not needed for
|
||
|
|
# session or constant tags
|
||
|
|
sub _expandTagOnTopicRendering {
|
||
|
|
my $this = shift;
|
||
|
|
my $tag = shift;
|
||
|
|
my $args = shift;
|
||
|
|
# my( $topic, $web ) = @_;
|
||
|
|
|
||
|
|
my $e = $this->{prefs}->getPreferencesValue( $tag );
|
||
|
|
unless( defined( $e )) {
|
||
|
|
$e = $this->{SESSION_TAGS}{$tag};
|
||
|
|
unless( defined( $e )) {
|
||
|
|
$e = $constantTags{$tag};
|
||
|
|
}
|
||
|
|
if( !defined( $e ) && defined( $functionTags{$tag} )) {
|
||
|
|
$e = &{$functionTags{$tag}}
|
||
|
|
( $this, new TWiki::Attrs(
|
||
|
|
$args, $contextFreeSyntax{$tag} ), @_ );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $e;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Handle expansion of a tag during new topic creation. When creating a
|
||
|
|
# new topic from a template we only expand a subset of the available legal
|
||
|
|
# tags, and we expand %NOP% differently.
|
||
|
|
sub _expandTagOnTopicCreation {
|
||
|
|
my $this = shift;
|
||
|
|
# my( $tag, $args, $topic, $web ) = @_;
|
||
|
|
|
||
|
|
# Required for Cairo compatibility. Ignore %NOP{...}%
|
||
|
|
# %NOP% is *not* ignored until all variable expansion is complete,
|
||
|
|
# otherwise them inside-out rule would remove it too early e.g.
|
||
|
|
# %GM%NOP%TIME -> %GMTIME -> 12:00. So we ignore it here and scrape it
|
||
|
|
# out later. We *have* to remove %NOP{...}% because it can foul up
|
||
|
|
# brace-matching.
|
||
|
|
return '' if $_[0] eq 'NOP' && defined $_[1];
|
||
|
|
|
||
|
|
# Only expand a subset of legal tags. Warning: $this->{user} may be
|
||
|
|
# overridden during this call, when a new user topic is being created.
|
||
|
|
# This is what we want to make sure new user templates are populated
|
||
|
|
# correctly, but you need to think about this if you extend the set of
|
||
|
|
# tags expanded here.
|
||
|
|
return undef unless $_[0] =~ /^(URLPARAM|DATE|(SERVER|GM)TIME|(USER|WIKI)NAME|WIKIUSERNAME|USERINFO)$/;
|
||
|
|
|
||
|
|
return $this->_expandTagOnTopicRendering( @_ );
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod enterContext( $id, $val )
|
||
|
|
|
||
|
|
Add the context id $id into the set of active contexts. The $val
|
||
|
|
can be anything you like, but should always evaluate to boolean
|
||
|
|
TRUE.
|
||
|
|
|
||
|
|
An example of the use of contexts is in the use of tag
|
||
|
|
expansion. The commonTagsHandler in plugins is called every
|
||
|
|
time tags need to be expanded, and the context of that expansion
|
||
|
|
is signalled by the expanding module using a context id. So the
|
||
|
|
forms module adds the context id "form" before invoking common
|
||
|
|
tags expansion.
|
||
|
|
|
||
|
|
Contexts are not just useful for tag expansion; they are also
|
||
|
|
relevant when rendering.
|
||
|
|
|
||
|
|
Contexts are intended for use mainly by plugins. Core modules can
|
||
|
|
use $session->inContext( $id ) to determine if a context is active.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub enterContext {
|
||
|
|
my( $this, $id, $val ) = @_;
|
||
|
|
$val ||= 1;
|
||
|
|
$this->{context}->{$id} = $val;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod leaveContext( $id )
|
||
|
|
|
||
|
|
Remove the context id $id from the set of active contexts.
|
||
|
|
(see =enterContext= for more information on contexts)
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub leaveContext {
|
||
|
|
my( $this, $id ) = @_;
|
||
|
|
my $res = $this->{context}->{$id};
|
||
|
|
delete $this->{context}->{$id};
|
||
|
|
return $res;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod inContext( $id )
|
||
|
|
|
||
|
|
Return the value for the given context id
|
||
|
|
(see =enterContext= for more information on contexts)
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub inContext {
|
||
|
|
my( $this, $id ) = @_;
|
||
|
|
return $this->{context}->{$id};
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod registerTagHandler( $tag, $fnref )
|
||
|
|
|
||
|
|
STATIC Add a tag handler to the function tag handlers.
|
||
|
|
* =$tag= name of the tag e.g. MYTAG
|
||
|
|
* =$fnref= Function to execute. Will be passed ($session, \%params, $web, $topic )
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub registerTagHandler {
|
||
|
|
my ( $tag, $fnref, $syntax ) = @_;
|
||
|
|
$functionTags{$tag} = \&$fnref;
|
||
|
|
if( $syntax && $syntax eq 'context-free' ) {
|
||
|
|
$contextFreeSyntax{$tag} = 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod=
|
||
|
|
|
||
|
|
---++ StaticMethod registerRESTHandler( $subject, $verb, \&fn )
|
||
|
|
|
||
|
|
Adds a function to the dispatch table of the REST interface
|
||
|
|
for a given subject. See TWikiScripts#rest for more info.
|
||
|
|
|
||
|
|
* =$subject= - The subject under which the function will be registered.
|
||
|
|
* =$verb= - The verb under which the function will be registered.
|
||
|
|
* =\&fn= - Reference to the function.
|
||
|
|
|
||
|
|
The handler function must be of the form:
|
||
|
|
<verbatim>
|
||
|
|
sub handler(\%session,$subject,$verb) -> $text
|
||
|
|
</verbatim>
|
||
|
|
where:
|
||
|
|
* =\%session= - a reference to the TWiki session object (may be ignored)
|
||
|
|
* =$subject= - The invoked subject (may be ignored)
|
||
|
|
* =$verb= - The invoked verb (may be ignored)
|
||
|
|
|
||
|
|
*Since:* TWiki::Plugins::VERSION 1.1
|
||
|
|
|
||
|
|
=cut=
|
||
|
|
|
||
|
|
sub registerRESTHandler {
|
||
|
|
my ( $subject, $verb, $fnref) = @_;
|
||
|
|
$restDispatch{$subject}{$verb} = \&$fnref;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod=
|
||
|
|
|
||
|
|
---++ StaticMethod restDispatch( $subject, $verb) => \&fn
|
||
|
|
|
||
|
|
Returns the handler function associated to the given $subject and $werb,
|
||
|
|
or undef if none is found.
|
||
|
|
|
||
|
|
*Since:* TWiki::Plugins::VERSION 1.1
|
||
|
|
|
||
|
|
=cut=
|
||
|
|
|
||
|
|
sub restDispatch {
|
||
|
|
my ( $subject, $verb) = @_;
|
||
|
|
my $s=$restDispatch{$subject};
|
||
|
|
if (defined($s)) {
|
||
|
|
return $restDispatch{$subject}{$verb};
|
||
|
|
} else {
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod handleCommonTags( $text, $web, $topic ) -> $text
|
||
|
|
|
||
|
|
Processes %<nop>VARIABLE%, and %<nop>TOC% syntax; also includes
|
||
|
|
'commonTagsHandler' plugin hook.
|
||
|
|
|
||
|
|
Returns the text of the topic, after file inclusion, variable substitution,
|
||
|
|
table-of-contents generation, and any plugin changes from commonTagsHandler.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub handleCommonTags {
|
||
|
|
my( $this, $text, $theWeb, $theTopic ) = @_;
|
||
|
|
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
ASSERT($theWeb) if DEBUG;
|
||
|
|
ASSERT($theTopic) if DEBUG;
|
||
|
|
|
||
|
|
return $text unless $text;
|
||
|
|
my $verbatim={};
|
||
|
|
# Plugin Hook (for cache Plugins only)
|
||
|
|
$this->{plugins}->beforeCommonTagsHandler( $text, $theTopic, $theWeb );
|
||
|
|
|
||
|
|
#use a "global var", so included topics can extract and putback
|
||
|
|
#their verbatim blocks safetly.
|
||
|
|
$text = $this->{renderer}->takeOutBlocks( $text, 'verbatim',
|
||
|
|
$verbatim);
|
||
|
|
|
||
|
|
my $memW = $this->{SESSION_TAGS}{INCLUDINGWEB};
|
||
|
|
my $memT = $this->{SESSION_TAGS}{INCLUDINGTOPIC};
|
||
|
|
$this->{SESSION_TAGS}{INCLUDINGWEB} = $theWeb;
|
||
|
|
$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $theTopic;
|
||
|
|
|
||
|
|
$this->_expandAllTags( \$text, $theTopic, $theWeb );
|
||
|
|
|
||
|
|
$text = $this->{renderer}->takeOutBlocks( $text, 'verbatim',
|
||
|
|
$verbatim);
|
||
|
|
|
||
|
|
|
||
|
|
# Plugin Hook
|
||
|
|
$this->{plugins}->commonTagsHandler( $text, $theTopic, $theWeb, 0 );
|
||
|
|
|
||
|
|
# process tags again because plugin hook may have added more in
|
||
|
|
$this->_expandAllTags( \$text, $theTopic, $theWeb );
|
||
|
|
|
||
|
|
$this->{SESSION_TAGS}{INCLUDINGWEB} = $memW;
|
||
|
|
$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $memT;
|
||
|
|
|
||
|
|
# 'Special plugin tag' TOC hack, must be done after all other expansions
|
||
|
|
# are complete, and has to reprocess the entire topic.
|
||
|
|
$text =~ s/%TOC(?:{(.*?)})?%/$this->_TOC($text, $theTopic, $theWeb, $1)/ge;
|
||
|
|
|
||
|
|
# Codev.FormattedSearchWithConditionalOutput: remove <nop> lines,
|
||
|
|
# possibly introduced by SEARCHes with conditional CALC. This needs
|
||
|
|
# to be done after CALC and before table rendering in order to join
|
||
|
|
# table rows properly
|
||
|
|
$text =~ s/^<nop>\r?\n//gm;
|
||
|
|
|
||
|
|
$this->{renderer}->putBackBlocks( \$text, $verbatim, 'verbatim' );
|
||
|
|
|
||
|
|
# TWiki Plugin Hook (for cache Plugins only)
|
||
|
|
$this->{plugins}->afterCommonTagsHandler( $text, $theTopic, $theWeb );
|
||
|
|
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod addToHEAD( $id, $html )
|
||
|
|
|
||
|
|
Add =$html= to the HEAD tag of the page currently being generated.
|
||
|
|
|
||
|
|
Note that TWiki variables may be used in the HEAD. They will be expanded
|
||
|
|
according to normal variable expansion rules.
|
||
|
|
|
||
|
|
The 'id' is used to ensure that multiple adds of the same block of HTML don't
|
||
|
|
result in it being added many times.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub addToHEAD {
|
||
|
|
my ($this,$tag,$header) = @_;
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
|
||
|
|
$header = $this->handleCommonTags( $header, $this->{webName},
|
||
|
|
$this->{topicName} );
|
||
|
|
|
||
|
|
$this->{htmlHeaders}{$tag} = $header;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod initialize( $pathInfo, $remoteUser, $topic, $url, $query ) -> ($topicName, $webName, $scriptUrlPath, $userName, $dataDir)
|
||
|
|
|
||
|
|
Return value: ( $topicName, $webName, $TWiki::cfg{ScriptUrlPath}, $userName, $TWiki::cfg{DataDir} )
|
||
|
|
|
||
|
|
Static method to construct a new singleton session instance.
|
||
|
|
It creates a new TWiki and sets the Plugins $SESSION variable to
|
||
|
|
point to it, so that TWiki::Func methods will work.
|
||
|
|
|
||
|
|
This method is *DEPRECATED* but is maintained for script compatibility.
|
||
|
|
|
||
|
|
Note that $theUrl, if specified, must be identical to $query->url()
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub initialize {
|
||
|
|
my ( $pathInfo, $theRemoteUser, $topic, $theUrl, $query ) = @_;
|
||
|
|
|
||
|
|
if( !$query ) {
|
||
|
|
$query = new CGI( {} );
|
||
|
|
}
|
||
|
|
if( $query->path_info() ne $pathInfo ) {
|
||
|
|
$query->path_info( $pathInfo );
|
||
|
|
}
|
||
|
|
if( $topic ) {
|
||
|
|
$query->param( -name => 'topic', -value => '' );
|
||
|
|
}
|
||
|
|
# can't do much if $theUrl is specified and it is inconsistent with
|
||
|
|
# the query. We are trying to get to all parameters passed in the
|
||
|
|
# query.
|
||
|
|
if( $theUrl && $theUrl ne $query->url()) {
|
||
|
|
die 'Sorry, this version of TWiki does not support the url parameter to TWiki::initialize being different to the url in the query';
|
||
|
|
}
|
||
|
|
my $twiki = new TWiki( $theRemoteUser, $query );
|
||
|
|
|
||
|
|
# Force the new session into the plugins context.
|
||
|
|
$TWiki::Plugins::SESSION = $twiki;
|
||
|
|
|
||
|
|
return ( $twiki->{topicName}, $twiki->{webName}, $twiki->{scriptUrlPath},
|
||
|
|
$twiki->{userName}, $TWiki::cfg{DataDir} );
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod readFile( $filename ) -> $text
|
||
|
|
|
||
|
|
Returns the entire contents of the given file, which can be specified in any
|
||
|
|
format acceptable to the Perl open() function. Fast, but inherently unsafe.
|
||
|
|
|
||
|
|
WARNING: Never, ever use this for accessing topics or attachments! Use the
|
||
|
|
Store API for that. This is for global control files only, and should be
|
||
|
|
used *only* if there is *absolutely no alternative*.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub readFile {
|
||
|
|
my $name = shift;
|
||
|
|
open( IN_FILE, "<$name" ) || return '';
|
||
|
|
local $/ = undef;
|
||
|
|
my $data = <IN_FILE>;
|
||
|
|
close( IN_FILE );
|
||
|
|
$data = '' unless( defined( $data ));
|
||
|
|
return $data;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _FORMFIELD {
|
||
|
|
my ( $this, $params, $topic, $web ) = @_;
|
||
|
|
my $cgiQuery = $this->{cgiQuery};
|
||
|
|
my $cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
|
||
|
|
$params->{rev} = $cgiRev;
|
||
|
|
return $this->{renderer}->renderFORMFIELD( $params, $topic, $web );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _TMPLP {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
return $this->{templates}->tmplP( $params );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _VAR {
|
||
|
|
my( $this, $params, $topic, $inweb ) = @_;
|
||
|
|
my $key = $params->{_DEFAULT};
|
||
|
|
my $web = $params->{web} || $inweb;
|
||
|
|
# handle %MAINWEB%-type cases
|
||
|
|
( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
|
||
|
|
# always return a value, even when the key isn't defined
|
||
|
|
return $this->{prefs}->getWebPreferencesValue( $key, $web ) || '';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _PLUGINVERSION {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
$this->{plugins}->getPluginVersion( $params->{_DEFAULT} );
|
||
|
|
}
|
||
|
|
|
||
|
|
my $ifFactory;
|
||
|
|
sub _IF {
|
||
|
|
my ( $this, $params ) = @_;
|
||
|
|
|
||
|
|
unless( $ifFactory ) {
|
||
|
|
require TWiki::If;
|
||
|
|
$ifFactory = new TWiki::If();
|
||
|
|
}
|
||
|
|
|
||
|
|
my $expr = $ifFactory->parse( $params->{_DEFAULT} );
|
||
|
|
return $this->inlineAlert(
|
||
|
|
'alerts', 'generic', 'IF{', $params->stringify(), '}:',
|
||
|
|
$ifFactory->{error} ) unless $expr;
|
||
|
|
|
||
|
|
if( $expr->evaluate( $this )) {
|
||
|
|
return $params->{then} || '';
|
||
|
|
} else {
|
||
|
|
return $params->{else} || '';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# generate an include warning
|
||
|
|
# SMELL: varying number of parameters idiotic to handle for customized $warn
|
||
|
|
sub _includeWarning {
|
||
|
|
my $this = shift;
|
||
|
|
my $warn = shift;
|
||
|
|
my $message = shift;
|
||
|
|
|
||
|
|
if( $warn eq 'on' ) {
|
||
|
|
return $this->inlineAlert( 'alerts', $message, @_ );
|
||
|
|
} elsif( isTrue( $warn )) {
|
||
|
|
# different inlineAlerts need different argument counts
|
||
|
|
my $argument = '';
|
||
|
|
if ($message eq 'topic_not_found') {
|
||
|
|
my ($web,$topic) = @_;
|
||
|
|
$argument = "$web.$topic";
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$argument = shift;
|
||
|
|
}
|
||
|
|
$warn =~ s/\$topic/$argument/go if $argument;
|
||
|
|
return $warn;
|
||
|
|
} # else fail silently
|
||
|
|
return '';
|
||
|
|
}
|
||
|
|
|
||
|
|
# Processes a specific instance %<nop>INCLUDE{...}% syntax.
|
||
|
|
# Returns the text to be inserted in place of the INCLUDE command.
|
||
|
|
# $topic and $web should be for the immediate parent topic in the
|
||
|
|
# include hierarchy. Works for both URLs and absolute server paths.
|
||
|
|
sub _INCLUDE {
|
||
|
|
my ( $this, $params, $includingTopic, $includingWeb ) = @_;
|
||
|
|
|
||
|
|
# remember args for the key before mangling the params
|
||
|
|
my $args = $params->stringify();
|
||
|
|
|
||
|
|
# Remove params, so they don't get expanded in the included page
|
||
|
|
my $path = $params->remove('_DEFAULT') || '';
|
||
|
|
my $pattern = $params->remove('pattern');
|
||
|
|
my $rev = $params->remove('rev');
|
||
|
|
my $section = $params->remove('section');
|
||
|
|
my $raw = $params->remove('raw') || '';
|
||
|
|
my $warn = $params->remove('warn')
|
||
|
|
|| $this->{prefs}->getPreferencesValue( 'INCLUDEWARNING' );
|
||
|
|
|
||
|
|
if( $path =~ /^https?\:/ ) {
|
||
|
|
# include web page
|
||
|
|
return $this->_includeUrl(
|
||
|
|
$path, $pattern, $includingWeb, $includingTopic,
|
||
|
|
$raw, $params, $warn );
|
||
|
|
}
|
||
|
|
|
||
|
|
$path =~ s/$TWiki::cfg{NameFilter}//go; # zap anything suspicious
|
||
|
|
if( $TWiki::cfg{DenyDotDotInclude} ) {
|
||
|
|
# Filter out '..' from filename, this is to
|
||
|
|
# prevent includes of '../../file'
|
||
|
|
$path =~ s/\.+/\./g;
|
||
|
|
} else {
|
||
|
|
# danger, could include .htpasswd with relative path
|
||
|
|
$path =~ s/passwd//gi; # filter out passwd filename
|
||
|
|
}
|
||
|
|
|
||
|
|
# make sure we have something to include. If we don't do this, then
|
||
|
|
# normalizeWebTopicName will default to WebHome. Item2209.
|
||
|
|
unless( $path ) {
|
||
|
|
# SMELL: could do with a different message here, but don't want to
|
||
|
|
# add one right now because translators are already working
|
||
|
|
return $this->_includeWarning( $warn, 'topic_not_found', '""','""' );
|
||
|
|
}
|
||
|
|
|
||
|
|
my $text = '';
|
||
|
|
my $meta = '';
|
||
|
|
my $includedWeb;
|
||
|
|
my $includedTopic = $path;
|
||
|
|
$includedTopic =~ s/\.txt$//; # strip optional (undocumented) .txt
|
||
|
|
|
||
|
|
($includedWeb, $includedTopic) =
|
||
|
|
$this->normalizeWebTopicName($includingWeb, $includedTopic);
|
||
|
|
|
||
|
|
# See Codev.FailedIncludeWarning for the history.
|
||
|
|
unless( $this->{store}->topicExists($includedWeb, $includedTopic)) {
|
||
|
|
return $this->_includeWarning( $warn, 'topic_not_found',
|
||
|
|
$includedWeb, $includedTopic );
|
||
|
|
}
|
||
|
|
|
||
|
|
# prevent recursive includes. Note that the inclusion of a topic into
|
||
|
|
# itself is not blocked; however subsequent attempts to include the
|
||
|
|
# topic will fail. There is a hard block of 99 on any recursive include.
|
||
|
|
my $key = $includingWeb.'.'.$includingTopic;
|
||
|
|
my $count = grep( $key, keys %{$this->{includes}});
|
||
|
|
$key .= $args;
|
||
|
|
if( $this->{includes}->{$key} || $count > 99) {
|
||
|
|
return $this->_includeWarning( $warn, 'already_included',
|
||
|
|
"$includedWeb.$includedTopic", '' );
|
||
|
|
}
|
||
|
|
|
||
|
|
my %saveTags = %{$this->{SESSION_TAGS}};
|
||
|
|
my $prefsMark = $this->{prefs}->mark();
|
||
|
|
|
||
|
|
$this->{includes}->{$key} = 1;
|
||
|
|
$this->{SESSION_TAGS}{INCLUDINGWEB} = $includingWeb;
|
||
|
|
$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $includingTopic;
|
||
|
|
|
||
|
|
# copy params into session tags
|
||
|
|
foreach my $k ( keys %$params ) {
|
||
|
|
$this->{SESSION_TAGS}{$k} = $params->{$k};
|
||
|
|
}
|
||
|
|
|
||
|
|
( $meta, $text ) =
|
||
|
|
$this->{store}->readTopic( undef, $includedWeb, $includedTopic,
|
||
|
|
$rev );
|
||
|
|
|
||
|
|
unless( $this->{security}->checkAccessPermission(
|
||
|
|
'VIEW', $this->{user}, $text, $meta, $includedTopic, $includedWeb )) {
|
||
|
|
if( isTrue( $warn )) {
|
||
|
|
return $this->inlineAlert( 'alerts', 'access_denied',
|
||
|
|
$includedTopic );
|
||
|
|
} # else fail silently
|
||
|
|
return '';
|
||
|
|
}
|
||
|
|
|
||
|
|
# remove everything before and after the selected include block
|
||
|
|
if( !$section ) {
|
||
|
|
$text =~ s/.*?%STARTINCLUDE%//s;
|
||
|
|
$text =~ s/%STOPINCLUDE%.*//s;
|
||
|
|
}
|
||
|
|
|
||
|
|
# handle sections
|
||
|
|
my( $ntext, $sections ) = parseSections( $text );
|
||
|
|
|
||
|
|
my $interesting = ( defined $section );
|
||
|
|
if( scalar( @$sections )) {
|
||
|
|
# Rebuild the text from the sections
|
||
|
|
$text = '';
|
||
|
|
foreach my $s ( @$sections ) {
|
||
|
|
if( $section && $s->{type} eq 'section' &&
|
||
|
|
$s->{name} eq $section) {
|
||
|
|
$text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} );
|
||
|
|
$interesting = 1;
|
||
|
|
last;
|
||
|
|
} elsif( $s->{type} eq 'include' && !$section ) {
|
||
|
|
$text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} );
|
||
|
|
$interesting = 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# If there were no interesting sections, restore the whole text
|
||
|
|
$text = $ntext unless $interesting;
|
||
|
|
|
||
|
|
$text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
|
||
|
|
|
||
|
|
$this->_expandAllTags( \$text, $includedTopic, $includedWeb );
|
||
|
|
|
||
|
|
# 4th parameter tells plugin that its called for an included file
|
||
|
|
$this->{plugins}->commonTagsHandler( $text, $includedTopic,
|
||
|
|
$includedWeb, 1 );
|
||
|
|
|
||
|
|
# We have to expand tags again, because a plugin may have inserted additional
|
||
|
|
# tags.
|
||
|
|
$this->_expandAllTags( \$text, $includedTopic, $includedWeb );
|
||
|
|
|
||
|
|
# If needed, fix all 'TopicNames' to 'Web.TopicNames' to get the
|
||
|
|
# right context so that links continue to work properly
|
||
|
|
if( $includedWeb ne $includingWeb ) {
|
||
|
|
my $removed = {};
|
||
|
|
|
||
|
|
# Must handle explicit [[]] before noautolink
|
||
|
|
# '[[TopicName]]' to '[[Web.TopicName][TopicName]]'
|
||
|
|
$text =~ s/\[\[([^\]]+)\]\]/&_fixIncludeLink( $includedWeb, $1 )/geo;
|
||
|
|
# '[[TopicName][...]]' to '[[Web.TopicName][...]]'
|
||
|
|
$text =~ s/\[\[([^\]]+)\]\[([^\]]+)\]\]/&_fixIncludeLink( $includedWeb, $1, $2 )/geo;
|
||
|
|
|
||
|
|
unless( TWiki::isTrue( $this->{prefs}->getPreferencesValue('NOAUTOLINK')) ) {
|
||
|
|
# Handle WikiWords
|
||
|
|
$text = $this->{renderer}->takeOutBlocks( $text, 'noautolink', $removed );
|
||
|
|
}
|
||
|
|
|
||
|
|
# 'TopicName' to 'Web.TopicName'
|
||
|
|
$text =~ s/(^|[\s(])($regex{webNameRegex}\.$regex{wikiWordRegex})/$1$TranslationToken$2/go;
|
||
|
|
$text =~ s/(^|[\s(])($regex{wikiWordRegex})/$1$includedWeb\.$2/go;
|
||
|
|
$text =~ s/(^|[\s(])$TranslationToken/$1/go;
|
||
|
|
|
||
|
|
$this->{renderer}->putBackBlocks( \$text, $removed, 'noautolink' );
|
||
|
|
}
|
||
|
|
|
||
|
|
# handle tags again because of plugin hook
|
||
|
|
$this->_expandAllTags( \$text, $includedTopic, $includedWeb );
|
||
|
|
|
||
|
|
# restore the tags
|
||
|
|
delete $this->{includes}->{$key};
|
||
|
|
%{$this->{SESSION_TAGS}} = %saveTags;
|
||
|
|
|
||
|
|
$this->{prefs}->restore( $prefsMark );
|
||
|
|
$text =~ s/^[\r\n]+/\n/;
|
||
|
|
$text =~ s/[\r\n]+$/\n/;
|
||
|
|
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _HTTP {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $res;
|
||
|
|
if( $params->{_DEFAULT} ) {
|
||
|
|
$res = $this->{cgiQuery}->http( $params->{_DEFAULT} );
|
||
|
|
}
|
||
|
|
$res = '' unless defined( $res );
|
||
|
|
return $res;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _HTTPS {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $res;
|
||
|
|
if( $params->{_DEFAULT} ) {
|
||
|
|
$res = $this->{cgiQuery}->https( $params->{_DEFAULT} );
|
||
|
|
}
|
||
|
|
$res = '' unless defined( $res );
|
||
|
|
return $res;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _HTTP_HOST {
|
||
|
|
return $ENV{HTTP_HOST} || '';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _REMOTE_ADDR {
|
||
|
|
return $ENV{REMOTE_ADDR} || '';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _REMOTE_PORT {
|
||
|
|
return $ENV{REMOTE_PORT} || '';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _REMOTE_USER {
|
||
|
|
return $ENV{REMOTE_USER} || '';
|
||
|
|
}
|
||
|
|
|
||
|
|
# Only does simple search for topicmoved at present, can be expanded when required
|
||
|
|
# SMELL: this violates encapsulation of Store and Meta, by exporting
|
||
|
|
# the assumption that meta-data is stored embedded inside topic
|
||
|
|
# text.
|
||
|
|
sub _METASEARCH {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
|
||
|
|
return $this->{store}->searchMetaData( $params );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _DATE {
|
||
|
|
my $this = shift;
|
||
|
|
return TWiki::Time::formatTime(time(), '$day $mon $year', 'gmtime');
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _GMTIME {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'gmtime' );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _SERVERTIME {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'servertime' );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _DISPLAYTIME {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', $TWiki::cfg{DisplayTimeValues} );
|
||
|
|
}
|
||
|
|
|
||
|
|
#| $web | web and |
|
||
|
|
#| $topic | topic to display the name for |
|
||
|
|
#| $formatString | twiki format string (like in search) |
|
||
|
|
sub _REVINFO {
|
||
|
|
my ( $this, $params, $theTopic, $theWeb ) = @_;
|
||
|
|
my $format = $params->{_DEFAULT} || $params->{format};
|
||
|
|
my $web = $params->{web} || $theWeb;
|
||
|
|
my $topic = $params->{topic} || $theTopic;
|
||
|
|
my $cgiQuery = $this->{cgiQuery};
|
||
|
|
my $cgiRev = '';
|
||
|
|
$cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
|
||
|
|
my $rev = $cgiRev || $params->{rev} || '';
|
||
|
|
|
||
|
|
return $this->{renderer}->renderRevisionInfo( $web, $topic, undef,
|
||
|
|
$rev, $format );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _ENCODE {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $type = $params->{type} || '';
|
||
|
|
my $text = $params->{_DEFAULT} || '';
|
||
|
|
if ( $type =~ /^entit(y|ies)$/i ) {
|
||
|
|
return entityEncode( $text );
|
||
|
|
} elsif ( $type =~ /^html$/i ) {
|
||
|
|
return entityEncode( $text, "\n\r" );
|
||
|
|
} elsif ( $type =~ /^quotes?$/i ) {
|
||
|
|
$text =~ s/\"/\\"/go; # escape quotes with backslash (Bugs:Item3383 fix)
|
||
|
|
return $text;
|
||
|
|
} else {
|
||
|
|
$text =~ s/\r*\n\r*/<br \/>/; # Legacy.
|
||
|
|
return urlEncode( $text );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _SEARCH {
|
||
|
|
my ( $this, $params, $topic, $web ) = @_;
|
||
|
|
# pass on all attrs, and add some more
|
||
|
|
#$params->{_callback} = undef;
|
||
|
|
$params->{inline} = 1;
|
||
|
|
$params->{baseweb} = $web;
|
||
|
|
$params->{basetopic} = $topic;
|
||
|
|
$params->{search} = $params->{_DEFAULT} if( $params->{_DEFAULT} );
|
||
|
|
$params->{type} = $this->{prefs}->getPreferencesValue( 'SEARCHVARDEFAULTTYPE' ) unless( $params->{type} );
|
||
|
|
|
||
|
|
my $s = $this->{search}->searchWeb( %$params );
|
||
|
|
return $s;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _WEBLIST {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $format = $params->{_DEFAULT} || $params->{'format'} || '$name';
|
||
|
|
$format ||= '$name';
|
||
|
|
my $separator = $params->{separator} || "\n";
|
||
|
|
$separator =~ s/\$n/\n/;
|
||
|
|
my $web = $params->{web} || '';
|
||
|
|
my $webs = $params->{webs} || 'public';
|
||
|
|
my $selection = $params->{selection} || '';
|
||
|
|
$selection =~ s/\,/ /g;
|
||
|
|
$selection = " $selection ";
|
||
|
|
my $marker = $params->{marker} || 'selected="selected"';
|
||
|
|
$web =~ s#\.#/#go;
|
||
|
|
|
||
|
|
my @list = ();
|
||
|
|
my @webslist = split( /,\s*/, $webs );
|
||
|
|
foreach my $aweb ( @webslist ) {
|
||
|
|
if( $aweb eq 'public' ) {
|
||
|
|
push( @list, $this->{store}->getListOfWebs( 'user,public,allowed' ) );
|
||
|
|
} elsif( $aweb eq 'webtemplate' ) {
|
||
|
|
push( @list, $this->{store}->getListOfWebs( 'template,allowed' ));
|
||
|
|
} else{
|
||
|
|
push( @list, $aweb ) if( $this->{store}->webExists( $aweb ) );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
my @items;
|
||
|
|
my $indent = CGI::span({class=>'twikiWebIndent'},'');
|
||
|
|
foreach my $item ( @list ) {
|
||
|
|
my $line = $format;
|
||
|
|
$line =~ s/\$web\b/$web/g;
|
||
|
|
$line =~ s/\$name\b/$item/g;
|
||
|
|
$line =~ s/\$qname/"$item"/g;
|
||
|
|
my $indenteditem = $item;
|
||
|
|
$indenteditem =~ s#/$##g;
|
||
|
|
$indenteditem =~ s#\w+/#$indent#g;
|
||
|
|
$line =~ s/\$indentedname/$indenteditem/g;
|
||
|
|
my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
|
||
|
|
$line =~ s/\$marker/$mark/g;
|
||
|
|
push(@items, $line);
|
||
|
|
}
|
||
|
|
return join( $separator, @items);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _TOPICLIST {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $format = $params->{_DEFAULT} || $params->{'format'} || '$name';
|
||
|
|
$format ||= '$name';
|
||
|
|
my $separator = $params->{separator} || "\n";
|
||
|
|
$separator =~ s/\$n/\n/;
|
||
|
|
my $web = $params->{web} || $this->{webName};
|
||
|
|
my $selection = $params->{selection} || '';
|
||
|
|
$selection =~ s/\,/ /g;
|
||
|
|
$selection = " $selection ";
|
||
|
|
my $marker = $params->{marker} || 'selected="selected"';
|
||
|
|
$web =~ s#\.#/#go;
|
||
|
|
|
||
|
|
return '' if
|
||
|
|
$web ne $this->{webName} &&
|
||
|
|
$this->{prefs}->getWebPreferencesValue( 'NOSEARCHALL', $web );
|
||
|
|
|
||
|
|
my @items;
|
||
|
|
foreach my $item ( $this->{store}->getTopicNames( $web ) ) {
|
||
|
|
my $line = $format;
|
||
|
|
$line =~ s/\$web\b/$web/g;
|
||
|
|
$line =~ s/\$name\b/$item/g;
|
||
|
|
$line =~ s/\$qname/"$item"/g;
|
||
|
|
my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
|
||
|
|
$line =~ s/\$marker/$mark/g;
|
||
|
|
push( @items, $line );
|
||
|
|
}
|
||
|
|
return join( $separator, @items );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _QUERYSTRING {
|
||
|
|
my $this = shift;
|
||
|
|
return $this->{cgiQuery}->query_string();
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _QUERYPARAMS {
|
||
|
|
my ( $this, $params ) = @_;
|
||
|
|
return '' unless $this->{cgiQuery};
|
||
|
|
my $format = defined $params->{format} ? $params->{format} : '$name=$value';
|
||
|
|
my $separator = defined $params->{separator} ? $params->{separator} : "\n";
|
||
|
|
|
||
|
|
my @list;
|
||
|
|
foreach my $name ( $this->{cgiQuery}->param() ) {
|
||
|
|
# Issues multi-valued parameters as separate hiddens
|
||
|
|
my $value = $this->{cgiQuery}->param( $name );
|
||
|
|
my $entry = $format;
|
||
|
|
$entry =~ s/\$name/$name/g;
|
||
|
|
$entry =~ s/\$value/$value/;
|
||
|
|
push(@list, $entry);
|
||
|
|
}
|
||
|
|
return expandStandardEscapes(join($separator, @list));
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod expandStandardEscapes($str) -> $unescapedStr
|
||
|
|
|
||
|
|
Expands standard escapes used in parameter values to block evaluation. The following escapes
|
||
|
|
are handled:
|
||
|
|
|
||
|
|
| *Escape:* | *Expands To:* |
|
||
|
|
| =$n= or =$n()= | New line. Use =$n()= if followed by alphanumeric character, e.g. write =Foo$n()Bar= instead of =Foo$nBar= |
|
||
|
|
| =$nop= or =$nop()= | Is a "no operation". |
|
||
|
|
| =$quot= | Double quote (="=) |
|
||
|
|
| =$percnt= | Percent sign (=%=) |
|
||
|
|
| =$dollar= | Dollar sign (=$=) |
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub expandStandardEscapes {
|
||
|
|
my $text = shift;
|
||
|
|
$text =~ s/\$n\(\)/\n/gos; # expand '$n()' to new line
|
||
|
|
$text =~ s/\$n([^$regex{mixedAlpha}]|$)/\n$1/gos; # expand '$n' to new line
|
||
|
|
$text =~ s/\$nop(\(\))?//gos; # remove filler, useful for nested search
|
||
|
|
$text =~ s/\$quot(\(\))?/\"/gos; # expand double quote
|
||
|
|
$text =~ s/\$percnt(\(\))?/\%/gos; # expand percent
|
||
|
|
$text =~ s/\$dollar(\(\))?/\$/gos; # expand dollar
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _URLPARAM {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $param = $params->{_DEFAULT} || '';
|
||
|
|
my $newLine = $params->{newline} || '';
|
||
|
|
my $encode = $params->{encode};
|
||
|
|
my $multiple = $params->{multiple};
|
||
|
|
my $separator = $params->{separator} || "\n";
|
||
|
|
|
||
|
|
my $value = '';
|
||
|
|
if( $this->{cgiQuery} ) {
|
||
|
|
if( TWiki::isTrue( $multiple )) {
|
||
|
|
my @valueArray = $this->{cgiQuery}->param( $param );
|
||
|
|
if( @valueArray ) {
|
||
|
|
# join multiple values properly
|
||
|
|
unless( $multiple =~ m/^on$/i ) {
|
||
|
|
my $item = '';
|
||
|
|
@valueArray = map {
|
||
|
|
$item = $_;
|
||
|
|
$_ = $multiple;
|
||
|
|
$_ .= $item unless( s/\$item/$item/go );
|
||
|
|
$_
|
||
|
|
} @valueArray;
|
||
|
|
}
|
||
|
|
$value = join ( $separator, @valueArray );
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$value = $this->{cgiQuery}->param( $param );
|
||
|
|
$value = '' unless( defined $value );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$value =~ s/\r?\n/$newLine/go if( $newLine );
|
||
|
|
if ( $encode ) {
|
||
|
|
if ( $encode =~ /^entit(y|ies)$/i ) {
|
||
|
|
$value = entityEncode( $value );
|
||
|
|
} elsif ( $encode =~ /^quotes?$/i ) {
|
||
|
|
$value =~ s/\"/\\"/go; # escape quotes with backslash (Bugs:Item3383 fix)
|
||
|
|
} else {
|
||
|
|
$value =~ s/\r*\n\r*/<br \/>/; # Legacy
|
||
|
|
$value = urlEncode( $value );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
unless( $value ) {
|
||
|
|
$value = $params->{default} || '';
|
||
|
|
}
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
|
||
|
|
# This routine was introduced to URL encode Mozilla UTF-8 POST URLs in the
|
||
|
|
# TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now
|
||
|
|
# directly supported, but it is provided for backward compatibility with
|
||
|
|
# skins that may still be using the deprecated %INTURLENCODE%.
|
||
|
|
sub _INTURLENCODE {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
# Just strip double quotes, no URL encoding - Mozilla UTF-8 URLs
|
||
|
|
# directly supported now
|
||
|
|
return $params->{_DEFAULT} || '';
|
||
|
|
}
|
||
|
|
|
||
|
|
# This routine is deprecated as of DakarRelease,
|
||
|
|
# and is maintained only for backward compatibility.
|
||
|
|
# Spacing of WikiWords is now done with %SPACEOUT%
|
||
|
|
# (and the private routine _SPACEOUT).
|
||
|
|
sub _SPACEDTOPIC {
|
||
|
|
my ( $this, $params, $theTopic ) = @_;
|
||
|
|
my $topic = spaceOutWikiWord( $theTopic );
|
||
|
|
$topic =~ s/ / */g;
|
||
|
|
return urlEncode( $topic );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _SPACEOUT {
|
||
|
|
my ( $this, $params ) = @_;
|
||
|
|
my $spaceOutTopic = $params->{_DEFAULT};
|
||
|
|
my $sep = $params->{'separator'};
|
||
|
|
$spaceOutTopic = spaceOutWikiWord( $spaceOutTopic, $sep );
|
||
|
|
return $spaceOutTopic;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _ICON {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $file = $params->{_DEFAULT} || '';
|
||
|
|
# Try to map the file name to see if there is a matching filetype image
|
||
|
|
# If no mapping could be found, use the file name that was passed
|
||
|
|
my $iconFileName = $this->mapToIconFileName( $file, $file );
|
||
|
|
return CGI::img( { src => $this->getIconUrl( 0, $iconFileName ),
|
||
|
|
width => 16, height=>16,
|
||
|
|
align => 'top', alt => $iconFileName, border => 0 });
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _ICONURL {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $file = ( $params->{_DEFAULT} || '' );
|
||
|
|
|
||
|
|
return $this->getIconUrl( 1, $file );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _ICONURLPATH {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
my $file = ( $params->{_DEFAULT} || '' );
|
||
|
|
|
||
|
|
return $this->getIconUrl( 0, $file );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _RELATIVETOPICPATH {
|
||
|
|
my ( $this, $params, $theTopic, $web ) = @_;
|
||
|
|
my $topic = $params->{_DEFAULT};
|
||
|
|
|
||
|
|
return '' unless $topic;
|
||
|
|
|
||
|
|
my $theRelativePath;
|
||
|
|
# if there is no dot in $topic, no web has been specified
|
||
|
|
if ( index( $topic, '.' ) == -1 ) {
|
||
|
|
# add local web
|
||
|
|
$theRelativePath = $web . '/' . $topic;
|
||
|
|
} else {
|
||
|
|
$theRelativePath = $topic; #including dot
|
||
|
|
}
|
||
|
|
# replace dot by slash is not necessary; TWiki.MyTopic is a valid url
|
||
|
|
# add ../ if not already present to make a relative file reference
|
||
|
|
if ( $theRelativePath !~ m!^../! ) {
|
||
|
|
$theRelativePath = "../$theRelativePath";
|
||
|
|
}
|
||
|
|
return $theRelativePath;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _ATTACHURLPATH {
|
||
|
|
my ( $this, $params, $topic, $web ) = @_;
|
||
|
|
return $this->getPubUrl(0, $web, $topic);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _ATTACHURL {
|
||
|
|
my ( $this, $params, $topic, $web ) = @_;
|
||
|
|
return $this->getPubUrl(1, $web, $topic);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _LANGUAGE {
|
||
|
|
my $this = shift;
|
||
|
|
return $this->{i18n}->language();
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _LANGUAGES {
|
||
|
|
my ( $this , $params ) = @_;
|
||
|
|
my $format = $params->{format} || " * \$langname";
|
||
|
|
my $separator = $params->{separator} || "\n";
|
||
|
|
$separator =~ s/\\n/\n/g;
|
||
|
|
my $selection = $params->{selection} || '';
|
||
|
|
$selection =~ s/\,/ /g;
|
||
|
|
$selection = " $selection ";
|
||
|
|
my $marker = $params->{marker} || 'selected="selected"';
|
||
|
|
|
||
|
|
# $languages is a hash reference:
|
||
|
|
my $languages = $this->{i18n}->enabled_languages();
|
||
|
|
|
||
|
|
my @tags = sort(keys(%{$languages}));
|
||
|
|
|
||
|
|
my $result = '';
|
||
|
|
my $i = 0;
|
||
|
|
foreach my $lang (@tags) {
|
||
|
|
my $item = $format;
|
||
|
|
my $name = ${$languages}{$lang};
|
||
|
|
$item =~ s/\$langname/$name/g;
|
||
|
|
$item =~ s/\$langtag/$lang/g;
|
||
|
|
my $mark = ( $selection =~ / \Q$lang\E / ) ? $marker : '';
|
||
|
|
$item =~ s/\$marker/$mark/g;
|
||
|
|
$result .= $separator if $i;
|
||
|
|
$result .= $item;
|
||
|
|
$i++;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $result;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _MAKETEXT {
|
||
|
|
my( $this, $params ) = @_;
|
||
|
|
|
||
|
|
my $str = $params->{_DEFAULT} || $params->{string} || "";
|
||
|
|
return "" unless $str;
|
||
|
|
|
||
|
|
# escape everything:
|
||
|
|
$str =~ s/\[/~[/g;
|
||
|
|
$str =~ s/\]/~]/g;
|
||
|
|
|
||
|
|
# restore already escaped stuff:
|
||
|
|
$str =~ s/~~\[/~[/g;
|
||
|
|
$str =~ s/~~\]/~]/g;
|
||
|
|
|
||
|
|
# unescape parameters and calculate highest parameter number:
|
||
|
|
my $max = 0;
|
||
|
|
$str =~ s/~\[(\_(\d+))~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
|
||
|
|
$str =~ s/~\[(\*,\_(\d+),[^,]+(,([^,]+))?)~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
|
||
|
|
|
||
|
|
# get the args to be interpolated.
|
||
|
|
my $argsStr = $params->{args} || "";
|
||
|
|
|
||
|
|
my @args = split (/\s*,\s*/, $argsStr) ;
|
||
|
|
# fill omitted args with zeros
|
||
|
|
while ((scalar @args) < $max) {
|
||
|
|
push(@args, 0);
|
||
|
|
}
|
||
|
|
|
||
|
|
# do the magic:
|
||
|
|
my $result = $this->{i18n}->maketext($str, @args);
|
||
|
|
|
||
|
|
# replace accesskeys:
|
||
|
|
$result =~ s#(^|[^&])&([a-zA-Z])#$1<span class='twikiAccessKey'>$2</span>#g;
|
||
|
|
|
||
|
|
# replace escaped amperstands:
|
||
|
|
$result =~ s/&&/\&/g;
|
||
|
|
|
||
|
|
return $result;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _SCRIPTNAME {
|
||
|
|
#my ( $this, $params, $theTopic, $theWeb ) = @_;
|
||
|
|
# try SCRIPT_FILENAME
|
||
|
|
my $value = $ENV{SCRIPT_FILENAME};
|
||
|
|
if( $value ) {
|
||
|
|
$value =~ s!.*/([^/]+)$!$1!o;
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
# try SCRIPT_URL (won't work with url rewriting)
|
||
|
|
$value = $ENV{SCRIPT_URL};
|
||
|
|
if( $value ) {
|
||
|
|
# e.g. '/cgi-bin/view.cgi/TWiki/WebHome'
|
||
|
|
# cut URL path to get 'view.cgi/TWiki/WebHome'
|
||
|
|
$value =~ s|^$TWiki::cfg{ScriptUrlPath}/?||o;
|
||
|
|
# cut extended path to get 'view.cgi'
|
||
|
|
$value =~ s|/.*$||;
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
# no joy
|
||
|
|
return '';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _SCRIPTURL {
|
||
|
|
my ( $this, $params, $topic, $web ) = @_;
|
||
|
|
my $script = $params->{_DEFAULT} || '';
|
||
|
|
|
||
|
|
return $this->getScriptUrl( 1, $script );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _SCRIPTURLPATH {
|
||
|
|
my ( $this, $params, $topic, $web ) = @_;
|
||
|
|
my $script = $params->{_DEFAULT} || '';
|
||
|
|
|
||
|
|
return $this->getScriptUrl( 0, $script );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _PUBURL {
|
||
|
|
my $this = shift;
|
||
|
|
return $this->getPubUrl(1);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _PUBURLPATH {
|
||
|
|
my $this = shift;
|
||
|
|
return $this->getPubUrl(0);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _ALLVARIABLES {
|
||
|
|
return shift->{prefs}->stringify();
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _META {
|
||
|
|
my ( $this, $params, $topic, $web ) = @_;
|
||
|
|
|
||
|
|
my $meta = $this->inContext( 'can_render_meta' );
|
||
|
|
|
||
|
|
return '' unless $meta;
|
||
|
|
|
||
|
|
my $option = $params->{_DEFAULT};
|
||
|
|
|
||
|
|
if( $option eq 'form' ) {
|
||
|
|
# META:FORM and META:FIELD
|
||
|
|
return TWiki::Form::renderForDisplay( $this->{templates}, $meta );
|
||
|
|
} elsif ( $option eq 'formfield' ) {
|
||
|
|
# a formfield from within topic text
|
||
|
|
return $this->{renderer}->renderFormField( $meta, $params );
|
||
|
|
} elsif( $option eq 'attachments' ) {
|
||
|
|
# renders attachment tables
|
||
|
|
return $this->{attach}->renderMetaData( $web, $topic, $meta, $params );
|
||
|
|
} elsif( $option eq 'moved' ) {
|
||
|
|
return $this->{renderer}->renderMoved( $web, $topic, $meta, $params );
|
||
|
|
} elsif( $option eq 'parent' ) {
|
||
|
|
return $this->{renderer}->renderParent( $web, $topic, $meta, $params );
|
||
|
|
}
|
||
|
|
|
||
|
|
return '';
|
||
|
|
}
|
||
|
|
|
||
|
|
# Remove NOP tag in template topics but show content. Used in template
|
||
|
|
# _topics_ (not templates, per se, but topics used as templates for new
|
||
|
|
# topics)
|
||
|
|
sub _NOP {
|
||
|
|
my ( $this, $params, $topic, $web ) = @_;
|
||
|
|
|
||
|
|
return '<nop>' unless $params->{_RAW};
|
||
|
|
|
||
|
|
return $params->{_RAW};
|
||
|
|
}
|
||
|
|
|
||
|
|
# Shortcut to %TMPL:P{"sep"}%
|
||
|
|
sub _SEP {
|
||
|
|
my $this = shift;
|
||
|
|
return $this->{templates}->expandTemplate('sep');
|
||
|
|
}
|
||
|
|
|
||
|
|
#deprecated functionality, now implemented using %USERINFO%
|
||
|
|
#move to compatibility plugin in TWiki5
|
||
|
|
sub _WIKINAME_deprecated {
|
||
|
|
my ( $this, $params ) = @_;
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
|
||
|
|
$params->{format} = $this->{prefs}->getPreferencesValue( 'WIKINAME' ) ||
|
||
|
|
'$wikiname';
|
||
|
|
|
||
|
|
return $this->_USERINFO($params);
|
||
|
|
}
|
||
|
|
#deprecated functionality, now implemented using %USERINFO%
|
||
|
|
#move to compatibility plugin in TWiki5
|
||
|
|
sub _USERNAME_deprecated {
|
||
|
|
my ( $this, $params ) = @_;
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
|
||
|
|
$params->{format} = $this->{prefs}->getPreferencesValue( 'USERNAME' ) ||
|
||
|
|
'$username';
|
||
|
|
|
||
|
|
return $this->_USERINFO($params);
|
||
|
|
}
|
||
|
|
#deprecated functionality, now implemented using %USERINFO%
|
||
|
|
#move to compatibility plugin in TWiki5
|
||
|
|
sub _WIKIUSERNAME_deprecated {
|
||
|
|
my ( $this, $params ) = @_;
|
||
|
|
ASSERT($this->isa( 'TWiki')) if DEBUG;
|
||
|
|
|
||
|
|
$params->{format} =
|
||
|
|
$this->{prefs}->getPreferencesValue( 'WIKIUSERNAME' ) ||
|
||
|
|
'$wikiusername';
|
||
|
|
|
||
|
|
return $this->_USERINFO($params);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _USERINFO {
|
||
|
|
my ( $this, $params ) = @_;
|
||
|
|
my $format = $params->{format} || '$username, $wikiusername, $emails';
|
||
|
|
my $userDebug = $params->{'userdebug'} || '';
|
||
|
|
|
||
|
|
my $user = $this->{user};
|
||
|
|
if( $params->{_DEFAULT} ) {
|
||
|
|
$user = $this->{users}->findUser( $params->{_DEFAULT}, undef, 1 );
|
||
|
|
return '' if !$user;
|
||
|
|
return '' if( $TWiki::cfg{AntiSpam}{HideUserDetails} &&
|
||
|
|
!$this->{user}->isAdmin() &&
|
||
|
|
$user != $this->{user} );
|
||
|
|
}
|
||
|
|
|
||
|
|
my $info = $format;
|
||
|
|
|
||
|
|
if ($info =~ /\$username/) {
|
||
|
|
my $username = $user->login();
|
||
|
|
$info =~ s/\$username/$username/g;
|
||
|
|
}
|
||
|
|
if ($info =~ /\$wikiname/) {
|
||
|
|
my $wikiname = $user->wikiName();
|
||
|
|
$info =~ s/\$wikiname/$wikiname/g;
|
||
|
|
}
|
||
|
|
if ($info =~ /\$wikiusername/) {
|
||
|
|
my $wikiusername = $user->webDotWikiName();
|
||
|
|
$info =~ s/\$wikiusername/$wikiusername/g;
|
||
|
|
}
|
||
|
|
if ($info =~ /\$emails/) {
|
||
|
|
my $emails = join(', ', $user->emails());
|
||
|
|
$info =~ s/\$emails/$emails/g;
|
||
|
|
}
|
||
|
|
if ($info =~ /\$groups/) {
|
||
|
|
my @groupNames = map {$_->webDotWikiName();} $user->getGroups();
|
||
|
|
my $groups = join(', ', @groupNames);
|
||
|
|
$groups .= ' isAdmin()' if $user->isAdmin();
|
||
|
|
$info =~ s/\$groups/$groups/g;
|
||
|
|
}
|
||
|
|
|
||
|
|
#don't give out userlists to non-admins
|
||
|
|
if ($userDebug ne '' && $user->isAdmin()) {
|
||
|
|
my $users = '';
|
||
|
|
$users .= "\n\nLoaded Users: ".join(" \n", map {$_->webDotWikiName()} @{$this->{users}->getAllLoadedUsers()});
|
||
|
|
$users .= "\n\nALL Users: ".join(" \n", map {$_->webDotWikiName()} @{$this->{users}->getAllUsers()});
|
||
|
|
$info .= $users;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $info;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _GROUPS {
|
||
|
|
my ( $this, $params ) = @_;
|
||
|
|
|
||
|
|
my @groupNames = map {
|
||
|
|
'| [['.$_->webDotWikiName(). ']['.$_->wikiName().']] |'.
|
||
|
|
join(', ', map {
|
||
|
|
'[['.$_->webDotWikiName().']['.$_->wikiName().']]'
|
||
|
|
} @{$_->groupMembers()}). ' |';
|
||
|
|
} sort {$a->wikiName() cmp $b->wikiName()} @{$this->{users}->getAllGroups()};
|
||
|
|
|
||
|
|
return '| *Group* | *Members* |'."\n".join("\n", @groupNames);
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|