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