lib/TWiki.pm
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
equal deleted inserted replaced
-1:000000000000 0:414e01d06fd5
       
     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.