lib/TWiki.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
permissions -rw-r--r--
RELEASE 4.2.0 freetown
     1 # See bottom of file for license and copyright information
     2 package TWiki;
     3 
     4 =pod
     5 
     6 ---+ package TWiki
     7 
     8 TWiki operates by creating a singleton object (known as the Session
     9 object) that acts as a point of reference for all the different
    10 modules in the system. This package is the class for this singleton,
    11 and also contains the vast bulk of the basic constants and the per-
    12 site configuration mechanisms.
    13 
    14 Global variables are avoided wherever possible to avoid problems
    15 with CGI accelerators such as mod_perl.
    16 
    17 ---++ Public Data members
    18    * =cgiQuery=         Pointer to the CGI::
    19    * =context=          Hash of context ids
    20    * moved: =loginManager=     TWiki::LoginManager singleton (moved to TWiki::Users)
    21    * =plugins=          TWiki::Plugins singleton
    22    * =prefs=            TWiki::Prefs singleton
    23    * =remoteUser=       Login ID when using ApacheLogin. Maintained for
    24                         compatibility only, do not use.
    25    * =requestedWebName= Name of web found in URL path or =web= URL parameter
    26    * =sandbox=          TWiki::Sandbox singleton
    27    * =scriptUrlPath=    URL path to the current script. May be dynamically
    28                         extracted from the URL path if {GetScriptUrlFromCgi}.
    29                         Only required to support {GetScriptUrlFromCgi} and
    30                         not consistently used. Avoid.
    31    * =security=         TWiki::Access singleton
    32    * =SESSION_TAGS=     Hash of TWiki variables whose value is specific to
    33                         the current CGI request.
    34    * =store=            TWiki::Store singleton
    35    * =topicName=        Name of topic found in URL path or =topic= URL
    36                         parameter
    37    * =urlHost=          Host part of the URL (including the protocol)
    38                         determined during intialisation and defaulting to
    39                         {DefaultUrlHost}
    40    * =user=             Unique user ID of logged-in user
    41    * =users=            TWiki::Users singleton
    42    * =webName=          Name of web found in URL path, or =web= URL parameter,
    43                         or {UsersWebName}
    44 
    45 =cut
    46 
    47 use strict;
    48 use Assert;
    49 use Error qw( :try );
    50 use CGI;             # Always required to get the CGI object
    51 
    52 require 5.005;       # For regex objects and internationalisation
    53 
    54 # Site configuration constants
    55 use vars qw( %cfg );
    56 
    57 # Uncomment this and the __END__ to enable AutoLoader
    58 #use AutoLoader 'AUTOLOAD';
    59 # You then need to autosplit TWiki.pm:
    60 # cd lib
    61 # perl -e 'use AutoSplit; autosplit("TWiki.pm", "auto")'
    62 
    63 # Other computed constants
    64 use vars qw(
    65             $TranslationToken
    66             $twikiLibDir
    67             %regex
    68             %functionTags
    69             %contextFreeSyntax
    70             %restDispatch
    71             $VERSION $RELEASE
    72             $TRUE
    73             $FALSE
    74             $sandbox
    75             $ifParser
    76            );
    77 
    78 # Token character that must not occur in any normal text - converted
    79 # to a flag character if it ever does occur (very unlikely)
    80 # TWiki uses $TranslationToken to mark points in the text. This is
    81 # normally \0, which is not a useful character in any 8-bit character
    82 # set we can find, nor in UTF-8. But if you *do* encounter problems
    83 # with it, the workaround is to change $TranslationToken to something
    84 # longer that is unlikely to occur in your text - for example
    85 # muRfleFli5ble8leep (do *not* use punctuation characters or whitspace
    86 # in the string!)
    87 # See Codev.NationalCharTokenClash for more.
    88 $TranslationToken= "\0";
    89 
    90 =pod
    91 
    92 ---++ StaticMethod getTWikiLibDir() -> $path
    93 
    94 Returns the full path of the directory containing TWiki.pm
    95 
    96 =cut
    97 
    98 sub getTWikiLibDir {
    99     if( $twikiLibDir ) {
   100         return $twikiLibDir;
   101     }
   102 
   103     # FIXME: Should just use $INC{"TWiki.pm"} to get path used to load this
   104     # module.
   105     my $dir = '';
   106     foreach $dir ( @INC ) {
   107         if( $dir && -e "$dir/TWiki.pm" ) {
   108             $twikiLibDir = $dir;
   109             last;
   110         }
   111     }
   112 
   113     # fix path relative to location of called script
   114     if( $twikiLibDir =~ /^\./ ) {
   115         print STDERR "WARNING: TWiki lib path $twikiLibDir is relative; you should make it absolute, otherwise some scripts may not run from the command line.";
   116         my $bin;
   117         if( $ENV{SCRIPT_FILENAME} &&
   118             $ENV{SCRIPT_FILENAME} =~ /^(.+)\/[^\/]+$/ ) {
   119             # CGI script name
   120             $bin = $1;
   121         } elsif ( $0 =~ /^(.*)\/.*?$/ ) {
   122             # program name
   123             $bin = $1;
   124         } else {
   125             # last ditch; relative to current directory.
   126             require Cwd;
   127             import Cwd qw( cwd );
   128             $bin = cwd();
   129         }
   130         $twikiLibDir = "$bin/$twikiLibDir/";
   131         # normalize "/../" and "/./"
   132         while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) {
   133         };
   134         $twikiLibDir =~ s|([\\/])\.[\\/]|$1|g;
   135     }
   136     $twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/"
   137     $twikiLibDir =~ s|[\\/]$||;           # cut trailing "/"
   138 
   139     return $twikiLibDir;
   140 }
   141 
   142 BEGIN {
   143     require Monitor;
   144     require TWiki::Sandbox;            # system command sandbox
   145     require TWiki::Configure::Load;    # read configuration files
   146 
   147     $TRUE = 1;
   148     $FALSE = 0;
   149 
   150     if( DEBUG ) {
   151         # If ASSERTs are on, then warnings are errors. Paranoid,
   152         # but the only way to be sure we eliminate them all.
   153         # Look out also for $cfg{WarningsAreErrors}, below, which
   154         # is another way to install this handler without enabling
   155         # ASSERTs
   156         # ASSERTS are turned on by defining the environment variable
   157         # TWIKI_ASSERTS. If ASSERTs are off, this is assumed to be a
   158         # production environment, and no stack traces or paths are
   159         # output to the browser.
   160         $SIG{'__WARN__'} = sub { die @_ };
   161         $Error::Debug = 1; # verbose stack traces, please
   162     } else {
   163         $Error::Debug = 0; # no verbose stack traces
   164     }
   165 
   166     # DO NOT CHANGE THE FORMAT OF $VERSION
   167     # Automatically expanded on checkin of this module
   168     $VERSION = '$Date: 2008-01-22 04:18:51 +0100 (Tue, 22 Jan 2008) $ $Rev: 16278 (22 Jan 2008) $ ';
   169     $RELEASE = 'TWiki-4.2.0';
   170     $VERSION =~ s/^.*?\((.*)\).*: (\d+) .*?$/$RELEASE, $1, build $2/;
   171 
   172     # Default handlers for different %TAGS%
   173     %functionTags = (
   174         ALLVARIABLES      => \&ALLVARIABLES,
   175         ATTACHURL         => \&ATTACHURL,
   176         ATTACHURLPATH     => \&ATTACHURLPATH,
   177         DATE              => \&DATE,
   178         DISPLAYTIME       => \&DISPLAYTIME,
   179         ENCODE            => \&ENCODE,
   180         ENV               => \&ENV,
   181         FORMFIELD         => \&FORMFIELD,
   182         GMTIME            => \&GMTIME,
   183         GROUPS            => \&GROUPS,
   184         HTTP_HOST         => \&HTTP_HOST_deprecated,
   185         HTTP              => \&HTTP,
   186         HTTPS             => \&HTTPS,
   187         ICON              => \&ICON,
   188         ICONURL           => \&ICONURL,
   189         ICONURLPATH       => \&ICONURLPATH,
   190         IF                => \&IF,
   191         INCLUDE           => \&INCLUDE,
   192         INTURLENCODE      => \&INTURLENCODE_deprecated,
   193         LANGUAGES         => \&LANGUAGES,
   194         MAKETEXT          => \&MAKETEXT,
   195         META              => \&META,
   196         METASEARCH        => \&METASEARCH,
   197         NOP               => \&NOP,
   198         PLUGINVERSION     => \&PLUGINVERSION,
   199         PUBURL            => \&PUBURL,
   200         PUBURLPATH        => \&PUBURLPATH,
   201         QUERYPARAMS       => \&QUERYPARAMS,
   202         QUERYSTRING       => \&QUERYSTRING,
   203         RELATIVETOPICPATH => \&RELATIVETOPICPATH,
   204         REMOTE_ADDR       => \&REMOTE_ADDR_deprecated,
   205         REMOTE_PORT       => \&REMOTE_PORT_deprecated,
   206         REMOTE_USER       => \&REMOTE_USER_deprecated,
   207         REVINFO           => \&REVINFO,
   208         SCRIPTNAME        => \&SCRIPTNAME,
   209         SCRIPTURL         => \&SCRIPTURL,
   210         SCRIPTURLPATH     => \&SCRIPTURLPATH,
   211         SEARCH            => \&SEARCH,
   212         SEP               => \&SEP,
   213         SERVERTIME        => \&SERVERTIME,
   214         SPACEDTOPIC       => \&SPACEDTOPIC_deprecated,
   215         SPACEOUT          => \&SPACEOUT,
   216         'TMPL:P'          => \&TMPLP,
   217         TOPICLIST         => \&TOPICLIST,
   218         URLENCODE         => \&ENCODE,
   219         URLPARAM          => \&URLPARAM,
   220         LANGUAGE          => \&LANGUAGE,
   221         USERINFO          => \&USERINFO,
   222         USERNAME          => \&USERNAME_deprecated,
   223         VAR               => \&VAR,
   224         WEBLIST           => \&WEBLIST,
   225         WIKINAME          => \&WIKINAME_deprecated,
   226         WIKIUSERNAME      => \&WIKIUSERNAME_deprecated,
   227         # Constant tag strings _not_ dependent on config. These get nicely
   228         # optimised by the compiler.
   229         ENDSECTION        => sub { '' },
   230         WIKIVERSION       => sub { $VERSION },
   231         STARTSECTION      => sub { '' },
   232         STARTINCLUDE      => sub { '' },
   233         STOPINCLUDE       => sub { '' },
   234        );
   235     $contextFreeSyntax{IF} = 1;
   236 
   237     unless( ( $TWiki::cfg{DetailedOS} = $^O ) ) {
   238         require Config;
   239         $TWiki::cfg{DetailedOS} = $Config::Config{'osname'};
   240     }
   241     $TWiki::cfg{OS} = 'UNIX';
   242     if ($TWiki::cfg{DetailedOS} =~ /darwin/i) { # MacOS X
   243         $TWiki::cfg{OS} = 'UNIX';
   244     } elsif ($TWiki::cfg{DetailedOS} =~ /Win/i) {
   245         $TWiki::cfg{OS} = 'WINDOWS';
   246     } elsif ($TWiki::cfg{DetailedOS} =~ /vms/i) {
   247         $TWiki::cfg{OS} = 'VMS';
   248     } elsif ($TWiki::cfg{DetailedOS} =~ /bsdos/i) {
   249         $TWiki::cfg{OS} = 'UNIX';
   250     } elsif ($TWiki::cfg{DetailedOS} =~ /dos/i) {
   251         $TWiki::cfg{OS} = 'DOS';
   252     } elsif ($TWiki::cfg{DetailedOS} =~ /^MacOS$/i) { # MacOS 9 or earlier
   253         $TWiki::cfg{OS} = 'MACINTOSH';
   254     } elsif ($TWiki::cfg{DetailedOS} =~ /os2/i) {
   255         $TWiki::cfg{OS} = 'OS2';
   256     }
   257 
   258     # Validate and untaint Apache's SERVER_NAME Environment variable
   259     # for use in referencing virtualhost-based paths for separate data/ and templates/ instances, etc
   260     if ( $ENV{SERVER_NAME} &&
   261          $ENV{SERVER_NAME} =~ /^(([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6})$/ ) {
   262         $ENV{SERVER_NAME} =
   263           TWiki::Sandbox::untaintUnchecked( $ENV{SERVER_NAME} );
   264     }
   265 
   266     # readConfig is defined in TWiki::Configure::Load to allow overriding it
   267     TWiki::Configure::Load::readConfig();
   268 
   269     if( $TWiki::cfg{WarningsAreErrors} ) {
   270         # Note: Warnings are always errors if ASSERTs are enabled
   271         $SIG{'__WARN__'} = sub { die @_ };
   272     }
   273 
   274     if( $TWiki::cfg{UseLocale} ) {
   275         require locale;
   276         import locale();
   277     }
   278 
   279     # Constant tags dependent on the config
   280     $functionTags{ALLOWLOGINNAME}  =
   281       sub { $TWiki::cfg{Register}{AllowLoginName} || 0 };
   282     $functionTags{AUTHREALM}       = sub { $TWiki::cfg{AuthRealm} };
   283     $functionTags{DEFAULTURLHOST}  = sub { $TWiki::cfg{DefaultUrlHost} };
   284     $functionTags{HOMETOPIC}       = sub { $TWiki::cfg{HomeTopicName} };
   285     $functionTags{LOCALSITEPREFS}  = sub { $TWiki::cfg{LocalSitePreferences} };
   286     $functionTags{NOFOLLOW}        =
   287       sub { $TWiki::cfg{NoFollow} ? 'rel='.$TWiki::cfg{NoFollow} : '' };
   288     $functionTags{NOTIFYTOPIC}     = sub { $TWiki::cfg{NotifyTopicName} };
   289     $functionTags{SCRIPTSUFFIX}    = sub { $TWiki::cfg{ScriptSuffix} };
   290     $functionTags{STATISTICSTOPIC} = sub { $TWiki::cfg{Stats}{TopicName} };
   291     $functionTags{SYSTEMWEB}       = sub { $TWiki::cfg{SystemWebName} };
   292     $functionTags{TRASHWEB}        = sub { $TWiki::cfg{TrashWebName} };
   293     $functionTags{TWIKIADMINLOGIN} = sub { $TWiki::cfg{AdminUserLogin} };
   294     $functionTags{USERSWEB}        = sub { $TWiki::cfg{UsersWebName} };
   295     $functionTags{WEBPREFSTOPIC}   = sub { $TWiki::cfg{WebPrefsTopicName} };
   296     $functionTags{WIKIPREFSTOPIC}  = sub { $TWiki::cfg{SitePrefsTopicName} };
   297     $functionTags{WIKIUSERSTOPIC}  = sub { $TWiki::cfg{UsersTopicName} };
   298     $functionTags{WIKIWEBMASTER}   = sub { $TWiki::cfg{WebMasterEmail} };
   299     $functionTags{WIKIWEBMASTERNAME} = sub { $TWiki::cfg{WebMasterName} };
   300 
   301     # Compatibility synonyms, deprecated in 4.2 but still used throughout
   302     # the documentation.
   303     $functionTags{MAINWEB}         = $functionTags{USERSWEB};
   304     $functionTags{TWIKIWEB}        = $functionTags{SYSTEMWEB};
   305 
   306     # locale setup
   307     #
   308     #
   309     # Note that 'use locale' must be done in BEGIN block for regexes and
   310     # sorting to work properly, although regexes can still work without
   311     # this in 'non-locale regexes' mode.
   312 
   313     if ( $TWiki::cfg{UseLocale} ) {
   314         # Set environment variables for grep 
   315         $ENV{LC_CTYPE} = $TWiki::cfg{Site}{Locale};
   316 
   317         # Load POSIX for I18N support.
   318         require POSIX;
   319         import POSIX qw( locale_h LC_CTYPE LC_COLLATE );
   320 
   321         # SMELL: mod_perl compatibility note: If TWiki is running under Apache,
   322         # won't this play with the Apache process's locale settings too?
   323         # What effects would this have?
   324         setlocale(&LC_CTYPE, $TWiki::cfg{Site}{Locale});
   325         setlocale(&LC_COLLATE, $TWiki::cfg{Site}{Locale});
   326     }
   327 
   328     $functionTags{CHARSET}   = sub { $TWiki::cfg{Site}{CharSet} ||
   329                                        'iso-8859-1' };
   330     $functionTags{SHORTLANG} = sub { $TWiki::cfg{Site}{Lang} || '' };
   331     $functionTags{LANG}      = sub { $TWiki::cfg{Site}{FullLang} || '' };
   332 
   333     # Tell CGI.pm which charset we are using if not default
   334     if( defined $TWiki::cfg{Site}{CharSet} &&
   335           $TWiki::cfg{Site}{CharSet} !~ /^iso-?8859-?1$/io ) {
   336         CGI::charset( $TWiki::cfg{Site}{CharSet} );
   337     }
   338 
   339     # Set up pre-compiled regexes for use in rendering.  All regexes with
   340     # unchanging variables in match should use the '/o' option.
   341     # In the regex hash, all precompiled REs have "Regex" at the
   342     # end of the name. Anything else is a string, either intended
   343     # for use as a character class, or as a sub-expression in
   344     # another compiled RE.
   345 
   346     # Build up character class components for use in regexes.
   347     # Depends on locale mode and Perl version, and finally on
   348     # whether locale-based regexes are turned off.
   349     if ( not $TWiki::cfg{UseLocale} or $] < 5.006
   350          or not $TWiki::cfg{Site}{LocaleRegexes} ) {
   351 
   352         # No locales needed/working, or Perl 5.005, so just use
   353         # any additional national characters defined in TWiki.cfg
   354         $regex{upperAlpha} = 'A-Z'.$TWiki::cfg{UpperNational};
   355         $regex{lowerAlpha} = 'a-z'.$TWiki::cfg{LowerNational};
   356         $regex{numeric}    = '\d';
   357         $regex{mixedAlpha} = $regex{upperAlpha}.$regex{lowerAlpha};
   358     } else {
   359         # Perl 5.006 or higher with working locales
   360         $regex{upperAlpha} = '[:upper:]';
   361         $regex{lowerAlpha} = '[:lower:]';
   362         $regex{numeric}    = '[:digit:]';
   363         $regex{mixedAlpha} = '[:alpha:]';
   364     }
   365     $regex{mixedAlphaNum} = $regex{mixedAlpha}.$regex{numeric};
   366     $regex{lowerAlphaNum} = $regex{lowerAlpha}.$regex{numeric};
   367     $regex{upperAlphaNum} = $regex{upperAlpha}.$regex{numeric};
   368 
   369     # Compile regexes for efficiency and ease of use
   370     # Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl
   371     # book at http://regex.info/. 
   372 
   373     $regex{linkProtocolPattern} =
   374       $TWiki::cfg{LinkProtocolPattern};
   375 
   376     # Header patterns based on '+++'. The '###' are reserved for numbered
   377     # headers
   378     # '---++ Header', '---## Header'
   379     $regex{headerPatternDa} = qr/^---+(\++|\#+)(.*)$/m;
   380     # '<h6>Header</h6>
   381     $regex{headerPatternHt} = qr/^<h([1-6])>(.+?)<\/h\1>/mi;
   382     # '---++!! Header' or '---++ Header %NOTOC% ^top'
   383     $regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)';
   384 
   385     # TWiki concept regexes
   386     $regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlphaNum}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/o;
   387     $regex{webNameBaseRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}_]*/o;
   388     if ($TWiki::cfg{EnableHierarchicalWebs}) {
   389         $regex{webNameRegex} = qr/$regex{webNameBaseRegex}(?:(?:[\.\/]$regex{webNameBaseRegex})+)*/o;
   390     } else {
   391         $regex{webNameRegex} = $regex{webNameBaseRegex};
   392     }
   393     $regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/o;
   394     $regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/o;
   395     $regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/o;
   396 
   397     # Simplistic email regex, e.g. for WebNotify processing - no i18n
   398     # characters allowed
   399     $regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_]+\@[A-Za-z0-9\.\-]+)/;
   400 
   401     # Filename regex to used to match invalid characters in attachments - allow
   402     # alphanumeric characters, spaces, underscores, etc.
   403     # TODO: Get this to work with I18N chars - currently used only with UseLocale off
   404     $regex{filenameInvalidCharRegex} = qr/[^$regex{mixedAlphaNum}\. _-]/o;
   405 
   406     # Multi-character alpha-based regexes
   407     $regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/o;
   408 
   409     # %TAG% name
   410     $regex{tagNameRegex} = '['.$regex{mixedAlpha}.']['.$regex{mixedAlphaNum}.'_:]*';
   411 
   412     # Set statement in a topic
   413     $regex{bulletRegex} = '^(?:\t|   )+\*';
   414     $regex{setRegex} = $regex{bulletRegex}.'\s+(Set|Local)\s+';
   415     $regex{setVarRegex} = $regex{setRegex}.'('.$regex{tagNameRegex}.')\s*=\s*(.*)$';
   416 
   417     # Character encoding regexes
   418 
   419     # 7-bit ASCII only
   420     $regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o;
   421 
   422     # Regex to match only a valid UTF-8 character, taking care to avoid
   423     # security holes due to overlong encodings by excluding the relevant
   424     # gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode
   425     # Encodings section.  Tested against Markus Kuhn's UTF-8 test file
   426     # at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
   427     $regex{validUtf8CharRegex} = qr{
   428                 # Single byte - ASCII
   429                 [\x00-\x7F] 
   430                 |
   431 
   432                 # 2 bytes
   433                 [\xC2-\xDF][\x80-\xBF] 
   434                 |
   435 
   436                 # 3 bytes
   437 
   438                     # Avoid illegal codepoints - negative lookahead
   439                     (?!\xEF\xBF[\xBE\xBF])    
   440 
   441                     # Match valid codepoints
   442                     (?:
   443                     ([\xE0][\xA0-\xBF])|
   444                     ([\xE1-\xEC\xEE-\xEF][\x80-\xBF])|
   445                     ([\xED][\x80-\x9F])
   446                     )
   447                     [\x80-\xBF]
   448                 |
   449 
   450                 # 4 bytes 
   451                     (?:
   452                     ([\xF0][\x90-\xBF])|
   453                     ([\xF1-\xF3][\x80-\xBF])|
   454                     ([\xF4][\x80-\x8F])
   455                     )
   456                     [\x80-\xBF][\x80-\xBF]
   457                 }xo;
   458 
   459     $regex{validUtf8StringRegex} =
   460       qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo;
   461 
   462     # Check for unsafe search regex mode (affects filtering in) - default
   463     # to safe mode
   464     $TWiki::cfg{ForceUnsafeRegexes} = 0 unless defined $TWiki::cfg{ForceUnsafeRegexes};
   465 
   466     # initialize lib directory early because of later 'cd's
   467     getTWikiLibDir();
   468 
   469     Monitor::MARK('Static configuration loaded');
   470 };
   471 
   472 =pod
   473 
   474 ---++ StaticMethod UTF82SiteCharSet( $utf8 ) -> $ascii
   475 
   476 Auto-detect UTF-8 vs. site charset in string, and convert UTF-8 into site
   477 charset.
   478 
   479 =cut
   480 
   481 sub UTF82SiteCharSet {
   482     my $text = shift;
   483 
   484     return $text unless( defined $TWiki::cfg{Site}{CharSet} );
   485 
   486     # Detect character encoding of the full topic name from URL
   487     return undef if( $text =~ $regex{validAsciiStringRegex} );
   488 
   489     # If not UTF-8 - assume in site character set, no conversion required
   490     return undef unless( $text =~ $regex{validUtf8StringRegex} );
   491 
   492     # If site charset is already UTF-8, there is no need to convert anything:
   493     if ( $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) {
   494         # warn if using Perl older than 5.8
   495         if( $] <  5.008 ) {
   496             print STDERR 'UTF-8 not remotely supported on Perl ', $],
   497               ' - use Perl 5.8 or higher..' ;
   498         }
   499 
   500         # We still don't have Codev.UnicodeSupport
   501         print STDERR 'UTF-8 not yet supported as site charset -',
   502           'TWiki is likely to have problems';
   503         return $text;
   504     }
   505 
   506     # Convert into ISO-8859-1 if it is the site charset.  This conversion
   507     # is *not valid for ISO-8859-15*.
   508     if ( $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?1$/i ) {
   509         # ISO-8859-1 maps onto first 256 codepoints of Unicode
   510         # (conversion from 'perldoc perluniintro')
   511         $text =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) / 
   512           chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F )
   513             /egx;
   514     } else {
   515         # Convert from UTF-8 into some other site charset
   516         if( $] >= 5.008 ) {
   517             require Encode;
   518             import Encode qw(:fallbacks);
   519             # Map $TWiki::cfg{Site}{CharSet} into real encoding name
   520             my $charEncoding =
   521               Encode::resolve_alias( $TWiki::cfg{Site}{CharSet} );
   522             if( not $charEncoding ) {
   523                 print STDERR
   524                   'Conversion to "',$TWiki::cfg{Site}{CharSet},
   525                     '" not supported, or name not recognised - check ',
   526                       '"perldoc Encode::Supported"';
   527             } else {
   528                 # Convert text using Encode:
   529                 # - first, convert from UTF8 bytes into internal
   530                 # (UTF-8) characters
   531                 $text = Encode::decode('utf8', $text);    
   532                 # - then convert into site charset from internal UTF-8,
   533                 # inserting \x{NNNN} for characters that can't be converted
   534                 $text =
   535                   Encode::encode( $charEncoding, $text,
   536                                   &FB_PERLQQ() );
   537             }
   538         } else {
   539             require Unicode::MapUTF8;    # Pre-5.8 Perl versions
   540             my $charEncoding = $TWiki::cfg{Site}{CharSet};
   541             if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) {
   542                 print STDERR 'Conversion to "',$TWiki::cfg{Site}{CharSet},
   543                   '" not supported, or name not recognised - check ',
   544                     '"perldoc Unicode::MapUTF8"';
   545             } else {
   546                 # Convert text
   547                 $text =
   548                   Unicode::MapUTF8::from_utf8({
   549                                                -string => $text,
   550                                                -charset => $charEncoding
   551                                               });
   552                 # FIXME: Check for failed conversion?
   553             }
   554         }
   555     }
   556     return $text;
   557 }
   558 
   559 =pod
   560 
   561 ---++ ObjectMethod writeCompletePage( $text, $pageType, $contentType )
   562 
   563 Write a complete HTML page with basic header to the browser.
   564    * =$text= is the text of the page body (&lt;html&gt; to &lt;/html&gt; if it's HTML)
   565    * =$pageType= - May be "edit", which will cause headers to be generated that force
   566      caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused
   567      data loss with IE5 and IE6.
   568    * =$contentType= - page content type | text/html
   569 
   570 This method removes noautolink and nop tags before outputting the page unless
   571 $contentType is text/plain.
   572 
   573 =cut
   574 
   575 sub writeCompletePage {
   576     my ( $this, $text, $pageType, $contentType ) = @_;
   577     $contentType ||= 'text/html';
   578 
   579     if( $contentType ne 'text/plain' ) {
   580         # Remove <nop> and <noautolink> tags
   581         $text =~ s/([\t ]?)[ \t]*<\/?(nop|noautolink)\/?>/$1/gis;
   582         $text .= "\n" unless $text =~ /\n$/s;
   583 
   584         my $htmlHeader = join(
   585             "\n",
   586             map { '<!--'.$_.'-->'.$this->{_HTMLHEADERS}{$_} }
   587               keys %{$this->{_HTMLHEADERS}} );
   588         $text =~ s!(</head>)!$htmlHeader$1!i if $htmlHeader;
   589         chomp($text);
   590     }
   591 
   592     my $hdr = $this->generateHTTPHeaders( undef, $pageType, $contentType );
   593 
   594     # Call final handler
   595     $this->{plugins}->completePageHandler($text, $hdr);
   596 
   597     # HTTP1.1 says a content-length should _not_ be specified unless
   598     # the length is known. There is a bug in Netscape such that it
   599     # interprets a 0 content-length as "download until disconnect"
   600     # but that is a bug. The correct way is to not set a content-length.
   601     unless( $this->inContext('command_line') ) {
   602         # FIXME: Defer next line until we have Codev.UnicodeSupport
   603         # - too 5.8 dependent
   604         # my $len = do { use bytes; length( $text ); };
   605         my $len = length($text);
   606         $hdr =~ s/\n$/Content-Length: $len\n\n/s if $len;
   607     } else {
   608         $hdr = '';
   609     }
   610 
   611     print $hdr.$text;
   612 }
   613 
   614 =pod
   615 
   616 ---++ ObjectMethod generateHTTPHeaders( $query, $pageType, $contentType, $contentLength ) -> $header
   617 
   618 All parameters are optional.
   619 
   620    * =$query= CGI query object | Session CGI query (there is no good reason to set this)
   621    * =$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.
   622    * =$contentType= - page content type | text/html
   623    * =$contentLength= - content-length | no content-length will be set if this is undefined, as required by HTTP1.1
   624 
   625 Implements the post-Dec2001 release plugin API, which requires the
   626 writeHeaderHandler in plugin to return a string of HTTP headers, CR/LF
   627 delimited. Filters any illegal headers. Plugin headers will override
   628 core settings.
   629 
   630 Does *not* add a =Content-length= header.
   631 
   632 =cut
   633 
   634 sub generateHTTPHeaders {
   635     my( $this, $query, $pageType, $contentType ) = @_;
   636 
   637     $query = $this->{cgiQuery} unless $query;
   638 
   639     # Handle Edit pages - future versions will extend to caching
   640     # of other types of page, with expiry time driven by page type.
   641     my( $pluginHeaders, $coreHeaders );
   642 
   643     my $hopts = {};
   644 
   645     if ($pageType && $pageType eq 'edit') {
   646         # Get time now in HTTP header format
   647         require TWiki::Time;
   648         my $lastModifiedString =
   649           TWiki::Time::formatTime(time, '$http', 'gmtime');
   650 
   651         # Expiry time is set high to avoid any data loss.  Each instance of 
   652         # Edit page has a unique URL with time-string suffix (fix for 
   653         # RefreshEditPage), so this long expiry time simply means that the 
   654         # browser Back button always works.  The next Edit on this page 
   655         # will use another URL and therefore won't use any cached 
   656         # version of this Edit page.
   657         my $expireHours = 24;
   658         my $expireSeconds = $expireHours * 60 * 60;
   659 
   660         # and cache control headers, to ensure edit page 
   661         # is cached until required expiry time.
   662         $hopts->{'last-modified'} = $lastModifiedString;
   663         $hopts->{expires} = "+${expireHours}h";
   664         $hopts->{'cache-control'} = "max-age=$expireSeconds";
   665     }
   666 
   667     # DEPRECATED plugins header handler. Plugins should use
   668     # modifyHeaderHandler instead.
   669     $pluginHeaders = $this->{plugins}->writeHeaderHandler( $query ) || '';
   670     if( $pluginHeaders ) {
   671         foreach ( split /\r?\n/, $pluginHeaders ) {
   672             if ( m/^([\-a-z]+): (.*)$/i ) {
   673                 $hopts->{$1} = $2;
   674             }
   675         }
   676     }
   677 
   678     $contentType = 'text/html' unless $contentType;
   679     if( defined( $TWiki::cfg{Site}{CharSet} )) {
   680       $contentType .= '; charset='.$TWiki::cfg{Site}{CharSet};
   681     }
   682 
   683     # use our version of the content type
   684     $hopts->{'Content-Type'} = $contentType;
   685 
   686     # New (since 1.026)
   687     $this->{plugins}->modifyHeaderHandler( $hopts, $this->{cgiQuery} );
   688 
   689     # add cookie(s)
   690     $this->{users}->{loginManager}->modifyHeader( $hopts );
   691 
   692     return CGI::header( $hopts );
   693 }
   694 
   695 =pod
   696 
   697 ---++ StaticMethod isRedirectSafe($redirect) => $ok
   698 
   699 tests if the $redirect is an external URL, returning false if AllowRedirectUrl is denied
   700 
   701 =cut
   702 
   703 sub isRedirectSafe {
   704     my $redirect = shift;
   705     
   706     #TODO: this should really use URI
   707     if ((!$TWiki::cfg{AllowRedirectUrl}) && ( $redirect =~ m!^([^:]*://[^/]*)/*(.*)?$! )) {
   708         my $host = $1;
   709         #remove trailing /'s to match
   710         $TWiki::cfg{DefaultUrlHost} =~ m!^([^:]*://[^/]*)/*(.*)?$!;
   711         my $expected = $1;
   712         
   713         if (defined($TWiki::cfg{PermittedRedirectHostUrls} ) && $TWiki::cfg{PermittedRedirectHostUrls}  ne '') {
   714             my @permitted =
   715                 map { s!^([^:]*://[^/]*)/*(.*)?$!$1!; $1 }
   716                         split(/,\s*/, $TWiki::cfg{PermittedRedirectHostUrls});
   717             return 1 if ( grep ( { uc($host) eq uc($_) } @permitted));
   718         }
   719         return (uc($host) eq uc($expected));
   720     }
   721     return 1;
   722 }
   723 
   724 # _getRedirectUrl() => redirectURL set from the parameter
   725 # Reads a redirect url from CGI parameter 'redirectto'.
   726 # This function is used to get and test the 'redirectto' cgi parameter, 
   727 # and then the calling function can set its own reporting if there is a
   728 # problem.
   729 sub _getRedirectUrl {
   730     my $session = shift;
   731 
   732     my $query = $session->{cgiQuery};
   733     my $redirecturl = $query->param( 'redirectto' );
   734     return '' unless $redirecturl;
   735 
   736     if( $redirecturl =~ m#^$regex{linkProtocolPattern}://#o ) {
   737         # assuming URL
   738         if (isRedirectSafe($redirecturl)) {
   739             return $redirecturl;
   740         } else {
   741             return '';
   742         }
   743     }
   744     # assuming 'web.topic' or 'topic'
   745     my ( $w, $t ) = $session->normalizeWebTopicName( $session->{webName}, $redirecturl );
   746     $redirecturl = $session->getScriptUrl( 1, 'view', $w, $t );
   747     return $redirecturl;
   748 }
   749 
   750 
   751 =pod
   752 
   753 ---++ ObjectMethod redirect( $url, $passthrough, $action_redirectto )
   754 
   755    * $url - url or twikitopic to redirect to
   756    * $passthrough - (optional) parameter to **FILLMEIN**
   757    * $action_redirectto - (optional) redirect to where ?redirectto=
   758      points to (if it's valid)
   759 
   760 Redirects the request to =$url=, *unless*
   761    1 It is overridden by a plugin declaring a =redirectCgiQueryHandler=.
   762    1 =$session->{cgiQuery}= is =undef= or
   763    1 $query->param('noredirect') is set to a true value.
   764 Thus a redirect is only generated when in a CGI context.
   765 
   766 Normally this method will ignore parameters to the current query. Sometimes,
   767 for example when redirecting to a login page during authentication (and then
   768 again from the login page to the original requested URL), you want to make
   769 sure all parameters are passed on, and for this $passthrough should be set to
   770 true. In this case it will pass all parameters that were passed to the
   771 current query on to the redirect target. If the request_method for the
   772 current query was GET, then all parameters will be passed by encoding them
   773 in the URL (after ?). If the request_method was POST, then there is a risk the
   774 URL would be too big for the receiver, so it caches the form data and passes
   775 over a cache reference in the redirect GET.
   776 
   777 NOTE: Passthrough is only meaningful if the redirect target is on the same
   778 server.
   779 
   780 =cut
   781 
   782 sub redirect {
   783     my( $this, $url, $passthru, $action_redirectto ) = @_;
   784 
   785     my $query = $this->{cgiQuery};
   786     # if we got here without a query, there's not much more we can do
   787     return unless $query;
   788 
   789     # SMELL: if noredirect is set, don't generate the redirect, throw an
   790     # exception instead. This is a HACK used to support TWikiDrawPlugin.
   791     # It is deprecated and must be replaced by REST handlers in the plugin.
   792     if( $query->param( 'noredirect' )) {
   793         die "ERROR: $url";
   794         return;
   795     }
   796 
   797     if ($action_redirectto) {
   798         my $redir = _getRedirectUrl($this);
   799         $url = $redir if ($redir);
   800     }
   801 
   802     if ($passthru && defined $ENV{REQUEST_METHOD}) {
   803         my $existing = '';
   804         if ($url =~ s/\?(.*)$//) {
   805             $existing = $1;
   806         }
   807         if ($ENV{REQUEST_METHOD} eq 'POST') {
   808             # Redirecting from a post to a get
   809             my $cache = $this->cacheQuery();
   810             if ($cache) {
   811                 $url .= "?$cache";
   812             }
   813         } else {
   814             if ($query->query_string()) {
   815                 $url .= '?'.$query->query_string();
   816             }
   817             if ($existing) {
   818                 if ($url =~ /\?/) {
   819                     $url .= ';';
   820                 } else {
   821                     $url .= '?';
   822                 }
   823                 $url .= $existing;
   824             }
   825         }
   826     }
   827 
   828     # prevent phishing by only allowing redirect to configured host
   829     # do this check as late as possible to catch _any_ last minute hacks
   830     # TODO: this should really use URI
   831     if (!isRedirectSafe($url)) {
   832          # goto oops if URL is trying to take us somewhere dangerous
   833          $url = $this->getScriptUrl(
   834              1, 'oops',
   835              $this->{web} || $TWiki::cfg{UsersWebName},
   836              $this->{topic} || $TWiki::cfg{HomeTopicName},
   837              template => 'oopsaccessdenied',
   838              def => 'topic_access',
   839              param1 => 'redirect',
   840              param2 => 'unsafe redirect to '.$url.
   841                ': host does not match {DefaultUrlHost} , and is not in {PermittedRedirectHostUrls}"'.
   842                  $TWiki::cfg{DefaultUrlHost}.'"'
   843             );
   844     }
   845 
   846 
   847     return if( $this->{plugins}->redirectCgiQueryHandler( $query, $url ));
   848 
   849     # SMELL: this is a bad breaking of encapsulation: the loginManager
   850     # should just modify the url, then the redirect should only happen here.
   851     return if( $this->{users}->{loginManager}->redirectCgiQuery( $query, $url ) );
   852     die "Login manager returned 0 from redirectCgiQuery";
   853 }
   854 
   855 =pod
   856 
   857 ---++ ObjectMethod cacheQuery() -> $queryString
   858 
   859 Caches the current query in the params cache, and returns a rewritten
   860 query string for the cache to be picked up again on the other side of a
   861 redirect.
   862 
   863 We can't encode post params into a redirect, because they may exceed the
   864 size of the GET request. So we cache the params, and reload them when the
   865 redirect target is reached.
   866 
   867 =cut
   868 
   869 sub cacheQuery {
   870     my $this = shift;
   871     my $query = $this->{cgiQuery};
   872 
   873     return '' unless (scalar($query->param()));
   874     # Don't double-cache
   875     return '' if ($query->param('twiki_redirect_cache'));
   876 
   877     require Digest::MD5;
   878     my $md5 = new Digest::MD5();
   879     $md5->add($$, time(), rand(time));
   880     my $uid = $md5->hexdigest();
   881     my $passthruFilename = "$TWiki::cfg{WorkingDir}/tmp/passthru_$uid";
   882 
   883     use Fcntl;
   884     #passthrough file is only written to once, so if it already exists, suspect a security hack (O_EXCL)
   885     sysopen(F, "$passthruFilename", O_RDWR|O_EXCL|O_CREAT, 0600) ||
   886       die "Unable to open $TWiki::cfg{WorkingDir}/tmp for write; check the setting of {WorkingDir} in configure, and check file permissions: $!";
   887     $query->save(\*F);
   888     close(F);
   889     return 'twiki_redirect_cache='.$uid;
   890 }
   891 
   892 =pod
   893 
   894 ---++ StaticMethod isValidWikiWord( $name ) -> $boolean
   895 
   896 Check for a valid WikiWord or WikiName
   897 
   898 =cut
   899 
   900 sub isValidWikiWord {
   901     my $name  = shift || '';
   902     return ( $name =~ m/^$regex{wikiWordRegex}$/o )
   903 }
   904 
   905 =pod
   906 
   907 ---++ StaticMethod isValidTopicName( $name ) -> $boolean
   908 
   909 Check for a valid topic name
   910 
   911 =cut
   912 
   913 sub isValidTopicName {
   914     my( $name ) = @_;
   915 
   916     return isValidWikiWord( @_ ) || isValidAbbrev( @_ );
   917 }
   918 
   919 =pod
   920 
   921 ---++ StaticMethod isValidAbbrev( $name ) -> $boolean
   922 
   923 Check for a valid ABBREV (acronym)
   924 
   925 =cut
   926 
   927 sub isValidAbbrev {
   928     my $name = shift || '';
   929     return ( $name =~ m/^$regex{abbrevRegex}$/o )
   930 }
   931 
   932 =pod
   933 
   934 ---++ StaticMethod isValidWebName( $name, $system ) -> $boolean
   935 
   936 STATIC Check for a valid web name. If $system is true, then
   937 system web names are considered valid (names starting with _)
   938 otherwise only user web names are valid
   939 
   940 If $TWiki::cfg{EnableHierarchicalWebs} is off, it will also return false
   941 when a nested web name is passed to it.
   942 
   943 =cut
   944 
   945 sub isValidWebName {
   946     my $name = shift || '';
   947     my $sys = shift;
   948     return 1 if ( $sys && $name =~ m/^$regex{defaultWebNameRegex}$/o );
   949     return ( $name =~ m/^$regex{webNameRegex}$/o )
   950 }
   951 
   952 =pod
   953 
   954 ---++ ObjectMethod readOnlyMirrorWeb( $theWeb ) -> ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote )
   955 
   956 If this is a mirrored web, return information about the mirror. The info
   957 is returned in a quadruple:
   958 
   959 | site name | URL | link | note |
   960 
   961 =cut
   962 
   963 sub readOnlyMirrorWeb {
   964     my( $this, $theWeb ) = @_;
   965 
   966 
   967     my @mirrorInfo = ( '', '', '', '' );
   968     if( $TWiki::cfg{SiteWebTopicName} ) {
   969         my $mirrorSiteName =
   970           $this->{prefs}->getWebPreferencesValue( 'MIRRORSITENAME', $theWeb );
   971         if( $mirrorSiteName && $mirrorSiteName ne $TWiki::cfg{SiteWebTopicName} ) {
   972             my $mirrorViewURL  =
   973               $this->{prefs}->getWebPreferencesValue( 'MIRRORVIEWURL', $theWeb );
   974             my $mirrorLink = $this->templates->readTemplate( 'mirrorlink' );
   975             $mirrorLink =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
   976             $mirrorLink =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
   977             $mirrorLink =~ s/\s*$//g;
   978             my $mirrorNote = $this->templates->readTemplate( 'mirrornote' );
   979             $mirrorNote =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
   980             $mirrorNote =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
   981             $mirrorNote = $this->renderer->getRenderedVersion
   982               ( $mirrorNote, $theWeb, $TWiki::cfg{HomeTopic} );
   983             $mirrorNote =~ s/\s*$//g;
   984             @mirrorInfo = ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote );
   985         }
   986     }
   987     return @mirrorInfo;
   988 }
   989 
   990 =pod
   991 
   992 ---++ ObjectMethod getSkin () -> $string
   993 
   994 Get the currently requested skin path
   995 
   996 =cut
   997 
   998 sub getSkin {
   999     my $this = shift;
  1000 
  1001 
  1002     my $skinpath = $this->{prefs}->getPreferencesValue( 'SKIN' ) || '';
  1003 
  1004     if( $this->{cgiQuery} ) {
  1005         my $resurface = $this->{cgiQuery}->param( 'skin' );
  1006         $skinpath = $resurface if $resurface;
  1007     }
  1008 
  1009     my $epidermis = $this->{prefs}->getPreferencesValue( 'COVER' );
  1010     $skinpath = $epidermis.','.$skinpath if $epidermis;
  1011 
  1012     if( $this->{cgiQuery} ) {
  1013         $epidermis = $this->{cgiQuery}->param( 'cover' );
  1014         $skinpath = $epidermis.','.$skinpath if $epidermis;
  1015     }
  1016 
  1017     return $skinpath;
  1018 }
  1019 
  1020 =pod
  1021 
  1022 ---++ ObjectMethod getScriptUrl( $absolute, $script, $web, $topic, ... ) -> $scriptURL
  1023 
  1024 Returns the URL to a TWiki script, providing the web and topic as
  1025 "path info" parameters.  The result looks something like this:
  1026 "http://host/twiki/bin/$script/$web/$topic".
  1027    * =...= - 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>
  1028 
  1029 If $absolute is set, generates an absolute URL. $absolute is advisory only;
  1030 TWiki can decide to generate absolute URLs (for example when run from the
  1031 command-line) even when relative URLs have been requested.
  1032 
  1033 The default script url is taken from {ScriptUrlPath}, unless there is
  1034 an exception defined for the given script in {ScriptUrlPaths}. Both
  1035 {ScriptUrlPath} and {ScriptUrlPaths} may be absolute or relative URIs. If
  1036 they are absolute, then they will always generate absolute URLs. if they
  1037 are relative, then they will be converted to absolute when required (e.g.
  1038 when running from the command line, or when generating rss). If
  1039 $script is not given, absolute URLs will always be generated.
  1040 
  1041 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.
  1042 
  1043 =cut
  1044 
  1045 sub getScriptUrl {
  1046     my( $this, $absolute, $script, $web, $topic, @params ) = @_;
  1047 
  1048     $absolute ||= ($this->inContext( 'command_line' ) ||
  1049                      $this->inContext( 'rss' ) ||
  1050                        $this->inContext( 'absolute_urls' ));
  1051 
  1052     # SMELL: topics and webs that contain spaces?
  1053 
  1054     my $url;
  1055     if( defined $TWiki::cfg{ScriptUrlPaths} && $script) {
  1056         $url = $TWiki::cfg{ScriptUrlPaths}{$script};
  1057     }
  1058     unless( defined( $url )) {
  1059         $url = $TWiki::cfg{ScriptUrlPath};
  1060         if( $script ) {
  1061             $url .= '/' unless $url =~ /\/$/;
  1062             $url .= $script;
  1063             $url .= $TWiki::cfg{ScriptSuffix} if $script;
  1064         }
  1065     }
  1066 
  1067     if( $absolute && $url !~ /^[a-z]+:/ ) {
  1068         # See http://www.ietf.org/rfc/rfc2396.txt for the definition of
  1069         # "absolute URI". TWiki bastardises this definition by assuming
  1070         # that all relative URLs lack the <authority> component as well.
  1071         $url = $this->{urlHost}.$url;
  1072     }
  1073 
  1074     if( $web || $topic ) {
  1075         ( $web, $topic ) =
  1076           $this->normalizeWebTopicName( $web, $topic );
  1077 
  1078         $url .= urlEncode( '/'.$web.'/'.$topic );
  1079 
  1080 	$url .= _make_params(0, @params);
  1081     }
  1082 
  1083     return $url;
  1084 }
  1085 
  1086 sub _make_params {
  1087   my ( $notfirst, @args ) = @_;
  1088   my $url = '';
  1089   my $ps = '';
  1090   my $anchor = '';
  1091   while( my $p = shift @args ) {
  1092     if( $p eq '#' ) {
  1093       $anchor .= '#' . shift( @args );
  1094     } else {
  1095       $ps .= ';' . $p.'='.urlEncode(shift( @args )||'');
  1096     }
  1097   }
  1098   if( $ps ) {
  1099     $ps =~ s/^;/?/ unless $notfirst;
  1100     $url .= $ps;
  1101   }
  1102   $url .= $anchor;
  1103   return $url;
  1104 }
  1105 
  1106 =pod
  1107 
  1108 ---++ ObjectMethod getPubUrl($absolute, $web, $topic, $attachment) -> $url
  1109 
  1110 Composes a pub url. If $absolute is set, returns an absolute URL.
  1111 If $absolute is set, generates an absolute URL. $absolute is advisory only;
  1112 TWiki can decide to generate absolute URLs (for example when run from the
  1113 command-line) even when relative URLs have been requested.
  1114 
  1115 $web, $topic and $attachment are optional. A partial URL path will be
  1116 generated if one or all is not given.
  1117 
  1118 =cut
  1119 
  1120 sub getPubUrl {
  1121     my( $this, $absolute, $web, $topic, $attachment ) = @_;
  1122 
  1123     $absolute ||= ($this->inContext( 'command_line' ) ||
  1124                      $this->inContext( 'rss' ) ||
  1125                        $this->inContext( 'absolute_urls' ));
  1126 
  1127     my $url = '';
  1128     $url .= $TWiki::cfg{PubUrlPath};
  1129     if( $absolute && $url !~ /^[a-z]+:/ ) {
  1130         # See http://www.ietf.org/rfc/rfc2396.txt for the definition of
  1131         # "absolute URI". TWiki bastardises this definition by assuming
  1132         # that all relative URLs lack the <authority> component as well.
  1133         $url = $this->{urlHost}.$url;
  1134     }
  1135     if( $web || $topic || $attachment ) {
  1136         ( $web, $topic ) =
  1137           $this->normalizeWebTopicName( $web, $topic );
  1138 
  1139         my $path = '/'.$web.'/'.$topic;
  1140 	if( $attachment ) {
  1141 	    $path .= '/'.$attachment;
  1142 	    # Attachments are served directly by web server, need to handle
  1143 	    # URL encoding specially
  1144 	    $url .= urlEncodeAttachment ( $path );
  1145 	} else {
  1146 	    $url .= urlEncode( $path );
  1147 	}
  1148     }
  1149 
  1150     return $url;
  1151 }
  1152 
  1153 =pod
  1154 
  1155 ---++ ObjectMethod getIconUrl( $absolute, $iconName ) -> $iconURL
  1156 
  1157 Map an icon name to a URL path.
  1158 
  1159 =cut
  1160 
  1161 sub getIconUrl {
  1162     my( $this, $absolute, $iconName ) = @_;
  1163 
  1164     my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
  1165     my( $web, $topic) = $this->normalizeWebTopicName(
  1166         $this->{webName}, $iconTopic );
  1167     $iconName =~ s/^.*\.(.*?)$/$1/;
  1168     return $this->getPubUrl( $absolute, $web, $topic, $iconName.'.gif' );
  1169 }
  1170 
  1171 =pod
  1172 
  1173 ---++ ObjectMethod mapToIconFileName( $fileName, $default ) -> $fileName
  1174 
  1175 Maps from a filename (or just the extension) to the name of the
  1176 file that contains the image for that file type.
  1177 
  1178 =cut
  1179 
  1180 sub mapToIconFileName {
  1181     my( $this, $fileName, $default ) = @_;
  1182 	
  1183     my @bits = ( split( /\./, $fileName ) );
  1184     my $fileExt = lc $bits[$#bits];
  1185 
  1186     unless( $this->{_ICONMAP} ) {
  1187         my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
  1188         my( $web, $topic) = $this->normalizeWebTopicName(
  1189             $this->{webName}, $iconTopic );
  1190         local $/ = undef;
  1191         try {
  1192             my $icons = $this->{store}->getAttachmentStream(
  1193                 undef, $web, $topic, '_filetypes.txt' );
  1194             %{$this->{_ICONMAP}} = split( /\s+/, <$icons> );
  1195             close( $icons );
  1196         } catch Error::Simple with {
  1197             %{$this->{_ICONMAP}} = ();
  1198         };
  1199     }
  1200 
  1201     return $this->{_ICONMAP}->{$fileExt} || $default || 'else';
  1202 }
  1203 
  1204 =pod
  1205 
  1206 ---++ ObjectMethod normalizeWebTopicName( $theWeb, $theTopic ) -> ( $theWeb, $theTopic )
  1207 
  1208 Normalize a Web<nop>.<nop>TopicName
  1209 
  1210 See TWikiFuncDotPm for a full specification of the expansion (not duplicated
  1211 here)
  1212 
  1213 *WARNING* if there is no web specification (in the web or topic parameters)
  1214 the web defaults to $TWiki::cfg{UsersWebName}. If there is no topic
  1215 specification, or the topic is '0', the topic defaults to the web home topic
  1216 name.
  1217 
  1218 =cut
  1219 
  1220 sub normalizeWebTopicName {
  1221     my( $this, $web, $topic ) = @_;
  1222 
  1223     ASSERT(defined $topic) if DEBUG;
  1224 
  1225     if( $topic =~ m|^(.*)[./](.*?)$| ) {
  1226         $web = $1;
  1227         $topic = $2;
  1228     }
  1229     $web ||= $cfg{UsersWebName};
  1230     $topic ||= $cfg{HomeTopicName};
  1231     while( $web =~ s/%((MAIN|TWIKI|USERS|SYSTEM|DOC)WEB)%/_expandTagOnTopicRendering( $this,$1)||''/e ) {
  1232     }
  1233     $web =~ s#\.#/#go;
  1234     return( $web, $topic );
  1235 }
  1236 
  1237 =pod
  1238 
  1239 ---++ ClassMethod new( $loginName, $query, \%initialContext )
  1240 
  1241 Constructs a new TWiki object. Parameters are taken from the query object.
  1242 
  1243    * =$loginName= is the login username (*not* the wikiname) of the user you
  1244      want to be logged-in if none is available from a session or browser.
  1245      Used mainly for side scripts and debugging.
  1246    * =$query= the CGI query (may be undef, in which case an empty query
  1247      is used)
  1248    * =\%initialContext= - reference to a hash containing context
  1249      name=value pairs to be pre-installed in the context hash
  1250 
  1251 =cut
  1252 
  1253 sub new {
  1254     my( $class, $login, $query, $initialContext ) = @_;
  1255 
  1256     Monitor::MARK("Static compilation complete");
  1257 
  1258     # Compatibility; not used except maybe in plugins
  1259     $TWiki::cfg{TempfileDir} = "$TWiki::cfg{WorkingDir}/tmp"
  1260       unless defined($TWiki::cfg{TempfileDir});
  1261 
  1262     # Set command_line context if there is no query
  1263     $initialContext ||= defined( $query ) ? {} : { command_line => 1 };
  1264 
  1265     $query ||= new CGI( {} );
  1266     my $this = bless( {}, $class );
  1267 
  1268     $this->{_HTMLHEADERS} = {};
  1269     $this->{context} = $initialContext;
  1270 
  1271     # create the various sub-objects
  1272     unless ($sandbox) {
  1273         # "shared" between mod_perl instances
  1274         $sandbox = new TWiki::Sandbox(
  1275             $TWiki::cfg{OS}, $TWiki::cfg{DetailedOS} );
  1276     }
  1277     require TWiki::Plugins;
  1278     $this->{plugins} = new TWiki::Plugins( $this );
  1279     require TWiki::Store;
  1280     $this->{store} = new TWiki::Store( $this );
  1281     # cache CGI information in the session object
  1282     $this->{cgiQuery} = $query;
  1283 
  1284     $this->{remoteUser} = $login;	#use login as a default (set when running from cmd line)
  1285     require TWiki::Users;
  1286     $this->{users} = new TWiki::Users( $this );
  1287 	$this->{remoteUser} = $this->{users}->{remoteUser};
  1288 
  1289     # Make %ENV safer, preventing hijack of the search path
  1290     # SMELL: can this be done in a BEGIN block? Or is the environment
  1291     # set per-query?
  1292     # Item4382: Default $ENV{PATH} must be untainted because TWiki runs
  1293     # with use strict and calling external programs that writes on the disk
  1294     # will fail unless Perl seens it as set to safe value.
  1295     if( $TWiki::cfg{SafeEnvPath} ) {
  1296         $ENV{PATH} = $TWiki::cfg{SafeEnvPath};
  1297     } else {
  1298         $ENV{PATH} = TWiki::Sandbox::untaintUnchecked( $ENV{PATH} );
  1299     }
  1300     delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };
  1301 
  1302     my $web = '';
  1303     my $topic = $query->param( 'topic' );
  1304     if( $topic ) {
  1305         if( $topic =~ m#^$regex{linkProtocolPattern}://#o &&
  1306             $this->{cgiQuery} ) {
  1307             # redirect to URI
  1308                 print $this->redirect( $topic );
  1309                 exit;   #we seriously don't want to go through normal TWiki operations if we're redirecting..
  1310         } elsif( $topic =~ /((?:.*[\.\/])+)(.*)/ ) {
  1311             # is 'bin/script?topic=Webname.SomeTopic'
  1312             $web   = $1;
  1313             $topic = $2;
  1314             $web =~ s/\./\//go;
  1315             $web =~ s/\/$//o;
  1316             # jump to WebHome if 'bin/script?topic=Webname.'
  1317             $topic = $TWiki::cfg{HomeTopicName} if( $web && ! $topic );
  1318         }
  1319         # otherwise assume 'bin/script/Webname?topic=SomeTopic'
  1320     } else {
  1321         $topic = '';
  1322     }
  1323 
  1324     # SMELL: "The Microsoft Internet Information Server is broken with
  1325     # respect to additional path information. If you use the Perl DLL
  1326     # library, the IIS server will attempt to execute the additional
  1327     # path information as a Perl script. If you use the ordinary file
  1328     # associations mapping, the path information will be present in the
  1329     # environment, but incorrect. The best thing to do is to avoid using
  1330     # additional path information."
  1331 
  1332     # Clean up PATH_INFO problems, e.g.  Support.CobaltRaqInstall.  A valid
  1333     # PATH_INFO is '/Main/WebHome', i.e. the text after the script name;
  1334     # invalid PATH_INFO is often a full path starting with '/cgi-bin/...'.
  1335     my $pathInfo = $query->path_info();
  1336     my $cgiScriptName = $ENV{SCRIPT_NAME} || '';
  1337     $pathInfo =~ s!$cgiScriptName/!/!i;
  1338 
  1339     # Get the web and topic names from PATH_INFO
  1340     if( $pathInfo =~ /\/((?:.*[\.\/])+)(.*)/ ) {
  1341         # is 'bin/script/Webname/SomeTopic' or 'bin/script/Webname/'
  1342         $web   = $1 unless $web;
  1343         $topic = $2 unless $topic;
  1344         $web =~ s/\./\//go;
  1345         $web =~ s/\/$//o;
  1346     } elsif( $pathInfo =~ /\/(.*)/ ) {
  1347         # is 'bin/script/Webname' or 'bin/script/'
  1348         $web = $1 unless $web;
  1349     }
  1350 
  1351     # All roads lead to WebHome
  1352     $topic = $TWiki::cfg{HomeTopicName} if ( $topic =~ /\.\./ );
  1353     $topic =~ s/$TWiki::cfg{NameFilter}//go;
  1354     $topic = $TWiki::cfg{HomeTopicName} unless $topic;
  1355     $this->{topicName} = TWiki::Sandbox::untaintUnchecked( $topic );
  1356 
  1357     $web   =~ s/$TWiki::cfg{NameFilter}//go;
  1358     $this->{requestedWebName} = TWiki::Sandbox::untaintUnchecked( $web ); #can be an empty string
  1359     $web = $TWiki::cfg{UsersWebName} unless $web;
  1360     $this->{webName} = TWiki::Sandbox::untaintUnchecked( $web );
  1361 
  1362     # Convert UTF-8 web and topic name from URL into site charset if necessary 
  1363     # SMELL: merge these two cases, browsers just don't mix two encodings in one URL
  1364     # - can also simplify into 2 lines by making function return unprocessed text if no conversion
  1365     my $webNameTemp = UTF82SiteCharSet( $this->{webName} );
  1366     if ( $webNameTemp ) {
  1367         $this->{webName} = $webNameTemp;
  1368     }
  1369 
  1370     my $topicNameTemp = UTF82SiteCharSet( $this->{topicName} );
  1371     if ( $topicNameTemp ) {
  1372         $this->{topicName} = $topicNameTemp;
  1373     }
  1374 
  1375     # Item3270 - here's the appropriate place to enforce TWiki spec:
  1376     # All topic name sources are evaluated, site charset applied
  1377     # SMELL: This untaint unchecked is duplicate of one just above
  1378     $this->{topicName}  =
  1379         TWiki::Sandbox::untaintUnchecked(ucfirst $this->{topicName});
  1380 
  1381     $this->{scriptUrlPath} = $TWiki::cfg{ScriptUrlPath};
  1382 
  1383     my $url = $query->url();
  1384     if( $url && $url =~ m!^([^:]*://[^/]*)(.*)/.*$! && $2 ) {
  1385         $this->{urlHost} = $1;
  1386         # If the urlHost in the url is localhost, this is a lot less
  1387         # useful than the default url host. This is because new CGI("")
  1388         # assigns this host by default - it's a default setting, used
  1389         # when there is nothing better available.
  1390         if( $this->{urlHost} eq 'http://localhost' ) {
  1391             $this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
  1392         } elsif( $TWiki::cfg{RemovePortNumber} ) {
  1393             $this->{urlHost} =~ s/\:[0-9]+$//;
  1394         }
  1395         if( $TWiki::cfg{GetScriptUrlFromCgi} ) {
  1396             # SMELL: this is a really dangerous hack. It will fail
  1397             # spectacularly with mod_perl.
  1398             # SMELL: why not just use $query->script_name?
  1399             $this->{scriptUrlPath} = $2;
  1400         }
  1401     } else {
  1402         $this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
  1403     }
  1404 
  1405     require TWiki::Prefs;
  1406     my $prefs = new TWiki::Prefs( $this );
  1407     $this->{prefs} = $prefs;
  1408 
  1409     # Form definition cache
  1410     $this->{forms} = {};
  1411 
  1412     # Push global preferences from TWiki.TWikiPreferences
  1413     $prefs->pushGlobalPreferences();
  1414 
  1415 #TODO: what happens if we move this into the TWiki::User::new?
  1416     $this->{user} = $this->{users}->initialiseUser($this->{remoteUser});
  1417 
  1418     # Static session variables that can be expanded in topics when they
  1419     # are enclosed in % signs
  1420     # SMELL: should collapse these into one. The duplication is pretty
  1421     # pointless. Could get rid of the SESSION_TAGS hash, might be
  1422     # the easiest thing to do, but then that would allow other
  1423     # upper-case named fields in the object to be accessed as well...
  1424     $this->{SESSION_TAGS}{BASEWEB}        = $this->{webName};
  1425     $this->{SESSION_TAGS}{BASETOPIC}      = $this->{topicName};
  1426     $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $this->{topicName};
  1427     $this->{SESSION_TAGS}{INCLUDINGWEB}   = $this->{webName};
  1428 
  1429     # Push plugin settings
  1430     $this->{plugins}->settings();
  1431 
  1432     # Now the rest of the preferences
  1433     $prefs->pushGlobalPreferencesSiteSpecific();
  1434 
  1435     # User preferences only available if we can get to a valid wikiname,
  1436     # which depends on the user mapper.
  1437     my $wn = $this->{users}->getWikiName( $this->{user} );
  1438     if( $wn ) {
  1439         $prefs->pushPreferences(
  1440             $TWiki::cfg{UsersWebName}, $wn,
  1441             'USER ' . $wn );
  1442     }
  1443 
  1444     $prefs->pushWebPreferences( $this->{webName} );
  1445 
  1446     $prefs->pushPreferences(
  1447         $this->{webName}, $this->{topicName}, 'TOPIC' );
  1448 
  1449     $prefs->pushPreferenceValues( 'SESSION',
  1450                                   $this->{users}->{loginManager}->getSessionValues() );
  1451 
  1452     # Finish plugin initialization - register handlers
  1453     $this->{plugins}->enable();
  1454 
  1455     $TWiki::Plugins::SESSION = $this;
  1456 
  1457     Monitor::MARK("TWiki session created");
  1458 
  1459     return $this;
  1460 }
  1461 
  1462 =begin twiki
  1463 
  1464 ---++ ObjectMethod renderer()
  1465 Get a reference to the renderer object. Done lazily because not everyone
  1466 needs the renderer.
  1467 
  1468 =cut
  1469 
  1470 sub renderer {
  1471     my( $this ) = @_;
  1472 
  1473     unless( $this->{renderer} ) {
  1474         require TWiki::Render;
  1475         # requires preferences (such as LINKTOOLTIPINFO)
  1476         $this->{renderer} = new TWiki::Render( $this );
  1477     }
  1478     return $this->{renderer};
  1479 }
  1480 
  1481 =begin twiki
  1482 
  1483 ---++ ObjectMethod attach()
  1484 Get a reference to the attach object. Done lazily because not everyone
  1485 needs the attach.
  1486 
  1487 =cut
  1488 
  1489 sub attach {
  1490     my( $this ) = @_;
  1491 
  1492     unless( $this->{attach} ) {
  1493         require TWiki::Attach;
  1494         $this->{attach} = new TWiki::Attach( $this );
  1495     }
  1496     return $this->{attach};
  1497 }
  1498 
  1499 =begin twiki
  1500 
  1501 ---++ ObjectMethod templates()
  1502 Get a reference to the templates object. Done lazily because not everyone
  1503 needs the templates.
  1504 
  1505 =cut
  1506 
  1507 sub templates {
  1508     my( $this ) = @_;
  1509 
  1510     unless( $this->{templates} ) {
  1511         require TWiki::Templates;
  1512         $this->{templates} = new TWiki::Templates( $this );
  1513     }
  1514     return $this->{templates};
  1515 }
  1516 
  1517 =begin twiki
  1518 
  1519 ---++ ObjectMethod i18n()
  1520 Get a reference to the i18n object. Done lazily because not everyone
  1521 needs the i18ner.
  1522 
  1523 =cut
  1524 
  1525 sub i18n {
  1526     my( $this ) = @_;
  1527 
  1528     unless( $this->{i18n} ) {
  1529         require TWiki::I18N;
  1530         # language information; must be loaded after
  1531         # *all possible preferences sources* are available
  1532         $this->{i18n} = new TWiki::I18N( $this );
  1533     }
  1534     return $this->{i18n};
  1535 }
  1536 
  1537 =begin twiki
  1538 
  1539 ---++ ObjectMethod search()
  1540 Get a reference to the search object. Done lazily because not everyone
  1541 needs the searcher.
  1542 
  1543 =cut
  1544 
  1545 sub search {
  1546     my( $this ) = @_;
  1547 
  1548     unless( $this->{search} ) {
  1549         require TWiki::Search;
  1550         $this->{search} = new TWiki::Search( $this );
  1551     }
  1552     return $this->{search};
  1553 }
  1554 
  1555 =begin twiki
  1556 
  1557 ---++ ObjectMethod security()
  1558 Get a reference to the security object. Done lazily because not everyone
  1559 needs the security.
  1560 
  1561 =cut
  1562 
  1563 sub security {
  1564     my( $this ) = @_;
  1565 
  1566     unless( $this->{security} ) {
  1567         require TWiki::Access;
  1568         $this->{security} = new TWiki::Access( $this );
  1569     }
  1570     return $this->{security};
  1571 }
  1572 
  1573 =begin twiki
  1574 
  1575 ---++ ObjectMethod net()
  1576 Get a reference to the net object. Done lazily because not everyone
  1577 needs the net.
  1578 
  1579 =cut
  1580 
  1581 sub net {
  1582     my( $this ) = @_;
  1583 
  1584     unless( $this->{net} ) {
  1585         require TWiki::Net;
  1586         $this->{net} = new TWiki::Net( $this );
  1587     }
  1588     return $this->{net};
  1589 }
  1590 
  1591 =begin twiki
  1592 
  1593 ---++ ObjectMethod finish()
  1594 Break circular references.
  1595 
  1596 =cut
  1597 
  1598 # Note to developers; please undef *all* fields in the object explicitly,
  1599 # whether they are references or not. That way this method is "golden
  1600 # documentation" of the live fields in the object.
  1601 sub finish {
  1602     my $this = shift;
  1603 
  1604     map { $_->finish() } values %{$this->{forms}};
  1605     $this->{plugins}->finish() if $this->{plugins};
  1606     $this->{users}->finish() if $this->{users};
  1607     $this->{prefs}->finish() if $this->{prefs};
  1608     $this->{templates}->finish() if $this->{templates};
  1609     $this->{renderer}->finish() if $this->{renderer};
  1610     $this->{net}->finish() if $this->{net};
  1611     $this->{store}->finish() if $this->{store};
  1612     $this->{search}->finish() if $this->{search};
  1613     $this->{attach}->finish() if $this->{attach};
  1614     $this->{security}->finish() if $this->{security};
  1615     $this->{i18n}->finish() if $this->{i18n};
  1616 
  1617     undef $this->{_HTMLHEADERS};
  1618     undef $this->{cgiQuery};
  1619     undef $this->{urlHost};
  1620     undef $this->{web};
  1621     undef $this->{topic};
  1622     undef $this->{webName};
  1623     undef $this->{topicName};
  1624     undef $this->{_ICONMAP};
  1625     undef $this->{context};
  1626     undef $this->{remoteUser};
  1627     undef $this->{requestedWebName}; # Web name before renaming
  1628     undef $this->{scriptUrlPath};
  1629     undef $this->{user};
  1630     undef $this->{SESSION_TAGS};
  1631     undef $this->{_INCLUDES};
  1632 }
  1633 
  1634 =pod
  1635 
  1636 ---++ ObjectMethod writeLog( $action, $webTopic, $extra, $user )
  1637 
  1638    * =$action= - what happened, e.g. view, save, rename
  1639    * =$wbTopic= - what it happened to
  1640    * =$extra= - extra info, such as minor flag
  1641    * =$user= - user who did the saving (user id)
  1642 Write the log for an event to the logfile
  1643 
  1644 =cut
  1645 
  1646 sub writeLog {
  1647     my $this = shift;
  1648 
  1649     my $action = shift || '';
  1650     my $webTopic = shift || '';
  1651     my $extra = shift || '';
  1652     my $user = shift;
  1653 
  1654     $user ||= $this->{user};
  1655     $user = $this->{users}->getLoginName( $user ) if ($this->{users});
  1656 
  1657     if( $user eq $cfg{DefaultUserLogin} ) {
  1658        my $cgiQuery = $this->{cgiQuery};
  1659        if( $cgiQuery ) {
  1660            my $agent = $cgiQuery->user_agent();
  1661            if( $agent ) {
  1662                $agent =~ m/([\w]+)/;
  1663                $extra .= ' '.$1;
  1664            }
  1665        }
  1666     }
  1667 
  1668     my $remoteAddr = $ENV{REMOTE_ADDR} || '';
  1669     my $text = "$user | $action | $webTopic | $extra | $remoteAddr |";
  1670 
  1671     _writeReport( $this, $TWiki::cfg{LogFileName}, $text );
  1672 }
  1673 
  1674 =pod
  1675 
  1676 ---++ ObjectMethod writeWarning( $text )
  1677 
  1678 Prints date, time, and contents $text to $TWiki::cfg{WarningFileName}, typically
  1679 'warnings.txt'. Use for warnings and errors that may require admin
  1680 intervention. Use this for defensive programming warnings (e.g. assertions).
  1681 
  1682 =cut
  1683 
  1684 sub writeWarning {
  1685     my $this = shift;
  1686     _writeReport( $this, $TWiki::cfg{WarningFileName}, @_ );
  1687 }
  1688 
  1689 =pod
  1690 
  1691 ---++ ObjectMethod writeDebug( $text )
  1692 
  1693 Prints date, time, and contents of $text to $TWiki::cfg{DebugFileName}, typically
  1694 'debug.txt'.  Use for debugging messages.
  1695 
  1696 =cut
  1697 
  1698 sub writeDebug {
  1699     my $this = shift;
  1700     _writeReport( $this, $TWiki::cfg{DebugFileName}, @_ );
  1701 }
  1702 
  1703 # Concatenates date, time, and $text to a log file.
  1704 # The logfilename can optionally use a %DATE% variable to support
  1705 # logs that are rotated once a month.
  1706 # | =$log= | Base filename for log file |
  1707 # | =$message= | Message to print |
  1708 sub _writeReport {
  1709     my ( $this, $log, $message ) = @_;
  1710 
  1711     if ( $log ) {
  1712         require TWiki::Time;
  1713         my $time =
  1714           TWiki::Time::formatTime( time(), '$year$mo', 'servertime');
  1715         $log =~ s/%DATE%/$time/go;
  1716         $time = TWiki::Time::formatTime( time(), undef, 'servertime' );
  1717 
  1718         if( open( FILE, ">>$log" ) ) {
  1719             print FILE "| $time | $message\n";
  1720             close( FILE );
  1721         } else {
  1722             print STDERR 'Could not write "'.$message.'" to '."$log: $!\n";
  1723         }
  1724     }
  1725 }
  1726 
  1727 sub _removeNewlines {
  1728     my( $theTag ) = @_;
  1729     $theTag =~ s/[\r\n]+/ /gs;
  1730     return $theTag;
  1731 }
  1732 
  1733 # Convert relative URLs to absolute URIs
  1734 sub _rewriteURLInInclude {
  1735     my( $theHost, $theAbsPath, $url ) = @_;
  1736 
  1737     # leave out an eventual final non-directory component from the absolute path
  1738     $theAbsPath =~ s/(.*?)[^\/]*$/$1/;
  1739 
  1740     if( $url =~ /^\// ) {
  1741         # fix absolute URL
  1742         $url = $theHost.$url;
  1743     } elsif( $url =~ /^\./ ) {
  1744         # fix relative URL
  1745         $url = $theHost.$theAbsPath.'/'.$url;
  1746     } elsif( $url =~ /^$regex{linkProtocolPattern}:/o ) {
  1747         # full qualified URL, do nothing
  1748     } elsif( $url =~ /^#/ ) {
  1749         # anchor. This needs to be left relative to the including topic
  1750         # so do nothing
  1751     } elsif( $url ) {
  1752         # FIXME: is this test enough to detect relative URLs?
  1753         $url = $theHost.$theAbsPath.'/'.$url;
  1754     }
  1755 
  1756     return $url;
  1757 }
  1758 
  1759 # Add a web reference to a [[...][...]] link in an included topic
  1760 sub _fixIncludeLink {
  1761     my( $web, $link, $label ) = @_;
  1762 
  1763     # Detect absolute and relative URLs and web-qualified wikinames
  1764     if( $link =~ m#^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}:|/)#o ) {
  1765         if( $label ) {
  1766             return "[[$link][$label]]";
  1767         } else {
  1768             return "[[$link]]";
  1769         }
  1770     } elsif( !$label ) {
  1771         # Must be wikiword or spaced-out wikiword (or illegal link :-/)
  1772         $label = $link;
  1773     }
  1774     return "[[$web.$link][$label]]";
  1775 }
  1776 
  1777 # Replace web references in a topic. Called from forEachLine, applying to
  1778 # each non-verbatim and non-literal line.
  1779 sub _fixupIncludedTopic {
  1780     my( $text, $options ) = @_;
  1781 
  1782     my $fromWeb = $options->{web};
  1783 
  1784     unless( $options->{in_noautolink} ) {
  1785         # 'TopicName' to 'Web.TopicName'
  1786         $text =~ s#(?:^|(?<=[\s(]))($regex{wikiWordRegex})(?=\s|\)|$)#$fromWeb.$1#go;
  1787     }
  1788 
  1789     # Handle explicit [[]] everywhere
  1790     # '[[TopicName][...]]' to '[[Web.TopicName][...]]'
  1791     $text =~ s/\[\[([^]]+)\](?:\[([^]]+)\])?\]/
  1792       _fixIncludeLink( $fromWeb, $1, $2 )/geo;
  1793 
  1794     return $text;
  1795 }
  1796 
  1797 # Clean-up HTML text so that it can be shown embedded in a topic
  1798 sub _cleanupIncludedHTML {
  1799     my( $text, $host, $path, $options ) = @_;
  1800 
  1801     # FIXME: Make aware of <base> tag
  1802 
  1803     $text =~ s/^.*?<\/head>//is
  1804       unless ( $options->{disableremoveheaders} );   # remove all HEAD
  1805     $text =~ s/<script.*?<\/script>//gis
  1806       unless ( $options->{disableremovescript} );    # remove all SCRIPTs
  1807     $text =~ s/^.*?<body[^>]*>//is
  1808       unless ( $options->{disableremovebody} );      # remove all to <BODY>
  1809     $text =~ s/(?:\n)<\/body>.*//is
  1810       unless ( $options->{disableremovebody} );      # remove </BODY>
  1811     $text =~ s/(?:\n)<\/html>.*//is
  1812       unless ( $options->{disableremoveheaders} );   # remove </HTML>
  1813     $text =~ s/(<[^>]*>)/_removeNewlines($1)/ges
  1814       unless ( $options->{disablecompresstags} );    # replace newlines in html tags with space
  1815     $text =~ s/(\s(?:href|src|action)=(["']))(.*?)\2/$1._rewriteURLInInclude( $host, $path, $3 ).$2/geois
  1816       unless ( $options->{disablerewriteurls} );
  1817 
  1818     return $text;
  1819 }
  1820 
  1821 =pod
  1822 
  1823 ---++ StaticMethod applyPatternToIncludedText( $text, $pattern ) -> $text
  1824 
  1825 Apply a pattern on included text to extract a subset
  1826 
  1827 =cut
  1828 
  1829 sub applyPatternToIncludedText {
  1830     my( $theText, $thePattern ) = @_;
  1831     $thePattern =~ s/([^\\])([\$\@\%\&\#\'\`\/])/$1\\$2/g;  # escape some special chars
  1832     $thePattern = TWiki::Sandbox::untaintUnchecked( $thePattern );
  1833     $theText = '' unless( $theText =~ s/$thePattern/$1/is );
  1834     return $theText;
  1835 }
  1836 
  1837 # Fetch content from a URL for inclusion by an INCLUDE
  1838 sub _includeUrl {
  1839     my( $this, $url, $pattern, $web, $topic, $raw, $options, $warn ) = @_;
  1840     my $text = '';
  1841 
  1842     # For speed, read file directly if URL matches an attachment directory
  1843     if( $url =~ /^$this->{urlHost}$TWiki::cfg{PubUrlPath}\/([^\/\.]+)\/([^\/\.]+)\/([^\/]+)$/ ) {
  1844         my $incWeb = $1;
  1845         my $incTopic = $2;
  1846         my $incAtt = $3;
  1847         # FIXME: Check for MIME type, not file suffix
  1848         if( $incAtt =~ m/\.(txt|html?)$/i ) {
  1849             unless( $this->{store}->attachmentExists(
  1850                 $incWeb, $incTopic, $incAtt )) {
  1851                 return _includeWarning( $this, $warn, 'bad_attachment', $url );
  1852             }
  1853             if( $incWeb ne $web || $incTopic ne $topic ) {
  1854                 # CODE_SMELL: Does not account for not yet authenticated user
  1855                 unless( $this->security->checkAccessPermission(
  1856                     'VIEW', $this->{user}, undef, undef, $incTopic, $incWeb ) ) {
  1857                     return _includeWarning( $this, $warn, 'access_denied',
  1858                                                    "$incWeb.$incTopic" );
  1859                 }
  1860             }
  1861             $text = $this->{store}->readAttachment( undef, $incWeb, $incTopic,
  1862                                                     $incAtt );
  1863             $text = _cleanupIncludedHTML( $text, $this->{urlHost},
  1864                                           $TWiki::cfg{PubUrlPath}, $options )
  1865               unless $raw;
  1866             $text = applyPatternToIncludedText( $text, $pattern )
  1867               if( $pattern );
  1868             $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
  1869             return $text;
  1870         }
  1871         # fall through; try to include file over http based on MIME setting
  1872     }
  1873 
  1874     return _includeWarning( $this, $warn, 'urls_not_allowed' )
  1875       unless $TWiki::cfg{INCLUDE}{AllowURLs};
  1876 
  1877     # SMELL: should use the URI module from CPAN to parse the URL
  1878     # SMELL: but additional CPAN adds to code bloat
  1879     unless ($url =~ m!^https?:!) {
  1880         $text = _includeWarning( $this, $warn, 'bad_protocol', $url );
  1881         return $text;
  1882     }
  1883 
  1884     my $response = $this->net->getExternalResource( $url );
  1885     if( !$response->is_error()) {
  1886         my $contentType = $response->header('content-type');
  1887         $text = $response->content();
  1888         if( $contentType =~ /^text\/html/ ) {
  1889             if (!$raw) {
  1890                 $url =~ m!^([a-z]+:/*[^/]*)(/[^#?]*)!;
  1891                 $text = _cleanupIncludedHTML( $text, $1, $2, $options );
  1892             }
  1893         } elsif( $contentType =~ /^text\/(plain|css)/ ) {
  1894             # do nothing
  1895         } else {
  1896             $text = _includeWarning(
  1897                 $this, $warn, 'bad_content', $contentType );
  1898         }
  1899         $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
  1900         $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
  1901     } else {
  1902         $text = _includeWarning( $this, $warn, 'geturl_failed',
  1903                                  $url.' '.$response->message() );
  1904     }
  1905 
  1906     return $text;
  1907 }
  1908 
  1909 #
  1910 # SMELL: this is _not_ a tag handler in the sense of other builtin tags,
  1911 # because it requires far more context information (the text of the topic)
  1912 # than any handler.
  1913 # SMELL: as a tag handler that also semi-renders the topic to extract the
  1914 # headings, this handler would be much better as a preRenderingHandler in
  1915 # a plugin (where head, script and verbatim sections are already protected)
  1916 #
  1917 #    * $text  : ref to the text of the current topic
  1918 #    * $topic : the topic we are in
  1919 #    * $web   : the web we are in
  1920 #    * $args  : 'Topic' [web='Web'] [depth='N']
  1921 # Return value: $tableOfContents
  1922 # Handles %<nop>TOC{...}% syntax.  Creates a table of contents
  1923 # using TWiki bulleted
  1924 # list markup, linked to the section headings of a topic. A section heading is
  1925 # entered in one of the following forms:
  1926 #    * $headingPatternSp : \t++... spaces section heading
  1927 #    * $headingPatternDa : ---++... dashes section heading
  1928 #    * $headingPatternHt : &lt;h[1-6]> HTML section heading &lt;/h[1-6]>
  1929 sub _TOC {
  1930     my ( $this, $text, $defaultTopic, $defaultWeb, $args ) = @_;
  1931 
  1932     require TWiki::Attrs;
  1933 
  1934     my $params = new TWiki::Attrs( $args );
  1935     # get the topic name attribute
  1936     my $topic = $params->{_DEFAULT} || $defaultTopic;
  1937 
  1938     # get the web name attribute
  1939     $defaultWeb =~ s#/#.#g;
  1940     my $web = $params->{web} || $defaultWeb;
  1941 
  1942     my $isSameTopic = $web eq $defaultWeb  &&  $topic eq $defaultTopic;
  1943 
  1944     $web =~ s#/#\.#g;
  1945     my $webPath = $web;
  1946     $webPath =~ s/\./\//g;
  1947 
  1948     # get the depth limit attribute
  1949     my $maxDepth = $params->{depth} || $this->{prefs}->getPreferencesValue('TOC_MAX_DEPTH') || 6;
  1950     my $minDepth = $this->{prefs}->getPreferencesValue('TOC_MIN_DEPTH') || 1;
  1951     
  1952     # get the title attribute
  1953     my $title = $params->{title} || $this->{prefs}->getPreferencesValue('TOC_TITLE') || '';
  1954     $title = CGI::span( { class => 'twikiTocTitle' }, $title ) if( $title );
  1955 
  1956     if( $web ne $defaultWeb || $topic ne $defaultTopic ) {
  1957         unless( $this->security->checkAccessPermission
  1958                 ( 'VIEW', $this->{user}, undef, undef, $topic, $web ) ) {
  1959             return $this->inlineAlert( 'alerts', 'access_denied',
  1960                                        $web, $topic );
  1961         }
  1962         my $meta;
  1963         ( $meta, $text ) =
  1964           $this->{store}->readTopic( $this->{user}, $web, $topic );
  1965     }
  1966 
  1967     my $insidePre = 0;
  1968     my $insideVerbatim = 0;
  1969     my $highest = 99;
  1970     my $result  = '';
  1971     my $verbatim = {};
  1972     $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
  1973                                                $verbatim);
  1974     $text = $this->renderer->takeOutBlocks( $text, 'pre',
  1975                                                $verbatim);
  1976 
  1977     # Find URL parameters
  1978     my $query = $this->{cgiQuery};
  1979     my @qparams = ();
  1980     foreach my $name ( $query->param ) {
  1981       next if ($name eq 'keywords');
  1982       next if ($name eq 'topic');
  1983       next if ($name eq 'text');
  1984       push @qparams, $name => $query->param($name);
  1985     }
  1986 
  1987     # SMELL: this handling of <pre> is archaic.
  1988     # SMELL: use forEachLine
  1989     foreach my $line ( split( /\r?\n/, $text ) ) {
  1990         my $level;
  1991         if ( $line =~ m/$regex{headerPatternDa}/o ) {
  1992             $line = $2;
  1993             $level = length $1;
  1994         } elsif ( $line =~ m/$regex{headerPatternHt}/io ) {
  1995             $line = $2;
  1996             $level = $1;
  1997         } else {
  1998             next;
  1999         }
  2000 
  2001         if( $line && ($level >= $minDepth) && ($level <= $maxDepth) ) {
  2002             # cut TOC exclude '---+ heading !! exclude this bit'
  2003             $line =~ s/\s*$regex{headerPatternNoTOC}.+$//go;
  2004             next unless $line;
  2005             my $anchor = $this->renderer->makeAnchorName( $line );
  2006             $highest = $level if( $level < $highest );
  2007             my $tabs = "\t" x $level;
  2008             # Remove *bold*, _italic_ and =fixed= formatting
  2009             $line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
  2010             $line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
  2011             $line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
  2012             # Prevent WikiLinks
  2013             $line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g;  # '[[...][...]]'
  2014             $line =~ s/\[\[(.*?)\]\]/$1/ge;        # '[[...]]'
  2015             $line =~ s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1<nop>$3/go;  # 'Web.TopicName'
  2016             $line =~ s/([\s\(])($regex{wikiWordRegex})/$1<nop>$2/go;  # 'TopicName'
  2017             $line =~ s/([\s\(])($regex{abbrevRegex})/$1<nop>$2/go;    # 'TLA'
  2018             $line =~ s/([\s\-\*\(])([$regex{mixedAlphaNum}]+\:)/$1<nop>$2/go; # 'Site:page' Interwiki link
  2019             # Prevent manual links
  2020             $line =~ s/<[\/]?a\b[^>]*>//gi;
  2021             # create linked bullet item, using a relative link to anchor
  2022             my $target = $isSameTopic ?
  2023                          _make_params(0, '#'=>$anchor,@qparams) :
  2024                          $this->getScriptUrl(0,'view',$web,$topic,'#'=>$anchor,@qparams);
  2025             $line = $tabs.'* ' .  CGI::a({href=>$target},$line);
  2026             $result .= "\n".$line;
  2027         }
  2028     }
  2029 
  2030     if( $result ) {
  2031         if( $highest > 1 ) {
  2032             # left shift TOC
  2033             $highest--;
  2034             $result =~ s/^\t{$highest}//gm;
  2035         }
  2036         return CGI::div( { class=>'twikiToc' }, "$title$result\n" );
  2037     } else {
  2038         return '';
  2039     }
  2040 }
  2041 
  2042 =pod
  2043 
  2044 ---++ ObjectMethod inlineAlert($template, $def, ... ) -> $string
  2045 
  2046 Format an error for inline inclusion in rendered output. The message string
  2047 is obtained from the template 'oops'.$template, and the DEF $def is
  2048 selected. The parameters (...) are used to populate %PARAM1%..%PARAMn%
  2049 
  2050 =cut
  2051 
  2052 sub inlineAlert {
  2053     my $this = shift;
  2054     my $template = shift;
  2055     my $def = shift;
  2056 
  2057     my $text = $this->templates->readTemplate( 'oops'.$template,
  2058                                                  $this->getSkin() );
  2059     if( $text ) {
  2060         my $blah = $this->templates->expandTemplate( $def );
  2061         $text =~ s/%INSTANTIATE%/$blah/;
  2062         # web and topic can be anything; they are not used
  2063         $text = $this->handleCommonTags( $text, $this->{webName},
  2064                                          $this->{topicName} );
  2065         my $n = 1;
  2066         while( defined( my $param = shift )) {
  2067             $text =~ s/%PARAM$n%/$param/g;
  2068             $n++;
  2069         }
  2070 
  2071     } else {
  2072         $text = CGI::h1('TWiki Installation Error')
  2073           . 'Template "'.$template.'" not found.'.CGI::p()
  2074             . 'Check your configuration settings for {TemplateDir} and {TemplatePath}';
  2075     }
  2076 
  2077     return $text;
  2078 }
  2079 
  2080 =pod
  2081 
  2082 ---++ StaticMethod parseSections($text) -> ($string,$sectionlistref)
  2083 
  2084 Generic parser for sections within a topic. Sections are delimited
  2085 by STARTSECTION and ENDSECTION, which may be nested, overlapped or
  2086 otherwise abused. The parser builds an array of sections, which is
  2087 ordered by the order of the STARTSECTION within the topic. It also
  2088 removes all the SECTION tags from the text, and returns the text
  2089 and the array of sections.
  2090 
  2091 Each section is a =TWiki::Attrs= object, which contains the attributes
  2092 {type, name, start, end}
  2093 where start and end are character offsets in the
  2094 string *after all section tags have been removed*. All sections
  2095 are required to be uniquely named; if a section is unnamed, it
  2096 will be given a generated name. Sections may overlap or nest.
  2097 
  2098 See test/unit/Fn_SECTION.pm for detailed testcases that
  2099 round out the spec.
  2100 
  2101 =cut
  2102 
  2103 sub parseSections {
  2104     #my( $text _ = @_;
  2105     my %sections;
  2106     my @list = ();
  2107 
  2108     my $seq = 0;
  2109     my $ntext = '';
  2110     my $offset = 0;
  2111     foreach my $bit (split(/(%(?:START|END)SECTION(?:{.*?})?%)/, $_[0] )) {
  2112         if( $bit =~ /^%STARTSECTION(?:{(.*)})?%$/) {
  2113             require TWiki::Attrs;
  2114             my $attrs = new TWiki::Attrs( $1 );
  2115             $attrs->{type} ||= 'section';
  2116             $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} ||
  2117               '_SECTION'.$seq++;
  2118             delete $attrs->{_DEFAULT};
  2119             my $id = $attrs->{type}.':'.$attrs->{name};
  2120             if( $sections{$id} ) {
  2121                 # error, this named section already defined, ignore
  2122                 next;
  2123             }
  2124             # close open unnamed sections of the same type
  2125             foreach my $s ( @list ) {
  2126                 if( $s->{end} < 0 && $s->{type} eq $attrs->{type} &&
  2127                       $s->{name} =~ /^_SECTION\d+$/ ) {
  2128                     $s->{end} = $offset;
  2129                 }
  2130             }
  2131             $attrs->{start} = $offset;
  2132             $attrs->{end} = -1; # open section
  2133             $sections{$id} = $attrs;
  2134             push( @list, $attrs );
  2135         } elsif( $bit =~ /^%ENDSECTION(?:{(.*)})?%$/ ) {
  2136             require TWiki::Attrs;
  2137             my $attrs = new TWiki::Attrs( $1 );
  2138             $attrs->{type} ||= 'section';
  2139             $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} || '';
  2140             delete $attrs->{_DEFAULT};
  2141             unless( $attrs->{name} ) {
  2142                 # find the last open unnamed section of this type
  2143                 foreach my $s ( reverse @list ) {
  2144                     if( $s->{end} == -1 &&
  2145                           $s->{type} eq $attrs->{type} &&
  2146                          $s->{name} =~ /^_SECTION\d+$/ ) {
  2147                         $attrs->{name} = $s->{name};
  2148                         last;
  2149                     }
  2150                 }
  2151                 # ignore it if no matching START found
  2152                 next unless $attrs->{name};
  2153             }
  2154             my $id = $attrs->{type}.':'.$attrs->{name};
  2155             if( !$sections{$id} || $sections{$id}->{end} >= 0 ) {
  2156                 # error, no such open section, ignore
  2157                 next;
  2158             }
  2159             $sections{$id}->{end} = $offset;
  2160         } else {
  2161             $ntext .= $bit;
  2162             $offset = length( $ntext );
  2163         }
  2164     }
  2165 
  2166     # close open sections
  2167     foreach my $s ( @list ) {
  2168         $s->{end} = $offset if $s->{end} < 0;
  2169     }
  2170 
  2171     return( $ntext, \@list );
  2172 }
  2173 
  2174 =pod
  2175 
  2176 ---++ ObjectMethod expandVariablesOnTopicCreation ( $text, $user, $web, $topic ) -> $text
  2177 
  2178    * =$text= - text to expand
  2179    * =$user= - This is the user expanded in e.g. %USERNAME. Optional, defaults to logged-in user.
  2180 Expand limited set of variables during topic creation. These are variables
  2181 expected in templates that must be statically expanded in new content.
  2182    * =$web= - name of web
  2183    * =$topic= - name of topic
  2184 
  2185 # SMELL: no plugin handler
  2186 
  2187 =cut
  2188 
  2189 sub expandVariablesOnTopicCreation {
  2190     my ( $this, $text, $user, $theWeb, $theTopic ) = @_;
  2191 
  2192     $user ||= $this->{user};
  2193 
  2194     # Chop out templateonly sections
  2195     my( $ntext, $sections ) = parseSections( $text );
  2196     if( scalar( @$sections )) {
  2197         # Note that if named templateonly sections overlap, the behaviour is undefined.
  2198         foreach my $s ( reverse @$sections ) {
  2199             if( $s->{type} eq 'templateonly' ) {
  2200                 $ntext = substr($ntext, 0, $s->{start})
  2201                        . substr($ntext, $s->{end}, length($ntext));
  2202             } else {
  2203                 # put back non-templateonly sections
  2204                 my $start = $s->remove('start');
  2205                 my $end = $s->remove('end');
  2206                 $ntext = substr($ntext, 0, $start).
  2207                   '%STARTSECTION{'.$s->stringify().'}%'.
  2208                     substr($ntext, $start, $end - $start).
  2209                       '%ENDSECTION{'.$s->stringify().'}%'.
  2210                         substr($ntext, $end, length($ntext));
  2211             }
  2212         }
  2213         $text = $ntext;
  2214     }
  2215 
  2216     # Make sure func works, for registered tag handlers
  2217     $TWiki::Plugins::SESSION = $this;
  2218 
  2219     # Note: it may look dangerous to override the user this way, but
  2220     # it's actually quite safe, because only a subset of tags are
  2221     # expanded during topic creation. if the set of tags expanded is
  2222     # extended, then the impact has to be considered.
  2223     my $safe = $this->{user};
  2224     $this->{user} = $user;
  2225     $text = _processTags( $this, $text, \&_expandTagOnTopicCreation, 16 );
  2226 
  2227     # expand all variables for type="expandvariables" sections
  2228     ( $ntext, $sections ) = parseSections( $text );
  2229     if( scalar( @$sections )) {
  2230         $theWeb   ||= $this->{session}->{webName};
  2231         $theTopic ||= $this->{session}->{topicName};
  2232         foreach my $s ( reverse @$sections ) {
  2233             if( $s->{type} eq 'expandvariables' ) {
  2234                 my $etext = substr( $ntext, $s->{start}, $s->{end} - $s->{start} );
  2235                 expandAllTags( $this, \$etext, $theTopic, $theWeb );
  2236                 $ntext = substr( $ntext, 0, $s->{start})
  2237                        . $etext
  2238                        . substr( $ntext, $s->{end}, length($ntext) );
  2239             } else {
  2240                 # put back non-expandvariables sections
  2241                 my $start = $s->remove('start');
  2242                 my $end = $s->remove('end');
  2243                 $ntext = substr($ntext, 0, $start).
  2244                   '%STARTSECTION{'.$s->stringify().'}%'.
  2245                     substr($ntext, $start, $end - $start).
  2246                       '%ENDSECTION{'.$s->stringify().'}%'.
  2247                         substr($ntext, $end, length($ntext));
  2248             }
  2249         }
  2250         $text = $ntext;
  2251     }
  2252 
  2253     # kill markers used to prevent variable expansion
  2254     $text =~ s/%NOP%//g;
  2255     $this->{user} = $safe;
  2256     return $text;
  2257 }
  2258 
  2259 =pod
  2260 
  2261 ---++ StaticMethod entityEncode( $text, $extras ) -> $encodedText
  2262 
  2263 Escape special characters to HTML numeric entities. This is *not* a generic
  2264 encoding, it is tuned specifically for use in TWiki.
  2265 
  2266 HTML4.0 spec:
  2267 "Certain characters in HTML are reserved for use as markup and must be
  2268 escaped to appear literally. The "&lt;" character may be represented with
  2269 an <em>entity</em>, <strong class=html>&amp;lt;</strong>. Similarly, "&gt;"
  2270 is escaped as <strong class=html>&amp;gt;</strong>, and "&amp;" is escaped
  2271 as <strong class=html>&amp;amp;</strong>. If an attribute value contains a
  2272 double quotation mark and is delimited by double quotation marks, then the
  2273 quote should be escaped as <strong class=html>&amp;quot;</strong>.</p>
  2274 
  2275 Other entities exist for special characters that cannot easily be entered
  2276 with some keyboards..."
  2277 
  2278 This method encodes HTML special and any non-printable ascii
  2279 characters (except for \n and \r) using numeric entities.
  2280 
  2281 FURTHER this method also encodes characters that are special in TWiki
  2282 meta-language.
  2283 
  2284 $extras is an optional param that may be used to include *additional*
  2285 characters in the set of encoded characters. It should be a string
  2286 containing the additional chars.
  2287 
  2288 =cut
  2289 
  2290 sub entityEncode {
  2291     my( $text, $extra) = @_;
  2292     $extra ||= '';
  2293 
  2294     # encode all non-printable 7-bit chars (< \x1f),
  2295     # except \n (\xa) and \r (\xd)
  2296     # encode HTML special characters '>', '<', '&', ''' and '"'.
  2297     # encode TML special characters '%', '|', '[', ']', '@', '_',
  2298     # '*', and '='
  2299     $text =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|$extra])/'&#'.ord($1).';'/ge;
  2300     return $text;
  2301 }
  2302 
  2303 =pod
  2304 
  2305 ---++ StaticMethod entityDecode ( $encodedText ) -> $text
  2306 
  2307 Decodes all numeric entities (e.g. &amp;#123;). _Does not_ decode
  2308 named entities such as &amp;amp; (use HTML::Entities for that)
  2309 
  2310 =cut
  2311 
  2312 sub entityDecode {
  2313     my $text = shift;
  2314 
  2315     $text =~ s/&#(\d+);/chr($1)/ge;
  2316     return $text;
  2317 }
  2318 
  2319 =pod
  2320 
  2321 ---++ StaticMethod urlEncodeAttachment ( $text )
  2322 
  2323 For attachments, URL-encode specially to 'freeze' any characters >127 in the
  2324 site charset (e.g. ISO-8859-1 or KOI8-R), by doing URL encoding into native
  2325 charset ($siteCharset) - used when generating attachment URLs, to enable the
  2326 web server to serve attachments, including images, directly.  
  2327 
  2328 This encoding is required to handle the cases of:
  2329 
  2330     - browsers that generate UTF-8 URLs automatically from site charset URLs - now quite common
  2331     - web servers that directly serve attachments, using the site charset for
  2332       filenames, and cannot convert UTF-8 URLs into site charset filenames
  2333 
  2334 The aim is to prevent the browser from converting a site charset URL in the web
  2335 page to a UTF-8 URL, which is the default.  Hence we 'freeze' the URL into the
  2336 site character set through URL encoding. 
  2337 
  2338 In two cases, no URL encoding is needed:  For EBCDIC mainframes, we assume that 
  2339 site charset URLs will be translated (outbound and inbound) by the web server to/from an
  2340 EBCDIC character set. For sites running in UTF-8, there's no need for TWiki to
  2341 do anything since all URLs and attachment filenames are already in UTF-8.
  2342 
  2343 =cut
  2344 
  2345 sub urlEncodeAttachment {
  2346     my( $text ) = @_;
  2347 
  2348     my $usingEBCDIC = ( 'A' eq chr(193) ); 	# Only true on EBCDIC mainframes
  2349 
  2350     if( (defined($TWiki::cfg{Site}{CharSet}) and $TWiki::cfg{Site}{CharSet} eq "utf-8") or $usingEBCDIC ) {
  2351 	# Just let browser do UTF-8 URL encoding 
  2352 	return $text;
  2353     }
  2354 
  2355     # Freeze into site charset through URL encoding
  2356     return urlEncode( $text );
  2357 }
  2358 
  2359 
  2360 =pod
  2361 
  2362 ---++ StaticMethod urlEncode( $string ) -> encoded string
  2363 
  2364 Encode by converting characters that are illegal in URLs to
  2365 their %NN equivalents. This method is used for encoding
  2366 strings that must be embedded _verbatim_ in URLs; it cannot
  2367 be applied to URLs themselves, as it escapes reserved
  2368 characters such as = and ?.
  2369 
  2370 RFC 1738, Dec. '94:
  2371     <verbatim>
  2372     ...Only alphanumerics [0-9a-zA-Z], the special
  2373     characters $-_.+!*'(), and reserved characters used for their
  2374     reserved purposes may be used unencoded within a URL.
  2375     </verbatim>
  2376 
  2377 Reserved characters are $&+,/:;=?@ - these are _also_ encoded by
  2378 this method.
  2379 
  2380 This URL-encoding handles all character encodings including ISO-8859-*,
  2381 KOI8-R, EUC-* and UTF-8. 
  2382 
  2383 This may not handle EBCDIC properly, as it generates an EBCDIC URL-encoded
  2384 URL, but mainframe web servers seem to translate this outbound before it hits browser
  2385 - see CGI::Util::escape for another approach.
  2386 
  2387 =cut
  2388 
  2389 sub urlEncode {
  2390     my $text = shift;
  2391 
  2392     $text =~ s/([^0-9a-zA-Z-_.:~!*'\/%])/'%'.sprintf('%02x',ord($1))/ge;
  2393 
  2394     return $text;
  2395 }
  2396 
  2397 =pod
  2398 
  2399 ---++ StaticMethod urlDecode( $string ) -> decoded string
  2400 
  2401 Reverses the encoding done in urlEncode.
  2402 
  2403 =cut
  2404 
  2405 sub urlDecode {
  2406     my $text = shift;
  2407 
  2408     $text =~ s/%([\da-f]{2})/chr(hex($1))/gei;
  2409 
  2410     return $text;
  2411 }
  2412 
  2413 =pod
  2414 
  2415 ---++ StaticMethod isTrue( $value, $default ) -> $boolean
  2416 
  2417 Returns 1 if =$value= is true, and 0 otherwise. "true" means set to
  2418 something with a Perl true value, with the special cases that "off",
  2419 "false" and "no" (case insensitive) are forced to false. Leading and
  2420 trailing spaces in =$value= are ignored.
  2421 
  2422 If the value is undef, then =$default= is returned. If =$default= is
  2423 not specified it is taken as 0.
  2424 
  2425 =cut
  2426 
  2427 sub isTrue {
  2428     my( $value, $default ) = @_;
  2429 
  2430     $default ||= 0;
  2431 
  2432     return $default unless defined( $value );
  2433 
  2434     $value =~ s/^\s*(.*?)\s*$/$1/gi;
  2435     $value =~ s/off//gi;
  2436     $value =~ s/no//gi;
  2437     $value =~ s/false//gi;
  2438     return ( $value ) ? 1 : 0;
  2439 }
  2440 
  2441 =pod
  2442 
  2443 ---++ StaticMethod spaceOutWikiWord( $word, $sep ) -> $string
  2444 
  2445 Spaces out a wiki word by inserting a string (default: one space) between each word component.
  2446 With parameter $sep any string may be used as separator between the word components; if $sep is undefined it defaults to a space.
  2447 
  2448 =cut
  2449 
  2450 sub spaceOutWikiWord {
  2451     my $word = shift || '';
  2452     my $sep = shift || ' ';
  2453     $word =~ s/([$regex{lowerAlpha}])([$regex{upperAlpha}$regex{numeric}]+)/$1$sep$2/go;
  2454     $word =~ s/([$regex{numeric}])([$regex{upperAlpha}])/$1$sep$2/go;
  2455     return $word;
  2456 }
  2457 
  2458 =pod
  2459 
  2460 ---++ ObjectMethod expandAllTags(\$text, $topic, $web, $meta)
  2461 Expands variables by replacing the variables with their
  2462 values. Some example variables: %<nop>TOPIC%, %<nop>SCRIPTURL%,
  2463 %<nop>WIKINAME%, etc.
  2464 $web and $incs are passed in for recursive include expansion. They can
  2465 safely be undef.
  2466 The rules for tag expansion are:
  2467    1 Tags are expanded left to right, in the order they are encountered.
  2468    1 Tags are recursively expanded as soon as they are encountered -
  2469      the algorithm is inherently single-pass
  2470    1 A tag is not "encountered" until the matching }% has been seen, by
  2471      which time all tags in parameters will have been expanded
  2472    1 Tag expansions that create new tags recursively are limited to a
  2473      set number of hierarchical levels of expansion
  2474 
  2475 =cut
  2476 
  2477 sub expandAllTags {
  2478     my $this = shift;
  2479     my $text = shift; # reference
  2480     my ( $topic, $web, $meta ) = @_;
  2481     $web =~ s#\.#/#go;
  2482 
  2483     # push current context
  2484     my $memTopic = $this->{SESSION_TAGS}{TOPIC};
  2485     my $memWeb   = $this->{SESSION_TAGS}{WEB};
  2486 
  2487     $this->{SESSION_TAGS}{TOPIC}   = $topic;
  2488     $this->{SESSION_TAGS}{WEB}     = $web;
  2489 
  2490     # Escape ' !%VARIABLE%'
  2491     $$text =~ s/(?<=\s)!%($regex{tagNameRegex})/&#37;$1/g;
  2492 
  2493     # Make sure func works, for registered tag handlers
  2494     $TWiki::Plugins::SESSION = $this;
  2495 
  2496     # NOTE TO DEBUGGERS
  2497     # The depth parameter in the following call controls the maximum number
  2498     # of levels of expansion. If it is set to 1 then only tags in the
  2499     # topic will be expanded; tags that they in turn generate will be
  2500     # left unexpanded. If it is set to 2 then the expansion will stop after
  2501     # the first recursive inclusion, and so on. This is incredible useful
  2502     # when debugging. The default is set to 16
  2503     # to match the original limit on search expansion, though this of
  2504     # course applies to _all_ tags and not just search.
  2505     $$text = _processTags( $this, $$text, \&_expandTagOnTopicRendering,
  2506                                   16, @_ );
  2507 
  2508     # restore previous context
  2509     $this->{SESSION_TAGS}{TOPIC}   = $memTopic;
  2510     $this->{SESSION_TAGS}{WEB}     = $memWeb;
  2511 }
  2512 
  2513 # set this to 1 to print debugging
  2514 sub TRACE_TAG_PARSER { 0 }
  2515 
  2516 # Process TWiki %TAGS{}% by parsing the input tokenised into
  2517 # % separated sections. The parser is a simple stack-based parse,
  2518 # sufficient to ensure nesting of tags is correct, but no more
  2519 # than that.
  2520 # $depth limits the number of recursive expansion steps that
  2521 # can be performed on expanded tags.
  2522 sub _processTags {
  2523     my $this = shift;
  2524     my $text = shift;
  2525     my $tagf = shift;
  2526     my $tell = 0;
  2527 
  2528     return '' unless defined( $text );
  2529 
  2530     my $depth = shift;
  2531 
  2532     # my( $topic, $web, $meta ) = @_;
  2533 
  2534     unless ( $depth ) {
  2535         my $mess = "Max recursive depth reached: $text";
  2536         $this->writeWarning( $mess );
  2537         # prevent recursive expansion that just has been detected
  2538         # from happening in the error message
  2539         $text =~ s/%(.*?)%/$1/go;
  2540         return $text;
  2541     }
  2542 
  2543     my $verbatim = {};
  2544     $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
  2545                                                $verbatim);
  2546 
  2547     # See Item1442
  2548     #my $percent = ($TranslationToken x 3).'%'.($TranslationToken x 3);
  2549 
  2550     my @queue = split( /(%)/, $text );
  2551     my @stack;
  2552     my $stackTop = ''; # the top stack entry. Done this way instead of
  2553     # referring to the top of the stack for efficiency. This var
  2554     # should be considered to be $stack[$#stack]
  2555 
  2556     while ( scalar( @queue )) {
  2557         my $token = shift( @queue );
  2558         print STDERR ' ' x $tell,"PROCESSING $token \n" if TRACE_TAG_PARSER;
  2559 
  2560         # each % sign either closes an existing stacked context, or
  2561         # opens a new context.
  2562         if ( $token eq '%' ) {
  2563             print STDERR ' ' x $tell,"CONSIDER $stackTop\n" if TRACE_TAG_PARSER;
  2564             # If this is a closing }%, try to rejoin the previous
  2565             # tokens until we get to a valid tag construct. This is
  2566             # a bit of a hack, but it's hard to think of a better
  2567             # way to do this without a full parse that takes % signs
  2568             # in tag parameters into account.
  2569             if ( $stackTop =~ /}$/s ) {
  2570                 while ( scalar( @stack) &&
  2571                         $stackTop !~ /^%($regex{tagNameRegex}){.*}$/so ) {
  2572                     my $top = $stackTop;
  2573                     print STDERR ' ' x $tell,"COLLAPSE $top \n" if TRACE_TAG_PARSER;
  2574                     $stackTop = pop( @stack ) . $top;
  2575                 }
  2576             }
  2577             # /s so you can have newlines in parameters
  2578             if ( $stackTop =~ m/^%(($regex{tagNameRegex})(?:{(.*)})?)$/so ) {
  2579                 my( $expr, $tag, $args ) = ( $1, $2, $3 );
  2580                 print STDERR ' ' x $tell,"POP $tag\n" if TRACE_TAG_PARSER;
  2581                 my $e = &$tagf( $this, $tag, $args, @_ );
  2582 
  2583                 if ( defined( $e )) {
  2584                     print STDERR ' ' x $tell--,"EXPANDED $tag -> $e\n" if TRACE_TAG_PARSER;
  2585                     $stackTop = pop( @stack );
  2586                     # Recursively expand tags in the expansion of $tag
  2587                     $stackTop .= _processTags($this, $e, $tagf, $depth-1, @_ );
  2588                 } else { # expansion failed
  2589                     print STDERR ' ' x $tell++,"EXPAND $tag FAILED\n" if TRACE_TAG_PARSER;
  2590                     # To handle %NOP
  2591                     # correctly, we have to handle the %VAR% case differently
  2592                     # to the %VAR{}% case when a variable expansion fails.
  2593                     # This is so that recursively define variables e.g.
  2594                     # %A%B%D% expand correctly, but at the same time we ensure
  2595                     # that a mismatched }% can't accidentally close a context
  2596                     # that was left open when a tag expansion failed.
  2597                     # However Cairo didn't do this, so for compatibility
  2598                     # we have to accept that %NOP can never be fixed. if it
  2599                     # could, then we could uncomment the following:
  2600 
  2601                     #if( $stackTop =~ /}$/ ) {
  2602                     #    # %VAR{...}% case
  2603                     #    # We need to push the unexpanded expression back
  2604                     #    # onto the stack, but we don't want it to match the
  2605                     #    # tag expression again. So we protect the %'s
  2606                     #    $stackTop = $percent.$expr.$percent;
  2607                     #} else
  2608                     {
  2609                         # %VAR% case.
  2610                         # In this case we *do* want to match the tag expression
  2611                         # again, as an embedded %VAR% may have expanded to
  2612                         # create a valid outer expression. This is directly
  2613                         # at odds with the %VAR{...}% case.
  2614                         push( @stack, $stackTop );
  2615                         $stackTop = '%'; # open new context
  2616                     }
  2617                 }
  2618             } else {
  2619                 push( @stack, $stackTop );
  2620                 $stackTop = '%'; # push a new context
  2621                 $tell++ if TRACE_TAG_PARSER;
  2622             }
  2623         } else {
  2624             $stackTop .= $token;
  2625         }
  2626     }
  2627 
  2628     # Run out of input. Gather up everything in the stack.
  2629     while ( scalar( @stack )) {
  2630         my $expr = $stackTop;
  2631         $stackTop = pop( @stack );
  2632         $stackTop .= $expr;
  2633     }
  2634 
  2635     #$stackTop =~ s/$percent/%/go;
  2636 
  2637     $this->renderer->putBackBlocks( \$stackTop, $verbatim, 'verbatim' );
  2638 
  2639     print STDERR "FINAL $stackTop\n" if TRACE_TAG_PARSER;
  2640 
  2641     return $stackTop;
  2642 }
  2643 
  2644 # Handle expansion of a tag during topic rendering
  2645 # $tag is the tag name
  2646 # $args is the bit in the {} (if there are any)
  2647 # $topic and $web should be passed for dynamic tags (not needed for
  2648 # session or constant tags
  2649 sub _expandTagOnTopicRendering {
  2650     my $this = shift;
  2651     my $tag = shift;
  2652     my $args = shift;
  2653     # my( $topic, $web, $meta ) = @_;
  2654     require TWiki::Attrs;
  2655 
  2656     my $e = $this->{prefs}->getPreferencesValue( $tag );
  2657     unless( defined( $e )) {
  2658         $e = $this->{SESSION_TAGS}{$tag};
  2659         if( !defined( $e ) && defined( $functionTags{$tag} )) {
  2660             $e = &{$functionTags{$tag}}
  2661               ( $this, new TWiki::Attrs(
  2662                   $args, $contextFreeSyntax{$tag} ), @_ );
  2663         }
  2664     }
  2665     return $e;
  2666 }
  2667 
  2668 # Handle expansion of a tag during new topic creation. When creating a
  2669 # new topic from a template we only expand a subset of the available legal
  2670 # tags, and we expand %NOP% differently.
  2671 sub _expandTagOnTopicCreation {
  2672     my $this = shift;
  2673     # my( $tag, $args, $topic, $web ) = @_;
  2674 
  2675     # Required for Cairo compatibility. Ignore %NOP{...}%
  2676     # %NOP% is *not* ignored until all variable expansion is complete,
  2677     # otherwise them inside-out rule would remove it too early e.g.
  2678     # %GM%NOP%TIME -> %GMTIME -> 12:00. So we ignore it here and scrape it
  2679     # out later. We *have* to remove %NOP{...}% because it can foul up
  2680     # brace-matching.
  2681     return '' if $_[0] eq 'NOP' && defined $_[1];
  2682 
  2683     # Only expand a subset of legal tags. Warning: $this->{user} may be
  2684     # overridden during this call, when a new user topic is being created.
  2685     # This is what we want to make sure new user templates are populated
  2686     # correctly, but you need to think about this if you extend the set of
  2687     # tags expanded here.
  2688     return undef unless $_[0] =~ /^(URLPARAM|DATE|(SERVER|GM)TIME|(USER|WIKI)NAME|WIKIUSERNAME|USERINFO)$/;
  2689 
  2690     return _expandTagOnTopicRendering( $this, @_ );
  2691 }
  2692 
  2693 =pod
  2694 
  2695 ---++ ObjectMethod enterContext( $id, $val )
  2696 
  2697 Add the context id $id into the set of active contexts. The $val
  2698 can be anything you like, but should always evaluate to boolean
  2699 TRUE.
  2700 
  2701 An example of the use of contexts is in the use of tag
  2702 expansion. The commonTagsHandler in plugins is called every
  2703 time tags need to be expanded, and the context of that expansion
  2704 is signalled by the expanding module using a context id. So the
  2705 forms module adds the context id "form" before invoking common
  2706 tags expansion.
  2707 
  2708 Contexts are not just useful for tag expansion; they are also
  2709 relevant when rendering.
  2710 
  2711 Contexts are intended for use mainly by plugins. Core modules can
  2712 use $session->inContext( $id ) to determine if a context is active.
  2713 
  2714 =cut
  2715 
  2716 sub enterContext {
  2717     my( $this, $id, $val ) = @_;
  2718     $val ||= 1;
  2719     $this->{context}->{$id} = $val;
  2720 }
  2721 
  2722 =pod
  2723 
  2724 ---++ ObjectMethod leaveContext( $id )
  2725 
  2726 Remove the context id $id from the set of active contexts.
  2727 (see =enterContext= for more information on contexts)
  2728 
  2729 =cut
  2730 
  2731 sub leaveContext {
  2732     my( $this, $id ) = @_;
  2733     my $res = $this->{context}->{$id};
  2734     delete $this->{context}->{$id};
  2735     return $res;
  2736 }
  2737 
  2738 =pod
  2739 
  2740 ---++ ObjectMethod inContext( $id )
  2741 
  2742 Return the value for the given context id
  2743 (see =enterContext= for more information on contexts)
  2744 
  2745 =cut
  2746 
  2747 sub inContext {
  2748     my( $this, $id ) = @_;
  2749     return $this->{context}->{$id};
  2750 }
  2751 
  2752 =pod
  2753 
  2754 ---++ StaticMethod registerTagHandler( $tag, $fnref )
  2755 
  2756 STATIC Add a tag handler to the function tag handlers.
  2757    * =$tag= name of the tag e.g. MYTAG
  2758    * =$fnref= Function to execute. Will be passed ($session, \%params, $web, $topic )
  2759 
  2760 =cut
  2761 
  2762 sub registerTagHandler {
  2763     my ( $tag, $fnref, $syntax ) = @_;
  2764     $functionTags{$tag} = \&$fnref;
  2765     if( $syntax && $syntax eq 'context-free' ) {
  2766         $contextFreeSyntax{$tag} = 1;
  2767     }
  2768 }
  2769 
  2770 =pod=
  2771 
  2772 ---++ StaticMethod registerRESTHandler( $subject, $verb, \&fn )
  2773 
  2774 Adds a function to the dispatch table of the REST interface 
  2775 for a given subject. See TWikiScripts#rest for more info.
  2776 
  2777    * =$subject= - The subject under which the function will be registered.
  2778    * =$verb= - The verb under which the function will be registered.
  2779    * =\&fn= - Reference to the function.
  2780 
  2781 The handler function must be of the form:
  2782 <verbatim>
  2783 sub handler(\%session,$subject,$verb) -> $text
  2784 </verbatim>
  2785 where:
  2786    * =\%session= - a reference to the TWiki session object (may be ignored)
  2787    * =$subject= - The invoked subject (may be ignored)
  2788    * =$verb= - The invoked verb (may be ignored)
  2789 
  2790 *Since:* TWiki::Plugins::VERSION 1.1
  2791 
  2792 =cut=
  2793 
  2794 sub registerRESTHandler {
  2795    my ( $subject, $verb, $fnref) = @_;
  2796    $restDispatch{$subject}{$verb} = \&$fnref;
  2797 }
  2798 
  2799 =pod=
  2800 
  2801 ---++ StaticMethod restDispatch( $subject, $verb) => \&fn
  2802 
  2803 Returns the handler  function associated to the given $subject and $werb,
  2804 or undef if none is found.
  2805 
  2806 *Since:* TWiki::Plugins::VERSION 1.1
  2807 
  2808 =cut=
  2809 
  2810 sub restDispatch {
  2811    my ( $subject, $verb) = @_;
  2812    my $s=$restDispatch{$subject};
  2813    if (defined($s)) {
  2814        return $restDispatch{$subject}{$verb};
  2815    } else {
  2816        return undef;
  2817    }
  2818 }
  2819 
  2820 =pod
  2821 
  2822 ---++ ObjectMethod handleCommonTags( $text, $web, $topic, $meta ) -> $text
  2823 
  2824 Processes %<nop>VARIABLE%, and %<nop>TOC% syntax; also includes
  2825 'commonTagsHandler' plugin hook.
  2826 
  2827 Returns the text of the topic, after file inclusion, variable substitution,
  2828 table-of-contents generation, and any plugin changes from commonTagsHandler.
  2829 
  2830 $meta may be undef when, for example, expanding templates, or one-off strings
  2831 at a time when meta isn't available.
  2832 
  2833 =cut
  2834 
  2835 sub handleCommonTags {
  2836     my( $this, $text, $theWeb, $theTopic, $meta ) = @_;
  2837 
  2838     ASSERT($theWeb) if DEBUG;
  2839     ASSERT($theTopic) if DEBUG;
  2840 
  2841     return $text unless $text;
  2842     my $verbatim={};
  2843     # Plugin Hook (for cache Plugins only)
  2844     $this->{plugins}->beforeCommonTagsHandler(
  2845         $text, $theTopic, $theWeb, $meta );
  2846 
  2847     #use a "global var", so included topics can extract and putback 
  2848     #their verbatim blocks safetly.
  2849     $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
  2850                                               $verbatim);
  2851 
  2852     my $memW = $this->{SESSION_TAGS}{INCLUDINGWEB};
  2853     my $memT = $this->{SESSION_TAGS}{INCLUDINGTOPIC};
  2854     $this->{SESSION_TAGS}{INCLUDINGWEB} = $theWeb;
  2855     $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $theTopic;
  2856 
  2857     expandAllTags( $this, \$text, $theTopic, $theWeb, $meta );
  2858 
  2859     $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
  2860                                               $verbatim);
  2861 
  2862 
  2863     # Plugin Hook
  2864     $this->{plugins}->commonTagsHandler( $text, $theTopic, $theWeb, 0, $meta );
  2865 
  2866     # process tags again because plugin hook may have added more in
  2867     expandAllTags( $this, \$text, $theTopic, $theWeb, $meta );
  2868 
  2869     $this->{SESSION_TAGS}{INCLUDINGWEB} = $memW;
  2870     $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $memT;
  2871 
  2872     # 'Special plugin tag' TOC hack, must be done after all other expansions
  2873     # are complete, and has to reprocess the entire topic.
  2874     $text =~ s/%TOC(?:{(.*?)})?%/$this->_TOC($text, $theTopic, $theWeb, $1)/ge;
  2875 
  2876     # Codev.FormattedSearchWithConditionalOutput: remove <nop> lines,
  2877     # possibly introduced by SEARCHes with conditional CALC. This needs
  2878     # to be done after CALC and before table rendering in order to join
  2879     # table rows properly
  2880     $text =~ s/^<nop>\r?\n//gm;
  2881 
  2882     $this->renderer->putBackBlocks( \$text, $verbatim, 'verbatim' );
  2883 
  2884     # TWiki Plugin Hook (for cache Plugins only)
  2885     $this->{plugins}->afterCommonTagsHandler(
  2886         $text, $theTopic, $theWeb, $meta );
  2887 
  2888     return $text;
  2889 }
  2890 
  2891 =pod
  2892 
  2893 ---++ ObjectMethod addToHEAD( $id, $html )
  2894 
  2895 Add =$html= to the HEAD tag of the page currently being generated.
  2896 
  2897 Note that TWiki variables may be used in the HEAD. They will be expanded
  2898 according to normal variable expansion rules.
  2899 
  2900 The 'id' is used to ensure that multiple adds of the same block of HTML don't
  2901 result in it being added many times.
  2902 
  2903 =cut
  2904 
  2905 sub addToHEAD {
  2906 	my ($this, $tag, $header) = @_;
  2907 	
  2908 	$header = $this->handleCommonTags( $header, $this->{webName},
  2909                                        $this->{topicName} );
  2910 	
  2911 	$this->{_HTMLHEADERS}{$tag} = $header;
  2912 }
  2913 
  2914 =pod
  2915 
  2916 ---++ StaticMethod initialize( $pathInfo, $remoteUser, $topic, $url, $query ) -> ($topicName, $webName, $scriptUrlPath, $userName, $dataDir)
  2917 
  2918 Return value: ( $topicName, $webName, $TWiki::cfg{ScriptUrlPath}, $userName, $TWiki::cfg{DataDir} )
  2919 
  2920 Static method to construct a new singleton session instance.
  2921 It creates a new TWiki and sets the Plugins $SESSION variable to
  2922 point to it, so that TWiki::Func methods will work.
  2923 
  2924 This method is *DEPRECATED* but is maintained for script compatibility.
  2925 
  2926 Note that $theUrl, if specified, must be identical to $query->url()
  2927 
  2928 =cut
  2929 
  2930 sub initialize {
  2931     my ( $pathInfo, $theRemoteUser, $topic, $theUrl, $query ) = @_;
  2932 
  2933     if( !$query ) {
  2934         $query = new CGI( {} );
  2935     }
  2936     if( $query->path_info() ne $pathInfo ) {
  2937         $query->path_info( $pathInfo );
  2938     }
  2939     if( $topic ) {
  2940         $query->param( -name => 'topic', -value => '' );
  2941     }
  2942     # can't do much if $theUrl is specified and it is inconsistent with
  2943     # the query. We are trying to get to all parameters passed in the
  2944     # query.
  2945     if( $theUrl && $theUrl ne $query->url()) {
  2946         die 'Sorry, this version of TWiki does not support the url parameter to TWiki::initialize being different to the url in the query';
  2947     }
  2948     my $twiki = new TWiki( $theRemoteUser, $query );
  2949 
  2950     # Force the new session into the plugins context.
  2951     $TWiki::Plugins::SESSION = $twiki;
  2952 
  2953     return ( $twiki->{topicName}, $twiki->{webName}, $twiki->{scriptUrlPath},
  2954              $twiki->{userName}, $TWiki::cfg{DataDir} );
  2955 }
  2956 
  2957 =pod
  2958 
  2959 ---++ StaticMethod readFile( $filename ) -> $text
  2960 
  2961 Returns the entire contents of the given file, which can be specified in any
  2962 format acceptable to the Perl open() function. Fast, but inherently unsafe.
  2963 
  2964 WARNING: Never, ever use this for accessing topics or attachments! Use the
  2965 Store API for that. This is for global control files only, and should be
  2966 used *only* if there is *absolutely no alternative*.
  2967 
  2968 =cut
  2969 
  2970 sub readFile {
  2971     my $name = shift;
  2972     open( IN_FILE, "<$name" ) || return '';
  2973     local $/ = undef;
  2974     my $data = <IN_FILE>;
  2975     close( IN_FILE );
  2976     $data = '' unless( defined( $data ));
  2977     return $data;
  2978 }
  2979 
  2980 =pod
  2981 
  2982 ---++ StaticMethod expandStandardEscapes($str) -> $unescapedStr
  2983 
  2984 Expands standard escapes used in parameter values to block evaluation. The following escapes
  2985 are handled:
  2986 
  2987 | *Escape:* | *Expands To:* |
  2988 | =$n= or =$n()= | New line. Use =$n()= if followed by alphanumeric character, e.g. write =Foo$n()Bar= instead of =Foo$nBar= |
  2989 | =$nop= or =$nop()= | Is a "no operation". |
  2990 | =$quot= | Double quote (="=) |
  2991 | =$percnt= | Percent sign (=%=) |
  2992 | =$dollar= | Dollar sign (=$=) |
  2993 
  2994 =cut
  2995 
  2996 sub expandStandardEscapes {
  2997     my $text = shift;
  2998     $text =~ s/\$n\(\)/\n/gos;         # expand '$n()' to new line
  2999     $text =~ s/\$n([^$regex{mixedAlpha}]|$)/\n$1/gos; # expand '$n' to new line
  3000     $text =~ s/\$nop(\(\))?//gos;      # remove filler, useful for nested search
  3001     $text =~ s/\$quot(\(\))?/\"/gos;   # expand double quote
  3002     $text =~ s/\$percnt(\(\))?/\%/gos; # expand percent
  3003     $text =~ s/\$dollar(\(\))?/\$/gos; # expand dollar
  3004     return $text;
  3005 }
  3006 
  3007 # generate an include warning
  3008 # SMELL: varying number of parameters idiotic to handle for customized $warn
  3009 sub _includeWarning {
  3010     my $this = shift;
  3011     my $warn = shift;
  3012     my $message = shift;
  3013 
  3014     if( $warn eq 'on' ) {
  3015         return $this->inlineAlert( 'alerts', $message, @_ );
  3016     } elsif( isTrue( $warn )) {
  3017         # different inlineAlerts need different argument counts
  3018         my $argument = '';
  3019         if ($message  eq  'topic_not_found') {
  3020             my ($web,$topic)  =  @_;
  3021             $argument = "$web.$topic";
  3022         }
  3023         else {
  3024             $argument = shift;
  3025         }
  3026         $warn =~ s/\$topic/$argument/go if $argument;
  3027         return $warn;
  3028     } # else fail silently
  3029     return '';
  3030 }
  3031 
  3032 #-------------------------------------------------------------------
  3033 # Tag Handlers
  3034 #-------------------------------------------------------------------
  3035 
  3036 sub FORMFIELD {
  3037     my ( $this, $params, $topic, $web ) = @_;	
  3038     my $cgiQuery = $this->{cgiQuery};
  3039     my $cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
  3040     $params->{rev} = $cgiRev;
  3041     return $this->renderer->renderFORMFIELD( $params, $topic, $web );
  3042 }
  3043 
  3044 sub TMPLP {
  3045     my( $this, $params ) = @_;
  3046     return $this->templates->tmplP( $params );
  3047 }
  3048 
  3049 sub VAR {
  3050     my( $this, $params, $topic, $inweb ) = @_;
  3051     my $key = $params->{_DEFAULT};
  3052     return '' unless $key;
  3053     my $web = $params->{web} || $inweb;
  3054     # handle %USERSWEB%-type cases
  3055     ( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
  3056     # always return a value, even when the key isn't defined
  3057     return $this->{prefs}->getWebPreferencesValue( $key, $web ) || '';
  3058 }
  3059 
  3060 sub PLUGINVERSION {
  3061     my( $this, $params ) = @_;
  3062     $this->{plugins}->getPluginVersion( $params->{_DEFAULT} );
  3063 }
  3064 
  3065 sub IF {
  3066     my ( $this, $params, $topic, $web, $meta ) = @_;
  3067 
  3068     unless( $ifParser ) {
  3069         require TWiki::If::Parser;
  3070         $ifParser = new TWiki::If::Parser();
  3071     }
  3072 
  3073     my $expr;
  3074     my $result;
  3075     try {
  3076         $expr = $ifParser->parse( $params->{_DEFAULT} );
  3077         unless( $meta ) {
  3078             require TWiki::Meta;
  3079             $meta = new TWiki::Meta( $this, $web, $topic );
  3080         }
  3081         if( $expr->evaluate( tom=>$meta, data=>$meta )) {
  3082             $params->{then} = '' unless defined $params->{then};
  3083             $result = expandStandardEscapes( $params->{then} );
  3084         } else {
  3085             $params->{else} = '' unless defined $params->{else};
  3086             $result = expandStandardEscapes( $params->{else} );
  3087         }
  3088     } catch TWiki::Infix::Error with {
  3089         my $e = shift;
  3090         $result = $this->inlineAlert(
  3091             'alerts', 'generic', 'IF{', $params->stringify(), '}:',
  3092             $e->{-text} );
  3093     };
  3094     return $result;
  3095 }
  3096 
  3097 # Processes a specific instance %<nop>INCLUDE{...}% syntax.
  3098 # Returns the text to be inserted in place of the INCLUDE command.
  3099 # $topic and $web should be for the immediate parent topic in the
  3100 # include hierarchy. Works for both URLs and absolute server paths.
  3101 sub INCLUDE {
  3102     my ( $this, $params, $includingTopic, $includingWeb ) = @_;
  3103 
  3104     # remember args for the key before mangling the params
  3105     my $args = $params->stringify();
  3106 
  3107     # Remove params, so they don't get expanded in the included page
  3108     my $path = $params->remove('_DEFAULT') || '';
  3109     my $pattern = $params->remove('pattern');
  3110     my $rev = $params->remove('rev');
  3111     my $section = $params->remove('section');
  3112     my $raw = $params->remove('raw') || '';
  3113     my $warn = $params->remove('warn')
  3114       || $this->{prefs}->getPreferencesValue( 'INCLUDEWARNING' );
  3115 
  3116     if( $path =~ /^https?\:/ ) {
  3117         # include web page
  3118         return _includeUrl(
  3119             $this, $path, $pattern, $includingWeb, $includingTopic,
  3120             $raw, $params, $warn );
  3121     }
  3122 
  3123     $path =~ s/$TWiki::cfg{NameFilter}//go;    # zap anything suspicious
  3124     if( $TWiki::cfg{DenyDotDotInclude} ) {
  3125         # Filter out '..' from filename, this is to
  3126         # prevent includes of '../../file'
  3127         $path =~ s/\.+/\./g;
  3128     } else {
  3129         # danger, could include .htpasswd with relative path
  3130         $path =~ s/passwd//gi;    # filter out passwd filename
  3131     }
  3132 
  3133     # make sure we have something to include. If we don't do this, then
  3134     # normalizeWebTopicName will default to WebHome. Item2209.
  3135     unless( $path ) {
  3136         # SMELL: could do with a different message here, but don't want to
  3137         # add one right now because translators are already working
  3138         return _includeWarning( $this, $warn, 'topic_not_found', '""','""' );
  3139     }
  3140 
  3141     my $text = '';
  3142     my $meta = '';
  3143     my $includedWeb;
  3144     my $includedTopic = $path;
  3145     $includedTopic =~ s/\.txt$//; # strip optional (undocumented) .txt
  3146 
  3147     ($includedWeb, $includedTopic) =
  3148       $this->normalizeWebTopicName($includingWeb, $includedTopic);
  3149 
  3150     # See Codev.FailedIncludeWarning for the history.
  3151     unless( $this->{store}->topicExists($includedWeb, $includedTopic)) {
  3152         return _includeWarning( $this, $warn, 'topic_not_found',
  3153                                        $includedWeb, $includedTopic );
  3154     }
  3155 
  3156     # prevent recursive includes. Note that the inclusion of a topic into
  3157     # itself is not blocked; however subsequent attempts to include the
  3158     # topic will fail. There is a hard block of 99 on any recursive include.
  3159     my $key = $includingWeb.'.'.$includingTopic;
  3160     my $count = grep( $key, keys %{$this->{_INCLUDES}});
  3161     $key .= $args;
  3162     if( $this->{_INCLUDES}->{$key} || $count > 99) {
  3163         return _includeWarning( $this, $warn, 'already_included',
  3164                                        "$includedWeb.$includedTopic", '' );
  3165     }
  3166 
  3167     my %saveTags = %{$this->{SESSION_TAGS}};
  3168     my $prefsMark = $this->{prefs}->mark();
  3169 
  3170     $this->{_INCLUDES}->{$key} = 1;
  3171     $this->{SESSION_TAGS}{INCLUDINGWEB} = $includingWeb;
  3172     $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $includingTopic;
  3173 
  3174     # copy params into session tags
  3175     foreach my $k ( keys %$params ) {
  3176         $this->{SESSION_TAGS}{$k} = $params->{$k};
  3177     }
  3178 
  3179     ( $meta, $text ) =
  3180       $this->{store}->readTopic( undef, $includedWeb, $includedTopic, $rev );
  3181 
  3182     # Simplify leading, and remove trailing, newlines. If we don't remove
  3183     # trailing, it becomes impossible to %INCLUDE a topic into a table.
  3184     $text =~ s/^[\r\n]+/\n/;
  3185     $text =~ s/[\r\n]+$//;
  3186 
  3187     unless( $this->security->checkAccessPermission(
  3188         'VIEW', $this->{user}, $text, $meta, $includedTopic, $includedWeb )) {
  3189         if( isTrue( $warn )) {
  3190             return $this->inlineAlert( 'alerts', 'access_denied',
  3191                                        "[[$includedWeb.$includedTopic]]" );
  3192         } # else fail silently
  3193         return '';
  3194     }
  3195 
  3196     # remove everything before and after the default include block unless
  3197     # a section is explicitly defined
  3198     if( !$section ) {
  3199        $text =~ s/.*?%STARTINCLUDE%//s;
  3200        $text =~ s/%STOPINCLUDE%.*//s;
  3201     }
  3202 
  3203     # handle sections
  3204     my( $ntext, $sections ) = parseSections( $text );
  3205 
  3206     my $interesting = ( defined $section );
  3207     if( $interesting || scalar( @$sections )) {
  3208         # Rebuild the text from the interesting sections
  3209         $text = '';
  3210         foreach my $s ( @$sections ) {
  3211             if( $section && $s->{type} eq 'section' &&
  3212                   $s->{name} eq $section) {
  3213                 $text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} );
  3214                 $interesting = 1;
  3215                 last;
  3216             } elsif( $s->{type} eq 'include' && !$section ) {
  3217                 $text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} );
  3218                 $interesting = 1;
  3219             }
  3220         }
  3221     }
  3222     # If there were no interesting sections, restore the whole text
  3223     $text = $ntext unless $interesting;
  3224 
  3225     $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
  3226 
  3227     # Do not show TOC in included topic if TOC_HIDE_IF_INCLUDED
  3228     # preference has been set
  3229     if( isTrue( $this->{prefs}->getPreferencesValue( 'TOC_HIDE_IF_INCLUDED' ))) {
  3230         $text =~ s/%TOC(?:{(.*?)})?%//g;
  3231     }
  3232 
  3233     expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
  3234 
  3235     # 4th parameter tells plugin that its called for an included file
  3236     $this->{plugins}->commonTagsHandler( $text, $includedTopic,
  3237                                          $includedWeb, 1, $meta );
  3238 
  3239     # We have to expand tags again, because a plugin may have inserted additional
  3240     # tags.
  3241     expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
  3242 
  3243     # If needed, fix all 'TopicNames' to 'Web.TopicNames' to get the
  3244     # right context so that links continue to work properly
  3245     if( $includedWeb ne $includingWeb ) {
  3246 	    my $removed = {};
  3247 
  3248         $text = $this->renderer->forEachLine(
  3249             $text, \&_fixupIncludedTopic, { web => $includedWeb,
  3250                                             pre => 1,
  3251                                             noautolink => 1} );
  3252         # handle tags again because of plugin hook
  3253         expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
  3254     }
  3255 
  3256     # restore the tags
  3257     delete $this->{_INCLUDES}->{$key};
  3258     %{$this->{SESSION_TAGS}} = %saveTags;
  3259 
  3260     $this->{prefs}->restore( $prefsMark );
  3261 
  3262     return $text;
  3263 }
  3264 
  3265 sub HTTP {
  3266     my( $this, $params ) = @_;
  3267     my $res;
  3268     if( $params->{_DEFAULT} ) {
  3269         $res = $this->{cgiQuery}->http( $params->{_DEFAULT} );
  3270     }
  3271     $res = '' unless defined( $res );
  3272     return $res;
  3273 }
  3274 
  3275 sub HTTPS {
  3276     my( $this, $params ) = @_;
  3277     my $res;
  3278     if( $params->{_DEFAULT} ) {
  3279         $res = $this->{cgiQuery}->https( $params->{_DEFAULT} );
  3280     }
  3281     $res = '' unless defined( $res );
  3282     return $res;
  3283 }
  3284 
  3285 #deprecated functionality, now implemented using %ENV%
  3286 #move to compatibility plugin in TWiki5
  3287 sub HTTP_HOST_deprecated {
  3288     return $ENV{HTTP_HOST} || '';
  3289 }
  3290 
  3291 #deprecated functionality, now implemented using %ENV%
  3292 #move to compatibility plugin in TWiki5
  3293 sub REMOTE_ADDR_deprecated {
  3294     return $ENV{REMOTE_ADDR} || '';
  3295 }
  3296 
  3297 #deprecated functionality, now implemented using %ENV%
  3298 #move to compatibility plugin in TWiki5
  3299 sub REMOTE_PORT_deprecated {
  3300     return $ENV{REMOTE_PORT} || '';
  3301 }
  3302 
  3303 #deprecated functionality, now implemented using %ENV%
  3304 #move to compatibility plugin in TWiki5
  3305 sub REMOTE_USER_deprecated {
  3306     return $ENV{REMOTE_USER} || '';
  3307 }
  3308 
  3309 # Only does simple search for topicmoved at present, can be expanded when required
  3310 # SMELL: this violates encapsulation of Store and Meta, by exporting
  3311 # the assumption that meta-data is stored embedded inside topic
  3312 # text.
  3313 sub METASEARCH {
  3314     my( $this, $params ) = @_;
  3315 
  3316     return $this->{store}->searchMetaData( $params );
  3317 }
  3318 
  3319 sub DATE {
  3320     my $this = shift;
  3321     return TWiki::Time::formatTime(time(), $TWiki::cfg{DefaultDateFormat}, 'gmtime');
  3322 }
  3323 
  3324 sub GMTIME {
  3325     my( $this, $params ) = @_;
  3326     return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'gmtime' );
  3327 }
  3328 
  3329 sub SERVERTIME {
  3330     my( $this, $params ) = @_;
  3331     return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'servertime' );
  3332 }
  3333 
  3334 sub DISPLAYTIME {
  3335     my( $this, $params ) = @_;
  3336     return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', $TWiki::cfg{DisplayTimeValues} );
  3337 }
  3338 
  3339 #| $web | web and  |
  3340 #| $topic | topic to display the name for |
  3341 #| $formatString | twiki format string (like in search) |
  3342 sub REVINFO {
  3343     my ( $this, $params, $theTopic, $theWeb ) = @_;
  3344     my $format = $params->{_DEFAULT} || $params->{format};
  3345     my $web    = $params->{web} || $theWeb;
  3346     my $topic  = $params->{topic} || $theTopic;
  3347     my $cgiQuery = $this->{cgiQuery};
  3348     my $cgiRev = '';
  3349     $cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
  3350     my $rev = $params->{rev} || $cgiRev || '';
  3351 
  3352     return $this->renderer->renderRevisionInfo( $web, $topic, undef,
  3353                                                   $rev, $format );
  3354 }
  3355 
  3356 sub ENCODE {
  3357     my( $this, $params ) = @_;
  3358     my $type = $params->{type} || 'url';
  3359     my $text = $params->{_DEFAULT} || '';
  3360     return _encode($type, $text);
  3361 }
  3362 
  3363 sub _encode {
  3364     my ($type, $text) = @_;
  3365 
  3366     if ( $type =~ /^entit(y|ies)$/i ) {
  3367         return entityEncode( $text );
  3368     } elsif ( $type =~ /^html$/i ) {
  3369         return entityEncode( $text, "\n\r" );
  3370     } elsif ( $type =~ /^quotes?$/i ) {
  3371         # escape quotes with backslash (Bugs:Item3383 fix)
  3372         $text =~ s/\"/\\"/go;
  3373         return $text;
  3374     } elsif ($type =~ /^url$/i) {
  3375         $text =~ s/\r*\n\r*/<br \/>/; # Legacy.
  3376         return urlEncode( $text );
  3377     }
  3378 }
  3379 
  3380 sub ENV {
  3381     my ($this, $params) = @_;
  3382 
  3383     return '' unless $params->{_DEFAULT} &&
  3384       defined $TWiki::cfg{AccessibleENV} &&
  3385         $params->{_DEFAULT} =~ /$TWiki::cfg{AccessibleENV}/o;
  3386     my $val = $ENV{$params->{_DEFAULT}};
  3387     return 'not set' unless defined $val;
  3388     return $val;
  3389 }
  3390 
  3391 sub SEARCH {
  3392     my ( $this, $params, $topic, $web ) = @_;
  3393     # pass on all attrs, and add some more
  3394     #$params->{_callback} = undef;
  3395     $params->{inline} = 1;
  3396     $params->{baseweb} = $web;
  3397     $params->{basetopic} = $topic;
  3398     $params->{search} = $params->{_DEFAULT} if( $params->{_DEFAULT} );
  3399     $params->{type} = $this->{prefs}->getPreferencesValue( 'SEARCHVARDEFAULTTYPE' ) unless( $params->{type} );
  3400     my $s;
  3401     try {
  3402         $s = $this->search->searchWeb( %$params );
  3403     } catch Error::Simple with {
  3404         my $message = (DEBUG) ? shift->stringify() : shift->{-text};
  3405         # Block recursions kicked off by the text being repeated in the
  3406         # error message
  3407         $message =~ s/%([A-Z]*[{%])/%<nop>$1/g;
  3408         $s = $this->inlineAlert( 'alerts', 'bad_search', $message );
  3409     };
  3410     return $s;
  3411 }
  3412 
  3413 sub WEBLIST {
  3414     my( $this, $params ) = @_;
  3415     my $format = $params->{_DEFAULT} || $params->{'format'} || '$name';
  3416     $format ||= '$name';
  3417     my $separator = $params->{separator} || "\n";
  3418     $separator =~ s/\$n/\n/;
  3419     my $web = $params->{web} || '';
  3420     my $webs = $params->{webs} || 'public';
  3421     my $selection = $params->{selection} || '';
  3422     my $showWeb = $params->{subwebs} || '';
  3423     $selection =~ s/\,/ /g;
  3424     $selection = " $selection ";
  3425     my $marker = $params->{marker} || 'selected="selected"';
  3426     $web =~ s#\.#/#go;
  3427 
  3428     my @list = ();
  3429     my @webslist = split( /,\s*/, $webs );
  3430     foreach my $aweb ( @webslist ) {
  3431         if( $aweb eq 'public' ) {
  3432             push( @list, $this->{store}->getListOfWebs( 'user,public,allowed', $showWeb ) );
  3433         } elsif( $aweb eq 'webtemplate' ) {
  3434             push( @list, $this->{store}->getListOfWebs( 'template,allowed', $showWeb ));
  3435         } else{
  3436             push( @list, $aweb ) if( $this->{store}->webExists( $aweb ) );
  3437         }
  3438     }
  3439 
  3440     my @items;
  3441     my $indent = CGI::span({class=>'twikiWebIndent'},'');
  3442     foreach my $item ( @list ) {
  3443         my $line = $format;
  3444         $line =~ s/\$web\b/$web/g;
  3445         $line =~ s/\$name\b/$item/g;
  3446         $line =~ s/\$qname/"$item"/g;
  3447         my $indenteditem = $item;
  3448         $indenteditem =~ s#/$##g;
  3449         $indenteditem =~ s#\w+/#$indent#g;
  3450         $line =~ s/\$indentedname/$indenteditem/g;
  3451         my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
  3452         $line =~ s/\$marker/$mark/g;
  3453         push(@items, $line);
  3454     }
  3455     return join( $separator, @items);
  3456 }
  3457 
  3458 sub TOPICLIST {
  3459     my( $this, $params ) = @_;
  3460     my $format = $params->{_DEFAULT} || $params->{'format'} || '$topic';
  3461     my $separator = $params->{separator} || "\n";
  3462     $separator =~ s/\$n/\n/;
  3463     my $web = $params->{web} || $this->{webName};
  3464     my $selection = $params->{selection} || '';
  3465     $selection =~ s/\,/ /g;
  3466     $selection = " $selection ";
  3467     my $marker = $params->{marker} || 'selected="selected"';
  3468     $web =~ s#\.#/#go;
  3469 
  3470     return '' if
  3471       $web ne $this->{webName} &&
  3472       $this->{prefs}->getWebPreferencesValue( 'NOSEARCHALL', $web );
  3473 
  3474     my @items;
  3475     foreach my $item ( $this->{store}->getTopicNames( $web ) ) {
  3476         my $line = $format;
  3477         $line =~ s/\$web\b/$web/g;
  3478         $line =~ s/\$topic\b/$item/g;
  3479         $line =~ s/\$name\b/$item/g; # Undocumented, DO NOT REMOVE
  3480         $line =~ s/\$qname/"$item"/g; # Undocumented, DO NOT REMOVE
  3481         my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
  3482         $line =~ s/\$marker/$mark/g;
  3483         $line = expandStandardEscapes( $line );
  3484         push( @items, $line );
  3485     }
  3486     return join( $separator, @items);
  3487 }
  3488 
  3489 sub QUERYSTRING {
  3490     my $this = shift;
  3491     return $this->{cgiQuery}->query_string();
  3492 }
  3493 
  3494 sub QUERYPARAMS {
  3495     my ( $this, $params ) = @_;
  3496     return '' unless $this->{cgiQuery};
  3497     my $format = defined $params->{format} ? $params->{format} :
  3498       '$name=$value';
  3499     my $separator = defined $params->{separator} ? $params->{separator} : "\n";
  3500     my $encoding = $params->{encoding} || '';
  3501 
  3502     my @list;
  3503     foreach my $name ( $this->{cgiQuery}->param() ) {
  3504         # Issues multi-valued parameters as separate hiddens
  3505         my $value = $this->{cgiQuery}->param( $name );
  3506         if ($encoding) {
  3507             $value = _encode($encoding, $value);
  3508         }
  3509         my $entry = $format;
  3510         $entry =~ s/\$name/$name/g;
  3511         $entry =~ s/\$value/$value/;
  3512         push(@list, $entry);
  3513     }
  3514     return expandStandardEscapes(join($separator, @list));
  3515 }
  3516 
  3517 sub URLPARAM {
  3518     my( $this, $params ) = @_;
  3519     my $param     = $params->{_DEFAULT} || '';
  3520     my $newLine   = $params->{newline};
  3521     my $encode    = $params->{encode};
  3522     my $multiple  = $params->{multiple};
  3523     my $separator = $params->{separator};
  3524     $separator="\n" unless (defined $separator);
  3525 
  3526     my $value;
  3527     if( $this->{cgiQuery} ) {
  3528         if( TWiki::isTrue( $multiple )) {
  3529             my @valueArray = $this->{cgiQuery}->param( $param );
  3530             if( @valueArray ) {
  3531                 # join multiple values properly
  3532                 unless( $multiple =~ m/^on$/i ) {
  3533                     my $item = '';
  3534                     @valueArray = map {
  3535                         $item = $_;
  3536                         $_ = $multiple;
  3537                         $_ .= $item unless( s/\$item/$item/go );
  3538                         $_
  3539                     } @valueArray;
  3540                 }
  3541                 $value = join ( $separator, @valueArray );
  3542             }
  3543         } else {
  3544             $value = $this->{cgiQuery}->param( $param );
  3545         }
  3546     }
  3547     if( defined $value ) {
  3548         $value =~ s/\r?\n/$newLine/go if( defined $newLine );
  3549         if ( $encode ) {
  3550             if ( $encode =~ /^entit(y|ies)$/i ) {
  3551                 $value = entityEncode( $value );
  3552             } elsif ( $encode =~ /^quotes?$/i ) {
  3553                 $value =~ s/\"/\\"/go;    # escape quotes with backslash (Bugs:Item3383 fix)
  3554             } else {
  3555                 $value =~ s/\r*\n\r*/<br \/>/; # Legacy
  3556                 $value = urlEncode( $value );
  3557             }
  3558         }
  3559     }
  3560     unless( defined $value ) {
  3561         $value = $params->{default};
  3562         $value = '' unless defined $value;
  3563     }
  3564     # Block expansion of %URLPARAM in the value to prevent recursion
  3565     $value =~ s/%URLPARAM{/%<nop>URLPARAM{/g;
  3566     return $value;
  3567 }
  3568 
  3569 # This routine was introduced to URL encode Mozilla UTF-8 POST URLs in the
  3570 # TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now
  3571 # directly supported, but it is provided for backward compatibility with
  3572 # skins that may still be using the deprecated %INTURLENCODE%.
  3573 sub INTURLENCODE_deprecated {
  3574     my( $this, $params ) = @_;
  3575     # Just strip double quotes, no URL encoding - Mozilla UTF-8 URLs
  3576     # directly supported now
  3577     return $params->{_DEFAULT} || '';
  3578 }
  3579 
  3580 # This routine is deprecated as of DakarRelease,
  3581 # and is maintained only for backward compatibility.
  3582 # Spacing of WikiWords is now done with %SPACEOUT%
  3583 # (and the private routine _SPACEOUT).
  3584 # Move to compatibility module in TWiki5
  3585 sub SPACEDTOPIC_deprecated {
  3586     my ( $this, $params, $theTopic ) = @_;
  3587     my $topic = spaceOutWikiWord( $theTopic );
  3588     $topic =~ s/ / */g;
  3589     return urlEncode( $topic );
  3590 }
  3591 
  3592 sub SPACEOUT {
  3593     my ( $this, $params ) = @_;
  3594     my $spaceOutTopic = $params->{_DEFAULT};
  3595     my $sep = $params->{'separator'};
  3596     $spaceOutTopic = spaceOutWikiWord( $spaceOutTopic, $sep );
  3597     return $spaceOutTopic;
  3598 }
  3599 
  3600 sub ICON {
  3601     my( $this, $params ) = @_;
  3602     my $file = $params->{_DEFAULT} || '';
  3603     # Try to map the file name to see if there is a matching filetype image
  3604     # If no mapping could be found, use the file name that was passed
  3605     my $iconFileName = $this->mapToIconFileName( $file, $file );
  3606     return CGI::img( { src => $this->getIconUrl( 0, $iconFileName ),
  3607                        width => 16, height=>16,
  3608                        align => 'top', alt => $iconFileName, border => 0 });
  3609 }
  3610 
  3611 sub ICONURL {
  3612     my( $this, $params ) = @_;
  3613     my $file = ( $params->{_DEFAULT} || '' );
  3614 
  3615     return $this->getIconUrl( 1, $file );
  3616 }
  3617 
  3618 sub ICONURLPATH {
  3619     my( $this, $params ) = @_;
  3620     my $file = ( $params->{_DEFAULT} || '' );
  3621 
  3622     return $this->getIconUrl( 0, $file );
  3623 }
  3624 
  3625 sub RELATIVETOPICPATH {
  3626     my ( $this, $params, $theTopic, $web ) = @_;
  3627     my $topic = $params->{_DEFAULT};
  3628 
  3629     return '' unless $topic;
  3630 
  3631     my $theRelativePath;
  3632     # if there is no dot in $topic, no web has been specified
  3633     if ( index( $topic, '.' ) == -1 ) {
  3634         # add local web
  3635         $theRelativePath = $web . '/' . $topic;
  3636     } else {
  3637         $theRelativePath = $topic; #including dot
  3638     }
  3639     # replace dot by slash is not necessary; TWiki.MyTopic is a valid url
  3640     # add ../ if not already present to make a relative file reference
  3641     if ( $theRelativePath !~ m!^../! ) {
  3642         $theRelativePath = "../$theRelativePath";
  3643     }
  3644     return $theRelativePath;
  3645 }
  3646 
  3647 sub ATTACHURLPATH {
  3648     my ( $this, $params, $topic, $web ) = @_;
  3649     return $this->getPubUrl(0, $web, $topic);
  3650 }
  3651 
  3652 sub ATTACHURL {
  3653     my ( $this, $params, $topic, $web ) = @_;
  3654     return $this->getPubUrl(1, $web, $topic);
  3655 }
  3656 
  3657 sub LANGUAGE {
  3658     my $this = shift;
  3659     return $this->i18n->language();
  3660 }
  3661 
  3662 sub LANGUAGES {
  3663     my ( $this , $params ) = @_;
  3664     my $format = $params->{format} || "   * \$langname";
  3665     my $separator = $params->{separator} || "\n";
  3666     $separator =~ s/\\n/\n/g;
  3667     my $selection = $params->{selection} || '';
  3668     $selection =~ s/\,/ /g;
  3669     $selection = " $selection ";
  3670     my $marker = $params->{marker} || 'selected="selected"';
  3671 
  3672     # $languages is a hash reference:
  3673     my $languages = $this->i18n->enabled_languages();
  3674 
  3675     my @tags = sort(keys(%{$languages}));
  3676 
  3677     my $result = '';
  3678     my $i = 0; 
  3679     foreach my $lang (@tags) {
  3680          my $item = $format;
  3681          my $name = ${$languages}{$lang};
  3682          $item =~ s/\$langname/$name/g;
  3683          $item =~ s/\$langtag/$lang/g;
  3684          my $mark = ( $selection =~ / \Q$lang\E / ) ? $marker : '';
  3685          $item =~ s/\$marker/$mark/g;
  3686          $result .= $separator if $i;
  3687          $result .= $item;
  3688          $i++;
  3689     }
  3690 
  3691     return $result;
  3692 }
  3693 
  3694 sub MAKETEXT {
  3695     my( $this, $params ) = @_;
  3696 
  3697     my $str = $params->{_DEFAULT} || $params->{string} || "";
  3698     return "" unless $str;
  3699 
  3700     # escape everything:
  3701     $str =~ s/\[/~[/g;
  3702     $str =~ s/\]/~]/g;
  3703 
  3704     # restore already escaped stuff:
  3705     $str =~ s/~~\[/~[/g;
  3706     $str =~ s/~~\]/~]/g;
  3707 
  3708     # unescape parameters and calculate highest parameter number:
  3709     my $max = 0;
  3710     $str =~ s/~\[(\_(\d+))~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
  3711     $str =~ s/~\[(\*,\_(\d+),[^,]+(,([^,]+))?)~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
  3712 
  3713     # get the args to be interpolated.
  3714     my $argsStr = $params->{args} || "";
  3715 
  3716     my @args = split (/\s*,\s*/, $argsStr) ;
  3717     # fill omitted args with zeros
  3718     while ((scalar @args) < $max) {
  3719         push(@args, 0);
  3720     }
  3721 
  3722     # do the magic:
  3723     my $result = $this->i18n->maketext($str, @args);
  3724 
  3725     # replace accesskeys:
  3726     $result =~ s#(^|[^&])&([a-zA-Z])#$1<span class='twikiAccessKey'>$2</span>#g;
  3727 
  3728     # replace escaped amperstands:
  3729     $result =~ s/&&/\&/g;
  3730 
  3731     return $result;
  3732 }
  3733 
  3734 sub SCRIPTNAME {
  3735     #my ( $this, $params, $theTopic, $theWeb ) = @_;
  3736     # try SCRIPT_FILENAME
  3737     my $value = $ENV{SCRIPT_FILENAME};
  3738     if( $value ) {
  3739         $value =~ s!.*/([^/]+)$!$1!o;
  3740         return $value;
  3741     }
  3742     # try SCRIPT_URL (won't work with url rewriting)
  3743     $value = $ENV{SCRIPT_URL};
  3744     if( $value ) {
  3745         # e.g. '/cgi-bin/view.cgi/TWiki/WebHome'
  3746         # cut URL path to get 'view.cgi/TWiki/WebHome'
  3747         $value =~ s|^$TWiki::cfg{ScriptUrlPath}/?||o;
  3748         # cut extended path to get 'view.cgi'
  3749         $value =~ s|/.*$||;
  3750         return $value;
  3751     }
  3752     # no joy
  3753     return '';
  3754 }
  3755 
  3756 sub SCRIPTURL {
  3757     my ( $this, $params, $topic, $web ) = @_;
  3758     my $script = $params->{_DEFAULT} || '';
  3759 
  3760     return $this->getScriptUrl( 1, $script );
  3761 }
  3762 
  3763 sub SCRIPTURLPATH {
  3764     my ( $this, $params, $topic, $web ) = @_;
  3765     my $script = $params->{_DEFAULT} || '';
  3766 
  3767     return $this->getScriptUrl( 0, $script );
  3768 }
  3769 
  3770 sub PUBURL {
  3771     my $this = shift;
  3772     return $this->getPubUrl(1);
  3773 }
  3774 
  3775 sub PUBURLPATH {
  3776     my $this = shift;
  3777     return $this->getPubUrl(0);
  3778 }
  3779 
  3780 sub ALLVARIABLES {
  3781     return shift->{prefs}->stringify();
  3782 }
  3783 
  3784 sub META {
  3785     my ( $this, $params, $topic, $web ) = @_;
  3786 
  3787     my $meta  = $this->inContext( 'can_render_meta' );
  3788 
  3789     return '' unless $meta;
  3790 
  3791     my $option = $params->{_DEFAULT} || '';
  3792 
  3793     if( $option eq 'form' ) {
  3794         # META:FORM and META:FIELD
  3795         return $meta->renderFormForDisplay( $this->templates );
  3796     } elsif ( $option eq 'formfield' ) {
  3797         # a formfield from within topic text
  3798         return $meta->renderFormFieldForDisplay( $params );
  3799     } elsif( $option eq 'attachments' ) {
  3800         # renders attachment tables
  3801         return $this->attach->renderMetaData( $web, $topic, $meta, $params );
  3802     } elsif( $option eq 'moved' ) {
  3803         return $this->renderer->renderMoved( $web, $topic, $meta, $params );
  3804     } elsif( $option eq 'parent' ) {
  3805         return $this->renderer->renderParent( $web, $topic, $meta, $params );
  3806     }
  3807 
  3808     return '';
  3809 }
  3810 
  3811 # Remove NOP tag in template topics but show content. Used in template
  3812 # _topics_ (not templates, per se, but topics used as templates for new
  3813 # topics)
  3814 sub NOP {
  3815     my ( $this, $params, $topic, $web ) = @_;
  3816 
  3817     return '<nop>' unless $params->{_RAW};
  3818 
  3819     return $params->{_RAW};
  3820 }
  3821 
  3822 # Shortcut to %TMPL:P{"sep"}%
  3823 sub SEP {
  3824     my $this = shift;
  3825     return $this->templates->expandTemplate('sep');
  3826 }
  3827 
  3828 #deprecated functionality, now implemented using %USERINFO%
  3829 #move to compatibility plugin in TWiki5
  3830 sub WIKINAME_deprecated {
  3831     my ( $this, $params ) = @_;
  3832 
  3833     $params->{format} = $this->{prefs}->getPreferencesValue( 'WIKINAME' ) ||
  3834       '$wikiname';
  3835 
  3836     return $this->USERINFO($params);
  3837 }
  3838 
  3839 #deprecated functionality, now implemented using %USERINFO%
  3840 #move to compatibility plugin in TWiki5
  3841 sub USERNAME_deprecated {
  3842     my ( $this, $params ) = @_;
  3843 
  3844     $params->{format} = $this->{prefs}->getPreferencesValue( 'USERNAME' ) ||
  3845       '$username';
  3846 
  3847     return $this->USERINFO($params);
  3848 }
  3849 
  3850 #deprecated functionality, now implemented using %USERINFO%
  3851 #move to compatibility plugin in TWiki5
  3852 sub WIKIUSERNAME_deprecated {
  3853     my ( $this, $params ) = @_;
  3854 
  3855     $params->{format} =
  3856       $this->{prefs}->getPreferencesValue( 'WIKIUSERNAME' ) ||
  3857         '$wikiusername';
  3858 
  3859     return $this->USERINFO($params);
  3860 }
  3861 
  3862 sub USERINFO {
  3863     my ( $this, $params ) = @_;
  3864     my $format = $params->{format} || '$username, $wikiusername, $emails';
  3865 
  3866     my $user = $this->{user};
  3867 
  3868     if( $params->{_DEFAULT} ) {
  3869         $user = $params->{_DEFAULT};
  3870         return '' if !$user;
  3871         # map wikiname to a login name
  3872         $user =~ s/^.*\.//; # kill web
  3873         my $users = $this->{users}->findUserByWikiName($user);
  3874         return '' unless $users && scalar(@$users);
  3875         $user = $users->[0];
  3876         return '' if( $TWiki::cfg{AntiSpam}{HideUserDetails} &&
  3877                         !$this->{users}->isAdmin( $this->{user} ) &&
  3878                           $user ne $this->{user} );
  3879     }
  3880 
  3881     return '' unless $user;
  3882 
  3883     my $info = $format;
  3884 
  3885     if ($info =~ /\$username/) {
  3886         my $username = $this->{users}->getLoginName($user);
  3887         $info =~ s/\$username/$username/g;
  3888     }
  3889     if ($info =~ /\$wikiname/) {
  3890         my $wikiname = $this->{users}->getWikiName( $user );
  3891         $info =~ s/\$wikiname/$wikiname/g;
  3892     }
  3893     if ($info =~ /\$wikiusername/) {
  3894         my $wikiusername = $this->{users}->webDotWikiName($user);
  3895         $info =~ s/\$wikiusername/$wikiusername/g;
  3896     }
  3897     if ($info =~ /\$emails/) {
  3898         my $emails = join(', ', $this->{users}->getEmails($user));
  3899         $info =~ s/\$emails/$emails/g;
  3900     }
  3901     if ($info =~ /\$groups/) {
  3902         my @groupNames;
  3903         my $it = $this->{users}->eachMembership( $user );
  3904         while( $it->hasNext()) {
  3905             my $group = $it->next();
  3906             push( @groupNames, $group);
  3907         }
  3908         my $groups = join(', ', @groupNames);
  3909         $info =~ s/\$groups/$groups/g;
  3910     }
  3911     if ($info =~ /\$cUID/) {
  3912         my $cUID = $user;
  3913         $info =~ s/\$cUID/$cUID/g;
  3914     }
  3915     if ($info =~ /\$admin/) {
  3916         my $admin = $this->{users}->isAdmin($user) ? 'true' : 'false';
  3917         $info =~ s/\$admin/$admin/g;
  3918     }
  3919 
  3920     return $info;
  3921 }
  3922 
  3923 sub GROUPS {
  3924     my ( $this, $params ) = @_;
  3925 
  3926     my $groups = $this->{users}->eachGroup();
  3927     my @table;
  3928     while( $groups->hasNext() ) {
  3929         my $group = $groups->next();
  3930         # Nop it to prevent wikiname expansion unless the topic exists.
  3931 		my $groupLink = "<nop>$group";
  3932 		$groupLink = '[['.$TWiki::cfg{UsersWebName}.".$group][$group]]" if ($this->{store}->topicExists($TWiki::cfg{UsersWebName}, $group));
  3933         my $descr = "| $groupLink |";
  3934         my $it = $this->{users}->eachGroupMember( $group );
  3935         my $limit_output = 32;
  3936         while( $it->hasNext() ) {
  3937             my $user = $it->next();
  3938             $descr .= ' [['.$this->{users}->webDotWikiName($user).']['.
  3939               $this->{users}->getWikiName( $user ).']]';
  3940            if ($limit_output == 0) {
  3941                $descr .= '<div>%MAKETEXT{"user list truncated"}%</div>';
  3942                last;
  3943            }
  3944            $limit_output--;
  3945         }
  3946         push( @table, "$descr |");
  3947     }
  3948 
  3949     return '| *Group* | *Members* |'."\n".join("\n", sort @table);
  3950 }
  3951 
  3952 1;
  3953 __DATA__
  3954 # TWiki Enterprise Collaboration Platform, http://TWiki.org/
  3955 #
  3956 # Copyright (C) 1999-2007 Peter Thoeny, peter@thoeny.org
  3957 # and TWiki Contributors. All Rights Reserved. TWiki Contributors
  3958 # are listed in the AUTHORS file in the root of this distribution.
  3959 # NOTE: Please extend that file, not this notice.
  3960 #
  3961 # Additional copyrights apply to some or all of the code in this
  3962 # file as follows:
  3963 #
  3964 # Based on parts of Ward Cunninghams original Wiki and JosWiki.
  3965 # Copyright (C) 1998 Markus Peter - SPiN GmbH (warpi@spin.de)
  3966 # Some changes by Dave Harris (drh@bhresearch.co.uk) incorporated
  3967 #
  3968 # This program is free software; you can redistribute it and/or
  3969 # modify it under the terms of the GNU General Public License
  3970 # as published by the Free Software Foundation; either version 2
  3971 # of the License, or (at your option) any later version. For
  3972 # more details read LICENSE in the root of this distribution.
  3973 #
  3974 # This program is distributed in the hope that it will be useful,
  3975 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  3976 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  3977 #
  3978 # As per the GPL, removal of this notice is prohibited.