lib/TWiki.pm
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/lib/TWiki.pm	Sat Jan 26 15:50:53 2008 +0100
     1.3 @@ -0,0 +1,3978 @@
     1.4 +# See bottom of file for license and copyright information
     1.5 +package TWiki;
     1.6 +
     1.7 +=pod
     1.8 +
     1.9 +---+ package TWiki
    1.10 +
    1.11 +TWiki operates by creating a singleton object (known as the Session
    1.12 +object) that acts as a point of reference for all the different
    1.13 +modules in the system. This package is the class for this singleton,
    1.14 +and also contains the vast bulk of the basic constants and the per-
    1.15 +site configuration mechanisms.
    1.16 +
    1.17 +Global variables are avoided wherever possible to avoid problems
    1.18 +with CGI accelerators such as mod_perl.
    1.19 +
    1.20 +---++ Public Data members
    1.21 +   * =cgiQuery=         Pointer to the CGI::
    1.22 +   * =context=          Hash of context ids
    1.23 +   * moved: =loginManager=     TWiki::LoginManager singleton (moved to TWiki::Users)
    1.24 +   * =plugins=          TWiki::Plugins singleton
    1.25 +   * =prefs=            TWiki::Prefs singleton
    1.26 +   * =remoteUser=       Login ID when using ApacheLogin. Maintained for
    1.27 +                        compatibility only, do not use.
    1.28 +   * =requestedWebName= Name of web found in URL path or =web= URL parameter
    1.29 +   * =sandbox=          TWiki::Sandbox singleton
    1.30 +   * =scriptUrlPath=    URL path to the current script. May be dynamically
    1.31 +                        extracted from the URL path if {GetScriptUrlFromCgi}.
    1.32 +                        Only required to support {GetScriptUrlFromCgi} and
    1.33 +                        not consistently used. Avoid.
    1.34 +   * =security=         TWiki::Access singleton
    1.35 +   * =SESSION_TAGS=     Hash of TWiki variables whose value is specific to
    1.36 +                        the current CGI request.
    1.37 +   * =store=            TWiki::Store singleton
    1.38 +   * =topicName=        Name of topic found in URL path or =topic= URL
    1.39 +                        parameter
    1.40 +   * =urlHost=          Host part of the URL (including the protocol)
    1.41 +                        determined during intialisation and defaulting to
    1.42 +                        {DefaultUrlHost}
    1.43 +   * =user=             Unique user ID of logged-in user
    1.44 +   * =users=            TWiki::Users singleton
    1.45 +   * =webName=          Name of web found in URL path, or =web= URL parameter,
    1.46 +                        or {UsersWebName}
    1.47 +
    1.48 +=cut
    1.49 +
    1.50 +use strict;
    1.51 +use Assert;
    1.52 +use Error qw( :try );
    1.53 +use CGI;             # Always required to get the CGI object
    1.54 +
    1.55 +require 5.005;       # For regex objects and internationalisation
    1.56 +
    1.57 +# Site configuration constants
    1.58 +use vars qw( %cfg );
    1.59 +
    1.60 +# Uncomment this and the __END__ to enable AutoLoader
    1.61 +#use AutoLoader 'AUTOLOAD';
    1.62 +# You then need to autosplit TWiki.pm:
    1.63 +# cd lib
    1.64 +# perl -e 'use AutoSplit; autosplit("TWiki.pm", "auto")'
    1.65 +
    1.66 +# Other computed constants
    1.67 +use vars qw(
    1.68 +            $TranslationToken
    1.69 +            $twikiLibDir
    1.70 +            %regex
    1.71 +            %functionTags
    1.72 +            %contextFreeSyntax
    1.73 +            %restDispatch
    1.74 +            $VERSION $RELEASE
    1.75 +            $TRUE
    1.76 +            $FALSE
    1.77 +            $sandbox
    1.78 +            $ifParser
    1.79 +           );
    1.80 +
    1.81 +# Token character that must not occur in any normal text - converted
    1.82 +# to a flag character if it ever does occur (very unlikely)
    1.83 +# TWiki uses $TranslationToken to mark points in the text. This is
    1.84 +# normally \0, which is not a useful character in any 8-bit character
    1.85 +# set we can find, nor in UTF-8. But if you *do* encounter problems
    1.86 +# with it, the workaround is to change $TranslationToken to something
    1.87 +# longer that is unlikely to occur in your text - for example
    1.88 +# muRfleFli5ble8leep (do *not* use punctuation characters or whitspace
    1.89 +# in the string!)
    1.90 +# See Codev.NationalCharTokenClash for more.
    1.91 +$TranslationToken= "\0";
    1.92 +
    1.93 +=pod
    1.94 +
    1.95 +---++ StaticMethod getTWikiLibDir() -> $path
    1.96 +
    1.97 +Returns the full path of the directory containing TWiki.pm
    1.98 +
    1.99 +=cut
   1.100 +
   1.101 +sub getTWikiLibDir {
   1.102 +    if( $twikiLibDir ) {
   1.103 +        return $twikiLibDir;
   1.104 +    }
   1.105 +
   1.106 +    # FIXME: Should just use $INC{"TWiki.pm"} to get path used to load this
   1.107 +    # module.
   1.108 +    my $dir = '';
   1.109 +    foreach $dir ( @INC ) {
   1.110 +        if( $dir && -e "$dir/TWiki.pm" ) {
   1.111 +            $twikiLibDir = $dir;
   1.112 +            last;
   1.113 +        }
   1.114 +    }
   1.115 +
   1.116 +    # fix path relative to location of called script
   1.117 +    if( $twikiLibDir =~ /^\./ ) {
   1.118 +        print STDERR "WARNING: TWiki lib path $twikiLibDir is relative; you should make it absolute, otherwise some scripts may not run from the command line.";
   1.119 +        my $bin;
   1.120 +        if( $ENV{SCRIPT_FILENAME} &&
   1.121 +            $ENV{SCRIPT_FILENAME} =~ /^(.+)\/[^\/]+$/ ) {
   1.122 +            # CGI script name
   1.123 +            $bin = $1;
   1.124 +        } elsif ( $0 =~ /^(.*)\/.*?$/ ) {
   1.125 +            # program name
   1.126 +            $bin = $1;
   1.127 +        } else {
   1.128 +            # last ditch; relative to current directory.
   1.129 +            require Cwd;
   1.130 +            import Cwd qw( cwd );
   1.131 +            $bin = cwd();
   1.132 +        }
   1.133 +        $twikiLibDir = "$bin/$twikiLibDir/";
   1.134 +        # normalize "/../" and "/./"
   1.135 +        while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) {
   1.136 +        };
   1.137 +        $twikiLibDir =~ s|([\\/])\.[\\/]|$1|g;
   1.138 +    }
   1.139 +    $twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/"
   1.140 +    $twikiLibDir =~ s|[\\/]$||;           # cut trailing "/"
   1.141 +
   1.142 +    return $twikiLibDir;
   1.143 +}
   1.144 +
   1.145 +BEGIN {
   1.146 +    require Monitor;
   1.147 +    require TWiki::Sandbox;            # system command sandbox
   1.148 +    require TWiki::Configure::Load;    # read configuration files
   1.149 +
   1.150 +    $TRUE = 1;
   1.151 +    $FALSE = 0;
   1.152 +
   1.153 +    if( DEBUG ) {
   1.154 +        # If ASSERTs are on, then warnings are errors. Paranoid,
   1.155 +        # but the only way to be sure we eliminate them all.
   1.156 +        # Look out also for $cfg{WarningsAreErrors}, below, which
   1.157 +        # is another way to install this handler without enabling
   1.158 +        # ASSERTs
   1.159 +        # ASSERTS are turned on by defining the environment variable
   1.160 +        # TWIKI_ASSERTS. If ASSERTs are off, this is assumed to be a
   1.161 +        # production environment, and no stack traces or paths are
   1.162 +        # output to the browser.
   1.163 +        $SIG{'__WARN__'} = sub { die @_ };
   1.164 +        $Error::Debug = 1; # verbose stack traces, please
   1.165 +    } else {
   1.166 +        $Error::Debug = 0; # no verbose stack traces
   1.167 +    }
   1.168 +
   1.169 +    # DO NOT CHANGE THE FORMAT OF $VERSION
   1.170 +    # Automatically expanded on checkin of this module
   1.171 +    $VERSION = '$Date: 2008-01-22 04:18:51 +0100 (Tue, 22 Jan 2008) $ $Rev: 16278 (22 Jan 2008) $ ';
   1.172 +    $RELEASE = 'TWiki-4.2.0';
   1.173 +    $VERSION =~ s/^.*?\((.*)\).*: (\d+) .*?$/$RELEASE, $1, build $2/;
   1.174 +
   1.175 +    # Default handlers for different %TAGS%
   1.176 +    %functionTags = (
   1.177 +        ALLVARIABLES      => \&ALLVARIABLES,
   1.178 +        ATTACHURL         => \&ATTACHURL,
   1.179 +        ATTACHURLPATH     => \&ATTACHURLPATH,
   1.180 +        DATE              => \&DATE,
   1.181 +        DISPLAYTIME       => \&DISPLAYTIME,
   1.182 +        ENCODE            => \&ENCODE,
   1.183 +        ENV               => \&ENV,
   1.184 +        FORMFIELD         => \&FORMFIELD,
   1.185 +        GMTIME            => \&GMTIME,
   1.186 +        GROUPS            => \&GROUPS,
   1.187 +        HTTP_HOST         => \&HTTP_HOST_deprecated,
   1.188 +        HTTP              => \&HTTP,
   1.189 +        HTTPS             => \&HTTPS,
   1.190 +        ICON              => \&ICON,
   1.191 +        ICONURL           => \&ICONURL,
   1.192 +        ICONURLPATH       => \&ICONURLPATH,
   1.193 +        IF                => \&IF,
   1.194 +        INCLUDE           => \&INCLUDE,
   1.195 +        INTURLENCODE      => \&INTURLENCODE_deprecated,
   1.196 +        LANGUAGES         => \&LANGUAGES,
   1.197 +        MAKETEXT          => \&MAKETEXT,
   1.198 +        META              => \&META,
   1.199 +        METASEARCH        => \&METASEARCH,
   1.200 +        NOP               => \&NOP,
   1.201 +        PLUGINVERSION     => \&PLUGINVERSION,
   1.202 +        PUBURL            => \&PUBURL,
   1.203 +        PUBURLPATH        => \&PUBURLPATH,
   1.204 +        QUERYPARAMS       => \&QUERYPARAMS,
   1.205 +        QUERYSTRING       => \&QUERYSTRING,
   1.206 +        RELATIVETOPICPATH => \&RELATIVETOPICPATH,
   1.207 +        REMOTE_ADDR       => \&REMOTE_ADDR_deprecated,
   1.208 +        REMOTE_PORT       => \&REMOTE_PORT_deprecated,
   1.209 +        REMOTE_USER       => \&REMOTE_USER_deprecated,
   1.210 +        REVINFO           => \&REVINFO,
   1.211 +        SCRIPTNAME        => \&SCRIPTNAME,
   1.212 +        SCRIPTURL         => \&SCRIPTURL,
   1.213 +        SCRIPTURLPATH     => \&SCRIPTURLPATH,
   1.214 +        SEARCH            => \&SEARCH,
   1.215 +        SEP               => \&SEP,
   1.216 +        SERVERTIME        => \&SERVERTIME,
   1.217 +        SPACEDTOPIC       => \&SPACEDTOPIC_deprecated,
   1.218 +        SPACEOUT          => \&SPACEOUT,
   1.219 +        'TMPL:P'          => \&TMPLP,
   1.220 +        TOPICLIST         => \&TOPICLIST,
   1.221 +        URLENCODE         => \&ENCODE,
   1.222 +        URLPARAM          => \&URLPARAM,
   1.223 +        LANGUAGE          => \&LANGUAGE,
   1.224 +        USERINFO          => \&USERINFO,
   1.225 +        USERNAME          => \&USERNAME_deprecated,
   1.226 +        VAR               => \&VAR,
   1.227 +        WEBLIST           => \&WEBLIST,
   1.228 +        WIKINAME          => \&WIKINAME_deprecated,
   1.229 +        WIKIUSERNAME      => \&WIKIUSERNAME_deprecated,
   1.230 +        # Constant tag strings _not_ dependent on config. These get nicely
   1.231 +        # optimised by the compiler.
   1.232 +        ENDSECTION        => sub { '' },
   1.233 +        WIKIVERSION       => sub { $VERSION },
   1.234 +        STARTSECTION      => sub { '' },
   1.235 +        STARTINCLUDE      => sub { '' },
   1.236 +        STOPINCLUDE       => sub { '' },
   1.237 +       );
   1.238 +    $contextFreeSyntax{IF} = 1;
   1.239 +
   1.240 +    unless( ( $TWiki::cfg{DetailedOS} = $^O ) ) {
   1.241 +        require Config;
   1.242 +        $TWiki::cfg{DetailedOS} = $Config::Config{'osname'};
   1.243 +    }
   1.244 +    $TWiki::cfg{OS} = 'UNIX';
   1.245 +    if ($TWiki::cfg{DetailedOS} =~ /darwin/i) { # MacOS X
   1.246 +        $TWiki::cfg{OS} = 'UNIX';
   1.247 +    } elsif ($TWiki::cfg{DetailedOS} =~ /Win/i) {
   1.248 +        $TWiki::cfg{OS} = 'WINDOWS';
   1.249 +    } elsif ($TWiki::cfg{DetailedOS} =~ /vms/i) {
   1.250 +        $TWiki::cfg{OS} = 'VMS';
   1.251 +    } elsif ($TWiki::cfg{DetailedOS} =~ /bsdos/i) {
   1.252 +        $TWiki::cfg{OS} = 'UNIX';
   1.253 +    } elsif ($TWiki::cfg{DetailedOS} =~ /dos/i) {
   1.254 +        $TWiki::cfg{OS} = 'DOS';
   1.255 +    } elsif ($TWiki::cfg{DetailedOS} =~ /^MacOS$/i) { # MacOS 9 or earlier
   1.256 +        $TWiki::cfg{OS} = 'MACINTOSH';
   1.257 +    } elsif ($TWiki::cfg{DetailedOS} =~ /os2/i) {
   1.258 +        $TWiki::cfg{OS} = 'OS2';
   1.259 +    }
   1.260 +
   1.261 +    # Validate and untaint Apache's SERVER_NAME Environment variable
   1.262 +    # for use in referencing virtualhost-based paths for separate data/ and templates/ instances, etc
   1.263 +    if ( $ENV{SERVER_NAME} &&
   1.264 +         $ENV{SERVER_NAME} =~ /^(([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6})$/ ) {
   1.265 +        $ENV{SERVER_NAME} =
   1.266 +          TWiki::Sandbox::untaintUnchecked( $ENV{SERVER_NAME} );
   1.267 +    }
   1.268 +
   1.269 +    # readConfig is defined in TWiki::Configure::Load to allow overriding it
   1.270 +    TWiki::Configure::Load::readConfig();
   1.271 +
   1.272 +    if( $TWiki::cfg{WarningsAreErrors} ) {
   1.273 +        # Note: Warnings are always errors if ASSERTs are enabled
   1.274 +        $SIG{'__WARN__'} = sub { die @_ };
   1.275 +    }
   1.276 +
   1.277 +    if( $TWiki::cfg{UseLocale} ) {
   1.278 +        require locale;
   1.279 +        import locale();
   1.280 +    }
   1.281 +
   1.282 +    # Constant tags dependent on the config
   1.283 +    $functionTags{ALLOWLOGINNAME}  =
   1.284 +      sub { $TWiki::cfg{Register}{AllowLoginName} || 0 };
   1.285 +    $functionTags{AUTHREALM}       = sub { $TWiki::cfg{AuthRealm} };
   1.286 +    $functionTags{DEFAULTURLHOST}  = sub { $TWiki::cfg{DefaultUrlHost} };
   1.287 +    $functionTags{HOMETOPIC}       = sub { $TWiki::cfg{HomeTopicName} };
   1.288 +    $functionTags{LOCALSITEPREFS}  = sub { $TWiki::cfg{LocalSitePreferences} };
   1.289 +    $functionTags{NOFOLLOW}        =
   1.290 +      sub { $TWiki::cfg{NoFollow} ? 'rel='.$TWiki::cfg{NoFollow} : '' };
   1.291 +    $functionTags{NOTIFYTOPIC}     = sub { $TWiki::cfg{NotifyTopicName} };
   1.292 +    $functionTags{SCRIPTSUFFIX}    = sub { $TWiki::cfg{ScriptSuffix} };
   1.293 +    $functionTags{STATISTICSTOPIC} = sub { $TWiki::cfg{Stats}{TopicName} };
   1.294 +    $functionTags{SYSTEMWEB}       = sub { $TWiki::cfg{SystemWebName} };
   1.295 +    $functionTags{TRASHWEB}        = sub { $TWiki::cfg{TrashWebName} };
   1.296 +    $functionTags{TWIKIADMINLOGIN} = sub { $TWiki::cfg{AdminUserLogin} };
   1.297 +    $functionTags{USERSWEB}        = sub { $TWiki::cfg{UsersWebName} };
   1.298 +    $functionTags{WEBPREFSTOPIC}   = sub { $TWiki::cfg{WebPrefsTopicName} };
   1.299 +    $functionTags{WIKIPREFSTOPIC}  = sub { $TWiki::cfg{SitePrefsTopicName} };
   1.300 +    $functionTags{WIKIUSERSTOPIC}  = sub { $TWiki::cfg{UsersTopicName} };
   1.301 +    $functionTags{WIKIWEBMASTER}   = sub { $TWiki::cfg{WebMasterEmail} };
   1.302 +    $functionTags{WIKIWEBMASTERNAME} = sub { $TWiki::cfg{WebMasterName} };
   1.303 +
   1.304 +    # Compatibility synonyms, deprecated in 4.2 but still used throughout
   1.305 +    # the documentation.
   1.306 +    $functionTags{MAINWEB}         = $functionTags{USERSWEB};
   1.307 +    $functionTags{TWIKIWEB}        = $functionTags{SYSTEMWEB};
   1.308 +
   1.309 +    # locale setup
   1.310 +    #
   1.311 +    #
   1.312 +    # Note that 'use locale' must be done in BEGIN block for regexes and
   1.313 +    # sorting to work properly, although regexes can still work without
   1.314 +    # this in 'non-locale regexes' mode.
   1.315 +
   1.316 +    if ( $TWiki::cfg{UseLocale} ) {
   1.317 +        # Set environment variables for grep 
   1.318 +        $ENV{LC_CTYPE} = $TWiki::cfg{Site}{Locale};
   1.319 +
   1.320 +        # Load POSIX for I18N support.
   1.321 +        require POSIX;
   1.322 +        import POSIX qw( locale_h LC_CTYPE LC_COLLATE );
   1.323 +
   1.324 +        # SMELL: mod_perl compatibility note: If TWiki is running under Apache,
   1.325 +        # won't this play with the Apache process's locale settings too?
   1.326 +        # What effects would this have?
   1.327 +        setlocale(&LC_CTYPE, $TWiki::cfg{Site}{Locale});
   1.328 +        setlocale(&LC_COLLATE, $TWiki::cfg{Site}{Locale});
   1.329 +    }
   1.330 +
   1.331 +    $functionTags{CHARSET}   = sub { $TWiki::cfg{Site}{CharSet} ||
   1.332 +                                       'iso-8859-1' };
   1.333 +    $functionTags{SHORTLANG} = sub { $TWiki::cfg{Site}{Lang} || '' };
   1.334 +    $functionTags{LANG}      = sub { $TWiki::cfg{Site}{FullLang} || '' };
   1.335 +
   1.336 +    # Tell CGI.pm which charset we are using if not default
   1.337 +    if( defined $TWiki::cfg{Site}{CharSet} &&
   1.338 +          $TWiki::cfg{Site}{CharSet} !~ /^iso-?8859-?1$/io ) {
   1.339 +        CGI::charset( $TWiki::cfg{Site}{CharSet} );
   1.340 +    }
   1.341 +
   1.342 +    # Set up pre-compiled regexes for use in rendering.  All regexes with
   1.343 +    # unchanging variables in match should use the '/o' option.
   1.344 +    # In the regex hash, all precompiled REs have "Regex" at the
   1.345 +    # end of the name. Anything else is a string, either intended
   1.346 +    # for use as a character class, or as a sub-expression in
   1.347 +    # another compiled RE.
   1.348 +
   1.349 +    # Build up character class components for use in regexes.
   1.350 +    # Depends on locale mode and Perl version, and finally on
   1.351 +    # whether locale-based regexes are turned off.
   1.352 +    if ( not $TWiki::cfg{UseLocale} or $] < 5.006
   1.353 +         or not $TWiki::cfg{Site}{LocaleRegexes} ) {
   1.354 +
   1.355 +        # No locales needed/working, or Perl 5.005, so just use
   1.356 +        # any additional national characters defined in TWiki.cfg
   1.357 +        $regex{upperAlpha} = 'A-Z'.$TWiki::cfg{UpperNational};
   1.358 +        $regex{lowerAlpha} = 'a-z'.$TWiki::cfg{LowerNational};
   1.359 +        $regex{numeric}    = '\d';
   1.360 +        $regex{mixedAlpha} = $regex{upperAlpha}.$regex{lowerAlpha};
   1.361 +    } else {
   1.362 +        # Perl 5.006 or higher with working locales
   1.363 +        $regex{upperAlpha} = '[:upper:]';
   1.364 +        $regex{lowerAlpha} = '[:lower:]';
   1.365 +        $regex{numeric}    = '[:digit:]';
   1.366 +        $regex{mixedAlpha} = '[:alpha:]';
   1.367 +    }
   1.368 +    $regex{mixedAlphaNum} = $regex{mixedAlpha}.$regex{numeric};
   1.369 +    $regex{lowerAlphaNum} = $regex{lowerAlpha}.$regex{numeric};
   1.370 +    $regex{upperAlphaNum} = $regex{upperAlpha}.$regex{numeric};
   1.371 +
   1.372 +    # Compile regexes for efficiency and ease of use
   1.373 +    # Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl
   1.374 +    # book at http://regex.info/. 
   1.375 +
   1.376 +    $regex{linkProtocolPattern} =
   1.377 +      $TWiki::cfg{LinkProtocolPattern};
   1.378 +
   1.379 +    # Header patterns based on '+++'. The '###' are reserved for numbered
   1.380 +    # headers
   1.381 +    # '---++ Header', '---## Header'
   1.382 +    $regex{headerPatternDa} = qr/^---+(\++|\#+)(.*)$/m;
   1.383 +    # '<h6>Header</h6>
   1.384 +    $regex{headerPatternHt} = qr/^<h([1-6])>(.+?)<\/h\1>/mi;
   1.385 +    # '---++!! Header' or '---++ Header %NOTOC% ^top'
   1.386 +    $regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)';
   1.387 +
   1.388 +    # TWiki concept regexes
   1.389 +    $regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlphaNum}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/o;
   1.390 +    $regex{webNameBaseRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}_]*/o;
   1.391 +    if ($TWiki::cfg{EnableHierarchicalWebs}) {
   1.392 +        $regex{webNameRegex} = qr/$regex{webNameBaseRegex}(?:(?:[\.\/]$regex{webNameBaseRegex})+)*/o;
   1.393 +    } else {
   1.394 +        $regex{webNameRegex} = $regex{webNameBaseRegex};
   1.395 +    }
   1.396 +    $regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/o;
   1.397 +    $regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/o;
   1.398 +    $regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/o;
   1.399 +
   1.400 +    # Simplistic email regex, e.g. for WebNotify processing - no i18n
   1.401 +    # characters allowed
   1.402 +    $regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_]+\@[A-Za-z0-9\.\-]+)/;
   1.403 +
   1.404 +    # Filename regex to used to match invalid characters in attachments - allow
   1.405 +    # alphanumeric characters, spaces, underscores, etc.
   1.406 +    # TODO: Get this to work with I18N chars - currently used only with UseLocale off
   1.407 +    $regex{filenameInvalidCharRegex} = qr/[^$regex{mixedAlphaNum}\. _-]/o;
   1.408 +
   1.409 +    # Multi-character alpha-based regexes
   1.410 +    $regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/o;
   1.411 +
   1.412 +    # %TAG% name
   1.413 +    $regex{tagNameRegex} = '['.$regex{mixedAlpha}.']['.$regex{mixedAlphaNum}.'_:]*';
   1.414 +
   1.415 +    # Set statement in a topic
   1.416 +    $regex{bulletRegex} = '^(?:\t|   )+\*';
   1.417 +    $regex{setRegex} = $regex{bulletRegex}.'\s+(Set|Local)\s+';
   1.418 +    $regex{setVarRegex} = $regex{setRegex}.'('.$regex{tagNameRegex}.')\s*=\s*(.*)$';
   1.419 +
   1.420 +    # Character encoding regexes
   1.421 +
   1.422 +    # 7-bit ASCII only
   1.423 +    $regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o;
   1.424 +
   1.425 +    # Regex to match only a valid UTF-8 character, taking care to avoid
   1.426 +    # security holes due to overlong encodings by excluding the relevant
   1.427 +    # gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode
   1.428 +    # Encodings section.  Tested against Markus Kuhn's UTF-8 test file
   1.429 +    # at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
   1.430 +    $regex{validUtf8CharRegex} = qr{
   1.431 +                # Single byte - ASCII
   1.432 +                [\x00-\x7F] 
   1.433 +                |
   1.434 +
   1.435 +                # 2 bytes
   1.436 +                [\xC2-\xDF][\x80-\xBF] 
   1.437 +                |
   1.438 +
   1.439 +                # 3 bytes
   1.440 +
   1.441 +                    # Avoid illegal codepoints - negative lookahead
   1.442 +                    (?!\xEF\xBF[\xBE\xBF])    
   1.443 +
   1.444 +                    # Match valid codepoints
   1.445 +                    (?:
   1.446 +                    ([\xE0][\xA0-\xBF])|
   1.447 +                    ([\xE1-\xEC\xEE-\xEF][\x80-\xBF])|
   1.448 +                    ([\xED][\x80-\x9F])
   1.449 +                    )
   1.450 +                    [\x80-\xBF]
   1.451 +                |
   1.452 +
   1.453 +                # 4 bytes 
   1.454 +                    (?:
   1.455 +                    ([\xF0][\x90-\xBF])|
   1.456 +                    ([\xF1-\xF3][\x80-\xBF])|
   1.457 +                    ([\xF4][\x80-\x8F])
   1.458 +                    )
   1.459 +                    [\x80-\xBF][\x80-\xBF]
   1.460 +                }xo;
   1.461 +
   1.462 +    $regex{validUtf8StringRegex} =
   1.463 +      qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo;
   1.464 +
   1.465 +    # Check for unsafe search regex mode (affects filtering in) - default
   1.466 +    # to safe mode
   1.467 +    $TWiki::cfg{ForceUnsafeRegexes} = 0 unless defined $TWiki::cfg{ForceUnsafeRegexes};
   1.468 +
   1.469 +    # initialize lib directory early because of later 'cd's
   1.470 +    getTWikiLibDir();
   1.471 +
   1.472 +    Monitor::MARK('Static configuration loaded');
   1.473 +};
   1.474 +
   1.475 +=pod
   1.476 +
   1.477 +---++ StaticMethod UTF82SiteCharSet( $utf8 ) -> $ascii
   1.478 +
   1.479 +Auto-detect UTF-8 vs. site charset in string, and convert UTF-8 into site
   1.480 +charset.
   1.481 +
   1.482 +=cut
   1.483 +
   1.484 +sub UTF82SiteCharSet {
   1.485 +    my $text = shift;
   1.486 +
   1.487 +    return $text unless( defined $TWiki::cfg{Site}{CharSet} );
   1.488 +
   1.489 +    # Detect character encoding of the full topic name from URL
   1.490 +    return undef if( $text =~ $regex{validAsciiStringRegex} );
   1.491 +
   1.492 +    # If not UTF-8 - assume in site character set, no conversion required
   1.493 +    return undef unless( $text =~ $regex{validUtf8StringRegex} );
   1.494 +
   1.495 +    # If site charset is already UTF-8, there is no need to convert anything:
   1.496 +    if ( $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) {
   1.497 +        # warn if using Perl older than 5.8
   1.498 +        if( $] <  5.008 ) {
   1.499 +            print STDERR 'UTF-8 not remotely supported on Perl ', $],
   1.500 +              ' - use Perl 5.8 or higher..' ;
   1.501 +        }
   1.502 +
   1.503 +        # We still don't have Codev.UnicodeSupport
   1.504 +        print STDERR 'UTF-8 not yet supported as site charset -',
   1.505 +          'TWiki is likely to have problems';
   1.506 +        return $text;
   1.507 +    }
   1.508 +
   1.509 +    # Convert into ISO-8859-1 if it is the site charset.  This conversion
   1.510 +    # is *not valid for ISO-8859-15*.
   1.511 +    if ( $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?1$/i ) {
   1.512 +        # ISO-8859-1 maps onto first 256 codepoints of Unicode
   1.513 +        # (conversion from 'perldoc perluniintro')
   1.514 +        $text =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) / 
   1.515 +          chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F )
   1.516 +            /egx;
   1.517 +    } else {
   1.518 +        # Convert from UTF-8 into some other site charset
   1.519 +        if( $] >= 5.008 ) {
   1.520 +            require Encode;
   1.521 +            import Encode qw(:fallbacks);
   1.522 +            # Map $TWiki::cfg{Site}{CharSet} into real encoding name
   1.523 +            my $charEncoding =
   1.524 +              Encode::resolve_alias( $TWiki::cfg{Site}{CharSet} );
   1.525 +            if( not $charEncoding ) {
   1.526 +                print STDERR
   1.527 +                  'Conversion to "',$TWiki::cfg{Site}{CharSet},
   1.528 +                    '" not supported, or name not recognised - check ',
   1.529 +                      '"perldoc Encode::Supported"';
   1.530 +            } else {
   1.531 +                # Convert text using Encode:
   1.532 +                # - first, convert from UTF8 bytes into internal
   1.533 +                # (UTF-8) characters
   1.534 +                $text = Encode::decode('utf8', $text);    
   1.535 +                # - then convert into site charset from internal UTF-8,
   1.536 +                # inserting \x{NNNN} for characters that can't be converted
   1.537 +                $text =
   1.538 +                  Encode::encode( $charEncoding, $text,
   1.539 +                                  &FB_PERLQQ() );
   1.540 +            }
   1.541 +        } else {
   1.542 +            require Unicode::MapUTF8;    # Pre-5.8 Perl versions
   1.543 +            my $charEncoding = $TWiki::cfg{Site}{CharSet};
   1.544 +            if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) {
   1.545 +                print STDERR 'Conversion to "',$TWiki::cfg{Site}{CharSet},
   1.546 +                  '" not supported, or name not recognised - check ',
   1.547 +                    '"perldoc Unicode::MapUTF8"';
   1.548 +            } else {
   1.549 +                # Convert text
   1.550 +                $text =
   1.551 +                  Unicode::MapUTF8::from_utf8({
   1.552 +                                               -string => $text,
   1.553 +                                               -charset => $charEncoding
   1.554 +                                              });
   1.555 +                # FIXME: Check for failed conversion?
   1.556 +            }
   1.557 +        }
   1.558 +    }
   1.559 +    return $text;
   1.560 +}
   1.561 +
   1.562 +=pod
   1.563 +
   1.564 +---++ ObjectMethod writeCompletePage( $text, $pageType, $contentType )
   1.565 +
   1.566 +Write a complete HTML page with basic header to the browser.
   1.567 +   * =$text= is the text of the page body (&lt;html&gt; to &lt;/html&gt; if it's HTML)
   1.568 +   * =$pageType= - May be "edit", which will cause headers to be generated that force
   1.569 +     caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused
   1.570 +     data loss with IE5 and IE6.
   1.571 +   * =$contentType= - page content type | text/html
   1.572 +
   1.573 +This method removes noautolink and nop tags before outputting the page unless
   1.574 +$contentType is text/plain.
   1.575 +
   1.576 +=cut
   1.577 +
   1.578 +sub writeCompletePage {
   1.579 +    my ( $this, $text, $pageType, $contentType ) = @_;
   1.580 +    $contentType ||= 'text/html';
   1.581 +
   1.582 +    if( $contentType ne 'text/plain' ) {
   1.583 +        # Remove <nop> and <noautolink> tags
   1.584 +        $text =~ s/([\t ]?)[ \t]*<\/?(nop|noautolink)\/?>/$1/gis;
   1.585 +        $text .= "\n" unless $text =~ /\n$/s;
   1.586 +
   1.587 +        my $htmlHeader = join(
   1.588 +            "\n",
   1.589 +            map { '<!--'.$_.'-->'.$this->{_HTMLHEADERS}{$_} }
   1.590 +              keys %{$this->{_HTMLHEADERS}} );
   1.591 +        $text =~ s!(</head>)!$htmlHeader$1!i if $htmlHeader;
   1.592 +        chomp($text);
   1.593 +    }
   1.594 +
   1.595 +    my $hdr = $this->generateHTTPHeaders( undef, $pageType, $contentType );
   1.596 +
   1.597 +    # Call final handler
   1.598 +    $this->{plugins}->completePageHandler($text, $hdr);
   1.599 +
   1.600 +    # HTTP1.1 says a content-length should _not_ be specified unless
   1.601 +    # the length is known. There is a bug in Netscape such that it
   1.602 +    # interprets a 0 content-length as "download until disconnect"
   1.603 +    # but that is a bug. The correct way is to not set a content-length.
   1.604 +    unless( $this->inContext('command_line') ) {
   1.605 +        # FIXME: Defer next line until we have Codev.UnicodeSupport
   1.606 +        # - too 5.8 dependent
   1.607 +        # my $len = do { use bytes; length( $text ); };
   1.608 +        my $len = length($text);
   1.609 +        $hdr =~ s/\n$/Content-Length: $len\n\n/s if $len;
   1.610 +    } else {
   1.611 +        $hdr = '';
   1.612 +    }
   1.613 +
   1.614 +    print $hdr.$text;
   1.615 +}
   1.616 +
   1.617 +=pod
   1.618 +
   1.619 +---++ ObjectMethod generateHTTPHeaders( $query, $pageType, $contentType, $contentLength ) -> $header
   1.620 +
   1.621 +All parameters are optional.
   1.622 +
   1.623 +   * =$query= CGI query object | Session CGI query (there is no good reason to set this)
   1.624 +   * =$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.
   1.625 +   * =$contentType= - page content type | text/html
   1.626 +   * =$contentLength= - content-length | no content-length will be set if this is undefined, as required by HTTP1.1
   1.627 +
   1.628 +Implements the post-Dec2001 release plugin API, which requires the
   1.629 +writeHeaderHandler in plugin to return a string of HTTP headers, CR/LF
   1.630 +delimited. Filters any illegal headers. Plugin headers will override
   1.631 +core settings.
   1.632 +
   1.633 +Does *not* add a =Content-length= header.
   1.634 +
   1.635 +=cut
   1.636 +
   1.637 +sub generateHTTPHeaders {
   1.638 +    my( $this, $query, $pageType, $contentType ) = @_;
   1.639 +
   1.640 +    $query = $this->{cgiQuery} unless $query;
   1.641 +
   1.642 +    # Handle Edit pages - future versions will extend to caching
   1.643 +    # of other types of page, with expiry time driven by page type.
   1.644 +    my( $pluginHeaders, $coreHeaders );
   1.645 +
   1.646 +    my $hopts = {};
   1.647 +
   1.648 +    if ($pageType && $pageType eq 'edit') {
   1.649 +        # Get time now in HTTP header format
   1.650 +        require TWiki::Time;
   1.651 +        my $lastModifiedString =
   1.652 +          TWiki::Time::formatTime(time, '$http', 'gmtime');
   1.653 +
   1.654 +        # Expiry time is set high to avoid any data loss.  Each instance of 
   1.655 +        # Edit page has a unique URL with time-string suffix (fix for 
   1.656 +        # RefreshEditPage), so this long expiry time simply means that the 
   1.657 +        # browser Back button always works.  The next Edit on this page 
   1.658 +        # will use another URL and therefore won't use any cached 
   1.659 +        # version of this Edit page.
   1.660 +        my $expireHours = 24;
   1.661 +        my $expireSeconds = $expireHours * 60 * 60;
   1.662 +
   1.663 +        # and cache control headers, to ensure edit page 
   1.664 +        # is cached until required expiry time.
   1.665 +        $hopts->{'last-modified'} = $lastModifiedString;
   1.666 +        $hopts->{expires} = "+${expireHours}h";
   1.667 +        $hopts->{'cache-control'} = "max-age=$expireSeconds";
   1.668 +    }
   1.669 +
   1.670 +    # DEPRECATED plugins header handler. Plugins should use
   1.671 +    # modifyHeaderHandler instead.
   1.672 +    $pluginHeaders = $this->{plugins}->writeHeaderHandler( $query ) || '';
   1.673 +    if( $pluginHeaders ) {
   1.674 +        foreach ( split /\r?\n/, $pluginHeaders ) {
   1.675 +            if ( m/^([\-a-z]+): (.*)$/i ) {
   1.676 +                $hopts->{$1} = $2;
   1.677 +            }
   1.678 +        }
   1.679 +    }
   1.680 +
   1.681 +    $contentType = 'text/html' unless $contentType;
   1.682 +    if( defined( $TWiki::cfg{Site}{CharSet} )) {
   1.683 +      $contentType .= '; charset='.$TWiki::cfg{Site}{CharSet};
   1.684 +    }
   1.685 +
   1.686 +    # use our version of the content type
   1.687 +    $hopts->{'Content-Type'} = $contentType;
   1.688 +
   1.689 +    # New (since 1.026)
   1.690 +    $this->{plugins}->modifyHeaderHandler( $hopts, $this->{cgiQuery} );
   1.691 +
   1.692 +    # add cookie(s)
   1.693 +    $this->{users}->{loginManager}->modifyHeader( $hopts );
   1.694 +
   1.695 +    return CGI::header( $hopts );
   1.696 +}
   1.697 +
   1.698 +=pod
   1.699 +
   1.700 +---++ StaticMethod isRedirectSafe($redirect) => $ok
   1.701 +
   1.702 +tests if the $redirect is an external URL, returning false if AllowRedirectUrl is denied
   1.703 +
   1.704 +=cut
   1.705 +
   1.706 +sub isRedirectSafe {
   1.707 +    my $redirect = shift;
   1.708 +    
   1.709 +    #TODO: this should really use URI
   1.710 +    if ((!$TWiki::cfg{AllowRedirectUrl}) && ( $redirect =~ m!^([^:]*://[^/]*)/*(.*)?$! )) {
   1.711 +        my $host = $1;
   1.712 +        #remove trailing /'s to match
   1.713 +        $TWiki::cfg{DefaultUrlHost} =~ m!^([^:]*://[^/]*)/*(.*)?$!;
   1.714 +        my $expected = $1;
   1.715 +        
   1.716 +        if (defined($TWiki::cfg{PermittedRedirectHostUrls} ) && $TWiki::cfg{PermittedRedirectHostUrls}  ne '') {
   1.717 +            my @permitted =
   1.718 +                map { s!^([^:]*://[^/]*)/*(.*)?$!$1!; $1 }
   1.719 +                        split(/,\s*/, $TWiki::cfg{PermittedRedirectHostUrls});
   1.720 +            return 1 if ( grep ( { uc($host) eq uc($_) } @permitted));
   1.721 +        }
   1.722 +        return (uc($host) eq uc($expected));
   1.723 +    }
   1.724 +    return 1;
   1.725 +}
   1.726 +
   1.727 +# _getRedirectUrl() => redirectURL set from the parameter
   1.728 +# Reads a redirect url from CGI parameter 'redirectto'.
   1.729 +# This function is used to get and test the 'redirectto' cgi parameter, 
   1.730 +# and then the calling function can set its own reporting if there is a
   1.731 +# problem.
   1.732 +sub _getRedirectUrl {
   1.733 +    my $session = shift;
   1.734 +
   1.735 +    my $query = $session->{cgiQuery};
   1.736 +    my $redirecturl = $query->param( 'redirectto' );
   1.737 +    return '' unless $redirecturl;
   1.738 +
   1.739 +    if( $redirecturl =~ m#^$regex{linkProtocolPattern}://#o ) {
   1.740 +        # assuming URL
   1.741 +        if (isRedirectSafe($redirecturl)) {
   1.742 +            return $redirecturl;
   1.743 +        } else {
   1.744 +            return '';
   1.745 +        }
   1.746 +    }
   1.747 +    # assuming 'web.topic' or 'topic'
   1.748 +    my ( $w, $t ) = $session->normalizeWebTopicName( $session->{webName}, $redirecturl );
   1.749 +    $redirecturl = $session->getScriptUrl( 1, 'view', $w, $t );
   1.750 +    return $redirecturl;
   1.751 +}
   1.752 +
   1.753 +
   1.754 +=pod
   1.755 +
   1.756 +---++ ObjectMethod redirect( $url, $passthrough, $action_redirectto )
   1.757 +
   1.758 +   * $url - url or twikitopic to redirect to
   1.759 +   * $passthrough - (optional) parameter to **FILLMEIN**
   1.760 +   * $action_redirectto - (optional) redirect to where ?redirectto=
   1.761 +     points to (if it's valid)
   1.762 +
   1.763 +Redirects the request to =$url=, *unless*
   1.764 +   1 It is overridden by a plugin declaring a =redirectCgiQueryHandler=.
   1.765 +   1 =$session->{cgiQuery}= is =undef= or
   1.766 +   1 $query->param('noredirect') is set to a true value.
   1.767 +Thus a redirect is only generated when in a CGI context.
   1.768 +
   1.769 +Normally this method will ignore parameters to the current query. Sometimes,
   1.770 +for example when redirecting to a login page during authentication (and then
   1.771 +again from the login page to the original requested URL), you want to make
   1.772 +sure all parameters are passed on, and for this $passthrough should be set to
   1.773 +true. In this case it will pass all parameters that were passed to the
   1.774 +current query on to the redirect target. If the request_method for the
   1.775 +current query was GET, then all parameters will be passed by encoding them
   1.776 +in the URL (after ?). If the request_method was POST, then there is a risk the
   1.777 +URL would be too big for the receiver, so it caches the form data and passes
   1.778 +over a cache reference in the redirect GET.
   1.779 +
   1.780 +NOTE: Passthrough is only meaningful if the redirect target is on the same
   1.781 +server.
   1.782 +
   1.783 +=cut
   1.784 +
   1.785 +sub redirect {
   1.786 +    my( $this, $url, $passthru, $action_redirectto ) = @_;
   1.787 +
   1.788 +    my $query = $this->{cgiQuery};
   1.789 +    # if we got here without a query, there's not much more we can do
   1.790 +    return unless $query;
   1.791 +
   1.792 +    # SMELL: if noredirect is set, don't generate the redirect, throw an
   1.793 +    # exception instead. This is a HACK used to support TWikiDrawPlugin.
   1.794 +    # It is deprecated and must be replaced by REST handlers in the plugin.
   1.795 +    if( $query->param( 'noredirect' )) {
   1.796 +        die "ERROR: $url";
   1.797 +        return;
   1.798 +    }
   1.799 +
   1.800 +    if ($action_redirectto) {
   1.801 +        my $redir = _getRedirectUrl($this);
   1.802 +        $url = $redir if ($redir);
   1.803 +    }
   1.804 +
   1.805 +    if ($passthru && defined $ENV{REQUEST_METHOD}) {
   1.806 +        my $existing = '';
   1.807 +        if ($url =~ s/\?(.*)$//) {
   1.808 +            $existing = $1;
   1.809 +        }
   1.810 +        if ($ENV{REQUEST_METHOD} eq 'POST') {
   1.811 +            # Redirecting from a post to a get
   1.812 +            my $cache = $this->cacheQuery();
   1.813 +            if ($cache) {
   1.814 +                $url .= "?$cache";
   1.815 +            }
   1.816 +        } else {
   1.817 +            if ($query->query_string()) {
   1.818 +                $url .= '?'.$query->query_string();
   1.819 +            }
   1.820 +            if ($existing) {
   1.821 +                if ($url =~ /\?/) {
   1.822 +                    $url .= ';';
   1.823 +                } else {
   1.824 +                    $url .= '?';
   1.825 +                }
   1.826 +                $url .= $existing;
   1.827 +            }
   1.828 +        }
   1.829 +    }
   1.830 +
   1.831 +    # prevent phishing by only allowing redirect to configured host
   1.832 +    # do this check as late as possible to catch _any_ last minute hacks
   1.833 +    # TODO: this should really use URI
   1.834 +    if (!isRedirectSafe($url)) {
   1.835 +         # goto oops if URL is trying to take us somewhere dangerous
   1.836 +         $url = $this->getScriptUrl(
   1.837 +             1, 'oops',
   1.838 +             $this->{web} || $TWiki::cfg{UsersWebName},
   1.839 +             $this->{topic} || $TWiki::cfg{HomeTopicName},
   1.840 +             template => 'oopsaccessdenied',
   1.841 +             def => 'topic_access',
   1.842 +             param1 => 'redirect',
   1.843 +             param2 => 'unsafe redirect to '.$url.
   1.844 +               ': host does not match {DefaultUrlHost} , and is not in {PermittedRedirectHostUrls}"'.
   1.845 +                 $TWiki::cfg{DefaultUrlHost}.'"'
   1.846 +            );
   1.847 +    }
   1.848 +
   1.849 +
   1.850 +    return if( $this->{plugins}->redirectCgiQueryHandler( $query, $url ));
   1.851 +
   1.852 +    # SMELL: this is a bad breaking of encapsulation: the loginManager
   1.853 +    # should just modify the url, then the redirect should only happen here.
   1.854 +    return if( $this->{users}->{loginManager}->redirectCgiQuery( $query, $url ) );
   1.855 +    die "Login manager returned 0 from redirectCgiQuery";
   1.856 +}
   1.857 +
   1.858 +=pod
   1.859 +
   1.860 +---++ ObjectMethod cacheQuery() -> $queryString
   1.861 +
   1.862 +Caches the current query in the params cache, and returns a rewritten
   1.863 +query string for the cache to be picked up again on the other side of a
   1.864 +redirect.
   1.865 +
   1.866 +We can't encode post params into a redirect, because they may exceed the
   1.867 +size of the GET request. So we cache the params, and reload them when the
   1.868 +redirect target is reached.
   1.869 +
   1.870 +=cut
   1.871 +
   1.872 +sub cacheQuery {
   1.873 +    my $this = shift;
   1.874 +    my $query = $this->{cgiQuery};
   1.875 +
   1.876 +    return '' unless (scalar($query->param()));
   1.877 +    # Don't double-cache
   1.878 +    return '' if ($query->param('twiki_redirect_cache'));
   1.879 +
   1.880 +    require Digest::MD5;
   1.881 +    my $md5 = new Digest::MD5();
   1.882 +    $md5->add($$, time(), rand(time));
   1.883 +    my $uid = $md5->hexdigest();
   1.884 +    my $passthruFilename = "$TWiki::cfg{WorkingDir}/tmp/passthru_$uid";
   1.885 +
   1.886 +    use Fcntl;
   1.887 +    #passthrough file is only written to once, so if it already exists, suspect a security hack (O_EXCL)
   1.888 +    sysopen(F, "$passthruFilename", O_RDWR|O_EXCL|O_CREAT, 0600) ||
   1.889 +      die "Unable to open $TWiki::cfg{WorkingDir}/tmp for write; check the setting of {WorkingDir} in configure, and check file permissions: $!";
   1.890 +    $query->save(\*F);
   1.891 +    close(F);
   1.892 +    return 'twiki_redirect_cache='.$uid;
   1.893 +}
   1.894 +
   1.895 +=pod
   1.896 +
   1.897 +---++ StaticMethod isValidWikiWord( $name ) -> $boolean
   1.898 +
   1.899 +Check for a valid WikiWord or WikiName
   1.900 +
   1.901 +=cut
   1.902 +
   1.903 +sub isValidWikiWord {
   1.904 +    my $name  = shift || '';
   1.905 +    return ( $name =~ m/^$regex{wikiWordRegex}$/o )
   1.906 +}
   1.907 +
   1.908 +=pod
   1.909 +
   1.910 +---++ StaticMethod isValidTopicName( $name ) -> $boolean
   1.911 +
   1.912 +Check for a valid topic name
   1.913 +
   1.914 +=cut
   1.915 +
   1.916 +sub isValidTopicName {
   1.917 +    my( $name ) = @_;
   1.918 +
   1.919 +    return isValidWikiWord( @_ ) || isValidAbbrev( @_ );
   1.920 +}
   1.921 +
   1.922 +=pod
   1.923 +
   1.924 +---++ StaticMethod isValidAbbrev( $name ) -> $boolean
   1.925 +
   1.926 +Check for a valid ABBREV (acronym)
   1.927 +
   1.928 +=cut
   1.929 +
   1.930 +sub isValidAbbrev {
   1.931 +    my $name = shift || '';
   1.932 +    return ( $name =~ m/^$regex{abbrevRegex}$/o )
   1.933 +}
   1.934 +
   1.935 +=pod
   1.936 +
   1.937 +---++ StaticMethod isValidWebName( $name, $system ) -> $boolean
   1.938 +
   1.939 +STATIC Check for a valid web name. If $system is true, then
   1.940 +system web names are considered valid (names starting with _)
   1.941 +otherwise only user web names are valid
   1.942 +
   1.943 +If $TWiki::cfg{EnableHierarchicalWebs} is off, it will also return false
   1.944 +when a nested web name is passed to it.
   1.945 +
   1.946 +=cut
   1.947 +
   1.948 +sub isValidWebName {
   1.949 +    my $name = shift || '';
   1.950 +    my $sys = shift;
   1.951 +    return 1 if ( $sys && $name =~ m/^$regex{defaultWebNameRegex}$/o );
   1.952 +    return ( $name =~ m/^$regex{webNameRegex}$/o )
   1.953 +}
   1.954 +
   1.955 +=pod
   1.956 +
   1.957 +---++ ObjectMethod readOnlyMirrorWeb( $theWeb ) -> ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote )
   1.958 +
   1.959 +If this is a mirrored web, return information about the mirror. The info
   1.960 +is returned in a quadruple:
   1.961 +
   1.962 +| site name | URL | link | note |
   1.963 +
   1.964 +=cut
   1.965 +
   1.966 +sub readOnlyMirrorWeb {
   1.967 +    my( $this, $theWeb ) = @_;
   1.968 +
   1.969 +
   1.970 +    my @mirrorInfo = ( '', '', '', '' );
   1.971 +    if( $TWiki::cfg{SiteWebTopicName} ) {
   1.972 +        my $mirrorSiteName =
   1.973 +          $this->{prefs}->getWebPreferencesValue( 'MIRRORSITENAME', $theWeb );
   1.974 +        if( $mirrorSiteName && $mirrorSiteName ne $TWiki::cfg{SiteWebTopicName} ) {
   1.975 +            my $mirrorViewURL  =
   1.976 +              $this->{prefs}->getWebPreferencesValue( 'MIRRORVIEWURL', $theWeb );
   1.977 +            my $mirrorLink = $this->templates->readTemplate( 'mirrorlink' );
   1.978 +            $mirrorLink =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
   1.979 +            $mirrorLink =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
   1.980 +            $mirrorLink =~ s/\s*$//g;
   1.981 +            my $mirrorNote = $this->templates->readTemplate( 'mirrornote' );
   1.982 +            $mirrorNote =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
   1.983 +            $mirrorNote =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
   1.984 +            $mirrorNote = $this->renderer->getRenderedVersion
   1.985 +              ( $mirrorNote, $theWeb, $TWiki::cfg{HomeTopic} );
   1.986 +            $mirrorNote =~ s/\s*$//g;
   1.987 +            @mirrorInfo = ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote );
   1.988 +        }
   1.989 +    }
   1.990 +    return @mirrorInfo;
   1.991 +}
   1.992 +
   1.993 +=pod
   1.994 +
   1.995 +---++ ObjectMethod getSkin () -> $string
   1.996 +
   1.997 +Get the currently requested skin path
   1.998 +
   1.999 +=cut
  1.1000 +
  1.1001 +sub getSkin {
  1.1002 +    my $this = shift;
  1.1003 +
  1.1004 +
  1.1005 +    my $skinpath = $this->{prefs}->getPreferencesValue( 'SKIN' ) || '';
  1.1006 +
  1.1007 +    if( $this->{cgiQuery} ) {
  1.1008 +        my $resurface = $this->{cgiQuery}->param( 'skin' );
  1.1009 +        $skinpath = $resurface if $resurface;
  1.1010 +    }
  1.1011 +
  1.1012 +    my $epidermis = $this->{prefs}->getPreferencesValue( 'COVER' );
  1.1013 +    $skinpath = $epidermis.','.$skinpath if $epidermis;
  1.1014 +
  1.1015 +    if( $this->{cgiQuery} ) {
  1.1016 +        $epidermis = $this->{cgiQuery}->param( 'cover' );
  1.1017 +        $skinpath = $epidermis.','.$skinpath if $epidermis;
  1.1018 +    }
  1.1019 +
  1.1020 +    return $skinpath;
  1.1021 +}
  1.1022 +
  1.1023 +=pod
  1.1024 +
  1.1025 +---++ ObjectMethod getScriptUrl( $absolute, $script, $web, $topic, ... ) -> $scriptURL
  1.1026 +
  1.1027 +Returns the URL to a TWiki script, providing the web and topic as
  1.1028 +"path info" parameters.  The result looks something like this:
  1.1029 +"http://host/twiki/bin/$script/$web/$topic".
  1.1030 +   * =...= - 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>
  1.1031 +
  1.1032 +If $absolute is set, generates an absolute URL. $absolute is advisory only;
  1.1033 +TWiki can decide to generate absolute URLs (for example when run from the
  1.1034 +command-line) even when relative URLs have been requested.
  1.1035 +
  1.1036 +The default script url is taken from {ScriptUrlPath}, unless there is
  1.1037 +an exception defined for the given script in {ScriptUrlPaths}. Both
  1.1038 +{ScriptUrlPath} and {ScriptUrlPaths} may be absolute or relative URIs. If
  1.1039 +they are absolute, then they will always generate absolute URLs. if they
  1.1040 +are relative, then they will be converted to absolute when required (e.g.
  1.1041 +when running from the command line, or when generating rss). If
  1.1042 +$script is not given, absolute URLs will always be generated.
  1.1043 +
  1.1044 +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.
  1.1045 +
  1.1046 +=cut
  1.1047 +
  1.1048 +sub getScriptUrl {
  1.1049 +    my( $this, $absolute, $script, $web, $topic, @params ) = @_;
  1.1050 +
  1.1051 +    $absolute ||= ($this->inContext( 'command_line' ) ||
  1.1052 +                     $this->inContext( 'rss' ) ||
  1.1053 +                       $this->inContext( 'absolute_urls' ));
  1.1054 +
  1.1055 +    # SMELL: topics and webs that contain spaces?
  1.1056 +
  1.1057 +    my $url;
  1.1058 +    if( defined $TWiki::cfg{ScriptUrlPaths} && $script) {
  1.1059 +        $url = $TWiki::cfg{ScriptUrlPaths}{$script};
  1.1060 +    }
  1.1061 +    unless( defined( $url )) {
  1.1062 +        $url = $TWiki::cfg{ScriptUrlPath};
  1.1063 +        if( $script ) {
  1.1064 +            $url .= '/' unless $url =~ /\/$/;
  1.1065 +            $url .= $script;
  1.1066 +            $url .= $TWiki::cfg{ScriptSuffix} if $script;
  1.1067 +        }
  1.1068 +    }
  1.1069 +
  1.1070 +    if( $absolute && $url !~ /^[a-z]+:/ ) {
  1.1071 +        # See http://www.ietf.org/rfc/rfc2396.txt for the definition of
  1.1072 +        # "absolute URI". TWiki bastardises this definition by assuming
  1.1073 +        # that all relative URLs lack the <authority> component as well.
  1.1074 +        $url = $this->{urlHost}.$url;
  1.1075 +    }
  1.1076 +
  1.1077 +    if( $web || $topic ) {
  1.1078 +        ( $web, $topic ) =
  1.1079 +          $this->normalizeWebTopicName( $web, $topic );
  1.1080 +
  1.1081 +        $url .= urlEncode( '/'.$web.'/'.$topic );
  1.1082 +
  1.1083 +	$url .= _make_params(0, @params);
  1.1084 +    }
  1.1085 +
  1.1086 +    return $url;
  1.1087 +}
  1.1088 +
  1.1089 +sub _make_params {
  1.1090 +  my ( $notfirst, @args ) = @_;
  1.1091 +  my $url = '';
  1.1092 +  my $ps = '';
  1.1093 +  my $anchor = '';
  1.1094 +  while( my $p = shift @args ) {
  1.1095 +    if( $p eq '#' ) {
  1.1096 +      $anchor .= '#' . shift( @args );
  1.1097 +    } else {
  1.1098 +      $ps .= ';' . $p.'='.urlEncode(shift( @args )||'');
  1.1099 +    }
  1.1100 +  }
  1.1101 +  if( $ps ) {
  1.1102 +    $ps =~ s/^;/?/ unless $notfirst;
  1.1103 +    $url .= $ps;
  1.1104 +  }
  1.1105 +  $url .= $anchor;
  1.1106 +  return $url;
  1.1107 +}
  1.1108 +
  1.1109 +=pod
  1.1110 +
  1.1111 +---++ ObjectMethod getPubUrl($absolute, $web, $topic, $attachment) -> $url
  1.1112 +
  1.1113 +Composes a pub url. If $absolute is set, returns an absolute URL.
  1.1114 +If $absolute is set, generates an absolute URL. $absolute is advisory only;
  1.1115 +TWiki can decide to generate absolute URLs (for example when run from the
  1.1116 +command-line) even when relative URLs have been requested.
  1.1117 +
  1.1118 +$web, $topic and $attachment are optional. A partial URL path will be
  1.1119 +generated if one or all is not given.
  1.1120 +
  1.1121 +=cut
  1.1122 +
  1.1123 +sub getPubUrl {
  1.1124 +    my( $this, $absolute, $web, $topic, $attachment ) = @_;
  1.1125 +
  1.1126 +    $absolute ||= ($this->inContext( 'command_line' ) ||
  1.1127 +                     $this->inContext( 'rss' ) ||
  1.1128 +                       $this->inContext( 'absolute_urls' ));
  1.1129 +
  1.1130 +    my $url = '';
  1.1131 +    $url .= $TWiki::cfg{PubUrlPath};
  1.1132 +    if( $absolute && $url !~ /^[a-z]+:/ ) {
  1.1133 +        # See http://www.ietf.org/rfc/rfc2396.txt for the definition of
  1.1134 +        # "absolute URI". TWiki bastardises this definition by assuming
  1.1135 +        # that all relative URLs lack the <authority> component as well.
  1.1136 +        $url = $this->{urlHost}.$url;
  1.1137 +    }
  1.1138 +    if( $web || $topic || $attachment ) {
  1.1139 +        ( $web, $topic ) =
  1.1140 +          $this->normalizeWebTopicName( $web, $topic );
  1.1141 +
  1.1142 +        my $path = '/'.$web.'/'.$topic;
  1.1143 +	if( $attachment ) {
  1.1144 +	    $path .= '/'.$attachment;
  1.1145 +	    # Attachments are served directly by web server, need to handle
  1.1146 +	    # URL encoding specially
  1.1147 +	    $url .= urlEncodeAttachment ( $path );
  1.1148 +	} else {
  1.1149 +	    $url .= urlEncode( $path );
  1.1150 +	}
  1.1151 +    }
  1.1152 +
  1.1153 +    return $url;
  1.1154 +}
  1.1155 +
  1.1156 +=pod
  1.1157 +
  1.1158 +---++ ObjectMethod getIconUrl( $absolute, $iconName ) -> $iconURL
  1.1159 +
  1.1160 +Map an icon name to a URL path.
  1.1161 +
  1.1162 +=cut
  1.1163 +
  1.1164 +sub getIconUrl {
  1.1165 +    my( $this, $absolute, $iconName ) = @_;
  1.1166 +
  1.1167 +    my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
  1.1168 +    my( $web, $topic) = $this->normalizeWebTopicName(
  1.1169 +        $this->{webName}, $iconTopic );
  1.1170 +    $iconName =~ s/^.*\.(.*?)$/$1/;
  1.1171 +    return $this->getPubUrl( $absolute, $web, $topic, $iconName.'.gif' );
  1.1172 +}
  1.1173 +
  1.1174 +=pod
  1.1175 +
  1.1176 +---++ ObjectMethod mapToIconFileName( $fileName, $default ) -> $fileName
  1.1177 +
  1.1178 +Maps from a filename (or just the extension) to the name of the
  1.1179 +file that contains the image for that file type.
  1.1180 +
  1.1181 +=cut
  1.1182 +
  1.1183 +sub mapToIconFileName {
  1.1184 +    my( $this, $fileName, $default ) = @_;
  1.1185 +	
  1.1186 +    my @bits = ( split( /\./, $fileName ) );
  1.1187 +    my $fileExt = lc $bits[$#bits];
  1.1188 +
  1.1189 +    unless( $this->{_ICONMAP} ) {
  1.1190 +        my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
  1.1191 +        my( $web, $topic) = $this->normalizeWebTopicName(
  1.1192 +            $this->{webName}, $iconTopic );
  1.1193 +        local $/ = undef;
  1.1194 +        try {
  1.1195 +            my $icons = $this->{store}->getAttachmentStream(
  1.1196 +                undef, $web, $topic, '_filetypes.txt' );
  1.1197 +            %{$this->{_ICONMAP}} = split( /\s+/, <$icons> );
  1.1198 +            close( $icons );
  1.1199 +        } catch Error::Simple with {
  1.1200 +            %{$this->{_ICONMAP}} = ();
  1.1201 +        };
  1.1202 +    }
  1.1203 +
  1.1204 +    return $this->{_ICONMAP}->{$fileExt} || $default || 'else';
  1.1205 +}
  1.1206 +
  1.1207 +=pod
  1.1208 +
  1.1209 +---++ ObjectMethod normalizeWebTopicName( $theWeb, $theTopic ) -> ( $theWeb, $theTopic )
  1.1210 +
  1.1211 +Normalize a Web<nop>.<nop>TopicName
  1.1212 +
  1.1213 +See TWikiFuncDotPm for a full specification of the expansion (not duplicated
  1.1214 +here)
  1.1215 +
  1.1216 +*WARNING* if there is no web specification (in the web or topic parameters)
  1.1217 +the web defaults to $TWiki::cfg{UsersWebName}. If there is no topic
  1.1218 +specification, or the topic is '0', the topic defaults to the web home topic
  1.1219 +name.
  1.1220 +
  1.1221 +=cut
  1.1222 +
  1.1223 +sub normalizeWebTopicName {
  1.1224 +    my( $this, $web, $topic ) = @_;
  1.1225 +
  1.1226 +    ASSERT(defined $topic) if DEBUG;
  1.1227 +
  1.1228 +    if( $topic =~ m|^(.*)[./](.*?)$| ) {
  1.1229 +        $web = $1;
  1.1230 +        $topic = $2;
  1.1231 +    }
  1.1232 +    $web ||= $cfg{UsersWebName};
  1.1233 +    $topic ||= $cfg{HomeTopicName};
  1.1234 +    while( $web =~ s/%((MAIN|TWIKI|USERS|SYSTEM|DOC)WEB)%/_expandTagOnTopicRendering( $this,$1)||''/e ) {
  1.1235 +    }
  1.1236 +    $web =~ s#\.#/#go;
  1.1237 +    return( $web, $topic );
  1.1238 +}
  1.1239 +
  1.1240 +=pod
  1.1241 +
  1.1242 +---++ ClassMethod new( $loginName, $query, \%initialContext )
  1.1243 +
  1.1244 +Constructs a new TWiki object. Parameters are taken from the query object.
  1.1245 +
  1.1246 +   * =$loginName= is the login username (*not* the wikiname) of the user you
  1.1247 +     want to be logged-in if none is available from a session or browser.
  1.1248 +     Used mainly for side scripts and debugging.
  1.1249 +   * =$query= the CGI query (may be undef, in which case an empty query
  1.1250 +     is used)
  1.1251 +   * =\%initialContext= - reference to a hash containing context
  1.1252 +     name=value pairs to be pre-installed in the context hash
  1.1253 +
  1.1254 +=cut
  1.1255 +
  1.1256 +sub new {
  1.1257 +    my( $class, $login, $query, $initialContext ) = @_;
  1.1258 +
  1.1259 +    Monitor::MARK("Static compilation complete");
  1.1260 +
  1.1261 +    # Compatibility; not used except maybe in plugins
  1.1262 +    $TWiki::cfg{TempfileDir} = "$TWiki::cfg{WorkingDir}/tmp"
  1.1263 +      unless defined($TWiki::cfg{TempfileDir});
  1.1264 +
  1.1265 +    # Set command_line context if there is no query
  1.1266 +    $initialContext ||= defined( $query ) ? {} : { command_line => 1 };
  1.1267 +
  1.1268 +    $query ||= new CGI( {} );
  1.1269 +    my $this = bless( {}, $class );
  1.1270 +
  1.1271 +    $this->{_HTMLHEADERS} = {};
  1.1272 +    $this->{context} = $initialContext;
  1.1273 +
  1.1274 +    # create the various sub-objects
  1.1275 +    unless ($sandbox) {
  1.1276 +        # "shared" between mod_perl instances
  1.1277 +        $sandbox = new TWiki::Sandbox(
  1.1278 +            $TWiki::cfg{OS}, $TWiki::cfg{DetailedOS} );
  1.1279 +    }
  1.1280 +    require TWiki::Plugins;
  1.1281 +    $this->{plugins} = new TWiki::Plugins( $this );
  1.1282 +    require TWiki::Store;
  1.1283 +    $this->{store} = new TWiki::Store( $this );
  1.1284 +    # cache CGI information in the session object
  1.1285 +    $this->{cgiQuery} = $query;
  1.1286 +
  1.1287 +    $this->{remoteUser} = $login;	#use login as a default (set when running from cmd line)
  1.1288 +    require TWiki::Users;
  1.1289 +    $this->{users} = new TWiki::Users( $this );
  1.1290 +	$this->{remoteUser} = $this->{users}->{remoteUser};
  1.1291 +
  1.1292 +    # Make %ENV safer, preventing hijack of the search path
  1.1293 +    # SMELL: can this be done in a BEGIN block? Or is the environment
  1.1294 +    # set per-query?
  1.1295 +    # Item4382: Default $ENV{PATH} must be untainted because TWiki runs
  1.1296 +    # with use strict and calling external programs that writes on the disk
  1.1297 +    # will fail unless Perl seens it as set to safe value.
  1.1298 +    if( $TWiki::cfg{SafeEnvPath} ) {
  1.1299 +        $ENV{PATH} = $TWiki::cfg{SafeEnvPath};
  1.1300 +    } else {
  1.1301 +        $ENV{PATH} = TWiki::Sandbox::untaintUnchecked( $ENV{PATH} );
  1.1302 +    }
  1.1303 +    delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };
  1.1304 +
  1.1305 +    my $web = '';
  1.1306 +    my $topic = $query->param( 'topic' );
  1.1307 +    if( $topic ) {
  1.1308 +        if( $topic =~ m#^$regex{linkProtocolPattern}://#o &&
  1.1309 +            $this->{cgiQuery} ) {
  1.1310 +            # redirect to URI
  1.1311 +                print $this->redirect( $topic );
  1.1312 +                exit;   #we seriously don't want to go through normal TWiki operations if we're redirecting..
  1.1313 +        } elsif( $topic =~ /((?:.*[\.\/])+)(.*)/ ) {
  1.1314 +            # is 'bin/script?topic=Webname.SomeTopic'
  1.1315 +            $web   = $1;
  1.1316 +            $topic = $2;
  1.1317 +            $web =~ s/\./\//go;
  1.1318 +            $web =~ s/\/$//o;
  1.1319 +            # jump to WebHome if 'bin/script?topic=Webname.'
  1.1320 +            $topic = $TWiki::cfg{HomeTopicName} if( $web && ! $topic );
  1.1321 +        }
  1.1322 +        # otherwise assume 'bin/script/Webname?topic=SomeTopic'
  1.1323 +    } else {
  1.1324 +        $topic = '';
  1.1325 +    }
  1.1326 +
  1.1327 +    # SMELL: "The Microsoft Internet Information Server is broken with
  1.1328 +    # respect to additional path information. If you use the Perl DLL
  1.1329 +    # library, the IIS server will attempt to execute the additional
  1.1330 +    # path information as a Perl script. If you use the ordinary file
  1.1331 +    # associations mapping, the path information will be present in the
  1.1332 +    # environment, but incorrect. The best thing to do is to avoid using
  1.1333 +    # additional path information."
  1.1334 +
  1.1335 +    # Clean up PATH_INFO problems, e.g.  Support.CobaltRaqInstall.  A valid
  1.1336 +    # PATH_INFO is '/Main/WebHome', i.e. the text after the script name;
  1.1337 +    # invalid PATH_INFO is often a full path starting with '/cgi-bin/...'.
  1.1338 +    my $pathInfo = $query->path_info();
  1.1339 +    my $cgiScriptName = $ENV{SCRIPT_NAME} || '';
  1.1340 +    $pathInfo =~ s!$cgiScriptName/!/!i;
  1.1341 +
  1.1342 +    # Get the web and topic names from PATH_INFO
  1.1343 +    if( $pathInfo =~ /\/((?:.*[\.\/])+)(.*)/ ) {
  1.1344 +        # is 'bin/script/Webname/SomeTopic' or 'bin/script/Webname/'
  1.1345 +        $web   = $1 unless $web;
  1.1346 +        $topic = $2 unless $topic;
  1.1347 +        $web =~ s/\./\//go;
  1.1348 +        $web =~ s/\/$//o;
  1.1349 +    } elsif( $pathInfo =~ /\/(.*)/ ) {
  1.1350 +        # is 'bin/script/Webname' or 'bin/script/'
  1.1351 +        $web = $1 unless $web;
  1.1352 +    }
  1.1353 +
  1.1354 +    # All roads lead to WebHome
  1.1355 +    $topic = $TWiki::cfg{HomeTopicName} if ( $topic =~ /\.\./ );
  1.1356 +    $topic =~ s/$TWiki::cfg{NameFilter}//go;
  1.1357 +    $topic = $TWiki::cfg{HomeTopicName} unless $topic;
  1.1358 +    $this->{topicName} = TWiki::Sandbox::untaintUnchecked( $topic );
  1.1359 +
  1.1360 +    $web   =~ s/$TWiki::cfg{NameFilter}//go;
  1.1361 +    $this->{requestedWebName} = TWiki::Sandbox::untaintUnchecked( $web ); #can be an empty string
  1.1362 +    $web = $TWiki::cfg{UsersWebName} unless $web;
  1.1363 +    $this->{webName} = TWiki::Sandbox::untaintUnchecked( $web );
  1.1364 +
  1.1365 +    # Convert UTF-8 web and topic name from URL into site charset if necessary 
  1.1366 +    # SMELL: merge these two cases, browsers just don't mix two encodings in one URL
  1.1367 +    # - can also simplify into 2 lines by making function return unprocessed text if no conversion
  1.1368 +    my $webNameTemp = UTF82SiteCharSet( $this->{webName} );
  1.1369 +    if ( $webNameTemp ) {
  1.1370 +        $this->{webName} = $webNameTemp;
  1.1371 +    }
  1.1372 +
  1.1373 +    my $topicNameTemp = UTF82SiteCharSet( $this->{topicName} );
  1.1374 +    if ( $topicNameTemp ) {
  1.1375 +        $this->{topicName} = $topicNameTemp;
  1.1376 +    }
  1.1377 +
  1.1378 +    # Item3270 - here's the appropriate place to enforce TWiki spec:
  1.1379 +    # All topic name sources are evaluated, site charset applied
  1.1380 +    # SMELL: This untaint unchecked is duplicate of one just above
  1.1381 +    $this->{topicName}  =
  1.1382 +        TWiki::Sandbox::untaintUnchecked(ucfirst $this->{topicName});
  1.1383 +
  1.1384 +    $this->{scriptUrlPath} = $TWiki::cfg{ScriptUrlPath};
  1.1385 +
  1.1386 +    my $url = $query->url();
  1.1387 +    if( $url && $url =~ m!^([^:]*://[^/]*)(.*)/.*$! && $2 ) {
  1.1388 +        $this->{urlHost} = $1;
  1.1389 +        # If the urlHost in the url is localhost, this is a lot less
  1.1390 +        # useful than the default url host. This is because new CGI("")
  1.1391 +        # assigns this host by default - it's a default setting, used
  1.1392 +        # when there is nothing better available.
  1.1393 +        if( $this->{urlHost} eq 'http://localhost' ) {
  1.1394 +            $this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
  1.1395 +        } elsif( $TWiki::cfg{RemovePortNumber} ) {
  1.1396 +            $this->{urlHost} =~ s/\:[0-9]+$//;
  1.1397 +        }
  1.1398 +        if( $TWiki::cfg{GetScriptUrlFromCgi} ) {
  1.1399 +            # SMELL: this is a really dangerous hack. It will fail
  1.1400 +            # spectacularly with mod_perl.
  1.1401 +            # SMELL: why not just use $query->script_name?
  1.1402 +            $this->{scriptUrlPath} = $2;
  1.1403 +        }
  1.1404 +    } else {
  1.1405 +        $this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
  1.1406 +    }
  1.1407 +
  1.1408 +    require TWiki::Prefs;
  1.1409 +    my $prefs = new TWiki::Prefs( $this );
  1.1410 +    $this->{prefs} = $prefs;
  1.1411 +
  1.1412 +    # Form definition cache
  1.1413 +    $this->{forms} = {};
  1.1414 +
  1.1415 +    # Push global preferences from TWiki.TWikiPreferences
  1.1416 +    $prefs->pushGlobalPreferences();
  1.1417 +
  1.1418 +#TODO: what happens if we move this into the TWiki::User::new?
  1.1419 +    $this->{user} = $this->{users}->initialiseUser($this->{remoteUser});
  1.1420 +
  1.1421 +    # Static session variables that can be expanded in topics when they
  1.1422 +    # are enclosed in % signs
  1.1423 +    # SMELL: should collapse these into one. The duplication is pretty
  1.1424 +    # pointless. Could get rid of the SESSION_TAGS hash, might be
  1.1425 +    # the easiest thing to do, but then that would allow other
  1.1426 +    # upper-case named fields in the object to be accessed as well...
  1.1427 +    $this->{SESSION_TAGS}{BASEWEB}        = $this->{webName};
  1.1428 +    $this->{SESSION_TAGS}{BASETOPIC}      = $this->{topicName};
  1.1429 +    $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $this->{topicName};
  1.1430 +    $this->{SESSION_TAGS}{INCLUDINGWEB}   = $this->{webName};
  1.1431 +
  1.1432 +    # Push plugin settings
  1.1433 +    $this->{plugins}->settings();
  1.1434 +
  1.1435 +    # Now the rest of the preferences
  1.1436 +    $prefs->pushGlobalPreferencesSiteSpecific();
  1.1437 +
  1.1438 +    # User preferences only available if we can get to a valid wikiname,
  1.1439 +    # which depends on the user mapper.
  1.1440 +    my $wn = $this->{users}->getWikiName( $this->{user} );
  1.1441 +    if( $wn ) {
  1.1442 +        $prefs->pushPreferences(
  1.1443 +            $TWiki::cfg{UsersWebName}, $wn,
  1.1444 +            'USER ' . $wn );
  1.1445 +    }
  1.1446 +
  1.1447 +    $prefs->pushWebPreferences( $this->{webName} );
  1.1448 +
  1.1449 +    $prefs->pushPreferences(
  1.1450 +        $this->{webName}, $this->{topicName}, 'TOPIC' );
  1.1451 +
  1.1452 +    $prefs->pushPreferenceValues( 'SESSION',
  1.1453 +                                  $this->{users}->{loginManager}->getSessionValues() );
  1.1454 +
  1.1455 +    # Finish plugin initialization - register handlers
  1.1456 +    $this->{plugins}->enable();
  1.1457 +
  1.1458 +    $TWiki::Plugins::SESSION = $this;
  1.1459 +
  1.1460 +    Monitor::MARK("TWiki session created");
  1.1461 +
  1.1462 +    return $this;
  1.1463 +}
  1.1464 +
  1.1465 +=begin twiki
  1.1466 +
  1.1467 +---++ ObjectMethod renderer()
  1.1468 +Get a reference to the renderer object. Done lazily because not everyone
  1.1469 +needs the renderer.
  1.1470 +
  1.1471 +=cut
  1.1472 +
  1.1473 +sub renderer {
  1.1474 +    my( $this ) = @_;
  1.1475 +
  1.1476 +    unless( $this->{renderer} ) {
  1.1477 +        require TWiki::Render;
  1.1478 +        # requires preferences (such as LINKTOOLTIPINFO)
  1.1479 +        $this->{renderer} = new TWiki::Render( $this );
  1.1480 +    }
  1.1481 +    return $this->{renderer};
  1.1482 +}
  1.1483 +
  1.1484 +=begin twiki
  1.1485 +
  1.1486 +---++ ObjectMethod attach()
  1.1487 +Get a reference to the attach object. Done lazily because not everyone
  1.1488 +needs the attach.
  1.1489 +
  1.1490 +=cut
  1.1491 +
  1.1492 +sub attach {
  1.1493 +    my( $this ) = @_;
  1.1494 +
  1.1495 +    unless( $this->{attach} ) {
  1.1496 +        require TWiki::Attach;
  1.1497 +        $this->{attach} = new TWiki::Attach( $this );
  1.1498 +    }
  1.1499 +    return $this->{attach};
  1.1500 +}
  1.1501 +
  1.1502 +=begin twiki
  1.1503 +
  1.1504 +---++ ObjectMethod templates()
  1.1505 +Get a reference to the templates object. Done lazily because not everyone
  1.1506 +needs the templates.
  1.1507 +
  1.1508 +=cut
  1.1509 +
  1.1510 +sub templates {
  1.1511 +    my( $this ) = @_;
  1.1512 +
  1.1513 +    unless( $this->{templates} ) {
  1.1514 +        require TWiki::Templates;
  1.1515 +        $this->{templates} = new TWiki::Templates( $this );
  1.1516 +    }
  1.1517 +    return $this->{templates};
  1.1518 +}
  1.1519 +
  1.1520 +=begin twiki
  1.1521 +
  1.1522 +---++ ObjectMethod i18n()
  1.1523 +Get a reference to the i18n object. Done lazily because not everyone
  1.1524 +needs the i18ner.
  1.1525 +
  1.1526 +=cut
  1.1527 +
  1.1528 +sub i18n {
  1.1529 +    my( $this ) = @_;
  1.1530 +
  1.1531 +    unless( $this->{i18n} ) {
  1.1532 +        require TWiki::I18N;
  1.1533 +        # language information; must be loaded after
  1.1534 +        # *all possible preferences sources* are available
  1.1535 +        $this->{i18n} = new TWiki::I18N( $this );
  1.1536 +    }
  1.1537 +    return $this->{i18n};
  1.1538 +}
  1.1539 +
  1.1540 +=begin twiki
  1.1541 +
  1.1542 +---++ ObjectMethod search()
  1.1543 +Get a reference to the search object. Done lazily because not everyone
  1.1544 +needs the searcher.
  1.1545 +
  1.1546 +=cut
  1.1547 +
  1.1548 +sub search {
  1.1549 +    my( $this ) = @_;
  1.1550 +
  1.1551 +    unless( $this->{search} ) {
  1.1552 +        require TWiki::Search;
  1.1553 +        $this->{search} = new TWiki::Search( $this );
  1.1554 +    }
  1.1555 +    return $this->{search};
  1.1556 +}
  1.1557 +
  1.1558 +=begin twiki
  1.1559 +
  1.1560 +---++ ObjectMethod security()
  1.1561 +Get a reference to the security object. Done lazily because not everyone
  1.1562 +needs the security.
  1.1563 +
  1.1564 +=cut
  1.1565 +
  1.1566 +sub security {
  1.1567 +    my( $this ) = @_;
  1.1568 +
  1.1569 +    unless( $this->{security} ) {
  1.1570 +        require TWiki::Access;
  1.1571 +        $this->{security} = new TWiki::Access( $this );
  1.1572 +    }
  1.1573 +    return $this->{security};
  1.1574 +}
  1.1575 +
  1.1576 +=begin twiki
  1.1577 +
  1.1578 +---++ ObjectMethod net()
  1.1579 +Get a reference to the net object. Done lazily because not everyone
  1.1580 +needs the net.
  1.1581 +
  1.1582 +=cut
  1.1583 +
  1.1584 +sub net {
  1.1585 +    my( $this ) = @_;
  1.1586 +
  1.1587 +    unless( $this->{net} ) {
  1.1588 +        require TWiki::Net;
  1.1589 +        $this->{net} = new TWiki::Net( $this );
  1.1590 +    }
  1.1591 +    return $this->{net};
  1.1592 +}
  1.1593 +
  1.1594 +=begin twiki
  1.1595 +
  1.1596 +---++ ObjectMethod finish()
  1.1597 +Break circular references.
  1.1598 +
  1.1599 +=cut
  1.1600 +
  1.1601 +# Note to developers; please undef *all* fields in the object explicitly,
  1.1602 +# whether they are references or not. That way this method is "golden
  1.1603 +# documentation" of the live fields in the object.
  1.1604 +sub finish {
  1.1605 +    my $this = shift;
  1.1606 +
  1.1607 +    map { $_->finish() } values %{$this->{forms}};
  1.1608 +    $this->{plugins}->finish() if $this->{plugins};
  1.1609 +    $this->{users}->finish() if $this->{users};
  1.1610 +    $this->{prefs}->finish() if $this->{prefs};
  1.1611 +    $this->{templates}->finish() if $this->{templates};
  1.1612 +    $this->{renderer}->finish() if $this->{renderer};
  1.1613 +    $this->{net}->finish() if $this->{net};
  1.1614 +    $this->{store}->finish() if $this->{store};
  1.1615 +    $this->{search}->finish() if $this->{search};
  1.1616 +    $this->{attach}->finish() if $this->{attach};
  1.1617 +    $this->{security}->finish() if $this->{security};
  1.1618 +    $this->{i18n}->finish() if $this->{i18n};
  1.1619 +
  1.1620 +    undef $this->{_HTMLHEADERS};
  1.1621 +    undef $this->{cgiQuery};
  1.1622 +    undef $this->{urlHost};
  1.1623 +    undef $this->{web};
  1.1624 +    undef $this->{topic};
  1.1625 +    undef $this->{webName};
  1.1626 +    undef $this->{topicName};
  1.1627 +    undef $this->{_ICONMAP};
  1.1628 +    undef $this->{context};
  1.1629 +    undef $this->{remoteUser};
  1.1630 +    undef $this->{requestedWebName}; # Web name before renaming
  1.1631 +    undef $this->{scriptUrlPath};
  1.1632 +    undef $this->{user};
  1.1633 +    undef $this->{SESSION_TAGS};
  1.1634 +    undef $this->{_INCLUDES};
  1.1635 +}
  1.1636 +
  1.1637 +=pod
  1.1638 +
  1.1639 +---++ ObjectMethod writeLog( $action, $webTopic, $extra, $user )
  1.1640 +
  1.1641 +   * =$action= - what happened, e.g. view, save, rename
  1.1642 +   * =$wbTopic= - what it happened to
  1.1643 +   * =$extra= - extra info, such as minor flag
  1.1644 +   * =$user= - user who did the saving (user id)
  1.1645 +Write the log for an event to the logfile
  1.1646 +
  1.1647 +=cut
  1.1648 +
  1.1649 +sub writeLog {
  1.1650 +    my $this = shift;
  1.1651 +
  1.1652 +    my $action = shift || '';
  1.1653 +    my $webTopic = shift || '';
  1.1654 +    my $extra = shift || '';
  1.1655 +    my $user = shift;
  1.1656 +
  1.1657 +    $user ||= $this->{user};
  1.1658 +    $user = $this->{users}->getLoginName( $user ) if ($this->{users});
  1.1659 +
  1.1660 +    if( $user eq $cfg{DefaultUserLogin} ) {
  1.1661 +       my $cgiQuery = $this->{cgiQuery};
  1.1662 +       if( $cgiQuery ) {
  1.1663 +           my $agent = $cgiQuery->user_agent();
  1.1664 +           if( $agent ) {
  1.1665 +               $agent =~ m/([\w]+)/;
  1.1666 +               $extra .= ' '.$1;
  1.1667 +           }
  1.1668 +       }
  1.1669 +    }
  1.1670 +
  1.1671 +    my $remoteAddr = $ENV{REMOTE_ADDR} || '';
  1.1672 +    my $text = "$user | $action | $webTopic | $extra | $remoteAddr |";
  1.1673 +
  1.1674 +    _writeReport( $this, $TWiki::cfg{LogFileName}, $text );
  1.1675 +}
  1.1676 +
  1.1677 +=pod
  1.1678 +
  1.1679 +---++ ObjectMethod writeWarning( $text )
  1.1680 +
  1.1681 +Prints date, time, and contents $text to $TWiki::cfg{WarningFileName}, typically
  1.1682 +'warnings.txt'. Use for warnings and errors that may require admin
  1.1683 +intervention. Use this for defensive programming warnings (e.g. assertions).
  1.1684 +
  1.1685 +=cut
  1.1686 +
  1.1687 +sub writeWarning {
  1.1688 +    my $this = shift;
  1.1689 +    _writeReport( $this, $TWiki::cfg{WarningFileName}, @_ );
  1.1690 +}
  1.1691 +
  1.1692 +=pod
  1.1693 +
  1.1694 +---++ ObjectMethod writeDebug( $text )
  1.1695 +
  1.1696 +Prints date, time, and contents of $text to $TWiki::cfg{DebugFileName}, typically
  1.1697 +'debug.txt'.  Use for debugging messages.
  1.1698 +
  1.1699 +=cut
  1.1700 +
  1.1701 +sub writeDebug {
  1.1702 +    my $this = shift;
  1.1703 +    _writeReport( $this, $TWiki::cfg{DebugFileName}, @_ );
  1.1704 +}
  1.1705 +
  1.1706 +# Concatenates date, time, and $text to a log file.
  1.1707 +# The logfilename can optionally use a %DATE% variable to support
  1.1708 +# logs that are rotated once a month.
  1.1709 +# | =$log= | Base filename for log file |
  1.1710 +# | =$message= | Message to print |
  1.1711 +sub _writeReport {
  1.1712 +    my ( $this, $log, $message ) = @_;
  1.1713 +
  1.1714 +    if ( $log ) {
  1.1715 +        require TWiki::Time;
  1.1716 +        my $time =
  1.1717 +          TWiki::Time::formatTime( time(), '$year$mo', 'servertime');
  1.1718 +        $log =~ s/%DATE%/$time/go;
  1.1719 +        $time = TWiki::Time::formatTime( time(), undef, 'servertime' );
  1.1720 +
  1.1721 +        if( open( FILE, ">>$log" ) ) {
  1.1722 +            print FILE "| $time | $message\n";
  1.1723 +            close( FILE );
  1.1724 +        } else {
  1.1725 +            print STDERR 'Could not write "'.$message.'" to '."$log: $!\n";
  1.1726 +        }
  1.1727 +    }
  1.1728 +}
  1.1729 +
  1.1730 +sub _removeNewlines {
  1.1731 +    my( $theTag ) = @_;
  1.1732 +    $theTag =~ s/[\r\n]+/ /gs;
  1.1733 +    return $theTag;
  1.1734 +}
  1.1735 +
  1.1736 +# Convert relative URLs to absolute URIs
  1.1737 +sub _rewriteURLInInclude {
  1.1738 +    my( $theHost, $theAbsPath, $url ) = @_;
  1.1739 +
  1.1740 +    # leave out an eventual final non-directory component from the absolute path
  1.1741 +    $theAbsPath =~ s/(.*?)[^\/]*$/$1/;
  1.1742 +
  1.1743 +    if( $url =~ /^\// ) {
  1.1744 +        # fix absolute URL
  1.1745 +        $url = $theHost.$url;
  1.1746 +    } elsif( $url =~ /^\./ ) {
  1.1747 +        # fix relative URL
  1.1748 +        $url = $theHost.$theAbsPath.'/'.$url;
  1.1749 +    } elsif( $url =~ /^$regex{linkProtocolPattern}:/o ) {
  1.1750 +        # full qualified URL, do nothing
  1.1751 +    } elsif( $url =~ /^#/ ) {
  1.1752 +        # anchor. This needs to be left relative to the including topic
  1.1753 +        # so do nothing
  1.1754 +    } elsif( $url ) {
  1.1755 +        # FIXME: is this test enough to detect relative URLs?
  1.1756 +        $url = $theHost.$theAbsPath.'/'.$url;
  1.1757 +    }
  1.1758 +
  1.1759 +    return $url;
  1.1760 +}
  1.1761 +
  1.1762 +# Add a web reference to a [[...][...]] link in an included topic
  1.1763 +sub _fixIncludeLink {
  1.1764 +    my( $web, $link, $label ) = @_;
  1.1765 +
  1.1766 +    # Detect absolute and relative URLs and web-qualified wikinames
  1.1767 +    if( $link =~ m#^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}:|/)#o ) {
  1.1768 +        if( $label ) {
  1.1769 +            return "[[$link][$label]]";
  1.1770 +        } else {
  1.1771 +            return "[[$link]]";
  1.1772 +        }
  1.1773 +    } elsif( !$label ) {
  1.1774 +        # Must be wikiword or spaced-out wikiword (or illegal link :-/)
  1.1775 +        $label = $link;
  1.1776 +    }
  1.1777 +    return "[[$web.$link][$label]]";
  1.1778 +}
  1.1779 +
  1.1780 +# Replace web references in a topic. Called from forEachLine, applying to
  1.1781 +# each non-verbatim and non-literal line.
  1.1782 +sub _fixupIncludedTopic {
  1.1783 +    my( $text, $options ) = @_;
  1.1784 +
  1.1785 +    my $fromWeb = $options->{web};
  1.1786 +
  1.1787 +    unless( $options->{in_noautolink} ) {
  1.1788 +        # 'TopicName' to 'Web.TopicName'
  1.1789 +        $text =~ s#(?:^|(?<=[\s(]))($regex{wikiWordRegex})(?=\s|\)|$)#$fromWeb.$1#go;
  1.1790 +    }
  1.1791 +
  1.1792 +    # Handle explicit [[]] everywhere
  1.1793 +    # '[[TopicName][...]]' to '[[Web.TopicName][...]]'
  1.1794 +    $text =~ s/\[\[([^]]+)\](?:\[([^]]+)\])?\]/
  1.1795 +      _fixIncludeLink( $fromWeb, $1, $2 )/geo;
  1.1796 +
  1.1797 +    return $text;
  1.1798 +}
  1.1799 +
  1.1800 +# Clean-up HTML text so that it can be shown embedded in a topic
  1.1801 +sub _cleanupIncludedHTML {
  1.1802 +    my( $text, $host, $path, $options ) = @_;
  1.1803 +
  1.1804 +    # FIXME: Make aware of <base> tag
  1.1805 +
  1.1806 +    $text =~ s/^.*?<\/head>//is
  1.1807 +      unless ( $options->{disableremoveheaders} );   # remove all HEAD
  1.1808 +    $text =~ s/<script.*?<\/script>//gis
  1.1809 +      unless ( $options->{disableremovescript} );    # remove all SCRIPTs
  1.1810 +    $text =~ s/^.*?<body[^>]*>//is
  1.1811 +      unless ( $options->{disableremovebody} );      # remove all to <BODY>
  1.1812 +    $text =~ s/(?:\n)<\/body>.*//is
  1.1813 +      unless ( $options->{disableremovebody} );      # remove </BODY>
  1.1814 +    $text =~ s/(?:\n)<\/html>.*//is
  1.1815 +      unless ( $options->{disableremoveheaders} );   # remove </HTML>
  1.1816 +    $text =~ s/(<[^>]*>)/_removeNewlines($1)/ges
  1.1817 +      unless ( $options->{disablecompresstags} );    # replace newlines in html tags with space
  1.1818 +    $text =~ s/(\s(?:href|src|action)=(["']))(.*?)\2/$1._rewriteURLInInclude( $host, $path, $3 ).$2/geois
  1.1819 +      unless ( $options->{disablerewriteurls} );
  1.1820 +
  1.1821 +    return $text;
  1.1822 +}
  1.1823 +
  1.1824 +=pod
  1.1825 +
  1.1826 +---++ StaticMethod applyPatternToIncludedText( $text, $pattern ) -> $text
  1.1827 +
  1.1828 +Apply a pattern on included text to extract a subset
  1.1829 +
  1.1830 +=cut
  1.1831 +
  1.1832 +sub applyPatternToIncludedText {
  1.1833 +    my( $theText, $thePattern ) = @_;
  1.1834 +    $thePattern =~ s/([^\\])([\$\@\%\&\#\'\`\/])/$1\\$2/g;  # escape some special chars
  1.1835 +    $thePattern = TWiki::Sandbox::untaintUnchecked( $thePattern );
  1.1836 +    $theText = '' unless( $theText =~ s/$thePattern/$1/is );
  1.1837 +    return $theText;
  1.1838 +}
  1.1839 +
  1.1840 +# Fetch content from a URL for inclusion by an INCLUDE
  1.1841 +sub _includeUrl {
  1.1842 +    my( $this, $url, $pattern, $web, $topic, $raw, $options, $warn ) = @_;
  1.1843 +    my $text = '';
  1.1844 +
  1.1845 +    # For speed, read file directly if URL matches an attachment directory
  1.1846 +    if( $url =~ /^$this->{urlHost}$TWiki::cfg{PubUrlPath}\/([^\/\.]+)\/([^\/\.]+)\/([^\/]+)$/ ) {
  1.1847 +        my $incWeb = $1;
  1.1848 +        my $incTopic = $2;
  1.1849 +        my $incAtt = $3;
  1.1850 +        # FIXME: Check for MIME type, not file suffix
  1.1851 +        if( $incAtt =~ m/\.(txt|html?)$/i ) {
  1.1852 +            unless( $this->{store}->attachmentExists(
  1.1853 +                $incWeb, $incTopic, $incAtt )) {
  1.1854 +                return _includeWarning( $this, $warn, 'bad_attachment', $url );
  1.1855 +            }
  1.1856 +            if( $incWeb ne $web || $incTopic ne $topic ) {
  1.1857 +                # CODE_SMELL: Does not account for not yet authenticated user
  1.1858 +                unless( $this->security->checkAccessPermission(
  1.1859 +                    'VIEW', $this->{user}, undef, undef, $incTopic, $incWeb ) ) {
  1.1860 +                    return _includeWarning( $this, $warn, 'access_denied',
  1.1861 +                                                   "$incWeb.$incTopic" );
  1.1862 +                }
  1.1863 +            }
  1.1864 +            $text = $this->{store}->readAttachment( undef, $incWeb, $incTopic,
  1.1865 +                                                    $incAtt );
  1.1866 +            $text = _cleanupIncludedHTML( $text, $this->{urlHost},
  1.1867 +                                          $TWiki::cfg{PubUrlPath}, $options )
  1.1868 +              unless $raw;
  1.1869 +            $text = applyPatternToIncludedText( $text, $pattern )
  1.1870 +              if( $pattern );
  1.1871 +            $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
  1.1872 +            return $text;
  1.1873 +        }
  1.1874 +        # fall through; try to include file over http based on MIME setting
  1.1875 +    }
  1.1876 +
  1.1877 +    return _includeWarning( $this, $warn, 'urls_not_allowed' )
  1.1878 +      unless $TWiki::cfg{INCLUDE}{AllowURLs};
  1.1879 +
  1.1880 +    # SMELL: should use the URI module from CPAN to parse the URL
  1.1881 +    # SMELL: but additional CPAN adds to code bloat
  1.1882 +    unless ($url =~ m!^https?:!) {
  1.1883 +        $text = _includeWarning( $this, $warn, 'bad_protocol', $url );
  1.1884 +        return $text;
  1.1885 +    }
  1.1886 +
  1.1887 +    my $response = $this->net->getExternalResource( $url );
  1.1888 +    if( !$response->is_error()) {
  1.1889 +        my $contentType = $response->header('content-type');
  1.1890 +        $text = $response->content();
  1.1891 +        if( $contentType =~ /^text\/html/ ) {
  1.1892 +            if (!$raw) {
  1.1893 +                $url =~ m!^([a-z]+:/*[^/]*)(/[^#?]*)!;
  1.1894 +                $text = _cleanupIncludedHTML( $text, $1, $2, $options );
  1.1895 +            }
  1.1896 +        } elsif( $contentType =~ /^text\/(plain|css)/ ) {
  1.1897 +            # do nothing
  1.1898 +        } else {
  1.1899 +            $text = _includeWarning(
  1.1900 +                $this, $warn, 'bad_content', $contentType );
  1.1901 +        }
  1.1902 +        $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
  1.1903 +        $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
  1.1904 +    } else {
  1.1905 +        $text = _includeWarning( $this, $warn, 'geturl_failed',
  1.1906 +                                 $url.' '.$response->message() );
  1.1907 +    }
  1.1908 +
  1.1909 +    return $text;
  1.1910 +}
  1.1911 +
  1.1912 +#
  1.1913 +# SMELL: this is _not_ a tag handler in the sense of other builtin tags,
  1.1914 +# because it requires far more context information (the text of the topic)
  1.1915 +# than any handler.
  1.1916 +# SMELL: as a tag handler that also semi-renders the topic to extract the
  1.1917 +# headings, this handler would be much better as a preRenderingHandler in
  1.1918 +# a plugin (where head, script and verbatim sections are already protected)
  1.1919 +#
  1.1920 +#    * $text  : ref to the text of the current topic
  1.1921 +#    * $topic : the topic we are in
  1.1922 +#    * $web   : the web we are in
  1.1923 +#    * $args  : 'Topic' [web='Web'] [depth='N']
  1.1924 +# Return value: $tableOfContents
  1.1925 +# Handles %<nop>TOC{...}% syntax.  Creates a table of contents
  1.1926 +# using TWiki bulleted
  1.1927 +# list markup, linked to the section headings of a topic. A section heading is
  1.1928 +# entered in one of the following forms:
  1.1929 +#    * $headingPatternSp : \t++... spaces section heading
  1.1930 +#    * $headingPatternDa : ---++... dashes section heading
  1.1931 +#    * $headingPatternHt : &lt;h[1-6]> HTML section heading &lt;/h[1-6]>
  1.1932 +sub _TOC {
  1.1933 +    my ( $this, $text, $defaultTopic, $defaultWeb, $args ) = @_;
  1.1934 +
  1.1935 +    require TWiki::Attrs;
  1.1936 +
  1.1937 +    my $params = new TWiki::Attrs( $args );
  1.1938 +    # get the topic name attribute
  1.1939 +    my $topic = $params->{_DEFAULT} || $defaultTopic;
  1.1940 +
  1.1941 +    # get the web name attribute
  1.1942 +    $defaultWeb =~ s#/#.#g;
  1.1943 +    my $web = $params->{web} || $defaultWeb;
  1.1944 +
  1.1945 +    my $isSameTopic = $web eq $defaultWeb  &&  $topic eq $defaultTopic;
  1.1946 +
  1.1947 +    $web =~ s#/#\.#g;
  1.1948 +    my $webPath = $web;
  1.1949 +    $webPath =~ s/\./\//g;
  1.1950 +
  1.1951 +    # get the depth limit attribute
  1.1952 +    my $maxDepth = $params->{depth} || $this->{prefs}->getPreferencesValue('TOC_MAX_DEPTH') || 6;
  1.1953 +    my $minDepth = $this->{prefs}->getPreferencesValue('TOC_MIN_DEPTH') || 1;
  1.1954 +    
  1.1955 +    # get the title attribute
  1.1956 +    my $title = $params->{title} || $this->{prefs}->getPreferencesValue('TOC_TITLE') || '';
  1.1957 +    $title = CGI::span( { class => 'twikiTocTitle' }, $title ) if( $title );
  1.1958 +
  1.1959 +    if( $web ne $defaultWeb || $topic ne $defaultTopic ) {
  1.1960 +        unless( $this->security->checkAccessPermission
  1.1961 +                ( 'VIEW', $this->{user}, undef, undef, $topic, $web ) ) {
  1.1962 +            return $this->inlineAlert( 'alerts', 'access_denied',
  1.1963 +                                       $web, $topic );
  1.1964 +        }
  1.1965 +        my $meta;
  1.1966 +        ( $meta, $text ) =
  1.1967 +          $this->{store}->readTopic( $this->{user}, $web, $topic );
  1.1968 +    }
  1.1969 +
  1.1970 +    my $insidePre = 0;
  1.1971 +    my $insideVerbatim = 0;
  1.1972 +    my $highest = 99;
  1.1973 +    my $result  = '';
  1.1974 +    my $verbatim = {};
  1.1975 +    $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
  1.1976 +                                               $verbatim);
  1.1977 +    $text = $this->renderer->takeOutBlocks( $text, 'pre',
  1.1978 +                                               $verbatim);
  1.1979 +
  1.1980 +    # Find URL parameters
  1.1981 +    my $query = $this->{cgiQuery};
  1.1982 +    my @qparams = ();
  1.1983 +    foreach my $name ( $query->param ) {
  1.1984 +      next if ($name eq 'keywords');
  1.1985 +      next if ($name eq 'topic');
  1.1986 +      next if ($name eq 'text');
  1.1987 +      push @qparams, $name => $query->param($name);
  1.1988 +    }
  1.1989 +
  1.1990 +    # SMELL: this handling of <pre> is archaic.
  1.1991 +    # SMELL: use forEachLine
  1.1992 +    foreach my $line ( split( /\r?\n/, $text ) ) {
  1.1993 +        my $level;
  1.1994 +        if ( $line =~ m/$regex{headerPatternDa}/o ) {
  1.1995 +            $line = $2;
  1.1996 +            $level = length $1;
  1.1997 +        } elsif ( $line =~ m/$regex{headerPatternHt}/io ) {
  1.1998 +            $line = $2;
  1.1999 +            $level = $1;
  1.2000 +        } else {
  1.2001 +            next;
  1.2002 +        }
  1.2003 +
  1.2004 +        if( $line && ($level >= $minDepth) && ($level <= $maxDepth) ) {
  1.2005 +            # cut TOC exclude '---+ heading !! exclude this bit'
  1.2006 +            $line =~ s/\s*$regex{headerPatternNoTOC}.+$//go;
  1.2007 +            next unless $line;
  1.2008 +            my $anchor = $this->renderer->makeAnchorName( $line );
  1.2009 +            $highest = $level if( $level < $highest );
  1.2010 +            my $tabs = "\t" x $level;
  1.2011 +            # Remove *bold*, _italic_ and =fixed= formatting
  1.2012 +            $line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
  1.2013 +            $line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
  1.2014 +            $line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
  1.2015 +            # Prevent WikiLinks
  1.2016 +            $line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g;  # '[[...][...]]'
  1.2017 +            $line =~ s/\[\[(.*?)\]\]/$1/ge;        # '[[...]]'
  1.2018 +            $line =~ s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1<nop>$3/go;  # 'Web.TopicName'
  1.2019 +            $line =~ s/([\s\(])($regex{wikiWordRegex})/$1<nop>$2/go;  # 'TopicName'
  1.2020 +            $line =~ s/([\s\(])($regex{abbrevRegex})/$1<nop>$2/go;    # 'TLA'
  1.2021 +            $line =~ s/([\s\-\*\(])([$regex{mixedAlphaNum}]+\:)/$1<nop>$2/go; # 'Site:page' Interwiki link
  1.2022 +            # Prevent manual links
  1.2023 +            $line =~ s/<[\/]?a\b[^>]*>//gi;
  1.2024 +            # create linked bullet item, using a relative link to anchor
  1.2025 +            my $target = $isSameTopic ?
  1.2026 +                         _make_params(0, '#'=>$anchor,@qparams) :
  1.2027 +                         $this->getScriptUrl(0,'view',$web,$topic,'#'=>$anchor,@qparams);
  1.2028 +            $line = $tabs.'* ' .  CGI::a({href=>$target},$line);
  1.2029 +            $result .= "\n".$line;
  1.2030 +        }
  1.2031 +    }
  1.2032 +
  1.2033 +    if( $result ) {
  1.2034 +        if( $highest > 1 ) {
  1.2035 +            # left shift TOC
  1.2036 +            $highest--;
  1.2037 +            $result =~ s/^\t{$highest}//gm;
  1.2038 +        }
  1.2039 +        return CGI::div( { class=>'twikiToc' }, "$title$result\n" );
  1.2040 +    } else {
  1.2041 +        return '';
  1.2042 +    }
  1.2043 +}
  1.2044 +
  1.2045 +=pod
  1.2046 +
  1.2047 +---++ ObjectMethod inlineAlert($template, $def, ... ) -> $string
  1.2048 +
  1.2049 +Format an error for inline inclusion in rendered output. The message string
  1.2050 +is obtained from the template 'oops'.$template, and the DEF $def is
  1.2051 +selected. The parameters (...) are used to populate %PARAM1%..%PARAMn%
  1.2052 +
  1.2053 +=cut
  1.2054 +
  1.2055 +sub inlineAlert {
  1.2056 +    my $this = shift;
  1.2057 +    my $template = shift;
  1.2058 +    my $def = shift;
  1.2059 +
  1.2060 +    my $text = $this->templates->readTemplate( 'oops'.$template,
  1.2061 +                                                 $this->getSkin() );
  1.2062 +    if( $text ) {
  1.2063 +        my $blah = $this->templates->expandTemplate( $def );
  1.2064 +        $text =~ s/%INSTANTIATE%/$blah/;
  1.2065 +        # web and topic can be anything; they are not used
  1.2066 +        $text = $this->handleCommonTags( $text, $this->{webName},
  1.2067 +                                         $this->{topicName} );
  1.2068 +        my $n = 1;
  1.2069 +        while( defined( my $param = shift )) {
  1.2070 +            $text =~ s/%PARAM$n%/$param/g;
  1.2071 +            $n++;
  1.2072 +        }
  1.2073 +
  1.2074 +    } else {
  1.2075 +        $text = CGI::h1('TWiki Installation Error')
  1.2076 +          . 'Template "'.$template.'" not found.'.CGI::p()
  1.2077 +            . 'Check your configuration settings for {TemplateDir} and {TemplatePath}';
  1.2078 +    }
  1.2079 +
  1.2080 +    return $text;
  1.2081 +}
  1.2082 +
  1.2083 +=pod
  1.2084 +
  1.2085 +---++ StaticMethod parseSections($text) -> ($string,$sectionlistref)
  1.2086 +
  1.2087 +Generic parser for sections within a topic. Sections are delimited
  1.2088 +by STARTSECTION and ENDSECTION, which may be nested, overlapped or
  1.2089 +otherwise abused. The parser builds an array of sections, which is
  1.2090 +ordered by the order of the STARTSECTION within the topic. It also
  1.2091 +removes all the SECTION tags from the text, and returns the text
  1.2092 +and the array of sections.
  1.2093 +
  1.2094 +Each section is a =TWiki::Attrs= object, which contains the attributes
  1.2095 +{type, name, start, end}
  1.2096 +where start and end are character offsets in the
  1.2097 +string *after all section tags have been removed*. All sections
  1.2098 +are required to be uniquely named; if a section is unnamed, it
  1.2099 +will be given a generated name. Sections may overlap or nest.
  1.2100 +
  1.2101 +See test/unit/Fn_SECTION.pm for detailed testcases that
  1.2102 +round out the spec.
  1.2103 +
  1.2104 +=cut
  1.2105 +
  1.2106 +sub parseSections {
  1.2107 +    #my( $text _ = @_;
  1.2108 +    my %sections;
  1.2109 +    my @list = ();
  1.2110 +
  1.2111 +    my $seq = 0;
  1.2112 +    my $ntext = '';
  1.2113 +    my $offset = 0;
  1.2114 +    foreach my $bit (split(/(%(?:START|END)SECTION(?:{.*?})?%)/, $_[0] )) {
  1.2115 +        if( $bit =~ /^%STARTSECTION(?:{(.*)})?%$/) {
  1.2116 +            require TWiki::Attrs;
  1.2117 +            my $attrs = new TWiki::Attrs( $1 );
  1.2118 +            $attrs->{type} ||= 'section';
  1.2119 +            $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} ||
  1.2120 +              '_SECTION'.$seq++;
  1.2121 +            delete $attrs->{_DEFAULT};
  1.2122 +            my $id = $attrs->{type}.':'.$attrs->{name};
  1.2123 +            if( $sections{$id} ) {
  1.2124 +                # error, this named section already defined, ignore
  1.2125 +                next;
  1.2126 +            }
  1.2127 +            # close open unnamed sections of the same type
  1.2128 +            foreach my $s ( @list ) {
  1.2129 +                if( $s->{end} < 0 && $s->{type} eq $attrs->{type} &&
  1.2130 +                      $s->{name} =~ /^_SECTION\d+$/ ) {
  1.2131 +                    $s->{end} = $offset;
  1.2132 +                }
  1.2133 +            }
  1.2134 +            $attrs->{start} = $offset;
  1.2135 +            $attrs->{end} = -1; # open section
  1.2136 +            $sections{$id} = $attrs;
  1.2137 +            push( @list, $attrs );
  1.2138 +        } elsif( $bit =~ /^%ENDSECTION(?:{(.*)})?%$/ ) {
  1.2139 +            require TWiki::Attrs;
  1.2140 +            my $attrs = new TWiki::Attrs( $1 );
  1.2141 +            $attrs->{type} ||= 'section';
  1.2142 +            $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} || '';
  1.2143 +            delete $attrs->{_DEFAULT};
  1.2144 +            unless( $attrs->{name} ) {
  1.2145 +                # find the last open unnamed section of this type
  1.2146 +                foreach my $s ( reverse @list ) {
  1.2147 +                    if( $s->{end} == -1 &&
  1.2148 +                          $s->{type} eq $attrs->{type} &&
  1.2149 +                         $s->{name} =~ /^_SECTION\d+$/ ) {
  1.2150 +                        $attrs->{name} = $s->{name};
  1.2151 +                        last;
  1.2152 +                    }
  1.2153 +                }
  1.2154 +                # ignore it if no matching START found
  1.2155 +                next unless $attrs->{name};
  1.2156 +            }
  1.2157 +            my $id = $attrs->{type}.':'.$attrs->{name};
  1.2158 +            if( !$sections{$id} || $sections{$id}->{end} >= 0 ) {
  1.2159 +                # error, no such open section, ignore
  1.2160 +                next;
  1.2161 +            }
  1.2162 +            $sections{$id}->{end} = $offset;
  1.2163 +        } else {
  1.2164 +            $ntext .= $bit;
  1.2165 +            $offset = length( $ntext );
  1.2166 +        }
  1.2167 +    }
  1.2168 +
  1.2169 +    # close open sections
  1.2170 +    foreach my $s ( @list ) {
  1.2171 +        $s->{end} = $offset if $s->{end} < 0;
  1.2172 +    }
  1.2173 +
  1.2174 +    return( $ntext, \@list );
  1.2175 +}
  1.2176 +
  1.2177 +=pod
  1.2178 +
  1.2179 +---++ ObjectMethod expandVariablesOnTopicCreation ( $text, $user, $web, $topic ) -> $text
  1.2180 +
  1.2181 +   * =$text= - text to expand
  1.2182 +   * =$user= - This is the user expanded in e.g. %USERNAME. Optional, defaults to logged-in user.
  1.2183 +Expand limited set of variables during topic creation. These are variables
  1.2184 +expected in templates that must be statically expanded in new content.
  1.2185 +   * =$web= - name of web
  1.2186 +   * =$topic= - name of topic
  1.2187 +
  1.2188 +# SMELL: no plugin handler
  1.2189 +
  1.2190 +=cut
  1.2191 +
  1.2192 +sub expandVariablesOnTopicCreation {
  1.2193 +    my ( $this, $text, $user, $theWeb, $theTopic ) = @_;
  1.2194 +
  1.2195 +    $user ||= $this->{user};
  1.2196 +
  1.2197 +    # Chop out templateonly sections
  1.2198 +    my( $ntext, $sections ) = parseSections( $text );
  1.2199 +    if( scalar( @$sections )) {
  1.2200 +        # Note that if named templateonly sections overlap, the behaviour is undefined.
  1.2201 +        foreach my $s ( reverse @$sections ) {
  1.2202 +            if( $s->{type} eq 'templateonly' ) {
  1.2203 +                $ntext = substr($ntext, 0, $s->{start})
  1.2204 +                       . substr($ntext, $s->{end}, length($ntext));
  1.2205 +            } else {
  1.2206 +                # put back non-templateonly sections
  1.2207 +                my $start = $s->remove('start');
  1.2208 +                my $end = $s->remove('end');
  1.2209 +                $ntext = substr($ntext, 0, $start).
  1.2210 +                  '%STARTSECTION{'.$s->stringify().'}%'.
  1.2211 +                    substr($ntext, $start, $end - $start).
  1.2212 +                      '%ENDSECTION{'.$s->stringify().'}%'.
  1.2213 +                        substr($ntext, $end, length($ntext));
  1.2214 +            }
  1.2215 +        }
  1.2216 +        $text = $ntext;
  1.2217 +    }
  1.2218 +
  1.2219 +    # Make sure func works, for registered tag handlers
  1.2220 +    $TWiki::Plugins::SESSION = $this;
  1.2221 +
  1.2222 +    # Note: it may look dangerous to override the user this way, but
  1.2223 +    # it's actually quite safe, because only a subset of tags are
  1.2224 +    # expanded during topic creation. if the set of tags expanded is
  1.2225 +    # extended, then the impact has to be considered.
  1.2226 +    my $safe = $this->{user};
  1.2227 +    $this->{user} = $user;
  1.2228 +    $text = _processTags( $this, $text, \&_expandTagOnTopicCreation, 16 );
  1.2229 +
  1.2230 +    # expand all variables for type="expandvariables" sections
  1.2231 +    ( $ntext, $sections ) = parseSections( $text );
  1.2232 +    if( scalar( @$sections )) {
  1.2233 +        $theWeb   ||= $this->{session}->{webName};
  1.2234 +        $theTopic ||= $this->{session}->{topicName};
  1.2235 +        foreach my $s ( reverse @$sections ) {
  1.2236 +            if( $s->{type} eq 'expandvariables' ) {
  1.2237 +                my $etext = substr( $ntext, $s->{start}, $s->{end} - $s->{start} );
  1.2238 +                expandAllTags( $this, \$etext, $theTopic, $theWeb );
  1.2239 +                $ntext = substr( $ntext, 0, $s->{start})
  1.2240 +                       . $etext
  1.2241 +                       . substr( $ntext, $s->{end}, length($ntext) );
  1.2242 +            } else {
  1.2243 +                # put back non-expandvariables sections
  1.2244 +                my $start = $s->remove('start');
  1.2245 +                my $end = $s->remove('end');
  1.2246 +                $ntext = substr($ntext, 0, $start).
  1.2247 +                  '%STARTSECTION{'.$s->stringify().'}%'.
  1.2248 +                    substr($ntext, $start, $end - $start).
  1.2249 +                      '%ENDSECTION{'.$s->stringify().'}%'.
  1.2250 +                        substr($ntext, $end, length($ntext));
  1.2251 +            }
  1.2252 +        }
  1.2253 +        $text = $ntext;
  1.2254 +    }
  1.2255 +
  1.2256 +    # kill markers used to prevent variable expansion
  1.2257 +    $text =~ s/%NOP%//g;
  1.2258 +    $this->{user} = $safe;
  1.2259 +    return $text;
  1.2260 +}
  1.2261 +
  1.2262 +=pod
  1.2263 +
  1.2264 +---++ StaticMethod entityEncode( $text, $extras ) -> $encodedText
  1.2265 +
  1.2266 +Escape special characters to HTML numeric entities. This is *not* a generic
  1.2267 +encoding, it is tuned specifically for use in TWiki.
  1.2268 +
  1.2269 +HTML4.0 spec:
  1.2270 +"Certain characters in HTML are reserved for use as markup and must be
  1.2271 +escaped to appear literally. The "&lt;" character may be represented with
  1.2272 +an <em>entity</em>, <strong class=html>&amp;lt;</strong>. Similarly, "&gt;"
  1.2273 +is escaped as <strong class=html>&amp;gt;</strong>, and "&amp;" is escaped
  1.2274 +as <strong class=html>&amp;amp;</strong>. If an attribute value contains a
  1.2275 +double quotation mark and is delimited by double quotation marks, then the
  1.2276 +quote should be escaped as <strong class=html>&amp;quot;</strong>.</p>
  1.2277 +
  1.2278 +Other entities exist for special characters that cannot easily be entered
  1.2279 +with some keyboards..."
  1.2280 +
  1.2281 +This method encodes HTML special and any non-printable ascii
  1.2282 +characters (except for \n and \r) using numeric entities.
  1.2283 +
  1.2284 +FURTHER this method also encodes characters that are special in TWiki
  1.2285 +meta-language.
  1.2286 +
  1.2287 +$extras is an optional param that may be used to include *additional*
  1.2288 +characters in the set of encoded characters. It should be a string
  1.2289 +containing the additional chars.
  1.2290 +
  1.2291 +=cut
  1.2292 +
  1.2293 +sub entityEncode {
  1.2294 +    my( $text, $extra) = @_;
  1.2295 +    $extra ||= '';
  1.2296 +
  1.2297 +    # encode all non-printable 7-bit chars (< \x1f),
  1.2298 +    # except \n (\xa) and \r (\xd)
  1.2299 +    # encode HTML special characters '>', '<', '&', ''' and '"'.
  1.2300 +    # encode TML special characters '%', '|', '[', ']', '@', '_',
  1.2301 +    # '*', and '='
  1.2302 +    $text =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|$extra])/'&#'.ord($1).';'/ge;
  1.2303 +    return $text;
  1.2304 +}
  1.2305 +
  1.2306 +=pod
  1.2307 +
  1.2308 +---++ StaticMethod entityDecode ( $encodedText ) -> $text
  1.2309 +
  1.2310 +Decodes all numeric entities (e.g. &amp;#123;). _Does not_ decode
  1.2311 +named entities such as &amp;amp; (use HTML::Entities for that)
  1.2312 +
  1.2313 +=cut
  1.2314 +
  1.2315 +sub entityDecode {
  1.2316 +    my $text = shift;
  1.2317 +
  1.2318 +    $text =~ s/&#(\d+);/chr($1)/ge;
  1.2319 +    return $text;
  1.2320 +}
  1.2321 +
  1.2322 +=pod
  1.2323 +
  1.2324 +---++ StaticMethod urlEncodeAttachment ( $text )
  1.2325 +
  1.2326 +For attachments, URL-encode specially to 'freeze' any characters >127 in the
  1.2327 +site charset (e.g. ISO-8859-1 or KOI8-R), by doing URL encoding into native
  1.2328 +charset ($siteCharset) - used when generating attachment URLs, to enable the
  1.2329 +web server to serve attachments, including images, directly.  
  1.2330 +
  1.2331 +This encoding is required to handle the cases of:
  1.2332 +
  1.2333 +    - browsers that generate UTF-8 URLs automatically from site charset URLs - now quite common
  1.2334 +    - web servers that directly serve attachments, using the site charset for
  1.2335 +      filenames, and cannot convert UTF-8 URLs into site charset filenames
  1.2336 +
  1.2337 +The aim is to prevent the browser from converting a site charset URL in the web
  1.2338 +page to a UTF-8 URL, which is the default.  Hence we 'freeze' the URL into the
  1.2339 +site character set through URL encoding. 
  1.2340 +
  1.2341 +In two cases, no URL encoding is needed:  For EBCDIC mainframes, we assume that 
  1.2342 +site charset URLs will be translated (outbound and inbound) by the web server to/from an
  1.2343 +EBCDIC character set. For sites running in UTF-8, there's no need for TWiki to
  1.2344 +do anything since all URLs and attachment filenames are already in UTF-8.
  1.2345 +
  1.2346 +=cut
  1.2347 +
  1.2348 +sub urlEncodeAttachment {
  1.2349 +    my( $text ) = @_;
  1.2350 +
  1.2351 +    my $usingEBCDIC = ( 'A' eq chr(193) ); 	# Only true on EBCDIC mainframes
  1.2352 +
  1.2353 +    if( (defined($TWiki::cfg{Site}{CharSet}) and $TWiki::cfg{Site}{CharSet} eq "utf-8") or $usingEBCDIC ) {
  1.2354 +	# Just let browser do UTF-8 URL encoding 
  1.2355 +	return $text;
  1.2356 +    }
  1.2357 +
  1.2358 +    # Freeze into site charset through URL encoding
  1.2359 +    return urlEncode( $text );
  1.2360 +}
  1.2361 +
  1.2362 +
  1.2363 +=pod
  1.2364 +
  1.2365 +---++ StaticMethod urlEncode( $string ) -> encoded string
  1.2366 +
  1.2367 +Encode by converting characters that are illegal in URLs to
  1.2368 +their %NN equivalents. This method is used for encoding
  1.2369 +strings that must be embedded _verbatim_ in URLs; it cannot
  1.2370 +be applied to URLs themselves, as it escapes reserved
  1.2371 +characters such as = and ?.
  1.2372 +
  1.2373 +RFC 1738, Dec. '94:
  1.2374 +    <verbatim>
  1.2375 +    ...Only alphanumerics [0-9a-zA-Z], the special
  1.2376 +    characters $-_.+!*'(), and reserved characters used for their
  1.2377 +    reserved purposes may be used unencoded within a URL.
  1.2378 +    </verbatim>
  1.2379 +
  1.2380 +Reserved characters are $&+,/:;=?@ - these are _also_ encoded by
  1.2381 +this method.
  1.2382 +
  1.2383 +This URL-encoding handles all character encodings including ISO-8859-*,
  1.2384 +KOI8-R, EUC-* and UTF-8. 
  1.2385 +
  1.2386 +This may not handle EBCDIC properly, as it generates an EBCDIC URL-encoded
  1.2387 +URL, but mainframe web servers seem to translate this outbound before it hits browser
  1.2388 +- see CGI::Util::escape for another approach.
  1.2389 +
  1.2390 +=cut
  1.2391 +
  1.2392 +sub urlEncode {
  1.2393 +    my $text = shift;
  1.2394 +
  1.2395 +    $text =~ s/([^0-9a-zA-Z-_.:~!*'\/%])/'%'.sprintf('%02x',ord($1))/ge;
  1.2396 +
  1.2397 +    return $text;
  1.2398 +}
  1.2399 +
  1.2400 +=pod
  1.2401 +
  1.2402 +---++ StaticMethod urlDecode( $string ) -> decoded string
  1.2403 +
  1.2404 +Reverses the encoding done in urlEncode.
  1.2405 +
  1.2406 +=cut
  1.2407 +
  1.2408 +sub urlDecode {
  1.2409 +    my $text = shift;
  1.2410 +
  1.2411 +    $text =~ s/%([\da-f]{2})/chr(hex($1))/gei;
  1.2412 +
  1.2413 +    return $text;
  1.2414 +}
  1.2415 +
  1.2416 +=pod
  1.2417 +
  1.2418 +---++ StaticMethod isTrue( $value, $default ) -> $boolean
  1.2419 +
  1.2420 +Returns 1 if =$value= is true, and 0 otherwise. "true" means set to
  1.2421 +something with a Perl true value, with the special cases that "off",
  1.2422 +"false" and "no" (case insensitive) are forced to false. Leading and
  1.2423 +trailing spaces in =$value= are ignored.
  1.2424 +
  1.2425 +If the value is undef, then =$default= is returned. If =$default= is
  1.2426 +not specified it is taken as 0.
  1.2427 +
  1.2428 +=cut
  1.2429 +
  1.2430 +sub isTrue {
  1.2431 +    my( $value, $default ) = @_;
  1.2432 +
  1.2433 +    $default ||= 0;
  1.2434 +
  1.2435 +    return $default unless defined( $value );
  1.2436 +
  1.2437 +    $value =~ s/^\s*(.*?)\s*$/$1/gi;
  1.2438 +    $value =~ s/off//gi;
  1.2439 +    $value =~ s/no//gi;
  1.2440 +    $value =~ s/false//gi;
  1.2441 +    return ( $value ) ? 1 : 0;
  1.2442 +}
  1.2443 +
  1.2444 +=pod
  1.2445 +
  1.2446 +---++ StaticMethod spaceOutWikiWord( $word, $sep ) -> $string
  1.2447 +
  1.2448 +Spaces out a wiki word by inserting a string (default: one space) between each word component.
  1.2449 +With parameter $sep any string may be used as separator between the word components; if $sep is undefined it defaults to a space.
  1.2450 +
  1.2451 +=cut
  1.2452 +
  1.2453 +sub spaceOutWikiWord {
  1.2454 +    my $word = shift || '';
  1.2455 +    my $sep = shift || ' ';
  1.2456 +    $word =~ s/([$regex{lowerAlpha}])([$regex{upperAlpha}$regex{numeric}]+)/$1$sep$2/go;
  1.2457 +    $word =~ s/([$regex{numeric}])([$regex{upperAlpha}])/$1$sep$2/go;
  1.2458 +    return $word;
  1.2459 +}
  1.2460 +
  1.2461 +=pod
  1.2462 +
  1.2463 +---++ ObjectMethod expandAllTags(\$text, $topic, $web, $meta)
  1.2464 +Expands variables by replacing the variables with their
  1.2465 +values. Some example variables: %<nop>TOPIC%, %<nop>SCRIPTURL%,
  1.2466 +%<nop>WIKINAME%, etc.
  1.2467 +$web and $incs are passed in for recursive include expansion. They can
  1.2468 +safely be undef.
  1.2469 +The rules for tag expansion are:
  1.2470 +   1 Tags are expanded left to right, in the order they are encountered.
  1.2471 +   1 Tags are recursively expanded as soon as they are encountered -
  1.2472 +     the algorithm is inherently single-pass
  1.2473 +   1 A tag is not "encountered" until the matching }% has been seen, by
  1.2474 +     which time all tags in parameters will have been expanded
  1.2475 +   1 Tag expansions that create new tags recursively are limited to a
  1.2476 +     set number of hierarchical levels of expansion
  1.2477 +
  1.2478 +=cut
  1.2479 +
  1.2480 +sub expandAllTags {
  1.2481 +    my $this = shift;
  1.2482 +    my $text = shift; # reference
  1.2483 +    my ( $topic, $web, $meta ) = @_;
  1.2484 +    $web =~ s#\.#/#go;
  1.2485 +
  1.2486 +    # push current context
  1.2487 +    my $memTopic = $this->{SESSION_TAGS}{TOPIC};
  1.2488 +    my $memWeb   = $this->{SESSION_TAGS}{WEB};
  1.2489 +
  1.2490 +    $this->{SESSION_TAGS}{TOPIC}   = $topic;
  1.2491 +    $this->{SESSION_TAGS}{WEB}     = $web;
  1.2492 +
  1.2493 +    # Escape ' !%VARIABLE%'
  1.2494 +    $$text =~ s/(?<=\s)!%($regex{tagNameRegex})/&#37;$1/g;
  1.2495 +
  1.2496 +    # Make sure func works, for registered tag handlers
  1.2497 +    $TWiki::Plugins::SESSION = $this;
  1.2498 +
  1.2499 +    # NOTE TO DEBUGGERS
  1.2500 +    # The depth parameter in the following call controls the maximum number
  1.2501 +    # of levels of expansion. If it is set to 1 then only tags in the
  1.2502 +    # topic will be expanded; tags that they in turn generate will be
  1.2503 +    # left unexpanded. If it is set to 2 then the expansion will stop after
  1.2504 +    # the first recursive inclusion, and so on. This is incredible useful
  1.2505 +    # when debugging. The default is set to 16
  1.2506 +    # to match the original limit on search expansion, though this of
  1.2507 +    # course applies to _all_ tags and not just search.
  1.2508 +    $$text = _processTags( $this, $$text, \&_expandTagOnTopicRendering,
  1.2509 +                                  16, @_ );
  1.2510 +
  1.2511 +    # restore previous context
  1.2512 +    $this->{SESSION_TAGS}{TOPIC}   = $memTopic;
  1.2513 +    $this->{SESSION_TAGS}{WEB}     = $memWeb;
  1.2514 +}
  1.2515 +
  1.2516 +# set this to 1 to print debugging
  1.2517 +sub TRACE_TAG_PARSER { 0 }
  1.2518 +
  1.2519 +# Process TWiki %TAGS{}% by parsing the input tokenised into
  1.2520 +# % separated sections. The parser is a simple stack-based parse,
  1.2521 +# sufficient to ensure nesting of tags is correct, but no more
  1.2522 +# than that.
  1.2523 +# $depth limits the number of recursive expansion steps that
  1.2524 +# can be performed on expanded tags.
  1.2525 +sub _processTags {
  1.2526 +    my $this = shift;
  1.2527 +    my $text = shift;
  1.2528 +    my $tagf = shift;
  1.2529 +    my $tell = 0;
  1.2530 +
  1.2531 +    return '' unless defined( $text );
  1.2532 +
  1.2533 +    my $depth = shift;
  1.2534 +
  1.2535 +    # my( $topic, $web, $meta ) = @_;
  1.2536 +
  1.2537 +    unless ( $depth ) {
  1.2538 +        my $mess = "Max recursive depth reached: $text";
  1.2539 +        $this->writeWarning( $mess );
  1.2540 +        # prevent recursive expansion that just has been detected
  1.2541 +        # from happening in the error message
  1.2542 +        $text =~ s/%(.*?)%/$1/go;
  1.2543 +        return $text;
  1.2544 +    }
  1.2545 +
  1.2546 +    my $verbatim = {};
  1.2547 +    $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
  1.2548 +                                               $verbatim);
  1.2549 +
  1.2550 +    # See Item1442
  1.2551 +    #my $percent = ($TranslationToken x 3).'%'.($TranslationToken x 3);
  1.2552 +
  1.2553 +    my @queue = split( /(%)/, $text );
  1.2554 +    my @stack;
  1.2555 +    my $stackTop = ''; # the top stack entry. Done this way instead of
  1.2556 +    # referring to the top of the stack for efficiency. This var
  1.2557 +    # should be considered to be $stack[$#stack]
  1.2558 +
  1.2559 +    while ( scalar( @queue )) {
  1.2560 +        my $token = shift( @queue );
  1.2561 +        print STDERR ' ' x $tell,"PROCESSING $token \n" if TRACE_TAG_PARSER;
  1.2562 +
  1.2563 +        # each % sign either closes an existing stacked context, or
  1.2564 +        # opens a new context.
  1.2565 +        if ( $token eq '%' ) {
  1.2566 +            print STDERR ' ' x $tell,"CONSIDER $stackTop\n" if TRACE_TAG_PARSER;
  1.2567 +            # If this is a closing }%, try to rejoin the previous
  1.2568 +            # tokens until we get to a valid tag construct. This is
  1.2569 +            # a bit of a hack, but it's hard to think of a better
  1.2570 +            # way to do this without a full parse that takes % signs
  1.2571 +            # in tag parameters into account.
  1.2572 +            if ( $stackTop =~ /}$/s ) {
  1.2573 +                while ( scalar( @stack) &&
  1.2574 +                        $stackTop !~ /^%($regex{tagNameRegex}){.*}$/so ) {
  1.2575 +                    my $top = $stackTop;
  1.2576 +                    print STDERR ' ' x $tell,"COLLAPSE $top \n" if TRACE_TAG_PARSER;
  1.2577 +                    $stackTop = pop( @stack ) . $top;
  1.2578 +                }
  1.2579 +            }
  1.2580 +            # /s so you can have newlines in parameters
  1.2581 +            if ( $stackTop =~ m/^%(($regex{tagNameRegex})(?:{(.*)})?)$/so ) {
  1.2582 +                my( $expr, $tag, $args ) = ( $1, $2, $3 );
  1.2583 +                print STDERR ' ' x $tell,"POP $tag\n" if TRACE_TAG_PARSER;
  1.2584 +                my $e = &$tagf( $this, $tag, $args, @_ );
  1.2585 +
  1.2586 +                if ( defined( $e )) {
  1.2587 +                    print STDERR ' ' x $tell--,"EXPANDED $tag -> $e\n" if TRACE_TAG_PARSER;
  1.2588 +                    $stackTop = pop( @stack );
  1.2589 +                    # Recursively expand tags in the expansion of $tag
  1.2590 +                    $stackTop .= _processTags($this, $e, $tagf, $depth-1, @_ );
  1.2591 +                } else { # expansion failed
  1.2592 +                    print STDERR ' ' x $tell++,"EXPAND $tag FAILED\n" if TRACE_TAG_PARSER;
  1.2593 +                    # To handle %NOP
  1.2594 +                    # correctly, we have to handle the %VAR% case differently
  1.2595 +                    # to the %VAR{}% case when a variable expansion fails.
  1.2596 +                    # This is so that recursively define variables e.g.
  1.2597 +                    # %A%B%D% expand correctly, but at the same time we ensure
  1.2598 +                    # that a mismatched }% can't accidentally close a context
  1.2599 +                    # that was left open when a tag expansion failed.
  1.2600 +                    # However Cairo didn't do this, so for compatibility
  1.2601 +                    # we have to accept that %NOP can never be fixed. if it
  1.2602 +                    # could, then we could uncomment the following:
  1.2603 +
  1.2604 +                    #if( $stackTop =~ /}$/ ) {
  1.2605 +                    #    # %VAR{...}% case
  1.2606 +                    #    # We need to push the unexpanded expression back
  1.2607 +                    #    # onto the stack, but we don't want it to match the
  1.2608 +                    #    # tag expression again. So we protect the %'s
  1.2609 +                    #    $stackTop = $percent.$expr.$percent;
  1.2610 +                    #} else
  1.2611 +                    {
  1.2612 +                        # %VAR% case.
  1.2613 +                        # In this case we *do* want to match the tag expression
  1.2614 +                        # again, as an embedded %VAR% may have expanded to
  1.2615 +                        # create a valid outer expression. This is directly
  1.2616 +                        # at odds with the %VAR{...}% case.
  1.2617 +                        push( @stack, $stackTop );
  1.2618 +                        $stackTop = '%'; # open new context
  1.2619 +                    }
  1.2620 +                }
  1.2621 +            } else {
  1.2622 +                push( @stack, $stackTop );
  1.2623 +                $stackTop = '%'; # push a new context
  1.2624 +                $tell++ if TRACE_TAG_PARSER;
  1.2625 +            }
  1.2626 +        } else {
  1.2627 +            $stackTop .= $token;
  1.2628 +        }
  1.2629 +    }
  1.2630 +
  1.2631 +    # Run out of input. Gather up everything in the stack.
  1.2632 +    while ( scalar( @stack )) {
  1.2633 +        my $expr = $stackTop;
  1.2634 +        $stackTop = pop( @stack );
  1.2635 +        $stackTop .= $expr;
  1.2636 +    }
  1.2637 +
  1.2638 +    #$stackTop =~ s/$percent/%/go;
  1.2639 +
  1.2640 +    $this->renderer->putBackBlocks( \$stackTop, $verbatim, 'verbatim' );
  1.2641 +
  1.2642 +    print STDERR "FINAL $stackTop\n" if TRACE_TAG_PARSER;
  1.2643 +
  1.2644 +    return $stackTop;
  1.2645 +}
  1.2646 +
  1.2647 +# Handle expansion of a tag during topic rendering
  1.2648 +# $tag is the tag name
  1.2649 +# $args is the bit in the {} (if there are any)
  1.2650 +# $topic and $web should be passed for dynamic tags (not needed for
  1.2651 +# session or constant tags
  1.2652 +sub _expandTagOnTopicRendering {
  1.2653 +    my $this = shift;
  1.2654 +    my $tag = shift;
  1.2655 +    my $args = shift;
  1.2656 +    # my( $topic, $web, $meta ) = @_;
  1.2657 +    require TWiki::Attrs;
  1.2658 +
  1.2659 +    my $e = $this->{prefs}->getPreferencesValue( $tag );
  1.2660 +    unless( defined( $e )) {
  1.2661 +        $e = $this->{SESSION_TAGS}{$tag};
  1.2662 +        if( !defined( $e ) && defined( $functionTags{$tag} )) {
  1.2663 +            $e = &{$functionTags{$tag}}
  1.2664 +              ( $this, new TWiki::Attrs(
  1.2665 +                  $args, $contextFreeSyntax{$tag} ), @_ );
  1.2666 +        }
  1.2667 +    }
  1.2668 +    return $e;
  1.2669 +}
  1.2670 +
  1.2671 +# Handle expansion of a tag during new topic creation. When creating a
  1.2672 +# new topic from a template we only expand a subset of the available legal
  1.2673 +# tags, and we expand %NOP% differently.
  1.2674 +sub _expandTagOnTopicCreation {
  1.2675 +    my $this = shift;
  1.2676 +    # my( $tag, $args, $topic, $web ) = @_;
  1.2677 +
  1.2678 +    # Required for Cairo compatibility. Ignore %NOP{...}%
  1.2679 +    # %NOP% is *not* ignored until all variable expansion is complete,
  1.2680 +    # otherwise them inside-out rule would remove it too early e.g.
  1.2681 +    # %GM%NOP%TIME -> %GMTIME -> 12:00. So we ignore it here and scrape it
  1.2682 +    # out later. We *have* to remove %NOP{...}% because it can foul up
  1.2683 +    # brace-matching.
  1.2684 +    return '' if $_[0] eq 'NOP' && defined $_[1];
  1.2685 +
  1.2686 +    # Only expand a subset of legal tags. Warning: $this->{user} may be
  1.2687 +    # overridden during this call, when a new user topic is being created.
  1.2688 +    # This is what we want to make sure new user templates are populated
  1.2689 +    # correctly, but you need to think about this if you extend the set of
  1.2690 +    # tags expanded here.
  1.2691 +    return undef unless $_[0] =~ /^(URLPARAM|DATE|(SERVER|GM)TIME|(USER|WIKI)NAME|WIKIUSERNAME|USERINFO)$/;
  1.2692 +
  1.2693 +    return _expandTagOnTopicRendering( $this, @_ );
  1.2694 +}
  1.2695 +
  1.2696 +=pod
  1.2697 +
  1.2698 +---++ ObjectMethod enterContext( $id, $val )
  1.2699 +
  1.2700 +Add the context id $id into the set of active contexts. The $val
  1.2701 +can be anything you like, but should always evaluate to boolean
  1.2702 +TRUE.
  1.2703 +
  1.2704 +An example of the use of contexts is in the use of tag
  1.2705 +expansion. The commonTagsHandler in plugins is called every
  1.2706 +time tags need to be expanded, and the context of that expansion
  1.2707 +is signalled by the expanding module using a context id. So the
  1.2708 +forms module adds the context id "form" before invoking common
  1.2709 +tags expansion.
  1.2710 +
  1.2711 +Contexts are not just useful for tag expansion; they are also
  1.2712 +relevant when rendering.
  1.2713 +
  1.2714 +Contexts are intended for use mainly by plugins. Core modules can
  1.2715 +use $session->inContext( $id ) to determine if a context is active.
  1.2716 +
  1.2717 +=cut
  1.2718 +
  1.2719 +sub enterContext {
  1.2720 +    my( $this, $id, $val ) = @_;
  1.2721 +    $val ||= 1;
  1.2722 +    $this->{context}->{$id} = $val;
  1.2723 +}
  1.2724 +
  1.2725 +=pod
  1.2726 +
  1.2727 +---++ ObjectMethod leaveContext( $id )
  1.2728 +
  1.2729 +Remove the context id $id from the set of active contexts.
  1.2730 +(see =enterContext= for more information on contexts)
  1.2731 +
  1.2732 +=cut
  1.2733 +
  1.2734 +sub leaveContext {
  1.2735 +    my( $this, $id ) = @_;
  1.2736 +    my $res = $this->{context}->{$id};
  1.2737 +    delete $this->{context}->{$id};
  1.2738 +    return $res;
  1.2739 +}
  1.2740 +
  1.2741 +=pod
  1.2742 +
  1.2743 +---++ ObjectMethod inContext( $id )
  1.2744 +
  1.2745 +Return the value for the given context id
  1.2746 +(see =enterContext= for more information on contexts)
  1.2747 +
  1.2748 +=cut
  1.2749 +
  1.2750 +sub inContext {
  1.2751 +    my( $this, $id ) = @_;
  1.2752 +    return $this->{context}->{$id};
  1.2753 +}
  1.2754 +
  1.2755 +=pod
  1.2756 +
  1.2757 +---++ StaticMethod registerTagHandler( $tag, $fnref )
  1.2758 +
  1.2759 +STATIC Add a tag handler to the function tag handlers.
  1.2760 +   * =$tag= name of the tag e.g. MYTAG
  1.2761 +   * =$fnref= Function to execute. Will be passed ($session, \%params, $web, $topic )
  1.2762 +
  1.2763 +=cut
  1.2764 +
  1.2765 +sub registerTagHandler {
  1.2766 +    my ( $tag, $fnref, $syntax ) = @_;
  1.2767 +    $functionTags{$tag} = \&$fnref;
  1.2768 +    if( $syntax && $syntax eq 'context-free' ) {
  1.2769 +        $contextFreeSyntax{$tag} = 1;
  1.2770 +    }
  1.2771 +}
  1.2772 +
  1.2773 +=pod=
  1.2774 +
  1.2775 +---++ StaticMethod registerRESTHandler( $subject, $verb, \&fn )
  1.2776 +
  1.2777 +Adds a function to the dispatch table of the REST interface 
  1.2778 +for a given subject. See TWikiScripts#rest for more info.
  1.2779 +
  1.2780 +   * =$subject= - The subject under which the function will be registered.
  1.2781 +   * =$verb= - The verb under which the function will be registered.
  1.2782 +   * =\&fn= - Reference to the function.
  1.2783 +
  1.2784 +The handler function must be of the form:
  1.2785 +<verbatim>
  1.2786 +sub handler(\%session,$subject,$verb) -> $text
  1.2787 +</verbatim>
  1.2788 +where:
  1.2789 +   * =\%session= - a reference to the TWiki session object (may be ignored)
  1.2790 +   * =$subject= - The invoked subject (may be ignored)
  1.2791 +   * =$verb= - The invoked verb (may be ignored)
  1.2792 +
  1.2793 +*Since:* TWiki::Plugins::VERSION 1.1
  1.2794 +
  1.2795 +=cut=
  1.2796 +
  1.2797 +sub registerRESTHandler {
  1.2798 +   my ( $subject, $verb, $fnref) = @_;
  1.2799 +   $restDispatch{$subject}{$verb} = \&$fnref;
  1.2800 +}
  1.2801 +
  1.2802 +=pod=
  1.2803 +
  1.2804 +---++ StaticMethod restDispatch( $subject, $verb) => \&fn
  1.2805 +
  1.2806 +Returns the handler  function associated to the given $subject and $werb,
  1.2807 +or undef if none is found.
  1.2808 +
  1.2809 +*Since:* TWiki::Plugins::VERSION 1.1
  1.2810 +
  1.2811 +=cut=
  1.2812 +
  1.2813 +sub restDispatch {
  1.2814 +   my ( $subject, $verb) = @_;
  1.2815 +   my $s=$restDispatch{$subject};
  1.2816 +   if (defined($s)) {
  1.2817 +       return $restDispatch{$subject}{$verb};
  1.2818 +   } else {
  1.2819 +       return undef;
  1.2820 +   }
  1.2821 +}
  1.2822 +
  1.2823 +=pod
  1.2824 +
  1.2825 +---++ ObjectMethod handleCommonTags( $text, $web, $topic, $meta ) -> $text
  1.2826 +
  1.2827 +Processes %<nop>VARIABLE%, and %<nop>TOC% syntax; also includes
  1.2828 +'commonTagsHandler' plugin hook.
  1.2829 +
  1.2830 +Returns the text of the topic, after file inclusion, variable substitution,
  1.2831 +table-of-contents generation, and any plugin changes from commonTagsHandler.
  1.2832 +
  1.2833 +$meta may be undef when, for example, expanding templates, or one-off strings
  1.2834 +at a time when meta isn't available.
  1.2835 +
  1.2836 +=cut
  1.2837 +
  1.2838 +sub handleCommonTags {
  1.2839 +    my( $this, $text, $theWeb, $theTopic, $meta ) = @_;
  1.2840 +
  1.2841 +    ASSERT($theWeb) if DEBUG;
  1.2842 +    ASSERT($theTopic) if DEBUG;
  1.2843 +
  1.2844 +    return $text unless $text;
  1.2845 +    my $verbatim={};
  1.2846 +    # Plugin Hook (for cache Plugins only)
  1.2847 +    $this->{plugins}->beforeCommonTagsHandler(
  1.2848 +        $text, $theTopic, $theWeb, $meta );
  1.2849 +
  1.2850 +    #use a "global var", so included topics can extract and putback 
  1.2851 +    #their verbatim blocks safetly.
  1.2852 +    $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
  1.2853 +                                              $verbatim);
  1.2854 +
  1.2855 +    my $memW = $this->{SESSION_TAGS}{INCLUDINGWEB};
  1.2856 +    my $memT = $this->{SESSION_TAGS}{INCLUDINGTOPIC};
  1.2857 +    $this->{SESSION_TAGS}{INCLUDINGWEB} = $theWeb;
  1.2858 +    $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $theTopic;
  1.2859 +
  1.2860 +    expandAllTags( $this, \$text, $theTopic, $theWeb, $meta );
  1.2861 +
  1.2862 +    $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
  1.2863 +                                              $verbatim);
  1.2864 +
  1.2865 +
  1.2866 +    # Plugin Hook
  1.2867 +    $this->{plugins}->commonTagsHandler( $text, $theTopic, $theWeb, 0, $meta );
  1.2868 +
  1.2869 +    # process tags again because plugin hook may have added more in
  1.2870 +    expandAllTags( $this, \$text, $theTopic, $theWeb, $meta );
  1.2871 +
  1.2872 +    $this->{SESSION_TAGS}{INCLUDINGWEB} = $memW;
  1.2873 +    $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $memT;
  1.2874 +
  1.2875 +    # 'Special plugin tag' TOC hack, must be done after all other expansions
  1.2876 +    # are complete, and has to reprocess the entire topic.
  1.2877 +    $text =~ s/%TOC(?:{(.*?)})?%/$this->_TOC($text, $theTopic, $theWeb, $1)/ge;
  1.2878 +
  1.2879 +    # Codev.FormattedSearchWithConditionalOutput: remove <nop> lines,
  1.2880 +    # possibly introduced by SEARCHes with conditional CALC. This needs
  1.2881 +    # to be done after CALC and before table rendering in order to join
  1.2882 +    # table rows properly
  1.2883 +    $text =~ s/^<nop>\r?\n//gm;
  1.2884 +
  1.2885 +    $this->renderer->putBackBlocks( \$text, $verbatim, 'verbatim' );
  1.2886 +
  1.2887 +    # TWiki Plugin Hook (for cache Plugins only)
  1.2888 +    $this->{plugins}->afterCommonTagsHandler(
  1.2889 +        $text, $theTopic, $theWeb, $meta );
  1.2890 +
  1.2891 +    return $text;
  1.2892 +}
  1.2893 +
  1.2894 +=pod
  1.2895 +
  1.2896 +---++ ObjectMethod addToHEAD( $id, $html )
  1.2897 +
  1.2898 +Add =$html= to the HEAD tag of the page currently being generated.
  1.2899 +
  1.2900 +Note that TWiki variables may be used in the HEAD. They will be expanded
  1.2901 +according to normal variable expansion rules.
  1.2902 +
  1.2903 +The 'id' is used to ensure that multiple adds of the same block of HTML don't
  1.2904 +result in it being added many times.
  1.2905 +
  1.2906 +=cut
  1.2907 +
  1.2908 +sub addToHEAD {
  1.2909 +	my ($this, $tag, $header) = @_;
  1.2910 +	
  1.2911 +	$header = $this->handleCommonTags( $header, $this->{webName},
  1.2912 +                                       $this->{topicName} );
  1.2913 +	
  1.2914 +	$this->{_HTMLHEADERS}{$tag} = $header;
  1.2915 +}
  1.2916 +
  1.2917 +=pod
  1.2918 +
  1.2919 +---++ StaticMethod initialize( $pathInfo, $remoteUser, $topic, $url, $query ) -> ($topicName, $webName, $scriptUrlPath, $userName, $dataDir)
  1.2920 +
  1.2921 +Return value: ( $topicName, $webName, $TWiki::cfg{ScriptUrlPath}, $userName, $TWiki::cfg{DataDir} )
  1.2922 +
  1.2923 +Static method to construct a new singleton session instance.
  1.2924 +It creates a new TWiki and sets the Plugins $SESSION variable to
  1.2925 +point to it, so that TWiki::Func methods will work.
  1.2926 +
  1.2927 +This method is *DEPRECATED* but is maintained for script compatibility.
  1.2928 +
  1.2929 +Note that $theUrl, if specified, must be identical to $query->url()
  1.2930 +
  1.2931 +=cut
  1.2932 +
  1.2933 +sub initialize {
  1.2934 +    my ( $pathInfo, $theRemoteUser, $topic, $theUrl, $query ) = @_;
  1.2935 +
  1.2936 +    if( !$query ) {
  1.2937 +        $query = new CGI( {} );
  1.2938 +    }
  1.2939 +    if( $query->path_info() ne $pathInfo ) {
  1.2940 +        $query->path_info( $pathInfo );
  1.2941 +    }
  1.2942 +    if( $topic ) {
  1.2943 +        $query->param( -name => 'topic', -value => '' );
  1.2944 +    }
  1.2945 +    # can't do much if $theUrl is specified and it is inconsistent with
  1.2946 +    # the query. We are trying to get to all parameters passed in the
  1.2947 +    # query.
  1.2948 +    if( $theUrl && $theUrl ne $query->url()) {
  1.2949 +        die 'Sorry, this version of TWiki does not support the url parameter to TWiki::initialize being different to the url in the query';
  1.2950 +    }
  1.2951 +    my $twiki = new TWiki( $theRemoteUser, $query );
  1.2952 +
  1.2953 +    # Force the new session into the plugins context.
  1.2954 +    $TWiki::Plugins::SESSION = $twiki;
  1.2955 +
  1.2956 +    return ( $twiki->{topicName}, $twiki->{webName}, $twiki->{scriptUrlPath},
  1.2957 +             $twiki->{userName}, $TWiki::cfg{DataDir} );
  1.2958 +}
  1.2959 +
  1.2960 +=pod
  1.2961 +
  1.2962 +---++ StaticMethod readFile( $filename ) -> $text
  1.2963 +
  1.2964 +Returns the entire contents of the given file, which can be specified in any
  1.2965 +format acceptable to the Perl open() function. Fast, but inherently unsafe.
  1.2966 +
  1.2967 +WARNING: Never, ever use this for accessing topics or attachments! Use the
  1.2968 +Store API for that. This is for global control files only, and should be
  1.2969 +used *only* if there is *absolutely no alternative*.
  1.2970 +
  1.2971 +=cut
  1.2972 +
  1.2973 +sub readFile {
  1.2974 +    my $name = shift;
  1.2975 +    open( IN_FILE, "<$name" ) || return '';
  1.2976 +    local $/ = undef;
  1.2977 +    my $data = <IN_FILE>;
  1.2978 +    close( IN_FILE );
  1.2979 +    $data = '' unless( defined( $data ));
  1.2980 +    return $data;
  1.2981 +}
  1.2982 +
  1.2983 +=pod
  1.2984 +
  1.2985 +---++ StaticMethod expandStandardEscapes($str) -> $unescapedStr
  1.2986 +
  1.2987 +Expands standard escapes used in parameter values to block evaluation. The following escapes
  1.2988 +are handled:
  1.2989 +
  1.2990 +| *Escape:* | *Expands To:* |
  1.2991 +| =$n= or =$n()= | New line. Use =$n()= if followed by alphanumeric character, e.g. write =Foo$n()Bar= instead of =Foo$nBar= |
  1.2992 +| =$nop= or =$nop()= | Is a "no operation". |
  1.2993 +| =$quot= | Double quote (="=) |
  1.2994 +| =$percnt= | Percent sign (=%=) |
  1.2995 +| =$dollar= | Dollar sign (=$=) |
  1.2996 +
  1.2997 +=cut
  1.2998 +
  1.2999 +sub expandStandardEscapes {
  1.3000 +    my $text = shift;
  1.3001 +    $text =~ s/\$n\(\)/\n/gos;         # expand '$n()' to new line
  1.3002 +    $text =~ s/\$n([^$regex{mixedAlpha}]|$)/\n$1/gos; # expand '$n' to new line
  1.3003 +    $text =~ s/\$nop(\(\))?//gos;      # remove filler, useful for nested search
  1.3004 +    $text =~ s/\$quot(\(\))?/\"/gos;   # expand double quote
  1.3005 +    $text =~ s/\$percnt(\(\))?/\%/gos; # expand percent
  1.3006 +    $text =~ s/\$dollar(\(\))?/\$/gos; # expand dollar
  1.3007 +    return $text;
  1.3008 +}
  1.3009 +
  1.3010 +# generate an include warning
  1.3011 +# SMELL: varying number of parameters idiotic to handle for customized $warn
  1.3012 +sub _includeWarning {
  1.3013 +    my $this = shift;
  1.3014 +    my $warn = shift;
  1.3015 +    my $message = shift;
  1.3016 +
  1.3017 +    if( $warn eq 'on' ) {
  1.3018 +        return $this->inlineAlert( 'alerts', $message, @_ );
  1.3019 +    } elsif( isTrue( $warn )) {
  1.3020 +        # different inlineAlerts need different argument counts
  1.3021 +        my $argument = '';
  1.3022 +        if ($message  eq  'topic_not_found') {
  1.3023 +            my ($web,$topic)  =  @_;
  1.3024 +            $argument = "$web.$topic";
  1.3025 +        }
  1.3026 +        else {
  1.3027 +            $argument = shift;
  1.3028 +        }
  1.3029 +        $warn =~ s/\$topic/$argument/go if $argument;
  1.3030 +        return $warn;
  1.3031 +    } # else fail silently
  1.3032 +    return '';
  1.3033 +}
  1.3034 +
  1.3035 +#-------------------------------------------------------------------
  1.3036 +# Tag Handlers
  1.3037 +#-------------------------------------------------------------------
  1.3038 +
  1.3039 +sub FORMFIELD {
  1.3040 +    my ( $this, $params, $topic, $web ) = @_;	
  1.3041 +    my $cgiQuery = $this->{cgiQuery};
  1.3042 +    my $cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
  1.3043 +    $params->{rev} = $cgiRev;
  1.3044 +    return $this->renderer->renderFORMFIELD( $params, $topic, $web );
  1.3045 +}
  1.3046 +
  1.3047 +sub TMPLP {
  1.3048 +    my( $this, $params ) = @_;
  1.3049 +    return $this->templates->tmplP( $params );
  1.3050 +}
  1.3051 +
  1.3052 +sub VAR {
  1.3053 +    my( $this, $params, $topic, $inweb ) = @_;
  1.3054 +    my $key = $params->{_DEFAULT};
  1.3055 +    return '' unless $key;
  1.3056 +    my $web = $params->{web} || $inweb;
  1.3057 +    # handle %USERSWEB%-type cases
  1.3058 +    ( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
  1.3059 +    # always return a value, even when the key isn't defined
  1.3060 +    return $this->{prefs}->getWebPreferencesValue( $key, $web ) || '';
  1.3061 +}
  1.3062 +
  1.3063 +sub PLUGINVERSION {
  1.3064 +    my( $this, $params ) = @_;
  1.3065 +    $this->{plugins}->getPluginVersion( $params->{_DEFAULT} );
  1.3066 +}
  1.3067 +
  1.3068 +sub IF {
  1.3069 +    my ( $this, $params, $topic, $web, $meta ) = @_;
  1.3070 +
  1.3071 +    unless( $ifParser ) {
  1.3072 +        require TWiki::If::Parser;
  1.3073 +        $ifParser = new TWiki::If::Parser();
  1.3074 +    }
  1.3075 +
  1.3076 +    my $expr;
  1.3077 +    my $result;
  1.3078 +    try {
  1.3079 +        $expr = $ifParser->parse( $params->{_DEFAULT} );
  1.3080 +        unless( $meta ) {
  1.3081 +            require TWiki::Meta;
  1.3082 +            $meta = new TWiki::Meta( $this, $web, $topic );
  1.3083 +        }
  1.3084 +        if( $expr->evaluate( tom=>$meta, data=>$meta )) {
  1.3085 +            $params->{then} = '' unless defined $params->{then};
  1.3086 +            $result = expandStandardEscapes( $params->{then} );
  1.3087 +        } else {
  1.3088 +            $params->{else} = '' unless defined $params->{else};
  1.3089 +            $result = expandStandardEscapes( $params->{else} );
  1.3090 +        }
  1.3091 +    } catch TWiki::Infix::Error with {
  1.3092 +        my $e = shift;
  1.3093 +        $result = $this->inlineAlert(
  1.3094 +            'alerts', 'generic', 'IF{', $params->stringify(), '}:',
  1.3095 +            $e->{-text} );
  1.3096 +    };
  1.3097 +    return $result;
  1.3098 +}
  1.3099 +
  1.3100 +# Processes a specific instance %<nop>INCLUDE{...}% syntax.
  1.3101 +# Returns the text to be inserted in place of the INCLUDE command.
  1.3102 +# $topic and $web should be for the immediate parent topic in the
  1.3103 +# include hierarchy. Works for both URLs and absolute server paths.
  1.3104 +sub INCLUDE {
  1.3105 +    my ( $this, $params, $includingTopic, $includingWeb ) = @_;
  1.3106 +
  1.3107 +    # remember args for the key before mangling the params
  1.3108 +    my $args = $params->stringify();
  1.3109 +
  1.3110 +    # Remove params, so they don't get expanded in the included page
  1.3111 +    my $path = $params->remove('_DEFAULT') || '';
  1.3112 +    my $pattern = $params->remove('pattern');
  1.3113 +    my $rev = $params->remove('rev');
  1.3114 +    my $section = $params->remove('section');
  1.3115 +    my $raw = $params->remove('raw') || '';
  1.3116 +    my $warn = $params->remove('warn')
  1.3117 +      || $this->{prefs}->getPreferencesValue( 'INCLUDEWARNING' );
  1.3118 +
  1.3119 +    if( $path =~ /^https?\:/ ) {
  1.3120 +        # include web page
  1.3121 +        return _includeUrl(
  1.3122 +            $this, $path, $pattern, $includingWeb, $includingTopic,
  1.3123 +            $raw, $params, $warn );
  1.3124 +    }
  1.3125 +
  1.3126 +    $path =~ s/$TWiki::cfg{NameFilter}//go;    # zap anything suspicious
  1.3127 +    if( $TWiki::cfg{DenyDotDotInclude} ) {
  1.3128 +        # Filter out '..' from filename, this is to
  1.3129 +        # prevent includes of '../../file'
  1.3130 +        $path =~ s/\.+/\./g;
  1.3131 +    } else {
  1.3132 +        # danger, could include .htpasswd with relative path
  1.3133 +        $path =~ s/passwd//gi;    # filter out passwd filename
  1.3134 +    }
  1.3135 +
  1.3136 +    # make sure we have something to include. If we don't do this, then
  1.3137 +    # normalizeWebTopicName will default to WebHome. Item2209.
  1.3138 +    unless( $path ) {
  1.3139 +        # SMELL: could do with a different message here, but don't want to
  1.3140 +        # add one right now because translators are already working
  1.3141 +        return _includeWarning( $this, $warn, 'topic_not_found', '""','""' );
  1.3142 +    }
  1.3143 +
  1.3144 +    my $text = '';
  1.3145 +    my $meta = '';
  1.3146 +    my $includedWeb;
  1.3147 +    my $includedTopic = $path;
  1.3148 +    $includedTopic =~ s/\.txt$//; # strip optional (undocumented) .txt
  1.3149 +
  1.3150 +    ($includedWeb, $includedTopic) =
  1.3151 +      $this->normalizeWebTopicName($includingWeb, $includedTopic);
  1.3152 +
  1.3153 +    # See Codev.FailedIncludeWarning for the history.
  1.3154 +    unless( $this->{store}->topicExists($includedWeb, $includedTopic)) {
  1.3155 +        return _includeWarning( $this, $warn, 'topic_not_found',
  1.3156 +                                       $includedWeb, $includedTopic );
  1.3157 +    }
  1.3158 +
  1.3159 +    # prevent recursive includes. Note that the inclusion of a topic into
  1.3160 +    # itself is not blocked; however subsequent attempts to include the
  1.3161 +    # topic will fail. There is a hard block of 99 on any recursive include.
  1.3162 +    my $key = $includingWeb.'.'.$includingTopic;
  1.3163 +    my $count = grep( $key, keys %{$this->{_INCLUDES}});
  1.3164 +    $key .= $args;
  1.3165 +    if( $this->{_INCLUDES}->{$key} || $count > 99) {
  1.3166 +        return _includeWarning( $this, $warn, 'already_included',
  1.3167 +                                       "$includedWeb.$includedTopic", '' );
  1.3168 +    }
  1.3169 +
  1.3170 +    my %saveTags = %{$this->{SESSION_TAGS}};
  1.3171 +    my $prefsMark = $this->{prefs}->mark();
  1.3172 +
  1.3173 +    $this->{_INCLUDES}->{$key} = 1;
  1.3174 +    $this->{SESSION_TAGS}{INCLUDINGWEB} = $includingWeb;
  1.3175 +    $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $includingTopic;
  1.3176 +
  1.3177 +    # copy params into session tags
  1.3178 +    foreach my $k ( keys %$params ) {
  1.3179 +        $this->{SESSION_TAGS}{$k} = $params->{$k};
  1.3180 +    }
  1.3181 +
  1.3182 +    ( $meta, $text ) =
  1.3183 +      $this->{store}->readTopic( undef, $includedWeb, $includedTopic, $rev );
  1.3184 +
  1.3185 +    # Simplify leading, and remove trailing, newlines. If we don't remove
  1.3186 +    # trailing, it becomes impossible to %INCLUDE a topic into a table.
  1.3187 +    $text =~ s/^[\r\n]+/\n/;
  1.3188 +    $text =~ s/[\r\n]+$//;
  1.3189 +
  1.3190 +    unless( $this->security->checkAccessPermission(
  1.3191 +        'VIEW', $this->{user}, $text, $meta, $includedTopic, $includedWeb )) {
  1.3192 +        if( isTrue( $warn )) {
  1.3193 +            return $this->inlineAlert( 'alerts', 'access_denied',
  1.3194 +                                       "[[$includedWeb.$includedTopic]]" );
  1.3195 +        } # else fail silently
  1.3196 +        return '';
  1.3197 +    }
  1.3198 +
  1.3199 +    # remove everything before and after the default include block unless
  1.3200 +    # a section is explicitly defined
  1.3201 +    if( !$section ) {
  1.3202 +       $text =~ s/.*?%STARTINCLUDE%//s;
  1.3203 +       $text =~ s/%STOPINCLUDE%.*//s;
  1.3204 +    }
  1.3205 +
  1.3206 +    # handle sections
  1.3207 +    my( $ntext, $sections ) = parseSections( $text );
  1.3208 +
  1.3209 +    my $interesting = ( defined $section );
  1.3210 +    if( $interesting || scalar( @$sections )) {
  1.3211 +        # Rebuild the text from the interesting sections
  1.3212 +        $text = '';
  1.3213 +        foreach my $s ( @$sections ) {
  1.3214 +            if( $section && $s->{type} eq 'section' &&
  1.3215 +                  $s->{name} eq $section) {
  1.3216 +                $text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} );
  1.3217 +                $interesting = 1;
  1.3218 +                last;
  1.3219 +            } elsif( $s->{type} eq 'include' && !$section ) {
  1.3220 +                $text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} );
  1.3221 +                $interesting = 1;
  1.3222 +            }
  1.3223 +        }
  1.3224 +    }
  1.3225 +    # If there were no interesting sections, restore the whole text
  1.3226 +    $text = $ntext unless $interesting;
  1.3227 +
  1.3228 +    $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
  1.3229 +
  1.3230 +    # Do not show TOC in included topic if TOC_HIDE_IF_INCLUDED
  1.3231 +    # preference has been set
  1.3232 +    if( isTrue( $this->{prefs}->getPreferencesValue( 'TOC_HIDE_IF_INCLUDED' ))) {
  1.3233 +        $text =~ s/%TOC(?:{(.*?)})?%//g;
  1.3234 +    }
  1.3235 +
  1.3236 +    expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
  1.3237 +
  1.3238 +    # 4th parameter tells plugin that its called for an included file
  1.3239 +    $this->{plugins}->commonTagsHandler( $text, $includedTopic,
  1.3240 +                                         $includedWeb, 1, $meta );
  1.3241 +
  1.3242 +    # We have to expand tags again, because a plugin may have inserted additional
  1.3243 +    # tags.
  1.3244 +    expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
  1.3245 +
  1.3246 +    # If needed, fix all 'TopicNames' to 'Web.TopicNames' to get the
  1.3247 +    # right context so that links continue to work properly
  1.3248 +    if( $includedWeb ne $includingWeb ) {
  1.3249 +	    my $removed = {};
  1.3250 +
  1.3251 +        $text = $this->renderer->forEachLine(
  1.3252 +            $text, \&_fixupIncludedTopic, { web => $includedWeb,
  1.3253 +                                            pre => 1,
  1.3254 +                                            noautolink => 1} );
  1.3255 +        # handle tags again because of plugin hook
  1.3256 +        expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
  1.3257 +    }
  1.3258 +
  1.3259 +    # restore the tags
  1.3260 +    delete $this->{_INCLUDES}->{$key};
  1.3261 +    %{$this->{SESSION_TAGS}} = %saveTags;
  1.3262 +
  1.3263 +    $this->{prefs}->restore( $prefsMark );
  1.3264 +
  1.3265 +    return $text;
  1.3266 +}
  1.3267 +
  1.3268 +sub HTTP {
  1.3269 +    my( $this, $params ) = @_;
  1.3270 +    my $res;
  1.3271 +    if( $params->{_DEFAULT} ) {
  1.3272 +        $res = $this->{cgiQuery}->http( $params->{_DEFAULT} );
  1.3273 +    }
  1.3274 +    $res = '' unless defined( $res );
  1.3275 +    return $res;
  1.3276 +}
  1.3277 +
  1.3278 +sub HTTPS {
  1.3279 +    my( $this, $params ) = @_;
  1.3280 +    my $res;
  1.3281 +    if( $params->{_DEFAULT} ) {
  1.3282 +        $res = $this->{cgiQuery}->https( $params->{_DEFAULT} );
  1.3283 +    }
  1.3284 +    $res = '' unless defined( $res );
  1.3285 +    return $res;
  1.3286 +}
  1.3287 +
  1.3288 +#deprecated functionality, now implemented using %ENV%
  1.3289 +#move to compatibility plugin in TWiki5
  1.3290 +sub HTTP_HOST_deprecated {
  1.3291 +    return $ENV{HTTP_HOST} || '';
  1.3292 +}
  1.3293 +
  1.3294 +#deprecated functionality, now implemented using %ENV%
  1.3295 +#move to compatibility plugin in TWiki5
  1.3296 +sub REMOTE_ADDR_deprecated {
  1.3297 +    return $ENV{REMOTE_ADDR} || '';
  1.3298 +}
  1.3299 +
  1.3300 +#deprecated functionality, now implemented using %ENV%
  1.3301 +#move to compatibility plugin in TWiki5
  1.3302 +sub REMOTE_PORT_deprecated {
  1.3303 +    return $ENV{REMOTE_PORT} || '';
  1.3304 +}
  1.3305 +
  1.3306 +#deprecated functionality, now implemented using %ENV%
  1.3307 +#move to compatibility plugin in TWiki5
  1.3308 +sub REMOTE_USER_deprecated {
  1.3309 +    return $ENV{REMOTE_USER} || '';
  1.3310 +}
  1.3311 +
  1.3312 +# Only does simple search for topicmoved at present, can be expanded when required
  1.3313 +# SMELL: this violates encapsulation of Store and Meta, by exporting
  1.3314 +# the assumption that meta-data is stored embedded inside topic
  1.3315 +# text.
  1.3316 +sub METASEARCH {
  1.3317 +    my( $this, $params ) = @_;
  1.3318 +
  1.3319 +    return $this->{store}->searchMetaData( $params );
  1.3320 +}
  1.3321 +
  1.3322 +sub DATE {
  1.3323 +    my $this = shift;
  1.3324 +    return TWiki::Time::formatTime(time(), $TWiki::cfg{DefaultDateFormat}, 'gmtime');
  1.3325 +}
  1.3326 +
  1.3327 +sub GMTIME {
  1.3328 +    my( $this, $params ) = @_;
  1.3329 +    return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'gmtime' );
  1.3330 +}
  1.3331 +
  1.3332 +sub SERVERTIME {
  1.3333 +    my( $this, $params ) = @_;
  1.3334 +    return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'servertime' );
  1.3335 +}
  1.3336 +
  1.3337 +sub DISPLAYTIME {
  1.3338 +    my( $this, $params ) = @_;
  1.3339 +    return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', $TWiki::cfg{DisplayTimeValues} );
  1.3340 +}
  1.3341 +
  1.3342 +#| $web | web and  |
  1.3343 +#| $topic | topic to display the name for |
  1.3344 +#| $formatString | twiki format string (like in search) |
  1.3345 +sub REVINFO {
  1.3346 +    my ( $this, $params, $theTopic, $theWeb ) = @_;
  1.3347 +    my $format = $params->{_DEFAULT} || $params->{format};
  1.3348 +    my $web    = $params->{web} || $theWeb;
  1.3349 +    my $topic  = $params->{topic} || $theTopic;
  1.3350 +    my $cgiQuery = $this->{cgiQuery};
  1.3351 +    my $cgiRev = '';
  1.3352 +    $cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
  1.3353 +    my $rev = $params->{rev} || $cgiRev || '';
  1.3354 +
  1.3355 +    return $this->renderer->renderRevisionInfo( $web, $topic, undef,
  1.3356 +                                                  $rev, $format );
  1.3357 +}
  1.3358 +
  1.3359 +sub ENCODE {
  1.3360 +    my( $this, $params ) = @_;
  1.3361 +    my $type = $params->{type} || 'url';
  1.3362 +    my $text = $params->{_DEFAULT} || '';
  1.3363 +    return _encode($type, $text);
  1.3364 +}
  1.3365 +
  1.3366 +sub _encode {
  1.3367 +    my ($type, $text) = @_;
  1.3368 +
  1.3369 +    if ( $type =~ /^entit(y|ies)$/i ) {
  1.3370 +        return entityEncode( $text );
  1.3371 +    } elsif ( $type =~ /^html$/i ) {
  1.3372 +        return entityEncode( $text, "\n\r" );
  1.3373 +    } elsif ( $type =~ /^quotes?$/i ) {
  1.3374 +        # escape quotes with backslash (Bugs:Item3383 fix)
  1.3375 +        $text =~ s/\"/\\"/go;
  1.3376 +        return $text;
  1.3377 +    } elsif ($type =~ /^url$/i) {
  1.3378 +        $text =~ s/\r*\n\r*/<br \/>/; # Legacy.
  1.3379 +        return urlEncode( $text );
  1.3380 +    }
  1.3381 +}
  1.3382 +
  1.3383 +sub ENV {
  1.3384 +    my ($this, $params) = @_;
  1.3385 +
  1.3386 +    return '' unless $params->{_DEFAULT} &&
  1.3387 +      defined $TWiki::cfg{AccessibleENV} &&
  1.3388 +        $params->{_DEFAULT} =~ /$TWiki::cfg{AccessibleENV}/o;
  1.3389 +    my $val = $ENV{$params->{_DEFAULT}};
  1.3390 +    return 'not set' unless defined $val;
  1.3391 +    return $val;
  1.3392 +}
  1.3393 +
  1.3394 +sub SEARCH {
  1.3395 +    my ( $this, $params, $topic, $web ) = @_;
  1.3396 +    # pass on all attrs, and add some more
  1.3397 +    #$params->{_callback} = undef;
  1.3398 +    $params->{inline} = 1;
  1.3399 +    $params->{baseweb} = $web;
  1.3400 +    $params->{basetopic} = $topic;
  1.3401 +    $params->{search} = $params->{_DEFAULT} if( $params->{_DEFAULT} );
  1.3402 +    $params->{type} = $this->{prefs}->getPreferencesValue( 'SEARCHVARDEFAULTTYPE' ) unless( $params->{type} );
  1.3403 +    my $s;
  1.3404 +    try {
  1.3405 +        $s = $this->search->searchWeb( %$params );
  1.3406 +    } catch Error::Simple with {
  1.3407 +        my $message = (DEBUG) ? shift->stringify() : shift->{-text};
  1.3408 +        # Block recursions kicked off by the text being repeated in the
  1.3409 +        # error message
  1.3410 +        $message =~ s/%([A-Z]*[{%])/%<nop>$1/g;
  1.3411 +        $s = $this->inlineAlert( 'alerts', 'bad_search', $message );
  1.3412 +    };
  1.3413 +    return $s;
  1.3414 +}
  1.3415 +
  1.3416 +sub WEBLIST {
  1.3417 +    my( $this, $params ) = @_;
  1.3418 +    my $format = $params->{_DEFAULT} || $params->{'format'} || '$name';
  1.3419 +    $format ||= '$name';
  1.3420 +    my $separator = $params->{separator} || "\n";
  1.3421 +    $separator =~ s/\$n/\n/;
  1.3422 +    my $web = $params->{web} || '';
  1.3423 +    my $webs = $params->{webs} || 'public';
  1.3424 +    my $selection = $params->{selection} || '';
  1.3425 +    my $showWeb = $params->{subwebs} || '';
  1.3426 +    $selection =~ s/\,/ /g;
  1.3427 +    $selection = " $selection ";
  1.3428 +    my $marker = $params->{marker} || 'selected="selected"';
  1.3429 +    $web =~ s#\.#/#go;
  1.3430 +
  1.3431 +    my @list = ();
  1.3432 +    my @webslist = split( /,\s*/, $webs );
  1.3433 +    foreach my $aweb ( @webslist ) {
  1.3434 +        if( $aweb eq 'public' ) {
  1.3435 +            push( @list, $this->{store}->getListOfWebs( 'user,public,allowed', $showWeb ) );
  1.3436 +        } elsif( $aweb eq 'webtemplate' ) {
  1.3437 +            push( @list, $this->{store}->getListOfWebs( 'template,allowed', $showWeb ));
  1.3438 +        } else{
  1.3439 +            push( @list, $aweb ) if( $this->{store}->webExists( $aweb ) );
  1.3440 +        }
  1.3441 +    }
  1.3442 +
  1.3443 +    my @items;
  1.3444 +    my $indent = CGI::span({class=>'twikiWebIndent'},'');
  1.3445 +    foreach my $item ( @list ) {
  1.3446 +        my $line = $format;
  1.3447 +        $line =~ s/\$web\b/$web/g;
  1.3448 +        $line =~ s/\$name\b/$item/g;
  1.3449 +        $line =~ s/\$qname/"$item"/g;
  1.3450 +        my $indenteditem = $item;
  1.3451 +        $indenteditem =~ s#/$##g;
  1.3452 +        $indenteditem =~ s#\w+/#$indent#g;
  1.3453 +        $line =~ s/\$indentedname/$indenteditem/g;
  1.3454 +        my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
  1.3455 +        $line =~ s/\$marker/$mark/g;
  1.3456 +        push(@items, $line);
  1.3457 +    }
  1.3458 +    return join( $separator, @items);
  1.3459 +}
  1.3460 +
  1.3461 +sub TOPICLIST {
  1.3462 +    my( $this, $params ) = @_;
  1.3463 +    my $format = $params->{_DEFAULT} || $params->{'format'} || '$topic';
  1.3464 +    my $separator = $params->{separator} || "\n";
  1.3465 +    $separator =~ s/\$n/\n/;
  1.3466 +    my $web = $params->{web} || $this->{webName};
  1.3467 +    my $selection = $params->{selection} || '';
  1.3468 +    $selection =~ s/\,/ /g;
  1.3469 +    $selection = " $selection ";
  1.3470 +    my $marker = $params->{marker} || 'selected="selected"';
  1.3471 +    $web =~ s#\.#/#go;
  1.3472 +
  1.3473 +    return '' if
  1.3474 +      $web ne $this->{webName} &&
  1.3475 +      $this->{prefs}->getWebPreferencesValue( 'NOSEARCHALL', $web );
  1.3476 +
  1.3477 +    my @items;
  1.3478 +    foreach my $item ( $this->{store}->getTopicNames( $web ) ) {
  1.3479 +        my $line = $format;
  1.3480 +        $line =~ s/\$web\b/$web/g;
  1.3481 +        $line =~ s/\$topic\b/$item/g;
  1.3482 +        $line =~ s/\$name\b/$item/g; # Undocumented, DO NOT REMOVE
  1.3483 +        $line =~ s/\$qname/"$item"/g; # Undocumented, DO NOT REMOVE
  1.3484 +        my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
  1.3485 +        $line =~ s/\$marker/$mark/g;
  1.3486 +        $line = expandStandardEscapes( $line );
  1.3487 +        push( @items, $line );
  1.3488 +    }
  1.3489 +    return join( $separator, @items);
  1.3490 +}
  1.3491 +
  1.3492 +sub QUERYSTRING {
  1.3493 +    my $this = shift;
  1.3494 +    return $this->{cgiQuery}->query_string();
  1.3495 +}
  1.3496 +
  1.3497 +sub QUERYPARAMS {
  1.3498 +    my ( $this, $params ) = @_;
  1.3499 +    return '' unless $this->{cgiQuery};
  1.3500 +    my $format = defined $params->{format} ? $params->{format} :
  1.3501 +      '$name=$value';
  1.3502 +    my $separator = defined $params->{separator} ? $params->{separator} : "\n";
  1.3503 +    my $encoding = $params->{encoding} || '';
  1.3504 +
  1.3505 +    my @list;
  1.3506 +    foreach my $name ( $this->{cgiQuery}->param() ) {
  1.3507 +        # Issues multi-valued parameters as separate hiddens
  1.3508 +        my $value = $this->{cgiQuery}->param( $name );
  1.3509 +        if ($encoding) {
  1.3510 +            $value = _encode($encoding, $value);
  1.3511 +        }
  1.3512 +        my $entry = $format;
  1.3513 +        $entry =~ s/\$name/$name/g;
  1.3514 +        $entry =~ s/\$value/$value/;
  1.3515 +        push(@list, $entry);
  1.3516 +    }
  1.3517 +    return expandStandardEscapes(join($separator, @list));
  1.3518 +}
  1.3519 +
  1.3520 +sub URLPARAM {
  1.3521 +    my( $this, $params ) = @_;
  1.3522 +    my $param     = $params->{_DEFAULT} || '';
  1.3523 +    my $newLine   = $params->{newline};
  1.3524 +    my $encode    = $params->{encode};
  1.3525 +    my $multiple  = $params->{multiple};
  1.3526 +    my $separator = $params->{separator};
  1.3527 +    $separator="\n" unless (defined $separator);
  1.3528 +
  1.3529 +    my $value;
  1.3530 +    if( $this->{cgiQuery} ) {
  1.3531 +        if( TWiki::isTrue( $multiple )) {
  1.3532 +            my @valueArray = $this->{cgiQuery}->param( $param );
  1.3533 +            if( @valueArray ) {
  1.3534 +                # join multiple values properly
  1.3535 +                unless( $multiple =~ m/^on$/i ) {
  1.3536 +                    my $item = '';
  1.3537 +                    @valueArray = map {
  1.3538 +                        $item = $_;
  1.3539 +                        $_ = $multiple;
  1.3540 +                        $_ .= $item unless( s/\$item/$item/go );
  1.3541 +                        $_
  1.3542 +                    } @valueArray;
  1.3543 +                }
  1.3544 +                $value = join ( $separator, @valueArray );
  1.3545 +            }
  1.3546 +        } else {
  1.3547 +            $value = $this->{cgiQuery}->param( $param );
  1.3548 +        }
  1.3549 +    }
  1.3550 +    if( defined $value ) {
  1.3551 +        $value =~ s/\r?\n/$newLine/go if( defined $newLine );
  1.3552 +        if ( $encode ) {
  1.3553 +            if ( $encode =~ /^entit(y|ies)$/i ) {
  1.3554 +                $value = entityEncode( $value );
  1.3555 +            } elsif ( $encode =~ /^quotes?$/i ) {
  1.3556 +                $value =~ s/\"/\\"/go;    # escape quotes with backslash (Bugs:Item3383 fix)
  1.3557 +            } else {
  1.3558 +                $value =~ s/\r*\n\r*/<br \/>/; # Legacy
  1.3559 +                $value = urlEncode( $value );
  1.3560 +            }
  1.3561 +        }
  1.3562 +    }
  1.3563 +    unless( defined $value ) {
  1.3564 +        $value = $params->{default};
  1.3565 +        $value = '' unless defined $value;
  1.3566 +    }
  1.3567 +    # Block expansion of %URLPARAM in the value to prevent recursion
  1.3568 +    $value =~ s/%URLPARAM{/%<nop>URLPARAM{/g;
  1.3569 +    return $value;
  1.3570 +}
  1.3571 +
  1.3572 +# This routine was introduced to URL encode Mozilla UTF-8 POST URLs in the
  1.3573 +# TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now
  1.3574 +# directly supported, but it is provided for backward compatibility with
  1.3575 +# skins that may still be using the deprecated %INTURLENCODE%.
  1.3576 +sub INTURLENCODE_deprecated {
  1.3577 +    my( $this, $params ) = @_;
  1.3578 +    # Just strip double quotes, no URL encoding - Mozilla UTF-8 URLs
  1.3579 +    # directly supported now
  1.3580 +    return $params->{_DEFAULT} || '';
  1.3581 +}
  1.3582 +
  1.3583 +# This routine is deprecated as of DakarRelease,
  1.3584 +# and is maintained only for backward compatibility.
  1.3585 +# Spacing of WikiWords is now done with %SPACEOUT%
  1.3586 +# (and the private routine _SPACEOUT).
  1.3587 +# Move to compatibility module in TWiki5
  1.3588 +sub SPACEDTOPIC_deprecated {
  1.3589 +    my ( $this, $params, $theTopic ) = @_;
  1.3590 +    my $topic = spaceOutWikiWord( $theTopic );
  1.3591 +    $topic =~ s/ / */g;
  1.3592 +    return urlEncode( $topic );
  1.3593 +}
  1.3594 +
  1.3595 +sub SPACEOUT {
  1.3596 +    my ( $this, $params ) = @_;
  1.3597 +    my $spaceOutTopic = $params->{_DEFAULT};
  1.3598 +    my $sep = $params->{'separator'};
  1.3599 +    $spaceOutTopic = spaceOutWikiWord( $spaceOutTopic, $sep );
  1.3600 +    return $spaceOutTopic;
  1.3601 +}
  1.3602 +
  1.3603 +sub ICON {
  1.3604 +    my( $this, $params ) = @_;
  1.3605 +    my $file = $params->{_DEFAULT} || '';
  1.3606 +    # Try to map the file name to see if there is a matching filetype image
  1.3607 +    # If no mapping could be found, use the file name that was passed
  1.3608 +    my $iconFileName = $this->mapToIconFileName( $file, $file );
  1.3609 +    return CGI::img( { src => $this->getIconUrl( 0, $iconFileName ),
  1.3610 +                       width => 16, height=>16,
  1.3611 +                       align => 'top', alt => $iconFileName, border => 0 });
  1.3612 +}
  1.3613 +
  1.3614 +sub ICONURL {
  1.3615 +    my( $this, $params ) = @_;
  1.3616 +    my $file = ( $params->{_DEFAULT} || '' );
  1.3617 +
  1.3618 +    return $this->getIconUrl( 1, $file );
  1.3619 +}
  1.3620 +
  1.3621 +sub ICONURLPATH {
  1.3622 +    my( $this, $params ) = @_;
  1.3623 +    my $file = ( $params->{_DEFAULT} || '' );
  1.3624 +
  1.3625 +    return $this->getIconUrl( 0, $file );
  1.3626 +}
  1.3627 +
  1.3628 +sub RELATIVETOPICPATH {
  1.3629 +    my ( $this, $params, $theTopic, $web ) = @_;
  1.3630 +    my $topic = $params->{_DEFAULT};
  1.3631 +
  1.3632 +    return '' unless $topic;
  1.3633 +
  1.3634 +    my $theRelativePath;
  1.3635 +    # if there is no dot in $topic, no web has been specified
  1.3636 +    if ( index( $topic, '.' ) == -1 ) {
  1.3637 +        # add local web
  1.3638 +        $theRelativePath = $web . '/' . $topic;
  1.3639 +    } else {
  1.3640 +        $theRelativePath = $topic; #including dot
  1.3641 +    }
  1.3642 +    # replace dot by slash is not necessary; TWiki.MyTopic is a valid url
  1.3643 +    # add ../ if not already present to make a relative file reference
  1.3644 +    if ( $theRelativePath !~ m!^../! ) {
  1.3645 +        $theRelativePath = "../$theRelativePath";
  1.3646 +    }
  1.3647 +    return $theRelativePath;
  1.3648 +}
  1.3649 +
  1.3650 +sub ATTACHURLPATH {
  1.3651 +    my ( $this, $params, $topic, $web ) = @_;
  1.3652 +    return $this->getPubUrl(0, $web, $topic);
  1.3653 +}
  1.3654 +
  1.3655 +sub ATTACHURL {
  1.3656 +    my ( $this, $params, $topic, $web ) = @_;
  1.3657 +    return $this->getPubUrl(1, $web, $topic);
  1.3658 +}
  1.3659 +
  1.3660 +sub LANGUAGE {
  1.3661 +    my $this = shift;
  1.3662 +    return $this->i18n->language();
  1.3663 +}
  1.3664 +
  1.3665 +sub LANGUAGES {
  1.3666 +    my ( $this , $params ) = @_;
  1.3667 +    my $format = $params->{format} || "   * \$langname";
  1.3668 +    my $separator = $params->{separator} || "\n";
  1.3669 +    $separator =~ s/\\n/\n/g;
  1.3670 +    my $selection = $params->{selection} || '';
  1.3671 +    $selection =~ s/\,/ /g;
  1.3672 +    $selection = " $selection ";
  1.3673 +    my $marker = $params->{marker} || 'selected="selected"';
  1.3674 +
  1.3675 +    # $languages is a hash reference:
  1.3676 +    my $languages = $this->i18n->enabled_languages();
  1.3677 +
  1.3678 +    my @tags = sort(keys(%{$languages}));
  1.3679 +
  1.3680 +    my $result = '';
  1.3681 +    my $i = 0; 
  1.3682 +    foreach my $lang (@tags) {
  1.3683 +         my $item = $format;
  1.3684 +         my $name = ${$languages}{$lang};
  1.3685 +         $item =~ s/\$langname/$name/g;
  1.3686 +         $item =~ s/\$langtag/$lang/g;
  1.3687 +         my $mark = ( $selection =~ / \Q$lang\E / ) ? $marker : '';
  1.3688 +         $item =~ s/\$marker/$mark/g;
  1.3689 +         $result .= $separator if $i;
  1.3690 +         $result .= $item;
  1.3691 +         $i++;
  1.3692 +    }
  1.3693 +
  1.3694 +    return $result;
  1.3695 +}
  1.3696 +
  1.3697 +sub MAKETEXT {
  1.3698 +    my( $this, $params ) = @_;
  1.3699 +
  1.3700 +    my $str = $params->{_DEFAULT} || $params->{string} || "";
  1.3701 +    return "" unless $str;
  1.3702 +
  1.3703 +    # escape everything:
  1.3704 +    $str =~ s/\[/~[/g;
  1.3705 +    $str =~ s/\]/~]/g;
  1.3706 +
  1.3707 +    # restore already escaped stuff:
  1.3708 +    $str =~ s/~~\[/~[/g;
  1.3709 +    $str =~ s/~~\]/~]/g;
  1.3710 +
  1.3711 +    # unescape parameters and calculate highest parameter number:
  1.3712 +    my $max = 0;
  1.3713 +    $str =~ s/~\[(\_(\d+))~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
  1.3714 +    $str =~ s/~\[(\*,\_(\d+),[^,]+(,([^,]+))?)~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
  1.3715 +
  1.3716 +    # get the args to be interpolated.
  1.3717 +    my $argsStr = $params->{args} || "";
  1.3718 +
  1.3719 +    my @args = split (/\s*,\s*/, $argsStr) ;
  1.3720 +    # fill omitted args with zeros
  1.3721 +    while ((scalar @args) < $max) {
  1.3722 +        push(@args, 0);
  1.3723 +    }
  1.3724 +
  1.3725 +    # do the magic:
  1.3726 +    my $result = $this->i18n->maketext($str, @args);
  1.3727 +
  1.3728 +    # replace accesskeys:
  1.3729 +    $result =~ s#(^|[^&])&([a-zA-Z])#$1<span class='twikiAccessKey'>$2</span>#g;
  1.3730 +
  1.3731 +    # replace escaped amperstands:
  1.3732 +    $result =~ s/&&/\&/g;
  1.3733 +
  1.3734 +    return $result;
  1.3735 +}
  1.3736 +
  1.3737 +sub SCRIPTNAME {
  1.3738 +    #my ( $this, $params, $theTopic, $theWeb ) = @_;
  1.3739 +    # try SCRIPT_FILENAME
  1.3740 +    my $value = $ENV{SCRIPT_FILENAME};
  1.3741 +    if( $value ) {
  1.3742 +        $value =~ s!.*/([^/]+)$!$1!o;
  1.3743 +        return $value;
  1.3744 +    }
  1.3745 +    # try SCRIPT_URL (won't work with url rewriting)
  1.3746 +    $value = $ENV{SCRIPT_URL};
  1.3747 +    if( $value ) {
  1.3748 +        # e.g. '/cgi-bin/view.cgi/TWiki/WebHome'
  1.3749 +        # cut URL path to get 'view.cgi/TWiki/WebHome'
  1.3750 +        $value =~ s|^$TWiki::cfg{ScriptUrlPath}/?||o;
  1.3751 +        # cut extended path to get 'view.cgi'
  1.3752 +        $value =~ s|/.*$||;
  1.3753 +        return $value;
  1.3754 +    }
  1.3755 +    # no joy
  1.3756 +    return '';
  1.3757 +}
  1.3758 +
  1.3759 +sub SCRIPTURL {
  1.3760 +    my ( $this, $params, $topic, $web ) = @_;
  1.3761 +    my $script = $params->{_DEFAULT} || '';
  1.3762 +
  1.3763 +    return $this->getScriptUrl( 1, $script );
  1.3764 +}
  1.3765 +
  1.3766 +sub SCRIPTURLPATH {
  1.3767 +    my ( $this, $params, $topic, $web ) = @_;
  1.3768 +    my $script = $params->{_DEFAULT} || '';
  1.3769 +
  1.3770 +    return $this->getScriptUrl( 0, $script );
  1.3771 +}
  1.3772 +
  1.3773 +sub PUBURL {
  1.3774 +    my $this = shift;
  1.3775 +    return $this->getPubUrl(1);
  1.3776 +}
  1.3777 +
  1.3778 +sub PUBURLPATH {
  1.3779 +    my $this = shift;
  1.3780 +    return $this->getPubUrl(0);
  1.3781 +}
  1.3782 +
  1.3783 +sub ALLVARIABLES {
  1.3784 +    return shift->{prefs}->stringify();
  1.3785 +}
  1.3786 +
  1.3787 +sub META {
  1.3788 +    my ( $this, $params, $topic, $web ) = @_;
  1.3789 +
  1.3790 +    my $meta  = $this->inContext( 'can_render_meta' );
  1.3791 +
  1.3792 +    return '' unless $meta;
  1.3793 +
  1.3794 +    my $option = $params->{_DEFAULT} || '';
  1.3795 +
  1.3796 +    if( $option eq 'form' ) {
  1.3797 +        # META:FORM and META:FIELD
  1.3798 +        return $meta->renderFormForDisplay( $this->templates );
  1.3799 +    } elsif ( $option eq 'formfield' ) {
  1.3800 +        # a formfield from within topic text
  1.3801 +        return $meta->renderFormFieldForDisplay( $params );
  1.3802 +    } elsif( $option eq 'attachments' ) {
  1.3803 +        # renders attachment tables
  1.3804 +        return $this->attach->renderMetaData( $web, $topic, $meta, $params );
  1.3805 +    } elsif( $option eq 'moved' ) {
  1.3806 +        return $this->renderer->renderMoved( $web, $topic, $meta, $params );
  1.3807 +    } elsif( $option eq 'parent' ) {
  1.3808 +        return $this->renderer->renderParent( $web, $topic, $meta, $params );
  1.3809 +    }
  1.3810 +
  1.3811 +    return '';
  1.3812 +}
  1.3813 +
  1.3814 +# Remove NOP tag in template topics but show content. Used in template
  1.3815 +# _topics_ (not templates, per se, but topics used as templates for new
  1.3816 +# topics)
  1.3817 +sub NOP {
  1.3818 +    my ( $this, $params, $topic, $web ) = @_;
  1.3819 +
  1.3820 +    return '<nop>' unless $params->{_RAW};
  1.3821 +
  1.3822 +    return $params->{_RAW};
  1.3823 +}
  1.3824 +
  1.3825 +# Shortcut to %TMPL:P{"sep"}%
  1.3826 +sub SEP {
  1.3827 +    my $this = shift;
  1.3828 +    return $this->templates->expandTemplate('sep');
  1.3829 +}
  1.3830 +
  1.3831 +#deprecated functionality, now implemented using %USERINFO%
  1.3832 +#move to compatibility plugin in TWiki5
  1.3833 +sub WIKINAME_deprecated {
  1.3834 +    my ( $this, $params ) = @_;
  1.3835 +
  1.3836 +    $params->{format} = $this->{prefs}->getPreferencesValue( 'WIKINAME' ) ||
  1.3837 +      '$wikiname';
  1.3838 +
  1.3839 +    return $this->USERINFO($params);
  1.3840 +}
  1.3841 +
  1.3842 +#deprecated functionality, now implemented using %USERINFO%
  1.3843 +#move to compatibility plugin in TWiki5
  1.3844 +sub USERNAME_deprecated {
  1.3845 +    my ( $this, $params ) = @_;
  1.3846 +
  1.3847 +    $params->{format} = $this->{prefs}->getPreferencesValue( 'USERNAME' ) ||
  1.3848 +      '$username';
  1.3849 +
  1.3850 +    return $this->USERINFO($params);
  1.3851 +}
  1.3852 +
  1.3853 +#deprecated functionality, now implemented using %USERINFO%
  1.3854 +#move to compatibility plugin in TWiki5
  1.3855 +sub WIKIUSERNAME_deprecated {
  1.3856 +    my ( $this, $params ) = @_;
  1.3857 +
  1.3858 +    $params->{format} =
  1.3859 +      $this->{prefs}->getPreferencesValue( 'WIKIUSERNAME' ) ||
  1.3860 +        '$wikiusername';
  1.3861 +
  1.3862 +    return $this->USERINFO($params);
  1.3863 +}
  1.3864 +
  1.3865 +sub USERINFO {
  1.3866 +    my ( $this, $params ) = @_;
  1.3867 +    my $format = $params->{format} || '$username, $wikiusername, $emails';
  1.3868 +
  1.3869 +    my $user = $this->{user};
  1.3870 +
  1.3871 +    if( $params->{_DEFAULT} ) {
  1.3872 +        $user = $params->{_DEFAULT};
  1.3873 +        return '' if !$user;
  1.3874 +        # map wikiname to a login name
  1.3875 +        $user =~ s/^.*\.//; # kill web
  1.3876 +        my $users = $this->{users}->findUserByWikiName($user);
  1.3877 +        return '' unless $users && scalar(@$users);
  1.3878 +        $user = $users->[0];
  1.3879 +        return '' if( $TWiki::cfg{AntiSpam}{HideUserDetails} &&
  1.3880 +                        !$this->{users}->isAdmin( $this->{user} ) &&
  1.3881 +                          $user ne $this->{user} );
  1.3882 +    }
  1.3883 +
  1.3884 +    return '' unless $user;
  1.3885 +
  1.3886 +    my $info = $format;
  1.3887 +
  1.3888 +    if ($info =~ /\$username/) {
  1.3889 +        my $username = $this->{users}->getLoginName($user);
  1.3890 +        $info =~ s/\$username/$username/g;
  1.3891 +    }
  1.3892 +    if ($info =~ /\$wikiname/) {
  1.3893 +        my $wikiname = $this->{users}->getWikiName( $user );
  1.3894 +        $info =~ s/\$wikiname/$wikiname/g;
  1.3895 +    }
  1.3896 +    if ($info =~ /\$wikiusername/) {
  1.3897 +        my $wikiusername = $this->{users}->webDotWikiName($user);
  1.3898 +        $info =~ s/\$wikiusername/$wikiusername/g;
  1.3899 +    }
  1.3900 +    if ($info =~ /\$emails/) {
  1.3901 +        my $emails = join(', ', $this->{users}->getEmails($user));
  1.3902 +        $info =~ s/\$emails/$emails/g;
  1.3903 +    }
  1.3904 +    if ($info =~ /\$groups/) {
  1.3905 +        my @groupNames;
  1.3906 +        my $it = $this->{users}->eachMembership( $user );
  1.3907 +        while( $it->hasNext()) {
  1.3908 +            my $group = $it->next();
  1.3909 +            push( @groupNames, $group);
  1.3910 +        }
  1.3911 +        my $groups = join(', ', @groupNames);
  1.3912 +        $info =~ s/\$groups/$groups/g;
  1.3913 +    }
  1.3914 +    if ($info =~ /\$cUID/) {
  1.3915 +        my $cUID = $user;
  1.3916 +        $info =~ s/\$cUID/$cUID/g;
  1.3917 +    }
  1.3918 +    if ($info =~ /\$admin/) {
  1.3919 +        my $admin = $this->{users}->isAdmin($user) ? 'true' : 'false';
  1.3920 +        $info =~ s/\$admin/$admin/g;
  1.3921 +    }
  1.3922 +
  1.3923 +    return $info;
  1.3924 +}
  1.3925 +
  1.3926 +sub GROUPS {
  1.3927 +    my ( $this, $params ) = @_;
  1.3928 +
  1.3929 +    my $groups = $this->{users}->eachGroup();
  1.3930 +    my @table;
  1.3931 +    while( $groups->hasNext() ) {
  1.3932 +        my $group = $groups->next();
  1.3933 +        # Nop it to prevent wikiname expansion unless the topic exists.
  1.3934 +		my $groupLink = "<nop>$group";
  1.3935 +		$groupLink = '[['.$TWiki::cfg{UsersWebName}.".$group][$group]]" if ($this->{store}->topicExists($TWiki::cfg{UsersWebName}, $group));
  1.3936 +        my $descr = "| $groupLink |";
  1.3937 +        my $it = $this->{users}->eachGroupMember( $group );
  1.3938 +        my $limit_output = 32;
  1.3939 +        while( $it->hasNext() ) {
  1.3940 +            my $user = $it->next();
  1.3941 +            $descr .= ' [['.$this->{users}->webDotWikiName($user).']['.
  1.3942 +              $this->{users}->getWikiName( $user ).']]';
  1.3943 +           if ($limit_output == 0) {
  1.3944 +               $descr .= '<div>%MAKETEXT{"user list truncated"}%</div>';
  1.3945 +               last;
  1.3946 +           }
  1.3947 +           $limit_output--;
  1.3948 +        }
  1.3949 +        push( @table, "$descr |");
  1.3950 +    }
  1.3951 +
  1.3952 +    return '| *Group* | *Members* |'."\n".join("\n", sort @table);
  1.3953 +}
  1.3954 +
  1.3955 +1;
  1.3956 +__DATA__
  1.3957 +# TWiki Enterprise Collaboration Platform, http://TWiki.org/
  1.3958 +#
  1.3959 +# Copyright (C) 1999-2007 Peter Thoeny, peter@thoeny.org
  1.3960 +# and TWiki Contributors. All Rights Reserved. TWiki Contributors
  1.3961 +# are listed in the AUTHORS file in the root of this distribution.
  1.3962 +# NOTE: Please extend that file, not this notice.
  1.3963 +#
  1.3964 +# Additional copyrights apply to some or all of the code in this
  1.3965 +# file as follows:
  1.3966 +#
  1.3967 +# Based on parts of Ward Cunninghams original Wiki and JosWiki.
  1.3968 +# Copyright (C) 1998 Markus Peter - SPiN GmbH (warpi@spin.de)
  1.3969 +# Some changes by Dave Harris (drh@bhresearch.co.uk) incorporated
  1.3970 +#
  1.3971 +# This program is free software; you can redistribute it and/or
  1.3972 +# modify it under the terms of the GNU General Public License
  1.3973 +# as published by the Free Software Foundation; either version 2
  1.3974 +# of the License, or (at your option) any later version. For
  1.3975 +# more details read LICENSE in the root of this distribution.
  1.3976 +#
  1.3977 +# This program is distributed in the hope that it will be useful,
  1.3978 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
  1.3979 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  1.3980 +#
  1.3981 +# As per the GPL, removal of this notice is prohibited.