lib/TWiki.pm
author Colas Nahaboo <colas@nahaboo.net>
Mon, 11 Aug 2008 20:30:19 +0200
changeset 1 e2915a7cbdfa
parent 0 414e01d06fd5
child 2 7bc60a767fa4
permissions -rw-r--r--
TWiki-4.2.1 Release
colas@0
     1
# See bottom of file for license and copyright information
colas@0
     2
package TWiki;
colas@0
     3
colas@0
     4
=pod
colas@0
     5
colas@0
     6
---+ package TWiki
colas@0
     7
colas@0
     8
TWiki operates by creating a singleton object (known as the Session
colas@0
     9
object) that acts as a point of reference for all the different
colas@0
    10
modules in the system. This package is the class for this singleton,
colas@0
    11
and also contains the vast bulk of the basic constants and the per-
colas@0
    12
site configuration mechanisms.
colas@0
    13
colas@0
    14
Global variables are avoided wherever possible to avoid problems
colas@0
    15
with CGI accelerators such as mod_perl.
colas@0
    16
colas@0
    17
---++ Public Data members
colas@0
    18
   * =cgiQuery=         Pointer to the CGI::
colas@0
    19
   * =context=          Hash of context ids
colas@0
    20
   * moved: =loginManager=     TWiki::LoginManager singleton (moved to TWiki::Users)
colas@0
    21
   * =plugins=          TWiki::Plugins singleton
colas@0
    22
   * =prefs=            TWiki::Prefs singleton
colas@0
    23
   * =remoteUser=       Login ID when using ApacheLogin. Maintained for
colas@0
    24
                        compatibility only, do not use.
colas@0
    25
   * =requestedWebName= Name of web found in URL path or =web= URL parameter
colas@0
    26
   * =sandbox=          TWiki::Sandbox singleton
colas@0
    27
   * =scriptUrlPath=    URL path to the current script. May be dynamically
colas@0
    28
                        extracted from the URL path if {GetScriptUrlFromCgi}.
colas@0
    29
                        Only required to support {GetScriptUrlFromCgi} and
colas@0
    30
                        not consistently used. Avoid.
colas@0
    31
   * =security=         TWiki::Access singleton
colas@0
    32
   * =SESSION_TAGS=     Hash of TWiki variables whose value is specific to
colas@0
    33
                        the current CGI request.
colas@0
    34
   * =store=            TWiki::Store singleton
colas@0
    35
   * =topicName=        Name of topic found in URL path or =topic= URL
colas@0
    36
                        parameter
colas@0
    37
   * =urlHost=          Host part of the URL (including the protocol)
colas@0
    38
                        determined during intialisation and defaulting to
colas@0
    39
                        {DefaultUrlHost}
colas@0
    40
   * =user=             Unique user ID of logged-in user
colas@0
    41
   * =users=            TWiki::Users singleton
colas@0
    42
   * =webName=          Name of web found in URL path, or =web= URL parameter,
colas@0
    43
                        or {UsersWebName}
colas@0
    44
colas@0
    45
=cut
colas@0
    46
colas@0
    47
use strict;
colas@0
    48
use Assert;
colas@0
    49
use Error qw( :try );
colas@0
    50
use CGI;             # Always required to get the CGI object
colas@0
    51
colas@0
    52
require 5.005;       # For regex objects and internationalisation
colas@0
    53
colas@0
    54
# Site configuration constants
colas@0
    55
use vars qw( %cfg );
colas@0
    56
colas@0
    57
# Uncomment this and the __END__ to enable AutoLoader
colas@0
    58
#use AutoLoader 'AUTOLOAD';
colas@0
    59
# You then need to autosplit TWiki.pm:
colas@0
    60
# cd lib
colas@0
    61
# perl -e 'use AutoSplit; autosplit("TWiki.pm", "auto")'
colas@0
    62
colas@0
    63
# Other computed constants
colas@0
    64
use vars qw(
colas@0
    65
            $TranslationToken
colas@0
    66
            $twikiLibDir
colas@0
    67
            %regex
colas@0
    68
            %functionTags
colas@0
    69
            %contextFreeSyntax
colas@0
    70
            %restDispatch
colas@0
    71
            $VERSION $RELEASE
colas@0
    72
            $TRUE
colas@0
    73
            $FALSE
colas@0
    74
            $sandbox
colas@0
    75
            $ifParser
colas@0
    76
           );
colas@0
    77
colas@0
    78
# Token character that must not occur in any normal text - converted
colas@0
    79
# to a flag character if it ever does occur (very unlikely)
colas@0
    80
# TWiki uses $TranslationToken to mark points in the text. This is
colas@0
    81
# normally \0, which is not a useful character in any 8-bit character
colas@0
    82
# set we can find, nor in UTF-8. But if you *do* encounter problems
colas@0
    83
# with it, the workaround is to change $TranslationToken to something
colas@0
    84
# longer that is unlikely to occur in your text - for example
colas@0
    85
# muRfleFli5ble8leep (do *not* use punctuation characters or whitspace
colas@0
    86
# in the string!)
colas@0
    87
# See Codev.NationalCharTokenClash for more.
colas@0
    88
$TranslationToken= "\0";
colas@0
    89
colas@0
    90
=pod
colas@0
    91
colas@0
    92
---++ StaticMethod getTWikiLibDir() -> $path
colas@0
    93
colas@0
    94
Returns the full path of the directory containing TWiki.pm
colas@0
    95
colas@0
    96
=cut
colas@0
    97
colas@0
    98
sub getTWikiLibDir {
colas@0
    99
    if( $twikiLibDir ) {
colas@0
   100
        return $twikiLibDir;
colas@0
   101
    }
colas@0
   102
colas@0
   103
    # FIXME: Should just use $INC{"TWiki.pm"} to get path used to load this
colas@0
   104
    # module.
colas@0
   105
    my $dir = '';
colas@0
   106
    foreach $dir ( @INC ) {
colas@0
   107
        if( $dir && -e "$dir/TWiki.pm" ) {
colas@0
   108
            $twikiLibDir = $dir;
colas@0
   109
            last;
colas@0
   110
        }
colas@0
   111
    }
colas@0
   112
colas@0
   113
    # fix path relative to location of called script
colas@0
   114
    if( $twikiLibDir =~ /^\./ ) {
colas@0
   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.";
colas@0
   116
        my $bin;
colas@0
   117
        if( $ENV{SCRIPT_FILENAME} &&
colas@0
   118
            $ENV{SCRIPT_FILENAME} =~ /^(.+)\/[^\/]+$/ ) {
colas@0
   119
            # CGI script name
colas@0
   120
            $bin = $1;
colas@0
   121
        } elsif ( $0 =~ /^(.*)\/.*?$/ ) {
colas@0
   122
            # program name
colas@0
   123
            $bin = $1;
colas@0
   124
        } else {
colas@0
   125
            # last ditch; relative to current directory.
colas@0
   126
            require Cwd;
colas@0
   127
            import Cwd qw( cwd );
colas@0
   128
            $bin = cwd();
colas@0
   129
        }
colas@0
   130
        $twikiLibDir = "$bin/$twikiLibDir/";
colas@0
   131
        # normalize "/../" and "/./"
colas@0
   132
        while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) {
colas@0
   133
        };
colas@0
   134
        $twikiLibDir =~ s|([\\/])\.[\\/]|$1|g;
colas@0
   135
    }
colas@0
   136
    $twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/"
colas@0
   137
    $twikiLibDir =~ s|[\\/]$||;           # cut trailing "/"
colas@0
   138
colas@0
   139
    return $twikiLibDir;
colas@0
   140
}
colas@0
   141
colas@0
   142
BEGIN {
colas@0
   143
    require Monitor;
colas@0
   144
    require TWiki::Sandbox;            # system command sandbox
colas@0
   145
    require TWiki::Configure::Load;    # read configuration files
colas@0
   146
colas@0
   147
    $TRUE = 1;
colas@0
   148
    $FALSE = 0;
colas@0
   149
colas@0
   150
    if( DEBUG ) {
colas@0
   151
        # If ASSERTs are on, then warnings are errors. Paranoid,
colas@0
   152
        # but the only way to be sure we eliminate them all.
colas@0
   153
        # Look out also for $cfg{WarningsAreErrors}, below, which
colas@0
   154
        # is another way to install this handler without enabling
colas@0
   155
        # ASSERTs
colas@0
   156
        # ASSERTS are turned on by defining the environment variable
colas@0
   157
        # TWIKI_ASSERTS. If ASSERTs are off, this is assumed to be a
colas@0
   158
        # production environment, and no stack traces or paths are
colas@0
   159
        # output to the browser.
colas@0
   160
        $SIG{'__WARN__'} = sub { die @_ };
colas@0
   161
        $Error::Debug = 1; # verbose stack traces, please
colas@0
   162
    } else {
colas@0
   163
        $Error::Debug = 0; # no verbose stack traces
colas@0
   164
    }
colas@0
   165
colas@0
   166
    # DO NOT CHANGE THE FORMAT OF $VERSION
colas@0
   167
    # Automatically expanded on checkin of this module
colas@1
   168
    $VERSION = '$Date: 2008-08-03 07:36:58 +0200 (Sun, 03 Aug 2008) $ $Rev: 17311 (04 Aug 2008) $ ';
colas@1
   169
    $RELEASE = 'TWiki-4.2.1';
colas@0
   170
    $VERSION =~ s/^.*?\((.*)\).*: (\d+) .*?$/$RELEASE, $1, build $2/;
colas@0
   171
colas@0
   172
    # Default handlers for different %TAGS%
colas@0
   173
    %functionTags = (
colas@0
   174
        ALLVARIABLES      => \&ALLVARIABLES,
colas@0
   175
        ATTACHURL         => \&ATTACHURL,
colas@0
   176
        ATTACHURLPATH     => \&ATTACHURLPATH,
colas@0
   177
        DATE              => \&DATE,
colas@0
   178
        DISPLAYTIME       => \&DISPLAYTIME,
colas@0
   179
        ENCODE            => \&ENCODE,
colas@0
   180
        ENV               => \&ENV,
colas@0
   181
        FORMFIELD         => \&FORMFIELD,
colas@0
   182
        GMTIME            => \&GMTIME,
colas@0
   183
        GROUPS            => \&GROUPS,
colas@0
   184
        HTTP_HOST         => \&HTTP_HOST_deprecated,
colas@0
   185
        HTTP              => \&HTTP,
colas@0
   186
        HTTPS             => \&HTTPS,
colas@0
   187
        ICON              => \&ICON,
colas@0
   188
        ICONURL           => \&ICONURL,
colas@0
   189
        ICONURLPATH       => \&ICONURLPATH,
colas@0
   190
        IF                => \&IF,
colas@0
   191
        INCLUDE           => \&INCLUDE,
colas@0
   192
        INTURLENCODE      => \&INTURLENCODE_deprecated,
colas@0
   193
        LANGUAGES         => \&LANGUAGES,
colas@0
   194
        MAKETEXT          => \&MAKETEXT,
colas@0
   195
        META              => \&META,
colas@0
   196
        METASEARCH        => \&METASEARCH,
colas@0
   197
        NOP               => \&NOP,
colas@0
   198
        PLUGINVERSION     => \&PLUGINVERSION,
colas@0
   199
        PUBURL            => \&PUBURL,
colas@0
   200
        PUBURLPATH        => \&PUBURLPATH,
colas@0
   201
        QUERYPARAMS       => \&QUERYPARAMS,
colas@0
   202
        QUERYSTRING       => \&QUERYSTRING,
colas@0
   203
        RELATIVETOPICPATH => \&RELATIVETOPICPATH,
colas@0
   204
        REMOTE_ADDR       => \&REMOTE_ADDR_deprecated,
colas@0
   205
        REMOTE_PORT       => \&REMOTE_PORT_deprecated,
colas@0
   206
        REMOTE_USER       => \&REMOTE_USER_deprecated,
colas@0
   207
        REVINFO           => \&REVINFO,
colas@1
   208
        REVTITLE          => \&REVTITLE,
colas@1
   209
        REVARG            => \&REVARG,
colas@0
   210
        SCRIPTNAME        => \&SCRIPTNAME,
colas@0
   211
        SCRIPTURL         => \&SCRIPTURL,
colas@0
   212
        SCRIPTURLPATH     => \&SCRIPTURLPATH,
colas@0
   213
        SEARCH            => \&SEARCH,
colas@0
   214
        SEP               => \&SEP,
colas@0
   215
        SERVERTIME        => \&SERVERTIME,
colas@0
   216
        SPACEDTOPIC       => \&SPACEDTOPIC_deprecated,
colas@0
   217
        SPACEOUT          => \&SPACEOUT,
colas@0
   218
        'TMPL:P'          => \&TMPLP,
colas@0
   219
        TOPICLIST         => \&TOPICLIST,
colas@0
   220
        URLENCODE         => \&ENCODE,
colas@0
   221
        URLPARAM          => \&URLPARAM,
colas@0
   222
        LANGUAGE          => \&LANGUAGE,
colas@0
   223
        USERINFO          => \&USERINFO,
colas@0
   224
        USERNAME          => \&USERNAME_deprecated,
colas@0
   225
        VAR               => \&VAR,
colas@0
   226
        WEBLIST           => \&WEBLIST,
colas@0
   227
        WIKINAME          => \&WIKINAME_deprecated,
colas@0
   228
        WIKIUSERNAME      => \&WIKIUSERNAME_deprecated,
colas@0
   229
        # Constant tag strings _not_ dependent on config. These get nicely
colas@0
   230
        # optimised by the compiler.
colas@0
   231
        ENDSECTION        => sub { '' },
colas@0
   232
        WIKIVERSION       => sub { $VERSION },
colas@0
   233
        STARTSECTION      => sub { '' },
colas@0
   234
        STARTINCLUDE      => sub { '' },
colas@0
   235
        STOPINCLUDE       => sub { '' },
colas@0
   236
       );
colas@0
   237
    $contextFreeSyntax{IF} = 1;
colas@0
   238
colas@0
   239
    unless( ( $TWiki::cfg{DetailedOS} = $^O ) ) {
colas@0
   240
        require Config;
colas@0
   241
        $TWiki::cfg{DetailedOS} = $Config::Config{'osname'};
colas@0
   242
    }
colas@0
   243
    $TWiki::cfg{OS} = 'UNIX';
colas@0
   244
    if ($TWiki::cfg{DetailedOS} =~ /darwin/i) { # MacOS X
colas@0
   245
        $TWiki::cfg{OS} = 'UNIX';
colas@0
   246
    } elsif ($TWiki::cfg{DetailedOS} =~ /Win/i) {
colas@0
   247
        $TWiki::cfg{OS} = 'WINDOWS';
colas@0
   248
    } elsif ($TWiki::cfg{DetailedOS} =~ /vms/i) {
colas@0
   249
        $TWiki::cfg{OS} = 'VMS';
colas@0
   250
    } elsif ($TWiki::cfg{DetailedOS} =~ /bsdos/i) {
colas@0
   251
        $TWiki::cfg{OS} = 'UNIX';
colas@0
   252
    } elsif ($TWiki::cfg{DetailedOS} =~ /dos/i) {
colas@0
   253
        $TWiki::cfg{OS} = 'DOS';
colas@0
   254
    } elsif ($TWiki::cfg{DetailedOS} =~ /^MacOS$/i) { # MacOS 9 or earlier
colas@0
   255
        $TWiki::cfg{OS} = 'MACINTOSH';
colas@0
   256
    } elsif ($TWiki::cfg{DetailedOS} =~ /os2/i) {
colas@0
   257
        $TWiki::cfg{OS} = 'OS2';
colas@0
   258
    }
colas@0
   259
colas@0
   260
    # Validate and untaint Apache's SERVER_NAME Environment variable
colas@0
   261
    # for use in referencing virtualhost-based paths for separate data/ and templates/ instances, etc
colas@0
   262
    if ( $ENV{SERVER_NAME} &&
colas@0
   263
         $ENV{SERVER_NAME} =~ /^(([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6})$/ ) {
colas@0
   264
        $ENV{SERVER_NAME} =
colas@0
   265
          TWiki::Sandbox::untaintUnchecked( $ENV{SERVER_NAME} );
colas@0
   266
    }
colas@0
   267
colas@0
   268
    # readConfig is defined in TWiki::Configure::Load to allow overriding it
colas@0
   269
    TWiki::Configure::Load::readConfig();
colas@0
   270
colas@0
   271
    if( $TWiki::cfg{WarningsAreErrors} ) {
colas@0
   272
        # Note: Warnings are always errors if ASSERTs are enabled
colas@0
   273
        $SIG{'__WARN__'} = sub { die @_ };
colas@0
   274
    }
colas@0
   275
colas@0
   276
    if( $TWiki::cfg{UseLocale} ) {
colas@0
   277
        require locale;
colas@0
   278
        import locale();
colas@0
   279
    }
colas@0
   280
colas@0
   281
    # Constant tags dependent on the config
colas@0
   282
    $functionTags{ALLOWLOGINNAME}  =
colas@0
   283
      sub { $TWiki::cfg{Register}{AllowLoginName} || 0 };
colas@0
   284
    $functionTags{AUTHREALM}       = sub { $TWiki::cfg{AuthRealm} };
colas@0
   285
    $functionTags{DEFAULTURLHOST}  = sub { $TWiki::cfg{DefaultUrlHost} };
colas@0
   286
    $functionTags{HOMETOPIC}       = sub { $TWiki::cfg{HomeTopicName} };
colas@0
   287
    $functionTags{LOCALSITEPREFS}  = sub { $TWiki::cfg{LocalSitePreferences} };
colas@0
   288
    $functionTags{NOFOLLOW}        =
colas@0
   289
      sub { $TWiki::cfg{NoFollow} ? 'rel='.$TWiki::cfg{NoFollow} : '' };
colas@0
   290
    $functionTags{NOTIFYTOPIC}     = sub { $TWiki::cfg{NotifyTopicName} };
colas@0
   291
    $functionTags{SCRIPTSUFFIX}    = sub { $TWiki::cfg{ScriptSuffix} };
colas@0
   292
    $functionTags{STATISTICSTOPIC} = sub { $TWiki::cfg{Stats}{TopicName} };
colas@0
   293
    $functionTags{SYSTEMWEB}       = sub { $TWiki::cfg{SystemWebName} };
colas@0
   294
    $functionTags{TRASHWEB}        = sub { $TWiki::cfg{TrashWebName} };
colas@0
   295
    $functionTags{TWIKIADMINLOGIN} = sub { $TWiki::cfg{AdminUserLogin} };
colas@0
   296
    $functionTags{USERSWEB}        = sub { $TWiki::cfg{UsersWebName} };
colas@0
   297
    $functionTags{WEBPREFSTOPIC}   = sub { $TWiki::cfg{WebPrefsTopicName} };
colas@0
   298
    $functionTags{WIKIPREFSTOPIC}  = sub { $TWiki::cfg{SitePrefsTopicName} };
colas@0
   299
    $functionTags{WIKIUSERSTOPIC}  = sub { $TWiki::cfg{UsersTopicName} };
colas@0
   300
    $functionTags{WIKIWEBMASTER}   = sub { $TWiki::cfg{WebMasterEmail} };
colas@0
   301
    $functionTags{WIKIWEBMASTERNAME} = sub { $TWiki::cfg{WebMasterName} };
colas@0
   302
colas@0
   303
    # Compatibility synonyms, deprecated in 4.2 but still used throughout
colas@0
   304
    # the documentation.
colas@0
   305
    $functionTags{MAINWEB}         = $functionTags{USERSWEB};
colas@0
   306
    $functionTags{TWIKIWEB}        = $functionTags{SYSTEMWEB};
colas@0
   307
colas@0
   308
    # locale setup
colas@0
   309
    #
colas@0
   310
    #
colas@0
   311
    # Note that 'use locale' must be done in BEGIN block for regexes and
colas@0
   312
    # sorting to work properly, although regexes can still work without
colas@0
   313
    # this in 'non-locale regexes' mode.
colas@0
   314
colas@0
   315
    if ( $TWiki::cfg{UseLocale} ) {
colas@0
   316
        # Set environment variables for grep 
colas@0
   317
        $ENV{LC_CTYPE} = $TWiki::cfg{Site}{Locale};
colas@0
   318
colas@0
   319
        # Load POSIX for I18N support.
colas@0
   320
        require POSIX;
colas@0
   321
        import POSIX qw( locale_h LC_CTYPE LC_COLLATE );
colas@0
   322
colas@0
   323
        # SMELL: mod_perl compatibility note: If TWiki is running under Apache,
colas@0
   324
        # won't this play with the Apache process's locale settings too?
colas@0
   325
        # What effects would this have?
colas@0
   326
        setlocale(&LC_CTYPE, $TWiki::cfg{Site}{Locale});
colas@0
   327
        setlocale(&LC_COLLATE, $TWiki::cfg{Site}{Locale});
colas@0
   328
    }
colas@0
   329
colas@0
   330
    $functionTags{CHARSET}   = sub { $TWiki::cfg{Site}{CharSet} ||
colas@0
   331
                                       'iso-8859-1' };
colas@1
   332
colas@1
   333
    $functionTags{LANG} = sub { 
colas@1
   334
        $TWiki::cfg{Site}{Locale} =~ m/^([a-z]+_[a-z]+)/i ? $1 : 'en_US'; };
colas@0
   335
colas@0
   336
    # Set up pre-compiled regexes for use in rendering.  All regexes with
colas@0
   337
    # unchanging variables in match should use the '/o' option.
colas@0
   338
    # In the regex hash, all precompiled REs have "Regex" at the
colas@0
   339
    # end of the name. Anything else is a string, either intended
colas@0
   340
    # for use as a character class, or as a sub-expression in
colas@0
   341
    # another compiled RE.
colas@0
   342
colas@0
   343
    # Build up character class components for use in regexes.
colas@0
   344
    # Depends on locale mode and Perl version, and finally on
colas@0
   345
    # whether locale-based regexes are turned off.
colas@0
   346
    if ( not $TWiki::cfg{UseLocale} or $] < 5.006
colas@0
   347
         or not $TWiki::cfg{Site}{LocaleRegexes} ) {
colas@0
   348
colas@0
   349
        # No locales needed/working, or Perl 5.005, so just use
colas@0
   350
        # any additional national characters defined in TWiki.cfg
colas@0
   351
        $regex{upperAlpha} = 'A-Z'.$TWiki::cfg{UpperNational};
colas@0
   352
        $regex{lowerAlpha} = 'a-z'.$TWiki::cfg{LowerNational};
colas@0
   353
        $regex{numeric}    = '\d';
colas@0
   354
        $regex{mixedAlpha} = $regex{upperAlpha}.$regex{lowerAlpha};
colas@0
   355
    } else {
colas@0
   356
        # Perl 5.006 or higher with working locales
colas@0
   357
        $regex{upperAlpha} = '[:upper:]';
colas@0
   358
        $regex{lowerAlpha} = '[:lower:]';
colas@0
   359
        $regex{numeric}    = '[:digit:]';
colas@0
   360
        $regex{mixedAlpha} = '[:alpha:]';
colas@0
   361
    }
colas@0
   362
    $regex{mixedAlphaNum} = $regex{mixedAlpha}.$regex{numeric};
colas@0
   363
    $regex{lowerAlphaNum} = $regex{lowerAlpha}.$regex{numeric};
colas@0
   364
    $regex{upperAlphaNum} = $regex{upperAlpha}.$regex{numeric};
colas@0
   365
colas@0
   366
    # Compile regexes for efficiency and ease of use
colas@0
   367
    # Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl
colas@0
   368
    # book at http://regex.info/. 
colas@0
   369
colas@0
   370
    $regex{linkProtocolPattern} =
colas@0
   371
      $TWiki::cfg{LinkProtocolPattern};
colas@0
   372
colas@0
   373
    # Header patterns based on '+++'. The '###' are reserved for numbered
colas@0
   374
    # headers
colas@0
   375
    # '---++ Header', '---## Header'
colas@0
   376
    $regex{headerPatternDa} = qr/^---+(\++|\#+)(.*)$/m;
colas@0
   377
    # '<h6>Header</h6>
colas@0
   378
    $regex{headerPatternHt} = qr/^<h([1-6])>(.+?)<\/h\1>/mi;
colas@0
   379
    # '---++!! Header' or '---++ Header %NOTOC% ^top'
colas@0
   380
    $regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)';
colas@0
   381
colas@0
   382
    # TWiki concept regexes
colas@0
   383
    $regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlphaNum}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/o;
colas@0
   384
    $regex{webNameBaseRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}_]*/o;
colas@0
   385
    if ($TWiki::cfg{EnableHierarchicalWebs}) {
colas@0
   386
        $regex{webNameRegex} = qr/$regex{webNameBaseRegex}(?:(?:[\.\/]$regex{webNameBaseRegex})+)*/o;
colas@0
   387
    } else {
colas@0
   388
        $regex{webNameRegex} = $regex{webNameBaseRegex};
colas@0
   389
    }
colas@0
   390
    $regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/o;
colas@0
   391
    $regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/o;
colas@0
   392
    $regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/o;
colas@0
   393
colas@0
   394
    # Simplistic email regex, e.g. for WebNotify processing - no i18n
colas@0
   395
    # characters allowed
colas@0
   396
    $regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_]+\@[A-Za-z0-9\.\-]+)/;
colas@0
   397
colas@0
   398
    # Filename regex to used to match invalid characters in attachments - allow
colas@0
   399
    # alphanumeric characters, spaces, underscores, etc.
colas@0
   400
    # TODO: Get this to work with I18N chars - currently used only with UseLocale off
colas@0
   401
    $regex{filenameInvalidCharRegex} = qr/[^$regex{mixedAlphaNum}\. _-]/o;
colas@0
   402
colas@0
   403
    # Multi-character alpha-based regexes
colas@0
   404
    $regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/o;
colas@0
   405
colas@0
   406
    # %TAG% name
colas@0
   407
    $regex{tagNameRegex} = '['.$regex{mixedAlpha}.']['.$regex{mixedAlphaNum}.'_:]*';
colas@0
   408
colas@0
   409
    # Set statement in a topic
colas@0
   410
    $regex{bulletRegex} = '^(?:\t|   )+\*';
colas@0
   411
    $regex{setRegex} = $regex{bulletRegex}.'\s+(Set|Local)\s+';
colas@0
   412
    $regex{setVarRegex} = $regex{setRegex}.'('.$regex{tagNameRegex}.')\s*=\s*(.*)$';
colas@0
   413
colas@0
   414
    # Character encoding regexes
colas@0
   415
colas@0
   416
    # 7-bit ASCII only
colas@0
   417
    $regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o;
colas@0
   418
colas@0
   419
    # Regex to match only a valid UTF-8 character, taking care to avoid
colas@0
   420
    # security holes due to overlong encodings by excluding the relevant
colas@0
   421
    # gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode
colas@0
   422
    # Encodings section.  Tested against Markus Kuhn's UTF-8 test file
colas@0
   423
    # at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
colas@0
   424
    $regex{validUtf8CharRegex} = qr{
colas@0
   425
                # Single byte - ASCII
colas@0
   426
                [\x00-\x7F] 
colas@0
   427
                |
colas@0
   428
colas@0
   429
                # 2 bytes
colas@0
   430
                [\xC2-\xDF][\x80-\xBF] 
colas@0
   431
                |
colas@0
   432
colas@0
   433
                # 3 bytes
colas@0
   434
colas@0
   435
                    # Avoid illegal codepoints - negative lookahead
colas@0
   436
                    (?!\xEF\xBF[\xBE\xBF])    
colas@0
   437
colas@0
   438
                    # Match valid codepoints
colas@0
   439
                    (?:
colas@0
   440
                    ([\xE0][\xA0-\xBF])|
colas@0
   441
                    ([\xE1-\xEC\xEE-\xEF][\x80-\xBF])|
colas@0
   442
                    ([\xED][\x80-\x9F])
colas@0
   443
                    )
colas@0
   444
                    [\x80-\xBF]
colas@0
   445
                |
colas@0
   446
colas@0
   447
                # 4 bytes 
colas@0
   448
                    (?:
colas@0
   449
                    ([\xF0][\x90-\xBF])|
colas@0
   450
                    ([\xF1-\xF3][\x80-\xBF])|
colas@0
   451
                    ([\xF4][\x80-\x8F])
colas@0
   452
                    )
colas@0
   453
                    [\x80-\xBF][\x80-\xBF]
colas@0
   454
                }xo;
colas@0
   455
colas@0
   456
    $regex{validUtf8StringRegex} =
colas@0
   457
      qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo;
colas@0
   458
colas@0
   459
    # Check for unsafe search regex mode (affects filtering in) - default
colas@0
   460
    # to safe mode
colas@0
   461
    $TWiki::cfg{ForceUnsafeRegexes} = 0 unless defined $TWiki::cfg{ForceUnsafeRegexes};
colas@0
   462
colas@0
   463
    # initialize lib directory early because of later 'cd's
colas@0
   464
    getTWikiLibDir();
colas@0
   465
colas@0
   466
    Monitor::MARK('Static configuration loaded');
colas@0
   467
};
colas@0
   468
colas@0
   469
=pod
colas@0
   470
colas@0
   471
---++ StaticMethod UTF82SiteCharSet( $utf8 ) -> $ascii
colas@0
   472
colas@0
   473
Auto-detect UTF-8 vs. site charset in string, and convert UTF-8 into site
colas@0
   474
charset.
colas@0
   475
colas@0
   476
=cut
colas@0
   477
colas@0
   478
sub UTF82SiteCharSet {
colas@0
   479
    my $text = shift;
colas@0
   480
colas@0
   481
    return $text unless( defined $TWiki::cfg{Site}{CharSet} );
colas@0
   482
colas@0
   483
    # Detect character encoding of the full topic name from URL
colas@0
   484
    return undef if( $text =~ $regex{validAsciiStringRegex} );
colas@0
   485
colas@0
   486
    # If not UTF-8 - assume in site character set, no conversion required
colas@0
   487
    return undef unless( $text =~ $regex{validUtf8StringRegex} );
colas@0
   488
colas@0
   489
    # If site charset is already UTF-8, there is no need to convert anything:
colas@0
   490
    if ( $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) {
colas@0
   491
        # warn if using Perl older than 5.8
colas@0
   492
        if( $] <  5.008 ) {
colas@0
   493
            print STDERR 'UTF-8 not remotely supported on Perl ', $],
colas@0
   494
              ' - use Perl 5.8 or higher..' ;
colas@0
   495
        }
colas@0
   496
colas@0
   497
        # We still don't have Codev.UnicodeSupport
colas@0
   498
        print STDERR 'UTF-8 not yet supported as site charset -',
colas@0
   499
          'TWiki is likely to have problems';
colas@0
   500
        return $text;
colas@0
   501
    }
colas@0
   502
colas@0
   503
    # Convert into ISO-8859-1 if it is the site charset.  This conversion
colas@0
   504
    # is *not valid for ISO-8859-15*.
colas@0
   505
    if ( $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?1$/i ) {
colas@0
   506
        # ISO-8859-1 maps onto first 256 codepoints of Unicode
colas@0
   507
        # (conversion from 'perldoc perluniintro')
colas@0
   508
        $text =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) / 
colas@0
   509
          chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F )
colas@0
   510
            /egx;
colas@0
   511
    } else {
colas@0
   512
        # Convert from UTF-8 into some other site charset
colas@0
   513
        if( $] >= 5.008 ) {
colas@0
   514
            require Encode;
colas@0
   515
            import Encode qw(:fallbacks);
colas@0
   516
            # Map $TWiki::cfg{Site}{CharSet} into real encoding name
colas@0
   517
            my $charEncoding =
colas@0
   518
              Encode::resolve_alias( $TWiki::cfg{Site}{CharSet} );
colas@0
   519
            if( not $charEncoding ) {
colas@0
   520
                print STDERR
colas@0
   521
                  'Conversion to "',$TWiki::cfg{Site}{CharSet},
colas@0
   522
                    '" not supported, or name not recognised - check ',
colas@0
   523
                      '"perldoc Encode::Supported"';
colas@0
   524
            } else {
colas@0
   525
                # Convert text using Encode:
colas@0
   526
                # - first, convert from UTF8 bytes into internal
colas@0
   527
                # (UTF-8) characters
colas@0
   528
                $text = Encode::decode('utf8', $text);    
colas@0
   529
                # - then convert into site charset from internal UTF-8,
colas@0
   530
                # inserting \x{NNNN} for characters that can't be converted
colas@0
   531
                $text =
colas@0
   532
                  Encode::encode( $charEncoding, $text,
colas@0
   533
                                  &FB_PERLQQ() );
colas@0
   534
            }
colas@0
   535
        } else {
colas@0
   536
            require Unicode::MapUTF8;    # Pre-5.8 Perl versions
colas@0
   537
            my $charEncoding = $TWiki::cfg{Site}{CharSet};
colas@0
   538
            if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) {
colas@0
   539
                print STDERR 'Conversion to "',$TWiki::cfg{Site}{CharSet},
colas@0
   540
                  '" not supported, or name not recognised - check ',
colas@0
   541
                    '"perldoc Unicode::MapUTF8"';
colas@0
   542
            } else {
colas@0
   543
                # Convert text
colas@0
   544
                $text =
colas@0
   545
                  Unicode::MapUTF8::from_utf8({
colas@0
   546
                                               -string => $text,
colas@0
   547
                                               -charset => $charEncoding
colas@0
   548
                                              });
colas@0
   549
                # FIXME: Check for failed conversion?
colas@0
   550
            }
colas@0
   551
        }
colas@0
   552
    }
colas@0
   553
    return $text;
colas@0
   554
}
colas@0
   555
colas@0
   556
=pod
colas@0
   557
colas@0
   558
---++ ObjectMethod writeCompletePage( $text, $pageType, $contentType )
colas@0
   559
colas@0
   560
Write a complete HTML page with basic header to the browser.
colas@0
   561
   * =$text= is the text of the page body (&lt;html&gt; to &lt;/html&gt; if it's HTML)
colas@0
   562
   * =$pageType= - May be "edit", which will cause headers to be generated that force
colas@0
   563
     caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused
colas@0
   564
     data loss with IE5 and IE6.
colas@0
   565
   * =$contentType= - page content type | text/html
colas@0
   566
colas@0
   567
This method removes noautolink and nop tags before outputting the page unless
colas@0
   568
$contentType is text/plain.
colas@0
   569
colas@0
   570
=cut
colas@0
   571
colas@0
   572
sub writeCompletePage {
colas@0
   573
    my ( $this, $text, $pageType, $contentType ) = @_;
colas@0
   574
    $contentType ||= 'text/html';
colas@0
   575
colas@0
   576
    if( $contentType ne 'text/plain' ) {
colas@0
   577
        # Remove <nop> and <noautolink> tags
colas@0
   578
        $text =~ s/([\t ]?)[ \t]*<\/?(nop|noautolink)\/?>/$1/gis;
colas@0
   579
        $text .= "\n" unless $text =~ /\n$/s;
colas@0
   580
colas@0
   581
        my $htmlHeader = join(
colas@0
   582
            "\n",
colas@0
   583
            map { '<!--'.$_.'-->'.$this->{_HTMLHEADERS}{$_} }
colas@0
   584
              keys %{$this->{_HTMLHEADERS}} );
colas@0
   585
        $text =~ s!(</head>)!$htmlHeader$1!i if $htmlHeader;
colas@0
   586
        chomp($text);
colas@0
   587
    }
colas@0
   588
colas@0
   589
    my $hdr = $this->generateHTTPHeaders( undef, $pageType, $contentType );
colas@0
   590
colas@0
   591
    # Call final handler
colas@0
   592
    $this->{plugins}->completePageHandler($text, $hdr);
colas@0
   593
colas@0
   594
    # HTTP1.1 says a content-length should _not_ be specified unless
colas@0
   595
    # the length is known. There is a bug in Netscape such that it
colas@0
   596
    # interprets a 0 content-length as "download until disconnect"
colas@0
   597
    # but that is a bug. The correct way is to not set a content-length.
colas@0
   598
    unless( $this->inContext('command_line') ) {
colas@0
   599
        # FIXME: Defer next line until we have Codev.UnicodeSupport
colas@0
   600
        # - too 5.8 dependent
colas@0
   601
        # my $len = do { use bytes; length( $text ); };
colas@0
   602
        my $len = length($text);
colas@0
   603
        $hdr =~ s/\n$/Content-Length: $len\n\n/s if $len;
colas@0
   604
    } else {
colas@0
   605
        $hdr = '';
colas@0
   606
    }
colas@0
   607
colas@0
   608
    print $hdr.$text;
colas@0
   609
}
colas@0
   610
colas@0
   611
=pod
colas@0
   612
colas@0
   613
---++ ObjectMethod generateHTTPHeaders( $query, $pageType, $contentType, $contentLength ) -> $header
colas@0
   614
colas@0
   615
All parameters are optional.
colas@0
   616
colas@0
   617
   * =$query= CGI query object | Session CGI query (there is no good reason to set this)
colas@0
   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.
colas@0
   619
   * =$contentType= - page content type | text/html
colas@0
   620
   * =$contentLength= - content-length | no content-length will be set if this is undefined, as required by HTTP1.1
colas@0
   621
colas@0
   622
Implements the post-Dec2001 release plugin API, which requires the
colas@0
   623
writeHeaderHandler in plugin to return a string of HTTP headers, CR/LF
colas@0
   624
delimited. Filters any illegal headers. Plugin headers will override
colas@0
   625
core settings.
colas@0
   626
colas@0
   627
Does *not* add a =Content-length= header.
colas@0
   628
colas@0
   629
=cut
colas@0
   630
colas@0
   631
sub generateHTTPHeaders {
colas@0
   632
    my( $this, $query, $pageType, $contentType ) = @_;
colas@0
   633
colas@0
   634
    $query = $this->{cgiQuery} unless $query;
colas@0
   635
colas@0
   636
    # Handle Edit pages - future versions will extend to caching
colas@0
   637
    # of other types of page, with expiry time driven by page type.
colas@0
   638
    my( $pluginHeaders, $coreHeaders );
colas@0
   639
colas@0
   640
    my $hopts = {};
colas@0
   641
colas@0
   642
    if ($pageType && $pageType eq 'edit') {
colas@0
   643
        # Get time now in HTTP header format
colas@0
   644
        require TWiki::Time;
colas@0
   645
        my $lastModifiedString =
colas@0
   646
          TWiki::Time::formatTime(time, '$http', 'gmtime');
colas@0
   647
colas@0
   648
        # Expiry time is set high to avoid any data loss.  Each instance of 
colas@0
   649
        # Edit page has a unique URL with time-string suffix (fix for 
colas@0
   650
        # RefreshEditPage), so this long expiry time simply means that the 
colas@0
   651
        # browser Back button always works.  The next Edit on this page 
colas@0
   652
        # will use another URL and therefore won't use any cached 
colas@0
   653
        # version of this Edit page.
colas@0
   654
        my $expireHours = 24;
colas@0
   655
        my $expireSeconds = $expireHours * 60 * 60;
colas@0
   656
colas@0
   657
        # and cache control headers, to ensure edit page 
colas@0
   658
        # is cached until required expiry time.
colas@0
   659
        $hopts->{'last-modified'} = $lastModifiedString;
colas@0
   660
        $hopts->{expires} = "+${expireHours}h";
colas@0
   661
        $hopts->{'cache-control'} = "max-age=$expireSeconds";
colas@0
   662
    }
colas@0
   663
colas@0
   664
    # DEPRECATED plugins header handler. Plugins should use
colas@0
   665
    # modifyHeaderHandler instead.
colas@0
   666
    $pluginHeaders = $this->{plugins}->writeHeaderHandler( $query ) || '';
colas@0
   667
    if( $pluginHeaders ) {
colas@0
   668
        foreach ( split /\r?\n/, $pluginHeaders ) {
colas@0
   669
            if ( m/^([\-a-z]+): (.*)$/i ) {
colas@0
   670
                $hopts->{$1} = $2;
colas@0
   671
            }
colas@0
   672
        }
colas@0
   673
    }
colas@0
   674
colas@0
   675
    $contentType = 'text/html' unless $contentType;
colas@0
   676
    if( defined( $TWiki::cfg{Site}{CharSet} )) {
colas@0
   677
      $contentType .= '; charset='.$TWiki::cfg{Site}{CharSet};
colas@0
   678
    }
colas@0
   679
colas@0
   680
    # use our version of the content type
colas@0
   681
    $hopts->{'Content-Type'} = $contentType;
colas@0
   682
colas@0
   683
    # New (since 1.026)
colas@0
   684
    $this->{plugins}->modifyHeaderHandler( $hopts, $this->{cgiQuery} );
colas@0
   685
colas@0
   686
    # add cookie(s)
colas@0
   687
    $this->{users}->{loginManager}->modifyHeader( $hopts );
colas@0
   688
colas@0
   689
    return CGI::header( $hopts );
colas@0
   690
}
colas@0
   691
colas@0
   692
=pod
colas@0
   693
colas@0
   694
---++ StaticMethod isRedirectSafe($redirect) => $ok
colas@0
   695
colas@0
   696
tests if the $redirect is an external URL, returning false if AllowRedirectUrl is denied
colas@0
   697
colas@0
   698
=cut
colas@0
   699
colas@0
   700
sub isRedirectSafe {
colas@0
   701
    my $redirect = shift;
colas@0
   702
    
colas@0
   703
    #TODO: this should really use URI
colas@0
   704
    if ((!$TWiki::cfg{AllowRedirectUrl}) && ( $redirect =~ m!^([^:]*://[^/]*)/*(.*)?$! )) {
colas@0
   705
        my $host = $1;
colas@0
   706
        #remove trailing /'s to match
colas@0
   707
        $TWiki::cfg{DefaultUrlHost} =~ m!^([^:]*://[^/]*)/*(.*)?$!;
colas@0
   708
        my $expected = $1;
colas@0
   709
        
colas@0
   710
        if (defined($TWiki::cfg{PermittedRedirectHostUrls} ) && $TWiki::cfg{PermittedRedirectHostUrls}  ne '') {
colas@0
   711
            my @permitted =
colas@0
   712
                map { s!^([^:]*://[^/]*)/*(.*)?$!$1!; $1 }
colas@0
   713
                        split(/,\s*/, $TWiki::cfg{PermittedRedirectHostUrls});
colas@0
   714
            return 1 if ( grep ( { uc($host) eq uc($_) } @permitted));
colas@0
   715
        }
colas@0
   716
        return (uc($host) eq uc($expected));
colas@0
   717
    }
colas@0
   718
    return 1;
colas@0
   719
}
colas@0
   720
colas@0
   721
# _getRedirectUrl() => redirectURL set from the parameter
colas@0
   722
# Reads a redirect url from CGI parameter 'redirectto'.
colas@0
   723
# This function is used to get and test the 'redirectto' cgi parameter, 
colas@0
   724
# and then the calling function can set its own reporting if there is a
colas@0
   725
# problem.
colas@0
   726
sub _getRedirectUrl {
colas@0
   727
    my $session = shift;
colas@0
   728
colas@0
   729
    my $query = $session->{cgiQuery};
colas@0
   730
    my $redirecturl = $query->param( 'redirectto' );
colas@0
   731
    return '' unless $redirecturl;
colas@0
   732
colas@0
   733
    if( $redirecturl =~ m#^$regex{linkProtocolPattern}://#o ) {
colas@0
   734
        # assuming URL
colas@0
   735
        if (isRedirectSafe($redirecturl)) {
colas@0
   736
            return $redirecturl;
colas@0
   737
        } else {
colas@0
   738
            return '';
colas@0
   739
        }
colas@0
   740
    }
colas@0
   741
    # assuming 'web.topic' or 'topic'
colas@0
   742
    my ( $w, $t ) = $session->normalizeWebTopicName( $session->{webName}, $redirecturl );
colas@0
   743
    $redirecturl = $session->getScriptUrl( 1, 'view', $w, $t );
colas@0
   744
    return $redirecturl;
colas@0
   745
}
colas@0
   746
colas@0
   747
colas@0
   748
=pod
colas@0
   749
colas@0
   750
---++ ObjectMethod redirect( $url, $passthrough, $action_redirectto )
colas@0
   751
colas@0
   752
   * $url - url or twikitopic to redirect to
colas@0
   753
   * $passthrough - (optional) parameter to **FILLMEIN**
colas@0
   754
   * $action_redirectto - (optional) redirect to where ?redirectto=
colas@0
   755
     points to (if it's valid)
colas@0
   756
colas@0
   757
Redirects the request to =$url=, *unless*
colas@0
   758
   1 It is overridden by a plugin declaring a =redirectCgiQueryHandler=.
colas@0
   759
   1 =$session->{cgiQuery}= is =undef= or
colas@0
   760
   1 $query->param('noredirect') is set to a true value.
colas@0
   761
Thus a redirect is only generated when in a CGI context.
colas@0
   762
colas@0
   763
Normally this method will ignore parameters to the current query. Sometimes,
colas@0
   764
for example when redirecting to a login page during authentication (and then
colas@0
   765
again from the login page to the original requested URL), you want to make
colas@0
   766
sure all parameters are passed on, and for this $passthrough should be set to
colas@0
   767
true. In this case it will pass all parameters that were passed to the
colas@0
   768
current query on to the redirect target. If the request_method for the
colas@0
   769
current query was GET, then all parameters will be passed by encoding them
colas@0
   770
in the URL (after ?). If the request_method was POST, then there is a risk the
colas@0
   771
URL would be too big for the receiver, so it caches the form data and passes
colas@0
   772
over a cache reference in the redirect GET.
colas@0
   773
colas@0
   774
NOTE: Passthrough is only meaningful if the redirect target is on the same
colas@0
   775
server.
colas@0
   776
colas@0
   777
=cut
colas@0
   778
colas@0
   779
sub redirect {
colas@0
   780
    my( $this, $url, $passthru, $action_redirectto ) = @_;
colas@0
   781
colas@0
   782
    my $query = $this->{cgiQuery};
colas@0
   783
    # if we got here without a query, there's not much more we can do
colas@0
   784
    return unless $query;
colas@0
   785
colas@0
   786
    # SMELL: if noredirect is set, don't generate the redirect, throw an
colas@0
   787
    # exception instead. This is a HACK used to support TWikiDrawPlugin.
colas@0
   788
    # It is deprecated and must be replaced by REST handlers in the plugin.
colas@0
   789
    if( $query->param( 'noredirect' )) {
colas@0
   790
        die "ERROR: $url";
colas@0
   791
        return;
colas@0
   792
    }
colas@0
   793
colas@0
   794
    if ($action_redirectto) {
colas@0
   795
        my $redir = _getRedirectUrl($this);
colas@0
   796
        $url = $redir if ($redir);
colas@0
   797
    }
colas@0
   798
colas@0
   799
    if ($passthru && defined $ENV{REQUEST_METHOD}) {
colas@0
   800
        my $existing = '';
colas@0
   801
        if ($url =~ s/\?(.*)$//) {
colas@0
   802
            $existing = $1;
colas@0
   803
        }
colas@0
   804
        if ($ENV{REQUEST_METHOD} eq 'POST') {
colas@0
   805
            # Redirecting from a post to a get
colas@0
   806
            my $cache = $this->cacheQuery();
colas@0
   807
            if ($cache) {
colas@0
   808
                $url .= "?$cache";
colas@0
   809
            }
colas@0
   810
        } else {
colas@0
   811
            if ($query->query_string()) {
colas@0
   812
                $url .= '?'.$query->query_string();
colas@0
   813
            }
colas@0
   814
            if ($existing) {
colas@0
   815
                if ($url =~ /\?/) {
colas@0
   816
                    $url .= ';';
colas@0
   817
                } else {
colas@0
   818
                    $url .= '?';
colas@0
   819
                }
colas@0
   820
                $url .= $existing;
colas@0
   821
            }
colas@0
   822
        }
colas@0
   823
    }
colas@0
   824
colas@0
   825
    # prevent phishing by only allowing redirect to configured host
colas@0
   826
    # do this check as late as possible to catch _any_ last minute hacks
colas@0
   827
    # TODO: this should really use URI
colas@0
   828
    if (!isRedirectSafe($url)) {
colas@0
   829
         # goto oops if URL is trying to take us somewhere dangerous
colas@0
   830
         $url = $this->getScriptUrl(
colas@0
   831
             1, 'oops',
colas@0
   832
             $this->{web} || $TWiki::cfg{UsersWebName},
colas@0
   833
             $this->{topic} || $TWiki::cfg{HomeTopicName},
colas@0
   834
             template => 'oopsaccessdenied',
colas@0
   835
             def => 'topic_access',
colas@0
   836
             param1 => 'redirect',
colas@0
   837
             param2 => 'unsafe redirect to '.$url.
colas@0
   838
               ': host does not match {DefaultUrlHost} , and is not in {PermittedRedirectHostUrls}"'.
colas@0
   839
                 $TWiki::cfg{DefaultUrlHost}.'"'
colas@0
   840
            );
colas@0
   841
    }
colas@0
   842
colas@0
   843
colas@0
   844
    return if( $this->{plugins}->redirectCgiQueryHandler( $query, $url ));
colas@0
   845
colas@0
   846
    # SMELL: this is a bad breaking of encapsulation: the loginManager
colas@0
   847
    # should just modify the url, then the redirect should only happen here.
colas@0
   848
    return if( $this->{users}->{loginManager}->redirectCgiQuery( $query, $url ) );
colas@0
   849
    die "Login manager returned 0 from redirectCgiQuery";
colas@0
   850
}
colas@0
   851
colas@0
   852
=pod
colas@0
   853
colas@0
   854
---++ ObjectMethod cacheQuery() -> $queryString
colas@0
   855
colas@0
   856
Caches the current query in the params cache, and returns a rewritten
colas@0
   857
query string for the cache to be picked up again on the other side of a
colas@0
   858
redirect.
colas@0
   859
colas@0
   860
We can't encode post params into a redirect, because they may exceed the
colas@0
   861
size of the GET request. So we cache the params, and reload them when the
colas@0
   862
redirect target is reached.
colas@0
   863
colas@0
   864
=cut
colas@0
   865
colas@0
   866
sub cacheQuery {
colas@0
   867
    my $this = shift;
colas@0
   868
    my $query = $this->{cgiQuery};
colas@0
   869
colas@0
   870
    return '' unless (scalar($query->param()));
colas@0
   871
    # Don't double-cache
colas@0
   872
    return '' if ($query->param('twiki_redirect_cache'));
colas@0
   873
colas@0
   874
    require Digest::MD5;
colas@0
   875
    my $md5 = new Digest::MD5();
colas@0
   876
    $md5->add($$, time(), rand(time));
colas@0
   877
    my $uid = $md5->hexdigest();
colas@0
   878
    my $passthruFilename = "$TWiki::cfg{WorkingDir}/tmp/passthru_$uid";
colas@0
   879
colas@0
   880
    use Fcntl;
colas@0
   881
    #passthrough file is only written to once, so if it already exists, suspect a security hack (O_EXCL)
colas@0
   882
    sysopen(F, "$passthruFilename", O_RDWR|O_EXCL|O_CREAT, 0600) ||
colas@0
   883
      die "Unable to open $TWiki::cfg{WorkingDir}/tmp for write; check the setting of {WorkingDir} in configure, and check file permissions: $!";
colas@0
   884
    $query->save(\*F);
colas@0
   885
    close(F);
colas@0
   886
    return 'twiki_redirect_cache='.$uid;
colas@0
   887
}
colas@0
   888
colas@0
   889
=pod
colas@0
   890
colas@0
   891
---++ StaticMethod isValidWikiWord( $name ) -> $boolean
colas@0
   892
colas@0
   893
Check for a valid WikiWord or WikiName
colas@0
   894
colas@0
   895
=cut
colas@0
   896
colas@0
   897
sub isValidWikiWord {
colas@0
   898
    my $name  = shift || '';
colas@0
   899
    return ( $name =~ m/^$regex{wikiWordRegex}$/o )
colas@0
   900
}
colas@0
   901
colas@0
   902
=pod
colas@0
   903
colas@0
   904
---++ StaticMethod isValidTopicName( $name ) -> $boolean
colas@0
   905
colas@0
   906
Check for a valid topic name
colas@0
   907
colas@0
   908
=cut
colas@0
   909
colas@0
   910
sub isValidTopicName {
colas@0
   911
    my( $name ) = @_;
colas@0
   912
colas@0
   913
    return isValidWikiWord( @_ ) || isValidAbbrev( @_ );
colas@0
   914
}
colas@0
   915
colas@0
   916
=pod
colas@0
   917
colas@0
   918
---++ StaticMethod isValidAbbrev( $name ) -> $boolean
colas@0
   919
colas@0
   920
Check for a valid ABBREV (acronym)
colas@0
   921
colas@0
   922
=cut
colas@0
   923
colas@0
   924
sub isValidAbbrev {
colas@0
   925
    my $name = shift || '';
colas@0
   926
    return ( $name =~ m/^$regex{abbrevRegex}$/o )
colas@0
   927
}
colas@0
   928
colas@0
   929
=pod
colas@0
   930
colas@0
   931
---++ StaticMethod isValidWebName( $name, $system ) -> $boolean
colas@0
   932
colas@0
   933
STATIC Check for a valid web name. If $system is true, then
colas@0
   934
system web names are considered valid (names starting with _)
colas@0
   935
otherwise only user web names are valid
colas@0
   936
colas@0
   937
If $TWiki::cfg{EnableHierarchicalWebs} is off, it will also return false
colas@0
   938
when a nested web name is passed to it.
colas@0
   939
colas@0
   940
=cut
colas@0
   941
colas@0
   942
sub isValidWebName {
colas@0
   943
    my $name = shift || '';
colas@0
   944
    my $sys = shift;
colas@0
   945
    return 1 if ( $sys && $name =~ m/^$regex{defaultWebNameRegex}$/o );
colas@0
   946
    return ( $name =~ m/^$regex{webNameRegex}$/o )
colas@0
   947
}
colas@0
   948
colas@0
   949
=pod
colas@0
   950
colas@0
   951
---++ ObjectMethod readOnlyMirrorWeb( $theWeb ) -> ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote )
colas@0
   952
colas@0
   953
If this is a mirrored web, return information about the mirror. The info
colas@0
   954
is returned in a quadruple:
colas@0
   955
colas@0
   956
| site name | URL | link | note |
colas@0
   957
colas@0
   958
=cut
colas@0
   959
colas@0
   960
sub readOnlyMirrorWeb {
colas@0
   961
    my( $this, $theWeb ) = @_;
colas@0
   962
colas@0
   963
colas@0
   964
    my @mirrorInfo = ( '', '', '', '' );
colas@0
   965
    if( $TWiki::cfg{SiteWebTopicName} ) {
colas@0
   966
        my $mirrorSiteName =
colas@0
   967
          $this->{prefs}->getWebPreferencesValue( 'MIRRORSITENAME', $theWeb );
colas@0
   968
        if( $mirrorSiteName && $mirrorSiteName ne $TWiki::cfg{SiteWebTopicName} ) {
colas@0
   969
            my $mirrorViewURL  =
colas@0
   970
              $this->{prefs}->getWebPreferencesValue( 'MIRRORVIEWURL', $theWeb );
colas@0
   971
            my $mirrorLink = $this->templates->readTemplate( 'mirrorlink' );
colas@0
   972
            $mirrorLink =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
colas@0
   973
            $mirrorLink =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
colas@0
   974
            $mirrorLink =~ s/\s*$//g;
colas@0
   975
            my $mirrorNote = $this->templates->readTemplate( 'mirrornote' );
colas@0
   976
            $mirrorNote =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
colas@0
   977
            $mirrorNote =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
colas@0
   978
            $mirrorNote = $this->renderer->getRenderedVersion
colas@0
   979
              ( $mirrorNote, $theWeb, $TWiki::cfg{HomeTopic} );
colas@0
   980
            $mirrorNote =~ s/\s*$//g;
colas@0
   981
            @mirrorInfo = ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote );
colas@0
   982
        }
colas@0
   983
    }
colas@0
   984
    return @mirrorInfo;
colas@0
   985
}
colas@0
   986
colas@0
   987
=pod
colas@0
   988
colas@0
   989
---++ ObjectMethod getSkin () -> $string
colas@0
   990
colas@0
   991
Get the currently requested skin path
colas@0
   992
colas@0
   993
=cut
colas@0
   994
colas@0
   995
sub getSkin {
colas@0
   996
    my $this = shift;
colas@0
   997
colas@0
   998
colas@0
   999
    my $skinpath = $this->{prefs}->getPreferencesValue( 'SKIN' ) || '';
colas@0
  1000
colas@0
  1001
    if( $this->{cgiQuery} ) {
colas@0
  1002
        my $resurface = $this->{cgiQuery}->param( 'skin' );
colas@0
  1003
        $skinpath = $resurface if $resurface;
colas@0
  1004
    }
colas@0
  1005
colas@0
  1006
    my $epidermis = $this->{prefs}->getPreferencesValue( 'COVER' );
colas@0
  1007
    $skinpath = $epidermis.','.$skinpath if $epidermis;
colas@0
  1008
colas@0
  1009
    if( $this->{cgiQuery} ) {
colas@0
  1010
        $epidermis = $this->{cgiQuery}->param( 'cover' );
colas@0
  1011
        $skinpath = $epidermis.','.$skinpath if $epidermis;
colas@0
  1012
    }
colas@0
  1013
colas@0
  1014
    return $skinpath;
colas@0
  1015
}
colas@0
  1016
colas@0
  1017
=pod
colas@0
  1018
colas@0
  1019
---++ ObjectMethod getScriptUrl( $absolute, $script, $web, $topic, ... ) -> $scriptURL
colas@0
  1020
colas@0
  1021
Returns the URL to a TWiki script, providing the web and topic as
colas@0
  1022
"path info" parameters.  The result looks something like this:
colas@0
  1023
"http://host/twiki/bin/$script/$web/$topic".
colas@0
  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>
colas@0
  1025
colas@0
  1026
If $absolute is set, generates an absolute URL. $absolute is advisory only;
colas@0
  1027
TWiki can decide to generate absolute URLs (for example when run from the
colas@0
  1028
command-line) even when relative URLs have been requested.
colas@0
  1029
colas@0
  1030
The default script url is taken from {ScriptUrlPath}, unless there is
colas@0
  1031
an exception defined for the given script in {ScriptUrlPaths}. Both
colas@0
  1032
{ScriptUrlPath} and {ScriptUrlPaths} may be absolute or relative URIs. If
colas@0
  1033
they are absolute, then they will always generate absolute URLs. if they
colas@0
  1034
are relative, then they will be converted to absolute when required (e.g.
colas@0
  1035
when running from the command line, or when generating rss). If
colas@0
  1036
$script is not given, absolute URLs will always be generated.
colas@0
  1037
colas@0
  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.
colas@0
  1039
colas@0
  1040
=cut
colas@0
  1041
colas@0
  1042
sub getScriptUrl {
colas@0
  1043
    my( $this, $absolute, $script, $web, $topic, @params ) = @_;
colas@0
  1044
colas@0
  1045
    $absolute ||= ($this->inContext( 'command_line' ) ||
colas@0
  1046
                     $this->inContext( 'rss' ) ||
colas@0
  1047
                       $this->inContext( 'absolute_urls' ));
colas@0
  1048
colas@0
  1049
    # SMELL: topics and webs that contain spaces?
colas@0
  1050
colas@0
  1051
    my $url;
colas@0
  1052
    if( defined $TWiki::cfg{ScriptUrlPaths} && $script) {
colas@0
  1053
        $url = $TWiki::cfg{ScriptUrlPaths}{$script};
colas@0
  1054
    }
colas@0
  1055
    unless( defined( $url )) {
colas@0
  1056
        $url = $TWiki::cfg{ScriptUrlPath};
colas@0
  1057
        if( $script ) {
colas@0
  1058
            $url .= '/' unless $url =~ /\/$/;
colas@0
  1059
            $url .= $script;
colas@0
  1060
            $url .= $TWiki::cfg{ScriptSuffix} if $script;
colas@0
  1061
        }
colas@0
  1062
    }
colas@0
  1063
colas@0
  1064
    if( $absolute && $url !~ /^[a-z]+:/ ) {
colas@0
  1065
        # See http://www.ietf.org/rfc/rfc2396.txt for the definition of
colas@0
  1066
        # "absolute URI". TWiki bastardises this definition by assuming
colas@0
  1067
        # that all relative URLs lack the <authority> component as well.
colas@0
  1068
        $url = $this->{urlHost}.$url;
colas@0
  1069
    }
colas@0
  1070
colas@0
  1071
    if( $web || $topic ) {
colas@0
  1072
        ( $web, $topic ) =
colas@0
  1073
          $this->normalizeWebTopicName( $web, $topic );
colas@0
  1074
colas@0
  1075
        $url .= urlEncode( '/'.$web.'/'.$topic );
colas@0
  1076
colas@0
  1077
	$url .= _make_params(0, @params);
colas@0
  1078
    }
colas@0
  1079
colas@0
  1080
    return $url;
colas@0
  1081
}
colas@0
  1082
colas@0
  1083
sub _make_params {
colas@0
  1084
  my ( $notfirst, @args ) = @_;
colas@0
  1085
  my $url = '';
colas@0
  1086
  my $ps = '';
colas@0
  1087
  my $anchor = '';
colas@0
  1088
  while( my $p = shift @args ) {
colas@0
  1089
    if( $p eq '#' ) {
colas@0
  1090
      $anchor .= '#' . shift( @args );
colas@0
  1091
    } else {
colas@0
  1092
      $ps .= ';' . $p.'='.urlEncode(shift( @args )||'');
colas@0
  1093
    }
colas@0
  1094
  }
colas@0
  1095
  if( $ps ) {
colas@0
  1096
    $ps =~ s/^;/?/ unless $notfirst;
colas@0
  1097
    $url .= $ps;
colas@0
  1098
  }
colas@0
  1099
  $url .= $anchor;
colas@0
  1100
  return $url;
colas@0
  1101
}
colas@0
  1102
colas@0
  1103
=pod
colas@0
  1104
colas@0
  1105
---++ ObjectMethod getPubUrl($absolute, $web, $topic, $attachment) -> $url
colas@0
  1106
colas@0
  1107
Composes a pub url. If $absolute is set, returns an absolute URL.
colas@0
  1108
If $absolute is set, generates an absolute URL. $absolute is advisory only;
colas@0
  1109
TWiki can decide to generate absolute URLs (for example when run from the
colas@0
  1110
command-line) even when relative URLs have been requested.
colas@0
  1111
colas@0
  1112
$web, $topic and $attachment are optional. A partial URL path will be
colas@0
  1113
generated if one or all is not given.
colas@0
  1114
colas@0
  1115
=cut
colas@0
  1116
colas@0
  1117
sub getPubUrl {
colas@0
  1118
    my( $this, $absolute, $web, $topic, $attachment ) = @_;
colas@0
  1119
colas@0
  1120
    $absolute ||= ($this->inContext( 'command_line' ) ||
colas@0
  1121
                     $this->inContext( 'rss' ) ||
colas@0
  1122
                       $this->inContext( 'absolute_urls' ));
colas@0
  1123
colas@0
  1124
    my $url = '';
colas@0
  1125
    $url .= $TWiki::cfg{PubUrlPath};
colas@0
  1126
    if( $absolute && $url !~ /^[a-z]+:/ ) {
colas@0
  1127
        # See http://www.ietf.org/rfc/rfc2396.txt for the definition of
colas@0
  1128
        # "absolute URI". TWiki bastardises this definition by assuming
colas@0
  1129
        # that all relative URLs lack the <authority> component as well.
colas@0
  1130
        $url = $this->{urlHost}.$url;
colas@0
  1131
    }
colas@0
  1132
    if( $web || $topic || $attachment ) {
colas@0
  1133
        ( $web, $topic ) =
colas@0
  1134
          $this->normalizeWebTopicName( $web, $topic );
colas@0
  1135
colas@0
  1136
        my $path = '/'.$web.'/'.$topic;
colas@0
  1137
	if( $attachment ) {
colas@0
  1138
	    $path .= '/'.$attachment;
colas@0
  1139
	    # Attachments are served directly by web server, need to handle
colas@0
  1140
	    # URL encoding specially
colas@0
  1141
	    $url .= urlEncodeAttachment ( $path );
colas@0
  1142
	} else {
colas@0
  1143
	    $url .= urlEncode( $path );
colas@0
  1144
	}
colas@0
  1145
    }
colas@0
  1146
colas@0
  1147
    return $url;
colas@0
  1148
}
colas@0
  1149
colas@0
  1150
=pod
colas@0
  1151
colas@0
  1152
---++ ObjectMethod getIconUrl( $absolute, $iconName ) -> $iconURL
colas@0
  1153
colas@0
  1154
Map an icon name to a URL path.
colas@0
  1155
colas@0
  1156
=cut
colas@0
  1157
colas@0
  1158
sub getIconUrl {
colas@0
  1159
    my( $this, $absolute, $iconName ) = @_;
colas@0
  1160
colas@0
  1161
    my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
colas@0
  1162
    my( $web, $topic) = $this->normalizeWebTopicName(
colas@0
  1163
        $this->{webName}, $iconTopic );
colas@0
  1164
    $iconName =~ s/^.*\.(.*?)$/$1/;
colas@0
  1165
    return $this->getPubUrl( $absolute, $web, $topic, $iconName.'.gif' );
colas@0
  1166
}
colas@0
  1167
colas@0
  1168
=pod
colas@0
  1169
colas@0
  1170
---++ ObjectMethod mapToIconFileName( $fileName, $default ) -> $fileName
colas@0
  1171
colas@0
  1172
Maps from a filename (or just the extension) to the name of the
colas@0
  1173
file that contains the image for that file type.
colas@0
  1174
colas@0
  1175
=cut
colas@0
  1176
colas@0
  1177
sub mapToIconFileName {
colas@0
  1178
    my( $this, $fileName, $default ) = @_;
colas@0
  1179
	
colas@0
  1180
    my @bits = ( split( /\./, $fileName ) );
colas@0
  1181
    my $fileExt = lc $bits[$#bits];
colas@0
  1182
colas@0
  1183
    unless( $this->{_ICONMAP} ) {
colas@0
  1184
        my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
colas@0
  1185
        my( $web, $topic) = $this->normalizeWebTopicName(
colas@0
  1186
            $this->{webName}, $iconTopic );
colas@0
  1187
        local $/ = undef;
colas@0
  1188
        try {
colas@0
  1189
            my $icons = $this->{store}->getAttachmentStream(
colas@0
  1190
                undef, $web, $topic, '_filetypes.txt' );
colas@0
  1191
            %{$this->{_ICONMAP}} = split( /\s+/, <$icons> );
colas@0
  1192
            close( $icons );
colas@0
  1193
        } catch Error::Simple with {
colas@0
  1194
            %{$this->{_ICONMAP}} = ();
colas@0
  1195
        };
colas@0
  1196
    }
colas@0
  1197
colas@0
  1198
    return $this->{_ICONMAP}->{$fileExt} || $default || 'else';
colas@0
  1199
}
colas@0
  1200
colas@0
  1201
=pod
colas@0
  1202
colas@0
  1203
---++ ObjectMethod normalizeWebTopicName( $theWeb, $theTopic ) -> ( $theWeb, $theTopic )
colas@0
  1204
colas@0
  1205
Normalize a Web<nop>.<nop>TopicName
colas@0
  1206
colas@0
  1207
See TWikiFuncDotPm for a full specification of the expansion (not duplicated
colas@0
  1208
here)
colas@0
  1209
colas@0
  1210
*WARNING* if there is no web specification (in the web or topic parameters)
colas@0
  1211
the web defaults to $TWiki::cfg{UsersWebName}. If there is no topic
colas@0
  1212
specification, or the topic is '0', the topic defaults to the web home topic
colas@0
  1213
name.
colas@0
  1214
colas@0
  1215
=cut
colas@0
  1216
colas@0
  1217
sub normalizeWebTopicName {
colas@0
  1218
    my( $this, $web, $topic ) = @_;
colas@0
  1219
colas@0
  1220
    ASSERT(defined $topic) if DEBUG;
colas@0
  1221
colas@0
  1222
    if( $topic =~ m|^(.*)[./](.*?)$| ) {
colas@0
  1223
        $web = $1;
colas@0
  1224
        $topic = $2;
colas@0
  1225
    }
colas@0
  1226
    $web ||= $cfg{UsersWebName};
colas@0
  1227
    $topic ||= $cfg{HomeTopicName};
colas@0
  1228
    while( $web =~ s/%((MAIN|TWIKI|USERS|SYSTEM|DOC)WEB)%/_expandTagOnTopicRendering( $this,$1)||''/e ) {
colas@0
  1229
    }
colas@0
  1230
    $web =~ s#\.#/#go;
colas@0
  1231
    return( $web, $topic );
colas@0
  1232
}
colas@0
  1233
colas@0
  1234
=pod
colas@0
  1235
colas@0
  1236
---++ ClassMethod new( $loginName, $query, \%initialContext )
colas@0
  1237
colas@0
  1238
Constructs a new TWiki object. Parameters are taken from the query object.
colas@0
  1239
colas@0
  1240
   * =$loginName= is the login username (*not* the wikiname) of the user you
colas@0
  1241
     want to be logged-in if none is available from a session or browser.
colas@0
  1242
     Used mainly for side scripts and debugging.
colas@0
  1243
   * =$query= the CGI query (may be undef, in which case an empty query
colas@0
  1244
     is used)
colas@0
  1245
   * =\%initialContext= - reference to a hash containing context
colas@0
  1246
     name=value pairs to be pre-installed in the context hash
colas@0
  1247
colas@0
  1248
=cut
colas@0
  1249
colas@0
  1250
sub new {
colas@0
  1251
    my( $class, $login, $query, $initialContext ) = @_;
colas@0
  1252
colas@0
  1253
    Monitor::MARK("Static compilation complete");
colas@0
  1254
colas@0
  1255
    # Compatibility; not used except maybe in plugins
colas@0
  1256
    $TWiki::cfg{TempfileDir} = "$TWiki::cfg{WorkingDir}/tmp"
colas@0
  1257
      unless defined($TWiki::cfg{TempfileDir});
colas@0
  1258
colas@0
  1259
    # Set command_line context if there is no query
colas@0
  1260
    $initialContext ||= defined( $query ) ? {} : { command_line => 1 };
colas@0
  1261
colas@0
  1262
    $query ||= new CGI( {} );
colas@0
  1263
    my $this = bless( {}, $class );
colas@0
  1264
colas@1
  1265
    # Tell CGI.pm which charset we are using if not default
colas@1
  1266
    if( defined $TWiki::cfg{Site}{CharSet} &&
colas@1
  1267
          $TWiki::cfg{Site}{CharSet} !~ /^iso-?8859-?1$/io ) {
colas@1
  1268
        # Item5710: A bug in CGI::charset means we cannot use $query->charset
colas@1
  1269
        CGI::charset( $TWiki::cfg{Site}{CharSet} );
colas@1
  1270
    }
colas@1
  1271
colas@0
  1272
    $this->{_HTMLHEADERS} = {};
colas@0
  1273
    $this->{context} = $initialContext;
colas@0
  1274
colas@0
  1275
    # create the various sub-objects
colas@0
  1276
    unless ($sandbox) {
colas@0
  1277
        # "shared" between mod_perl instances
colas@0
  1278
        $sandbox = new TWiki::Sandbox(
colas@0
  1279
            $TWiki::cfg{OS}, $TWiki::cfg{DetailedOS} );
colas@0
  1280
    }
colas@0
  1281
    require TWiki::Plugins;
colas@0
  1282
    $this->{plugins} = new TWiki::Plugins( $this );
colas@0
  1283
    require TWiki::Store;
colas@0
  1284
    $this->{store} = new TWiki::Store( $this );
colas@0
  1285
    # cache CGI information in the session object
colas@0
  1286
    $this->{cgiQuery} = $query;
colas@0
  1287
colas@0
  1288
    $this->{remoteUser} = $login;	#use login as a default (set when running from cmd line)
colas@0
  1289
    require TWiki::Users;
colas@0
  1290
    $this->{users} = new TWiki::Users( $this );
colas@0
  1291
	$this->{remoteUser} = $this->{users}->{remoteUser};
colas@0
  1292
colas@0
  1293
    # Make %ENV safer, preventing hijack of the search path
colas@0
  1294
    # SMELL: can this be done in a BEGIN block? Or is the environment
colas@0
  1295
    # set per-query?
colas@0
  1296
    # Item4382: Default $ENV{PATH} must be untainted because TWiki runs
colas@0
  1297
    # with use strict and calling external programs that writes on the disk
colas@0
  1298
    # will fail unless Perl seens it as set to safe value.
colas@0
  1299
    if( $TWiki::cfg{SafeEnvPath} ) {
colas@0
  1300
        $ENV{PATH} = $TWiki::cfg{SafeEnvPath};
colas@0
  1301
    } else {
colas@0
  1302
        $ENV{PATH} = TWiki::Sandbox::untaintUnchecked( $ENV{PATH} );
colas@0
  1303
    }
colas@0
  1304
    delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };
colas@0
  1305
colas@1
  1306
    my $url = $query->url();
colas@1
  1307
    if( $url && $url =~ m{^([^:]*://[^/]*).*$} ) {
colas@1
  1308
        $this->{urlHost} = $1;
colas@1
  1309
        # If the urlHost in the url is localhost, this is a lot less
colas@1
  1310
        # useful than the default url host. This is because new CGI("")
colas@1
  1311
        # assigns this host by default - it's a default setting, used
colas@1
  1312
        # when there is nothing better available.
colas@1
  1313
        if( $this->{urlHost} eq 'http://localhost' ) {
colas@1
  1314
            $this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
colas@1
  1315
        } elsif( $TWiki::cfg{RemovePortNumber} ) {
colas@1
  1316
            $this->{urlHost} =~ s/\:[0-9]+$//;
colas@1
  1317
        }
colas@1
  1318
    } else {
colas@1
  1319
        $this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
colas@1
  1320
    }
colas@1
  1321
    if (   $TWiki::cfg{GetScriptUrlFromCgi}
colas@1
  1322
        && $url
colas@1
  1323
        && $url =~ m{^[^:]*://[^/]*(.*)/.*$}
colas@1
  1324
        && $1 )
colas@1
  1325
    {
colas@1
  1326
colas@1
  1327
        # SMELL: this is a really dangerous hack. It will fail
colas@1
  1328
        # spectacularly with mod_perl.
colas@1
  1329
        # SMELL: why not just use $query->script_name?
colas@1
  1330
        $this->{scriptUrlPath} = $1;
colas@1
  1331
    }
colas@1
  1332
colas@0
  1333
    my $web = '';
colas@0
  1334
    my $topic = $query->param( 'topic' );
colas@0
  1335
    if( $topic ) {
colas@0
  1336
        if( $topic =~ m#^$regex{linkProtocolPattern}://#o &&
colas@0
  1337
            $this->{cgiQuery} ) {
colas@0
  1338
            # redirect to URI
colas@0
  1339
                print $this->redirect( $topic );
colas@0
  1340
                exit;   #we seriously don't want to go through normal TWiki operations if we're redirecting..
colas@0
  1341
        } elsif( $topic =~ /((?:.*[\.\/])+)(.*)/ ) {
colas@0
  1342
            # is 'bin/script?topic=Webname.SomeTopic'
colas@0
  1343
            $web   = $1;
colas@0
  1344
            $topic = $2;
colas@0
  1345
            $web =~ s/\./\//go;
colas@0
  1346
            $web =~ s/\/$//o;
colas@0
  1347
            # jump to WebHome if 'bin/script?topic=Webname.'
colas@0
  1348
            $topic = $TWiki::cfg{HomeTopicName} if( $web && ! $topic );
colas@0
  1349
        }
colas@0
  1350
        # otherwise assume 'bin/script/Webname?topic=SomeTopic'
colas@0
  1351
    } else {
colas@0
  1352
        $topic = '';
colas@0
  1353
    }
colas@0
  1354
colas@0
  1355
    # SMELL: "The Microsoft Internet Information Server is broken with
colas@0
  1356
    # respect to additional path information. If you use the Perl DLL
colas@0
  1357
    # library, the IIS server will attempt to execute the additional
colas@0
  1358
    # path information as a Perl script. If you use the ordinary file
colas@0
  1359
    # associations mapping, the path information will be present in the
colas@0
  1360
    # environment, but incorrect. The best thing to do is to avoid using
colas@0
  1361
    # additional path information."
colas@0
  1362
colas@0
  1363
    # Clean up PATH_INFO problems, e.g.  Support.CobaltRaqInstall.  A valid
colas@0
  1364
    # PATH_INFO is '/Main/WebHome', i.e. the text after the script name;
colas@0
  1365
    # invalid PATH_INFO is often a full path starting with '/cgi-bin/...'.
colas@0
  1366
    my $pathInfo = $query->path_info();
colas@0
  1367
    my $cgiScriptName = $ENV{SCRIPT_NAME} || '';
colas@0
  1368
    $pathInfo =~ s!$cgiScriptName/!/!i;
colas@0
  1369
colas@0
  1370
    # Get the web and topic names from PATH_INFO
colas@0
  1371
    if( $pathInfo =~ /\/((?:.*[\.\/])+)(.*)/ ) {
colas@0
  1372
        # is 'bin/script/Webname/SomeTopic' or 'bin/script/Webname/'
colas@0
  1373
        $web   = $1 unless $web;
colas@0
  1374
        $topic = $2 unless $topic;
colas@0
  1375
        $web =~ s/\./\//go;
colas@0
  1376
        $web =~ s/\/$//o;
colas@0
  1377
    } elsif( $pathInfo =~ /\/(.*)/ ) {
colas@0
  1378
        # is 'bin/script/Webname' or 'bin/script/'
colas@0
  1379
        $web = $1 unless $web;
colas@0
  1380
    }
colas@0
  1381
colas@0
  1382
    # All roads lead to WebHome
colas@0
  1383
    $topic = $TWiki::cfg{HomeTopicName} if ( $topic =~ /\.\./ );
colas@0
  1384
    $topic =~ s/$TWiki::cfg{NameFilter}//go;
colas@0
  1385
    $topic = $TWiki::cfg{HomeTopicName} unless $topic;
colas@0
  1386
    $this->{topicName} = TWiki::Sandbox::untaintUnchecked( $topic );
colas@0
  1387
colas@0
  1388
    $web   =~ s/$TWiki::cfg{NameFilter}//go;
colas@0
  1389
    $this->{requestedWebName} = TWiki::Sandbox::untaintUnchecked( $web ); #can be an empty string
colas@0
  1390
    $web = $TWiki::cfg{UsersWebName} unless $web;
colas@0
  1391
    $this->{webName} = TWiki::Sandbox::untaintUnchecked( $web );
colas@0
  1392
colas@0
  1393
    # Convert UTF-8 web and topic name from URL into site charset if necessary 
colas@0
  1394
    # SMELL: merge these two cases, browsers just don't mix two encodings in one URL
colas@0
  1395
    # - can also simplify into 2 lines by making function return unprocessed text if no conversion
colas@0
  1396
    my $webNameTemp = UTF82SiteCharSet( $this->{webName} );
colas@0
  1397
    if ( $webNameTemp ) {
colas@0
  1398
        $this->{webName} = $webNameTemp;
colas@0
  1399
    }
colas@0
  1400
colas@0
  1401
    my $topicNameTemp = UTF82SiteCharSet( $this->{topicName} );
colas@0
  1402
    if ( $topicNameTemp ) {
colas@0
  1403
        $this->{topicName} = $topicNameTemp;
colas@0
  1404
    }
colas@0
  1405
colas@0
  1406
    # Item3270 - here's the appropriate place to enforce TWiki spec:
colas@0
  1407
    # All topic name sources are evaluated, site charset applied
colas@0
  1408
    # SMELL: This untaint unchecked is duplicate of one just above
colas@0
  1409
    $this->{topicName}  =
colas@0
  1410
        TWiki::Sandbox::untaintUnchecked(ucfirst $this->{topicName});
colas@0
  1411
colas@0
  1412
    $this->{scriptUrlPath} = $TWiki::cfg{ScriptUrlPath};
colas@0
  1413
colas@0
  1414
    require TWiki::Prefs;
colas@0
  1415
    my $prefs = new TWiki::Prefs( $this );
colas@0
  1416
    $this->{prefs} = $prefs;
colas@0
  1417
colas@0
  1418
    # Form definition cache
colas@0
  1419
    $this->{forms} = {};
colas@0
  1420
colas@0
  1421
    # Push global preferences from TWiki.TWikiPreferences
colas@0
  1422
    $prefs->pushGlobalPreferences();
colas@0
  1423
colas@0
  1424
#TODO: what happens if we move this into the TWiki::User::new?
colas@0
  1425
    $this->{user} = $this->{users}->initialiseUser($this->{remoteUser});
colas@0
  1426
colas@0
  1427
    # Static session variables that can be expanded in topics when they
colas@0
  1428
    # are enclosed in % signs
colas@0
  1429
    # SMELL: should collapse these into one. The duplication is pretty
colas@0
  1430
    # pointless. Could get rid of the SESSION_TAGS hash, might be
colas@0
  1431
    # the easiest thing to do, but then that would allow other
colas@0
  1432
    # upper-case named fields in the object to be accessed as well...
colas@0
  1433
    $this->{SESSION_TAGS}{BASEWEB}        = $this->{webName};
colas@0
  1434
    $this->{SESSION_TAGS}{BASETOPIC}      = $this->{topicName};
colas@0
  1435
    $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $this->{topicName};
colas@0
  1436
    $this->{SESSION_TAGS}{INCLUDINGWEB}   = $this->{webName};
colas@0
  1437
colas@0
  1438
    # Push plugin settings
colas@0
  1439
    $this->{plugins}->settings();
colas@0
  1440
colas@0
  1441
    # Now the rest of the preferences
colas@0
  1442
    $prefs->pushGlobalPreferencesSiteSpecific();
colas@0
  1443
colas@0
  1444
    # User preferences only available if we can get to a valid wikiname,
colas@0
  1445
    # which depends on the user mapper.
colas@0
  1446
    my $wn = $this->{users}->getWikiName( $this->{user} );
colas@0
  1447
    if( $wn ) {
colas@0
  1448
        $prefs->pushPreferences(
colas@0
  1449
            $TWiki::cfg{UsersWebName}, $wn,
colas@0
  1450
            'USER ' . $wn );
colas@0
  1451
    }
colas@0
  1452
colas@0
  1453
    $prefs->pushWebPreferences( $this->{webName} );
colas@0
  1454
colas@0
  1455
    $prefs->pushPreferences(
colas@0
  1456
        $this->{webName}, $this->{topicName}, 'TOPIC' );
colas@0
  1457
colas@0
  1458
    $prefs->pushPreferenceValues( 'SESSION',
colas@0
  1459
                                  $this->{users}->{loginManager}->getSessionValues() );
colas@0
  1460
colas@0
  1461
    # Finish plugin initialization - register handlers
colas@0
  1462
    $this->{plugins}->enable();
colas@0
  1463
colas@0
  1464
    $TWiki::Plugins::SESSION = $this;
colas@0
  1465
colas@0
  1466
    Monitor::MARK("TWiki session created");
colas@0
  1467
colas@0
  1468
    return $this;
colas@0
  1469
}
colas@0
  1470
colas@0
  1471
=begin twiki
colas@0
  1472
colas@0
  1473
---++ ObjectMethod renderer()
colas@0
  1474
Get a reference to the renderer object. Done lazily because not everyone
colas@0
  1475
needs the renderer.
colas@0
  1476
colas@0
  1477
=cut
colas@0
  1478
colas@0
  1479
sub renderer {
colas@0
  1480
    my( $this ) = @_;
colas@0
  1481
colas@0
  1482
    unless( $this->{renderer} ) {
colas@0
  1483
        require TWiki::Render;
colas@0
  1484
        # requires preferences (such as LINKTOOLTIPINFO)
colas@0
  1485
        $this->{renderer} = new TWiki::Render( $this );
colas@0
  1486
    }
colas@0
  1487
    return $this->{renderer};
colas@0
  1488
}
colas@0
  1489
colas@0
  1490
=begin twiki
colas@0
  1491
colas@0
  1492
---++ ObjectMethod attach()
colas@0
  1493
Get a reference to the attach object. Done lazily because not everyone
colas@0
  1494
needs the attach.
colas@0
  1495
colas@0
  1496
=cut
colas@0
  1497
colas@0
  1498
sub attach {
colas@0
  1499
    my( $this ) = @_;
colas@0
  1500
colas@0
  1501
    unless( $this->{attach} ) {
colas@0
  1502
        require TWiki::Attach;
colas@0
  1503
        $this->{attach} = new TWiki::Attach( $this );
colas@0
  1504
    }
colas@0
  1505
    return $this->{attach};
colas@0
  1506
}
colas@0
  1507
colas@0
  1508
=begin twiki
colas@0
  1509
colas@0
  1510
---++ ObjectMethod templates()
colas@0
  1511
Get a reference to the templates object. Done lazily because not everyone
colas@0
  1512
needs the templates.
colas@0
  1513
colas@0
  1514
=cut
colas@0
  1515
colas@0
  1516
sub templates {
colas@0
  1517
    my( $this ) = @_;
colas@0
  1518
colas@0
  1519
    unless( $this->{templates} ) {
colas@0
  1520
        require TWiki::Templates;
colas@0
  1521
        $this->{templates} = new TWiki::Templates( $this );
colas@0
  1522
    }
colas@0
  1523
    return $this->{templates};
colas@0
  1524
}
colas@0
  1525
colas@0
  1526
=begin twiki
colas@0
  1527
colas@0
  1528
---++ ObjectMethod i18n()
colas@0
  1529
Get a reference to the i18n object. Done lazily because not everyone
colas@0
  1530
needs the i18ner.
colas@0
  1531
colas@0
  1532
=cut
colas@0
  1533
colas@0
  1534
sub i18n {
colas@0
  1535
    my( $this ) = @_;
colas@0
  1536
colas@0
  1537
    unless( $this->{i18n} ) {
colas@0
  1538
        require TWiki::I18N;
colas@0
  1539
        # language information; must be loaded after
colas@0
  1540
        # *all possible preferences sources* are available
colas@0
  1541
        $this->{i18n} = new TWiki::I18N( $this );
colas@0
  1542
    }
colas@0
  1543
    return $this->{i18n};
colas@0
  1544
}
colas@0
  1545
colas@0
  1546
=begin twiki
colas@0
  1547
colas@0
  1548
---++ ObjectMethod search()
colas@0
  1549
Get a reference to the search object. Done lazily because not everyone
colas@0
  1550
needs the searcher.
colas@0
  1551
colas@0
  1552
=cut
colas@0
  1553
colas@0
  1554
sub search {
colas@0
  1555
    my( $this ) = @_;
colas@0
  1556
colas@0
  1557
    unless( $this->{search} ) {
colas@0
  1558
        require TWiki::Search;
colas@0
  1559
        $this->{search} = new TWiki::Search( $this );
colas@0
  1560
    }
colas@0
  1561
    return $this->{search};
colas@0
  1562
}
colas@0
  1563
colas@0
  1564
=begin twiki
colas@0
  1565
colas@0
  1566
---++ ObjectMethod security()
colas@0
  1567
Get a reference to the security object. Done lazily because not everyone
colas@0
  1568
needs the security.
colas@0
  1569
colas@0
  1570
=cut
colas@0
  1571
colas@0
  1572
sub security {
colas@0
  1573
    my( $this ) = @_;
colas@0
  1574
colas@0
  1575
    unless( $this->{security} ) {
colas@0
  1576
        require TWiki::Access;
colas@0
  1577
        $this->{security} = new TWiki::Access( $this );
colas@0
  1578
    }
colas@0
  1579
    return $this->{security};
colas@0
  1580
}
colas@0
  1581
colas@0
  1582
=begin twiki
colas@0
  1583
colas@0
  1584
---++ ObjectMethod net()
colas@0
  1585
Get a reference to the net object. Done lazily because not everyone
colas@0
  1586
needs the net.
colas@0
  1587
colas@0
  1588
=cut
colas@0
  1589
colas@0
  1590
sub net {
colas@0
  1591
    my( $this ) = @_;
colas@0
  1592
colas@0
  1593
    unless( $this->{net} ) {
colas@0
  1594
        require TWiki::Net;
colas@0
  1595
        $this->{net} = new TWiki::Net( $this );
colas@0
  1596
    }
colas@0
  1597
    return $this->{net};
colas@0
  1598
}
colas@0
  1599
colas@0
  1600
=begin twiki
colas@0
  1601
colas@0
  1602
---++ ObjectMethod finish()
colas@0
  1603
Break circular references.
colas@0
  1604
colas@0
  1605
=cut
colas@0
  1606
colas@0
  1607
# Note to developers; please undef *all* fields in the object explicitly,
colas@0
  1608
# whether they are references or not. That way this method is "golden
colas@0
  1609
# documentation" of the live fields in the object.
colas@0
  1610
sub finish {
colas@0
  1611
    my $this = shift;
colas@0
  1612
colas@0
  1613
    map { $_->finish() } values %{$this->{forms}};
colas@0
  1614
    $this->{plugins}->finish() if $this->{plugins};
colas@0
  1615
    $this->{users}->finish() if $this->{users};
colas@0
  1616
    $this->{prefs}->finish() if $this->{prefs};
colas@0
  1617
    $this->{templates}->finish() if $this->{templates};
colas@0
  1618
    $this->{renderer}->finish() if $this->{renderer};
colas@0
  1619
    $this->{net}->finish() if $this->{net};
colas@0
  1620
    $this->{store}->finish() if $this->{store};
colas@0
  1621
    $this->{search}->finish() if $this->{search};
colas@0
  1622
    $this->{attach}->finish() if $this->{attach};
colas@0
  1623
    $this->{security}->finish() if $this->{security};
colas@0
  1624
    $this->{i18n}->finish() if $this->{i18n};
colas@0
  1625
colas@0
  1626
    undef $this->{_HTMLHEADERS};
colas@0
  1627
    undef $this->{cgiQuery};
colas@0
  1628
    undef $this->{urlHost};
colas@0
  1629
    undef $this->{web};
colas@0
  1630
    undef $this->{topic};
colas@0
  1631
    undef $this->{webName};
colas@0
  1632
    undef $this->{topicName};
colas@0
  1633
    undef $this->{_ICONMAP};
colas@0
  1634
    undef $this->{context};
colas@0
  1635
    undef $this->{remoteUser};
colas@0
  1636
    undef $this->{requestedWebName}; # Web name before renaming
colas@0
  1637
    undef $this->{scriptUrlPath};
colas@0
  1638
    undef $this->{user};
colas@0
  1639
    undef $this->{SESSION_TAGS};
colas@0
  1640
    undef $this->{_INCLUDES};
colas@1
  1641
    undef $this->{evaluating_if};
colas@0
  1642
}
colas@0
  1643
colas@0
  1644
=pod
colas@0
  1645
colas@0
  1646
---++ ObjectMethod writeLog( $action, $webTopic, $extra, $user )
colas@0
  1647
colas@0
  1648
   * =$action= - what happened, e.g. view, save, rename
colas@0
  1649
   * =$wbTopic= - what it happened to
colas@0
  1650
   * =$extra= - extra info, such as minor flag
colas@0
  1651
   * =$user= - user who did the saving (user id)
colas@0
  1652
Write the log for an event to the logfile
colas@0
  1653
colas@0
  1654
=cut
colas@0
  1655
colas@0
  1656
sub writeLog {
colas@0
  1657
    my $this = shift;
colas@0
  1658
colas@0
  1659
    my $action = shift || '';
colas@0
  1660
    my $webTopic = shift || '';
colas@0
  1661
    my $extra = shift || '';
colas@0
  1662
    my $user = shift;
colas@0
  1663
colas@0
  1664
    $user ||= $this->{user};
colas@1
  1665
    $user = ($this->{users}->getLoginName( $user ) || 'unknown')
colas@1
  1666
      if ($this->{users});
colas@0
  1667
colas@0
  1668
    if( $user eq $cfg{DefaultUserLogin} ) {
colas@0
  1669
       my $cgiQuery = $this->{cgiQuery};
colas@0
  1670
       if( $cgiQuery ) {
colas@0
  1671
           my $agent = $cgiQuery->user_agent();
colas@0
  1672
           if( $agent ) {
colas@0
  1673
               $agent =~ m/([\w]+)/;
colas@0
  1674
               $extra .= ' '.$1;
colas@0
  1675
           }
colas@0
  1676
       }
colas@0
  1677
    }
colas@0
  1678
colas@0
  1679
    my $remoteAddr = $ENV{REMOTE_ADDR} || '';
colas@0
  1680
    my $text = "$user | $action | $webTopic | $extra | $remoteAddr |";
colas@0
  1681
colas@0
  1682
    _writeReport( $this, $TWiki::cfg{LogFileName}, $text );
colas@0
  1683
}
colas@0
  1684
colas@0
  1685
=pod
colas@0
  1686
colas@0
  1687
---++ ObjectMethod writeWarning( $text )
colas@0
  1688
colas@0
  1689
Prints date, time, and contents $text to $TWiki::cfg{WarningFileName}, typically
colas@0
  1690
'warnings.txt'. Use for warnings and errors that may require admin
colas@0
  1691
intervention. Use this for defensive programming warnings (e.g. assertions).
colas@0
  1692
colas@0
  1693
=cut
colas@0
  1694
colas@0
  1695
sub writeWarning {
colas@0
  1696
    my $this = shift;
colas@0
  1697
    _writeReport( $this, $TWiki::cfg{WarningFileName}, @_ );
colas@0
  1698
}
colas@0
  1699
colas@0
  1700
=pod
colas@0
  1701
colas@0
  1702
---++ ObjectMethod writeDebug( $text )
colas@0
  1703
colas@0
  1704
Prints date, time, and contents of $text to $TWiki::cfg{DebugFileName}, typically
colas@0
  1705
'debug.txt'.  Use for debugging messages.
colas@0
  1706
colas@0
  1707
=cut
colas@0
  1708
colas@0
  1709
sub writeDebug {
colas@0
  1710
    my $this = shift;
colas@0
  1711
    _writeReport( $this, $TWiki::cfg{DebugFileName}, @_ );
colas@0
  1712
}
colas@0
  1713
colas@0
  1714
# Concatenates date, time, and $text to a log file.
colas@0
  1715
# The logfilename can optionally use a %DATE% variable to support
colas@0
  1716
# logs that are rotated once a month.
colas@0
  1717
# | =$log= | Base filename for log file |
colas@0
  1718
# | =$message= | Message to print |
colas@0
  1719
sub _writeReport {
colas@0
  1720
    my ( $this, $log, $message ) = @_;
colas@0
  1721
colas@0
  1722
    if ( $log ) {
colas@0
  1723
        require TWiki::Time;
colas@0
  1724
        my $time =
colas@0
  1725
          TWiki::Time::formatTime( time(), '$year$mo', 'servertime');
colas@0
  1726
        $log =~ s/%DATE%/$time/go;
colas@0
  1727
        $time = TWiki::Time::formatTime( time(), undef, 'servertime' );
colas@0
  1728
colas@0
  1729
        if( open( FILE, ">>$log" ) ) {
colas@0
  1730
            print FILE "| $time | $message\n";
colas@0
  1731
            close( FILE );
colas@0
  1732
        } else {
colas@0
  1733
            print STDERR 'Could not write "'.$message.'" to '."$log: $!\n";
colas@0
  1734
        }
colas@0
  1735
    }
colas@0
  1736
}
colas@0
  1737
colas@0
  1738
sub _removeNewlines {
colas@0
  1739
    my( $theTag ) = @_;
colas@0
  1740
    $theTag =~ s/[\r\n]+/ /gs;
colas@0
  1741
    return $theTag;
colas@0
  1742
}
colas@0
  1743
colas@0
  1744
# Convert relative URLs to absolute URIs
colas@0
  1745
sub _rewriteURLInInclude {
colas@0
  1746
    my( $theHost, $theAbsPath, $url ) = @_;
colas@0
  1747
colas@0
  1748
    # leave out an eventual final non-directory component from the absolute path
colas@0
  1749
    $theAbsPath =~ s/(.*?)[^\/]*$/$1/;
colas@0
  1750
colas@0
  1751
    if( $url =~ /^\// ) {
colas@0
  1752
        # fix absolute URL
colas@0
  1753
        $url = $theHost.$url;
colas@0
  1754
    } elsif( $url =~ /^\./ ) {
colas@0
  1755
        # fix relative URL
colas@0
  1756
        $url = $theHost.$theAbsPath.'/'.$url;
colas@0
  1757
    } elsif( $url =~ /^$regex{linkProtocolPattern}:/o ) {
colas@0
  1758
        # full qualified URL, do nothing
colas@0
  1759
    } elsif( $url =~ /^#/ ) {
colas@0
  1760
        # anchor. This needs to be left relative to the including topic
colas@0
  1761
        # so do nothing
colas@0
  1762
    } elsif( $url ) {
colas@0
  1763
        # FIXME: is this test enough to detect relative URLs?
colas@0
  1764
        $url = $theHost.$theAbsPath.'/'.$url;
colas@0
  1765
    }
colas@0
  1766
colas@0
  1767
    return $url;
colas@0
  1768
}
colas@0
  1769
colas@0
  1770
# Add a web reference to a [[...][...]] link in an included topic
colas@0
  1771
sub _fixIncludeLink {
colas@0
  1772
    my( $web, $link, $label ) = @_;
colas@0
  1773
colas@0
  1774
    # Detect absolute and relative URLs and web-qualified wikinames
colas@0
  1775
    if( $link =~ m#^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}:|/)#o ) {
colas@0
  1776
        if( $label ) {
colas@0
  1777
            return "[[$link][$label]]";
colas@0
  1778
        } else {
colas@0
  1779
            return "[[$link]]";
colas@0
  1780
        }
colas@0
  1781
    } elsif( !$label ) {
colas@0
  1782
        # Must be wikiword or spaced-out wikiword (or illegal link :-/)
colas@0
  1783
        $label = $link;
colas@0
  1784
    }
colas@0
  1785
    return "[[$web.$link][$label]]";
colas@0
  1786
}
colas@0
  1787
colas@0
  1788
# Replace web references in a topic. Called from forEachLine, applying to
colas@0
  1789
# each non-verbatim and non-literal line.
colas@0
  1790
sub _fixupIncludedTopic {
colas@0
  1791
    my( $text, $options ) = @_;
colas@0
  1792
colas@0
  1793
    my $fromWeb = $options->{web};
colas@0
  1794
colas@0
  1795
    unless( $options->{in_noautolink} ) {
colas@0
  1796
        # 'TopicName' to 'Web.TopicName'
colas@0
  1797
        $text =~ s#(?:^|(?<=[\s(]))($regex{wikiWordRegex})(?=\s|\)|$)#$fromWeb.$1#go;
colas@0
  1798
    }
colas@0
  1799
colas@0
  1800
    # Handle explicit [[]] everywhere
colas@0
  1801
    # '[[TopicName][...]]' to '[[Web.TopicName][...]]'
colas@0
  1802
    $text =~ s/\[\[([^]]+)\](?:\[([^]]+)\])?\]/
colas@0
  1803
      _fixIncludeLink( $fromWeb, $1, $2 )/geo;
colas@0
  1804
colas@0
  1805
    return $text;
colas@0
  1806
}
colas@0
  1807
colas@0
  1808
# Clean-up HTML text so that it can be shown embedded in a topic
colas@0
  1809
sub _cleanupIncludedHTML {
colas@0
  1810
    my( $text, $host, $path, $options ) = @_;
colas@0
  1811
colas@0
  1812
    # FIXME: Make aware of <base> tag
colas@0
  1813
colas@0
  1814
    $text =~ s/^.*?<\/head>//is
colas@0
  1815
      unless ( $options->{disableremoveheaders} );   # remove all HEAD
colas@0
  1816
    $text =~ s/<script.*?<\/script>//gis
colas@0
  1817
      unless ( $options->{disableremovescript} );    # remove all SCRIPTs
colas@0
  1818
    $text =~ s/^.*?<body[^>]*>//is
colas@0
  1819
      unless ( $options->{disableremovebody} );      # remove all to <BODY>
colas@0
  1820
    $text =~ s/(?:\n)<\/body>.*//is
colas@0
  1821
      unless ( $options->{disableremovebody} );      # remove </BODY>
colas@0
  1822
    $text =~ s/(?:\n)<\/html>.*//is
colas@0
  1823
      unless ( $options->{disableremoveheaders} );   # remove </HTML>
colas@0
  1824
    $text =~ s/(<[^>]*>)/_removeNewlines($1)/ges
colas@0
  1825
      unless ( $options->{disablecompresstags} );    # replace newlines in html tags with space
colas@0
  1826
    $text =~ s/(\s(?:href|src|action)=(["']))(.*?)\2/$1._rewriteURLInInclude( $host, $path, $3 ).$2/geois
colas@0
  1827
      unless ( $options->{disablerewriteurls} );
colas@0
  1828
colas@0
  1829
    return $text;
colas@0
  1830
}
colas@0
  1831
colas@0
  1832
=pod
colas@0
  1833
colas@0
  1834
---++ StaticMethod applyPatternToIncludedText( $text, $pattern ) -> $text
colas@0
  1835
colas@0
  1836
Apply a pattern on included text to extract a subset
colas@0
  1837
colas@0
  1838
=cut
colas@0
  1839
colas@0
  1840
sub applyPatternToIncludedText {
colas@0
  1841
    my( $theText, $thePattern ) = @_;
colas@0
  1842
    $thePattern =~ s/([^\\])([\$\@\%\&\#\'\`\/])/$1\\$2/g;  # escape some special chars
colas@0
  1843
    $thePattern = TWiki::Sandbox::untaintUnchecked( $thePattern );
colas@0
  1844
    $theText = '' unless( $theText =~ s/$thePattern/$1/is );
colas@0
  1845
    return $theText;
colas@0
  1846
}
colas@0
  1847
colas@0
  1848
# Fetch content from a URL for inclusion by an INCLUDE
colas@0
  1849
sub _includeUrl {
colas@0
  1850
    my( $this, $url, $pattern, $web, $topic, $raw, $options, $warn ) = @_;
colas@0
  1851
    my $text = '';
colas@0
  1852
colas@0
  1853
    # For speed, read file directly if URL matches an attachment directory
colas@1
  1854
    if( $url =~ /^$this->{urlHost}$TWiki::cfg{PubUrlPath}\/($regex{webNameRegex})\/([^\/\.]+)\/([^\/]+)$/ ) {
colas@0
  1855
        my $incWeb = $1;
colas@0
  1856
        my $incTopic = $2;
colas@0
  1857
        my $incAtt = $3;
colas@0
  1858
        # FIXME: Check for MIME type, not file suffix
colas@0
  1859
        if( $incAtt =~ m/\.(txt|html?)$/i ) {
colas@0
  1860
            unless( $this->{store}->attachmentExists(
colas@0
  1861
                $incWeb, $incTopic, $incAtt )) {
colas@0
  1862
                return _includeWarning( $this, $warn, 'bad_attachment', $url );
colas@0
  1863
            }
colas@0
  1864
            if( $incWeb ne $web || $incTopic ne $topic ) {
colas@0
  1865
                # CODE_SMELL: Does not account for not yet authenticated user
colas@0
  1866
                unless( $this->security->checkAccessPermission(
colas@0
  1867
                    'VIEW', $this->{user}, undef, undef, $incTopic, $incWeb ) ) {
colas@0
  1868
                    return _includeWarning( $this, $warn, 'access_denied',
colas@0
  1869
                                                   "$incWeb.$incTopic" );
colas@0
  1870
                }
colas@0
  1871
            }
colas@0
  1872
            $text = $this->{store}->readAttachment( undef, $incWeb, $incTopic,
colas@0
  1873
                                                    $incAtt );
colas@0
  1874
            $text = _cleanupIncludedHTML( $text, $this->{urlHost},
colas@0
  1875
                                          $TWiki::cfg{PubUrlPath}, $options )
colas@0
  1876
              unless $raw;
colas@0
  1877
            $text = applyPatternToIncludedText( $text, $pattern )
colas@0
  1878
              if( $pattern );
colas@0
  1879
            $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
colas@0
  1880
            return $text;
colas@0
  1881
        }
colas@0
  1882
        # fall through; try to include file over http based on MIME setting
colas@0
  1883
    }
colas@0
  1884
colas@0
  1885
    return _includeWarning( $this, $warn, 'urls_not_allowed' )
colas@0
  1886
      unless $TWiki::cfg{INCLUDE}{AllowURLs};
colas@0
  1887
colas@0
  1888
    # SMELL: should use the URI module from CPAN to parse the URL
colas@0
  1889
    # SMELL: but additional CPAN adds to code bloat
colas@0
  1890
    unless ($url =~ m!^https?:!) {
colas@0
  1891
        $text = _includeWarning( $this, $warn, 'bad_protocol', $url );
colas@0
  1892
        return $text;
colas@0
  1893
    }
colas@0
  1894
colas@0
  1895
    my $response = $this->net->getExternalResource( $url );
colas@0
  1896
    if( !$response->is_error()) {
colas@0
  1897
        my $contentType = $response->header('content-type');
colas@0
  1898
        $text = $response->content();
colas@0
  1899
        if( $contentType =~ /^text\/html/ ) {
colas@0
  1900
            if (!$raw) {
colas@0
  1901
                $url =~ m!^([a-z]+:/*[^/]*)(/[^#?]*)!;
colas@0
  1902
                $text = _cleanupIncludedHTML( $text, $1, $2, $options );
colas@0
  1903
            }
colas@0
  1904
        } elsif( $contentType =~ /^text\/(plain|css)/ ) {
colas@0
  1905
            # do nothing
colas@0
  1906
        } else {
colas@0
  1907
            $text = _includeWarning(
colas@0
  1908
                $this, $warn, 'bad_content', $contentType );
colas@0
  1909
        }
colas@0
  1910
        $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
colas@0
  1911
        $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
colas@0
  1912
    } else {
colas@0
  1913
        $text = _includeWarning( $this, $warn, 'geturl_failed',
colas@0
  1914
                                 $url.' '.$response->message() );
colas@0
  1915
    }
colas@0
  1916
colas@0
  1917
    return $text;
colas@0
  1918
}
colas@0
  1919
colas@0
  1920
#
colas@0
  1921
# SMELL: this is _not_ a tag handler in the sense of other builtin tags,
colas@0
  1922
# because it requires far more context information (the text of the topic)
colas@0
  1923
# than any handler.
colas@0
  1924
# SMELL: as a tag handler that also semi-renders the topic to extract the
colas@0
  1925
# headings, this handler would be much better as a preRenderingHandler in
colas@0
  1926
# a plugin (where head, script and verbatim sections are already protected)
colas@0
  1927
#
colas@0
  1928
#    * $text  : ref to the text of the current topic
colas@0
  1929
#    * $topic : the topic we are in
colas@0
  1930
#    * $web   : the web we are in
colas@0
  1931
#    * $args  : 'Topic' [web='Web'] [depth='N']
colas@0
  1932
# Return value: $tableOfContents
colas@0
  1933
# Handles %<nop>TOC{...}% syntax.  Creates a table of contents
colas@0
  1934
# using TWiki bulleted
colas@0
  1935
# list markup, linked to the section headings of a topic. A section heading is
colas@0
  1936
# entered in one of the following forms:
colas@0
  1937
#    * $headingPatternSp : \t++... spaces section heading
colas@0
  1938
#    * $headingPatternDa : ---++... dashes section heading
colas@0
  1939
#    * $headingPatternHt : &lt;h[1-6]> HTML section heading &lt;/h[1-6]>
colas@0
  1940
sub _TOC {
colas@0
  1941
    my ( $this, $text, $defaultTopic, $defaultWeb, $args ) = @_;
colas@0
  1942
colas@0
  1943
    require TWiki::Attrs;
colas@0
  1944
colas@0
  1945
    my $params = new TWiki::Attrs( $args );
colas@0
  1946
    # get the topic name attribute
colas@0
  1947
    my $topic = $params->{_DEFAULT} || $defaultTopic;
colas@0
  1948
colas@0
  1949
    # get the web name attribute
colas@0
  1950
    $defaultWeb =~ s#/#.#g;
colas@0
  1951
    my $web = $params->{web} || $defaultWeb;
colas@0
  1952
colas@0
  1953
    my $isSameTopic = $web eq $defaultWeb  &&  $topic eq $defaultTopic;
colas@0
  1954
colas@0
  1955
    $web =~ s#/#\.#g;
colas@0
  1956
    my $webPath = $web;
colas@0
  1957
    $webPath =~ s/\./\//g;
colas@0
  1958
colas@0
  1959
    # get the depth limit attribute
colas@0
  1960
    my $maxDepth = $params->{depth} || $this->{prefs}->getPreferencesValue('TOC_MAX_DEPTH') || 6;
colas@0
  1961
    my $minDepth = $this->{prefs}->getPreferencesValue('TOC_MIN_DEPTH') || 1;
colas@0
  1962
    
colas@0
  1963
    # get the title attribute
colas@0
  1964
    my $title = $params->{title} || $this->{prefs}->getPreferencesValue('TOC_TITLE') || '';
colas@0
  1965
    $title = CGI::span( { class => 'twikiTocTitle' }, $title ) if( $title );
colas@0
  1966
colas@0
  1967
    if( $web ne $defaultWeb || $topic ne $defaultTopic ) {
colas@0
  1968
        unless( $this->security->checkAccessPermission
colas@0
  1969
                ( 'VIEW', $this->{user}, undef, undef, $topic, $web ) ) {
colas@0
  1970
            return $this->inlineAlert( 'alerts', 'access_denied',
colas@0
  1971
                                       $web, $topic );
colas@0
  1972
        }
colas@0
  1973
        my $meta;
colas@0
  1974
        ( $meta, $text ) =
colas@0
  1975
          $this->{store}->readTopic( $this->{user}, $web, $topic );
colas@0
  1976
    }
colas@0
  1977
colas@0
  1978
    my $insidePre = 0;
colas@0
  1979
    my $insideVerbatim = 0;
colas@0
  1980
    my $highest = 99;
colas@0
  1981
    my $result  = '';
colas@0
  1982
    my $verbatim = {};
colas@0
  1983
    $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
colas@0
  1984
                                               $verbatim);
colas@0
  1985
    $text = $this->renderer->takeOutBlocks( $text, 'pre',
colas@0
  1986
                                               $verbatim);
colas@0
  1987
colas@0
  1988
    # Find URL parameters
colas@0
  1989
    my $query = $this->{cgiQuery};
colas@0
  1990
    my @qparams = ();
colas@0
  1991
    foreach my $name ( $query->param ) {
colas@0
  1992
      next if ($name eq 'keywords');
colas@0
  1993
      next if ($name eq 'topic');
colas@0
  1994
      next if ($name eq 'text');
colas@0
  1995
      push @qparams, $name => $query->param($name);
colas@0
  1996
    }
colas@0
  1997
colas@0
  1998
    # SMELL: this handling of <pre> is archaic.
colas@0
  1999
    # SMELL: use forEachLine
colas@0
  2000
    foreach my $line ( split( /\r?\n/, $text ) ) {
colas@0
  2001
        my $level;
colas@0
  2002
        if ( $line =~ m/$regex{headerPatternDa}/o ) {
colas@0
  2003
            $line = $2;
colas@0
  2004
            $level = length $1;
colas@0
  2005
        } elsif ( $line =~ m/$regex{headerPatternHt}/io ) {
colas@0
  2006
            $line = $2;
colas@0
  2007
            $level = $1;
colas@0
  2008
        } else {
colas@0
  2009
            next;
colas@0
  2010
        }
colas@0
  2011
colas@0
  2012
        if( $line && ($level >= $minDepth) && ($level <= $maxDepth) ) {
colas@0
  2013
            # cut TOC exclude '---+ heading !! exclude this bit'
colas@0
  2014
            $line =~ s/\s*$regex{headerPatternNoTOC}.+$//go;
colas@0
  2015
            next unless $line;
colas@0
  2016
            my $anchor = $this->renderer->makeAnchorName( $line );
colas@0
  2017
            $highest = $level if( $level < $highest );
colas@0
  2018
            my $tabs = "\t" x $level;
colas@0
  2019
            # Remove *bold*, _italic_ and =fixed= formatting
colas@0
  2020
            $line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
colas@0
  2021
            $line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
colas@0
  2022
            $line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
colas@0
  2023
            # Prevent WikiLinks
colas@0
  2024
            $line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g;  # '[[...][...]]'
colas@0
  2025
            $line =~ s/\[\[(.*?)\]\]/$1/ge;        # '[[...]]'
colas@0
  2026
            $line =~ s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1<nop>$3/go;  # 'Web.TopicName'
colas@0
  2027
            $line =~ s/([\s\(])($regex{wikiWordRegex})/$1<nop>$2/go;  # 'TopicName'
colas@0
  2028
            $line =~ s/([\s\(])($regex{abbrevRegex})/$1<nop>$2/go;    # 'TLA'
colas@0
  2029
            $line =~ s/([\s\-\*\(])([$regex{mixedAlphaNum}]+\:)/$1<nop>$2/go; # 'Site:page' Interwiki link
colas@0
  2030
            # Prevent manual links
colas@0
  2031
            $line =~ s/<[\/]?a\b[^>]*>//gi;
colas@0
  2032
            # create linked bullet item, using a relative link to anchor
colas@0
  2033
            my $target = $isSameTopic ?
colas@0
  2034
                         _make_params(0, '#'=>$anchor,@qparams) :
colas@0
  2035
                         $this->getScriptUrl(0,'view',$web,$topic,'#'=>$anchor,@qparams);
colas@0
  2036
            $line = $tabs.'* ' .  CGI::a({href=>$target},$line);
colas@0
  2037
            $result .= "\n".$line;
colas@0
  2038
        }
colas@0
  2039
    }
colas@0
  2040
colas@0
  2041
    if( $result ) {
colas@0
  2042
        if( $highest > 1 ) {
colas@0
  2043
            # left shift TOC
colas@0
  2044
            $highest--;
colas@0
  2045
            $result =~ s/^\t{$highest}//gm;
colas@0
  2046
        }
colas@0
  2047
        return CGI::div( { class=>'twikiToc' }, "$title$result\n" );
colas@0
  2048
    } else {
colas@0
  2049
        return '';
colas@0
  2050
    }
colas@0
  2051
}
colas@0
  2052
colas@0
  2053
=pod
colas@0
  2054
colas@0
  2055
---++ ObjectMethod inlineAlert($template, $def, ... ) -> $string
colas@0
  2056
colas@0
  2057
Format an error for inline inclusion in rendered output. The message string
colas@0
  2058
is obtained from the template 'oops'.$template, and the DEF $def is
colas@0
  2059
selected. The parameters (...) are used to populate %PARAM1%..%PARAMn%
colas@0
  2060
colas@0
  2061
=cut
colas@0
  2062
colas@0
  2063
sub inlineAlert {
colas@0
  2064
    my $this = shift;
colas@0
  2065
    my $template = shift;
colas@0
  2066
    my $def = shift;
colas@0
  2067
colas@0
  2068
    my $text = $this->templates->readTemplate( 'oops'.$template,
colas@0
  2069
                                                 $this->getSkin() );
colas@0
  2070
    if( $text ) {
colas@0
  2071
        my $blah = $this->templates->expandTemplate( $def );
colas@0
  2072
        $text =~ s/%INSTANTIATE%/$blah/;
colas@0
  2073
        # web and topic can be anything; they are not used
colas@0
  2074
        $text = $this->handleCommonTags( $text, $this->{webName},
colas@0
  2075
                                         $this->{topicName} );
colas@0
  2076
        my $n = 1;
colas@0
  2077
        while( defined( my $param = shift )) {
colas@0
  2078
            $text =~ s/%PARAM$n%/$param/g;
colas@0
  2079
            $n++;
colas@0
  2080
        }
colas@0
  2081
colas@0
  2082
    } else {
colas@0
  2083
        $text = CGI::h1('TWiki Installation Error')
colas@0
  2084
          . 'Template "'.$template.'" not found.'.CGI::p()
colas@0
  2085
            . 'Check your configuration settings for {TemplateDir} and {TemplatePath}';
colas@0
  2086
    }
colas@0
  2087
colas@0
  2088
    return $text;
colas@0
  2089
}
colas@0
  2090
colas@0
  2091
=pod
colas@0
  2092
colas@0
  2093
---++ StaticMethod parseSections($text) -> ($string,$sectionlistref)
colas@0
  2094
colas@0
  2095
Generic parser for sections within a topic. Sections are delimited
colas@0
  2096
by STARTSECTION and ENDSECTION, which may be nested, overlapped or
colas@0
  2097
otherwise abused. The parser builds an array of sections, which is
colas@0
  2098
ordered by the order of the STARTSECTION within the topic. It also
colas@0
  2099
removes all the SECTION tags from the text, and returns the text
colas@0
  2100
and the array of sections.
colas@0
  2101
colas@0
  2102
Each section is a =TWiki::Attrs= object, which contains the attributes
colas@0
  2103
{type, name, start, end}
colas@0
  2104
where start and end are character offsets in the
colas@0
  2105
string *after all section tags have been removed*. All sections
colas@0
  2106
are required to be uniquely named; if a section is unnamed, it
colas@0
  2107
will be given a generated name. Sections may overlap or nest.
colas@0
  2108
colas@0
  2109
See test/unit/Fn_SECTION.pm for detailed testcases that
colas@0
  2110
round out the spec.
colas@0
  2111
colas@0
  2112
=cut
colas@0
  2113
colas@0
  2114
sub parseSections {
colas@0
  2115
    #my( $text _ = @_;
colas@0
  2116
    my %sections;
colas@0
  2117
    my @list = ();
colas@0
  2118
colas@0
  2119
    my $seq = 0;
colas@0
  2120
    my $ntext = '';
colas@0
  2121
    my $offset = 0;
colas@0
  2122
    foreach my $bit (split(/(%(?:START|END)SECTION(?:{.*?})?%)/, $_[0] )) {
colas@0
  2123
        if( $bit =~ /^%STARTSECTION(?:{(.*)})?%$/) {
colas@0
  2124
            require TWiki::Attrs;
colas@0
  2125
            my $attrs = new TWiki::Attrs( $1 );
colas@0
  2126
            $attrs->{type} ||= 'section';
colas@0
  2127
            $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} ||
colas@0
  2128
              '_SECTION'.$seq++;
colas@0
  2129
            delete $attrs->{_DEFAULT};
colas@0
  2130
            my $id = $attrs->{type}.':'.$attrs->{name};
colas@0
  2131
            if( $sections{$id} ) {
colas@0
  2132
                # error, this named section already defined, ignore
colas@0
  2133
                next;
colas@0
  2134
            }
colas@0
  2135
            # close open unnamed sections of the same type
colas@0
  2136
            foreach my $s ( @list ) {
colas@0
  2137
                if( $s->{end} < 0 && $s->{type} eq $attrs->{type} &&
colas@0
  2138
                      $s->{name} =~ /^_SECTION\d+$/ ) {
colas@0
  2139
                    $s->{end} = $offset;
colas@0
  2140
                }
colas@0
  2141
            }
colas@0
  2142
            $attrs->{start} = $offset;
colas@0
  2143
            $attrs->{end} = -1; # open section
colas@0
  2144
            $sections{$id} = $attrs;
colas@0
  2145
            push( @list, $attrs );
colas@0
  2146
        } elsif( $bit =~ /^%ENDSECTION(?:{(.*)})?%$/ ) {
colas@0
  2147
            require TWiki::Attrs;
colas@0
  2148
            my $attrs = new TWiki::Attrs( $1 );
colas@0
  2149
            $attrs->{type} ||= 'section';
colas@0
  2150
            $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} || '';
colas@0
  2151
            delete $attrs->{_DEFAULT};
colas@0
  2152
            unless( $attrs->{name} ) {
colas@0
  2153
                # find the last open unnamed section of this type
colas@0
  2154
                foreach my $s ( reverse @list ) {
colas@0
  2155
                    if( $s->{end} == -1 &&
colas@0
  2156
                          $s->{type} eq $attrs->{type} &&
colas@0
  2157
                         $s->{name} =~ /^_SECTION\d+$/ ) {
colas@0
  2158
                        $attrs->{name} = $s->{name};
colas@0
  2159
                        last;
colas@0
  2160
                    }
colas@0
  2161
                }
colas@0
  2162
                # ignore it if no matching START found
colas@0
  2163
                next unless $attrs->{name};
colas@0
  2164
            }
colas@0
  2165
            my $id = $attrs->{type}.':'.$attrs->{name};
colas@0
  2166
            if( !$sections{$id} || $sections{$id}->{end} >= 0 ) {
colas@0
  2167
                # error, no such open section, ignore
colas@0
  2168
                next;
colas@0
  2169
            }
colas@0
  2170
            $sections{$id}->{end} = $offset;
colas@0
  2171
        } else {
colas@0
  2172
            $ntext .= $bit;
colas@0
  2173
            $offset = length( $ntext );
colas@0
  2174
        }
colas@0
  2175
    }
colas@0
  2176
colas@0
  2177
    # close open sections
colas@0
  2178
    foreach my $s ( @list ) {
colas@0
  2179
        $s->{end} = $offset if $s->{end} < 0;
colas@0
  2180
    }
colas@0
  2181
colas@0
  2182
    return( $ntext, \@list );
colas@0
  2183
}
colas@0
  2184
colas@0
  2185
=pod
colas@0
  2186
colas@0
  2187
---++ ObjectMethod expandVariablesOnTopicCreation ( $text, $user, $web, $topic ) -> $text
colas@0
  2188
colas@0
  2189
   * =$text= - text to expand
colas@0
  2190
   * =$user= - This is the user expanded in e.g. %USERNAME. Optional, defaults to logged-in user.
colas@0
  2191
Expand limited set of variables during topic creation. These are variables
colas@0
  2192
expected in templates that must be statically expanded in new content.
colas@0
  2193
   * =$web= - name of web
colas@0
  2194
   * =$topic= - name of topic
colas@0
  2195
colas@0
  2196
# SMELL: no plugin handler
colas@0
  2197
colas@0
  2198
=cut
colas@0
  2199
colas@0
  2200
sub expandVariablesOnTopicCreation {
colas@0
  2201
    my ( $this, $text, $user, $theWeb, $theTopic ) = @_;
colas@0
  2202
colas@0
  2203
    $user ||= $this->{user};
colas@0
  2204
colas@0
  2205
    # Chop out templateonly sections
colas@0
  2206
    my( $ntext, $sections ) = parseSections( $text );
colas@0
  2207
    if( scalar( @$sections )) {
colas@0
  2208
        # Note that if named templateonly sections overlap, the behaviour is undefined.
colas@0
  2209
        foreach my $s ( reverse @$sections ) {
colas@0
  2210
            if( $s->{type} eq 'templateonly' ) {
colas@0
  2211
                $ntext = substr($ntext, 0, $s->{start})
colas@0
  2212
                       . substr($ntext, $s->{end}, length($ntext));
colas@0
  2213
            } else {
colas@0
  2214
                # put back non-templateonly sections
colas@0
  2215
                my $start = $s->remove('start');
colas@0
  2216
                my $end = $s->remove('end');
colas@0
  2217
                $ntext = substr($ntext, 0, $start).
colas@0
  2218
                  '%STARTSECTION{'.$s->stringify().'}%'.
colas@0
  2219
                    substr($ntext, $start, $end - $start).
colas@0
  2220
                      '%ENDSECTION{'.$s->stringify().'}%'.
colas@0
  2221
                        substr($ntext, $end, length($ntext));
colas@0
  2222
            }
colas@0
  2223
        }
colas@0
  2224
        $text = $ntext;
colas@0
  2225
    }
colas@0
  2226
colas@0
  2227
    # Make sure func works, for registered tag handlers
colas@0
  2228
    $TWiki::Plugins::SESSION = $this;
colas@0
  2229
colas@0
  2230
    # Note: it may look dangerous to override the user this way, but
colas@0
  2231
    # it's actually quite safe, because only a subset of tags are
colas@0
  2232
    # expanded during topic creation. if the set of tags expanded is
colas@0
  2233
    # extended, then the impact has to be considered.
colas@0
  2234
    my $safe = $this->{user};
colas@0
  2235
    $this->{user} = $user;
colas@0
  2236
    $text = _processTags( $this, $text, \&_expandTagOnTopicCreation, 16 );
colas@0
  2237
colas@0
  2238
    # expand all variables for type="expandvariables" sections
colas@0
  2239
    ( $ntext, $sections ) = parseSections( $text );
colas@0
  2240
    if( scalar( @$sections )) {
colas@0
  2241
        $theWeb   ||= $this->{session}->{webName};
colas@0
  2242
        $theTopic ||= $this->{session}->{topicName};
colas@0
  2243
        foreach my $s ( reverse @$sections ) {
colas@0
  2244
            if( $s->{type} eq 'expandvariables' ) {
colas@0
  2245
                my $etext = substr( $ntext, $s->{start}, $s->{end} - $s->{start} );
colas@0
  2246
                expandAllTags( $this, \$etext, $theTopic, $theWeb );
colas@0
  2247
                $ntext = substr( $ntext, 0, $s->{start})
colas@0
  2248
                       . $etext
colas@0
  2249
                       . substr( $ntext, $s->{end}, length($ntext) );
colas@0
  2250
            } else {
colas@0
  2251
                # put back non-expandvariables sections
colas@0
  2252
                my $start = $s->remove('start');
colas@0
  2253
                my $end = $s->remove('end');
colas@0
  2254
                $ntext = substr($ntext, 0, $start).
colas@0
  2255
                  '%STARTSECTION{'.$s->stringify().'}%'.
colas@0
  2256
                    substr($ntext, $start, $end - $start).
colas@0
  2257
                      '%ENDSECTION{'.$s->stringify().'}%'.
colas@0
  2258
                        substr($ntext, $end, length($ntext));
colas@0
  2259
            }
colas@0
  2260
        }
colas@0
  2261
        $text = $ntext;
colas@0
  2262
    }
colas@0
  2263
colas@0
  2264
    # kill markers used to prevent variable expansion
colas@0
  2265
    $text =~ s/%NOP%//g;
colas@0
  2266
    $this->{user} = $safe;
colas@0
  2267
    return $text;
colas@0
  2268
}
colas@0
  2269
colas@0
  2270
=pod
colas@0
  2271
colas@0
  2272
---++ StaticMethod entityEncode( $text, $extras ) -> $encodedText
colas@0
  2273
colas@0
  2274
Escape special characters to HTML numeric entities. This is *not* a generic
colas@0
  2275
encoding, it is tuned specifically for use in TWiki.
colas@0
  2276
colas@0
  2277
HTML4.0 spec:
colas@0
  2278
"Certain characters in HTML are reserved for use as markup and must be
colas@0
  2279
escaped to appear literally. The "&lt;" character may be represented with
colas@0
  2280
an <em>entity</em>, <strong class=html>&amp;lt;</strong>. Similarly, "&gt;"
colas@0
  2281
is escaped as <strong class=html>&amp;gt;</strong>, and "&amp;" is escaped
colas@0
  2282
as <strong class=html>&amp;amp;</strong>. If an attribute value contains a
colas@0
  2283
double quotation mark and is delimited by double quotation marks, then the
colas@0
  2284
quote should be escaped as <strong class=html>&amp;quot;</strong>.</p>
colas@0
  2285
colas@0
  2286
Other entities exist for special characters that cannot easily be entered
colas@0
  2287
with some keyboards..."
colas@0
  2288
colas@0
  2289
This method encodes HTML special and any non-printable ascii
colas@0
  2290
characters (except for \n and \r) using numeric entities.
colas@0
  2291
colas@0
  2292
FURTHER this method also encodes characters that are special in TWiki
colas@0
  2293
meta-language.
colas@0
  2294
colas@0
  2295
$extras is an optional param that may be used to include *additional*
colas@0
  2296
characters in the set of encoded characters. It should be a string
colas@0
  2297
containing the additional chars.
colas@0
  2298
colas@0
  2299
=cut
colas@0
  2300
colas@0
  2301
sub entityEncode {
colas@0
  2302
    my( $text, $extra) = @_;
colas@0
  2303
    $extra ||= '';
colas@0
  2304
colas@0
  2305
    # encode all non-printable 7-bit chars (< \x1f),
colas@0
  2306
    # except \n (\xa) and \r (\xd)
colas@0
  2307
    # encode HTML special characters '>', '<', '&', ''' and '"'.
colas@0
  2308
    # encode TML special characters '%', '|', '[', ']', '@', '_',
colas@0
  2309
    # '*', and '='
colas@0
  2310
    $text =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|$extra])/'&#'.ord($1).';'/ge;
colas@0
  2311
    return $text;
colas@0
  2312
}
colas@0
  2313
colas@0
  2314
=pod
colas@0
  2315
colas@0
  2316
---++ StaticMethod entityDecode ( $encodedText ) -> $text
colas@0
  2317
colas@0
  2318
Decodes all numeric entities (e.g. &amp;#123;). _Does not_ decode
colas@0
  2319
named entities such as &amp;amp; (use HTML::Entities for that)
colas@0
  2320
colas@0
  2321
=cut
colas@0
  2322
colas@0
  2323
sub entityDecode {
colas@0
  2324
    my $text = shift;
colas@0
  2325
colas@0
  2326
    $text =~ s/&#(\d+);/chr($1)/ge;
colas@0
  2327
    return $text;
colas@0
  2328
}
colas@0
  2329
colas@0
  2330
=pod
colas@0
  2331
colas@0
  2332
---++ StaticMethod urlEncodeAttachment ( $text )
colas@0
  2333
colas@0
  2334
For attachments, URL-encode specially to 'freeze' any characters >127 in the
colas@0
  2335
site charset (e.g. ISO-8859-1 or KOI8-R), by doing URL encoding into native
colas@0
  2336
charset ($siteCharset) - used when generating attachment URLs, to enable the
colas@0
  2337
web server to serve attachments, including images, directly.  
colas@0
  2338
colas@0
  2339
This encoding is required to handle the cases of:
colas@0
  2340
colas@0
  2341
    - browsers that generate UTF-8 URLs automatically from site charset URLs - now quite common
colas@0
  2342
    - web servers that directly serve attachments, using the site charset for
colas@0
  2343
      filenames, and cannot convert UTF-8 URLs into site charset filenames
colas@0
  2344
colas@0
  2345
The aim is to prevent the browser from converting a site charset URL in the web
colas@0
  2346
page to a UTF-8 URL, which is the default.  Hence we 'freeze' the URL into the
colas@0
  2347
site character set through URL encoding. 
colas@0
  2348
colas@0
  2349
In two cases, no URL encoding is needed:  For EBCDIC mainframes, we assume that 
colas@0
  2350
site charset URLs will be translated (outbound and inbound) by the web server to/from an
colas@0
  2351
EBCDIC character set. For sites running in UTF-8, there's no need for TWiki to
colas@0
  2352
do anything since all URLs and attachment filenames are already in UTF-8.
colas@0
  2353
colas@0
  2354
=cut
colas@0
  2355
colas@0
  2356
sub urlEncodeAttachment {
colas@0
  2357
    my( $text ) = @_;
colas@0
  2358
colas@0
  2359
    my $usingEBCDIC = ( 'A' eq chr(193) ); 	# Only true on EBCDIC mainframes
colas@0
  2360
colas@1
  2361
    if( (defined($TWiki::cfg{Site}{CharSet}) and $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) or $usingEBCDIC ) {
colas@0
  2362
	# Just let browser do UTF-8 URL encoding 
colas@0
  2363
	return $text;
colas@0
  2364
    }
colas@0
  2365
colas@0
  2366
    # Freeze into site charset through URL encoding
colas@0
  2367
    return urlEncode( $text );
colas@0
  2368
}
colas@0
  2369
colas@0
  2370
colas@0
  2371
=pod
colas@0
  2372
colas@0
  2373
---++ StaticMethod urlEncode( $string ) -> encoded string
colas@0
  2374
colas@0
  2375
Encode by converting characters that are illegal in URLs to
colas@0
  2376
their %NN equivalents. This method is used for encoding
colas@0
  2377
strings that must be embedded _verbatim_ in URLs; it cannot
colas@0
  2378
be applied to URLs themselves, as it escapes reserved
colas@0
  2379
characters such as = and ?.
colas@0
  2380
colas@0
  2381
RFC 1738, Dec. '94:
colas@0
  2382
    <verbatim>
colas@0
  2383
    ...Only alphanumerics [0-9a-zA-Z], the special
colas@0
  2384
    characters $-_.+!*'(), and reserved characters used for their
colas@0
  2385
    reserved purposes may be used unencoded within a URL.
colas@0
  2386
    </verbatim>
colas@0
  2387
colas@0
  2388
Reserved characters are $&+,/:;=?@ - these are _also_ encoded by
colas@0
  2389
this method.
colas@0
  2390
colas@0
  2391
This URL-encoding handles all character encodings including ISO-8859-*,
colas@0
  2392
KOI8-R, EUC-* and UTF-8. 
colas@0
  2393
colas@0
  2394
This may not handle EBCDIC properly, as it generates an EBCDIC URL-encoded
colas@0
  2395
URL, but mainframe web servers seem to translate this outbound before it hits browser
colas@0
  2396
- see CGI::Util::escape for another approach.
colas@0
  2397
colas@0
  2398
=cut
colas@0
  2399
colas@0
  2400
sub urlEncode {
colas@0
  2401
    my $text = shift;
colas@0
  2402
colas@0
  2403
    $text =~ s/([^0-9a-zA-Z-_.:~!*'\/%])/'%'.sprintf('%02x',ord($1))/ge;
colas@0
  2404
colas@0
  2405
    return $text;
colas@0
  2406
}
colas@0
  2407
colas@0
  2408
=pod
colas@0
  2409
colas@0
  2410
---++ StaticMethod urlDecode( $string ) -> decoded string
colas@0
  2411
colas@0
  2412
Reverses the encoding done in urlEncode.
colas@0
  2413
colas@0
  2414
=cut
colas@0
  2415
colas@0
  2416
sub urlDecode {
colas@0
  2417
    my $text = shift;
colas@0
  2418
colas@0
  2419
    $text =~ s/%([\da-f]{2})/chr(hex($1))/gei;
colas@0
  2420
colas@0
  2421
    return $text;
colas@0
  2422
}
colas@0
  2423
colas@0
  2424
=pod
colas@0
  2425
colas@0
  2426
---++ StaticMethod isTrue( $value, $default ) -> $boolean
colas@0
  2427
colas@0
  2428
Returns 1 if =$value= is true, and 0 otherwise. "true" means set to
colas@0
  2429
something with a Perl true value, with the special cases that "off",
colas@0
  2430
"false" and "no" (case insensitive) are forced to false. Leading and
colas@0
  2431
trailing spaces in =$value= are ignored.
colas@0
  2432
colas@0
  2433
If the value is undef, then =$default= is returned. If =$default= is
colas@0
  2434
not specified it is taken as 0.
colas@0
  2435
colas@0
  2436
=cut
colas@0
  2437
colas@0
  2438
sub isTrue {
colas@0
  2439
    my( $value, $default ) = @_;
colas@0
  2440
colas@0
  2441
    $default ||= 0;
colas@0
  2442
colas@0
  2443
    return $default unless defined( $value );
colas@0
  2444
colas@0
  2445
    $value =~ s/^\s*(.*?)\s*$/$1/gi;
colas@0
  2446
    $value =~ s/off//gi;
colas@0
  2447
    $value =~ s/no//gi;
colas@0
  2448
    $value =~ s/false//gi;
colas@0
  2449
    return ( $value ) ? 1 : 0;
colas@0
  2450
}
colas@0
  2451
colas@0
  2452
=pod
colas@0
  2453
colas@0
  2454
---++ StaticMethod spaceOutWikiWord( $word, $sep ) -> $string
colas@0
  2455
colas@0
  2456
Spaces out a wiki word by inserting a string (default: one space) between each word component.
colas@0
  2457
With parameter $sep any string may be used as separator between the word components; if $sep is undefined it defaults to a space.
colas@0
  2458
colas@0
  2459
=cut
colas@0
  2460
colas@0
  2461
sub spaceOutWikiWord {
colas@0
  2462
    my $word = shift || '';
colas@0
  2463
    my $sep = shift || ' ';
colas@0
  2464
    $word =~ s/([$regex{lowerAlpha}])([$regex{upperAlpha}$regex{numeric}]+)/$1$sep$2/go;
colas@0
  2465
    $word =~ s/([$regex{numeric}])([$regex{upperAlpha}])/$1$sep$2/go;
colas@0
  2466
    return $word;
colas@0
  2467
}
colas@0
  2468
colas@0
  2469
=pod
colas@0
  2470
colas@0
  2471
---++ ObjectMethod expandAllTags(\$text, $topic, $web, $meta)
colas@0
  2472
Expands variables by replacing the variables with their
colas@0
  2473
values. Some example variables: %<nop>TOPIC%, %<nop>SCRIPTURL%,
colas@0
  2474
%<nop>WIKINAME%, etc.
colas@0
  2475
$web and $incs are passed in for recursive include expansion. They can
colas@0
  2476
safely be undef.
colas@0
  2477
The rules for tag expansion are:
colas@0
  2478
   1 Tags are expanded left to right, in the order they are encountered.
colas@0
  2479
   1 Tags are recursively expanded as soon as they are encountered -
colas@0
  2480
     the algorithm is inherently single-pass
colas@0
  2481
   1 A tag is not "encountered" until the matching }% has been seen, by
colas@0
  2482
     which time all tags in parameters will have been expanded
colas@0
  2483
   1 Tag expansions that create new tags recursively are limited to a
colas@0
  2484
     set number of hierarchical levels of expansion
colas@0
  2485
colas@0
  2486
=cut
colas@0
  2487
colas@0
  2488
sub expandAllTags {
colas@0
  2489
    my $this = shift;
colas@0
  2490
    my $text = shift; # reference
colas@0
  2491
    my ( $topic, $web, $meta ) = @_;
colas@0
  2492
    $web =~ s#\.#/#go;
colas@0
  2493
colas@0
  2494
    # push current context
colas@0
  2495
    my $memTopic = $this->{SESSION_TAGS}{TOPIC};
colas@0
  2496
    my $memWeb   = $this->{SESSION_TAGS}{WEB};
colas@0
  2497
colas@0
  2498
    $this->{SESSION_TAGS}{TOPIC}   = $topic;
colas@0
  2499
    $this->{SESSION_TAGS}{WEB}     = $web;
colas@0
  2500
colas@0
  2501
    # Escape ' !%VARIABLE%'
colas@0
  2502
    $$text =~ s/(?<=\s)!%($regex{tagNameRegex})/&#37;$1/g;
colas@0
  2503
colas@0
  2504
    # Make sure func works, for registered tag handlers
colas@0
  2505
    $TWiki::Plugins::SESSION = $this;
colas@0
  2506
colas@0
  2507
    # NOTE TO DEBUGGERS
colas@0
  2508
    # The depth parameter in the following call controls the maximum number
colas@0
  2509
    # of levels of expansion. If it is set to 1 then only tags in the
colas@0
  2510
    # topic will be expanded; tags that they in turn generate will be
colas@0
  2511
    # left unexpanded. If it is set to 2 then the expansion will stop after
colas@0
  2512
    # the first recursive inclusion, and so on. This is incredible useful
colas@0
  2513
    # when debugging. The default is set to 16
colas@0
  2514
    # to match the original limit on search expansion, though this of
colas@0
  2515
    # course applies to _all_ tags and not just search.
colas@0
  2516
    $$text = _processTags( $this, $$text, \&_expandTagOnTopicRendering,
colas@0
  2517
                                  16, @_ );
colas@0
  2518
colas@0
  2519
    # restore previous context
colas@0
  2520
    $this->{SESSION_TAGS}{TOPIC}   = $memTopic;
colas@0
  2521
    $this->{SESSION_TAGS}{WEB}     = $memWeb;
colas@0
  2522
}
colas@0
  2523
colas@0
  2524
# Process TWiki %TAGS{}% by parsing the input tokenised into
colas@0
  2525
# % separated sections. The parser is a simple stack-based parse,
colas@0
  2526
# sufficient to ensure nesting of tags is correct, but no more
colas@0
  2527
# than that.
colas@0
  2528
# $depth limits the number of recursive expansion steps that
colas@0
  2529
# can be performed on expanded tags.
colas@0
  2530
sub _processTags {
colas@0
  2531
    my $this = shift;
colas@0
  2532
    my $text = shift;
colas@0
  2533
    my $tagf = shift;
colas@0
  2534
    my $tell = 0;
colas@0
  2535
colas@1
  2536
    return '' if (
colas@1
  2537
        (!defined( $text )) || 
colas@1
  2538
        ($text eq ''));
colas@1
  2539
colas@1
  2540
    #no tags to process
colas@1
  2541
    return $text unless ($text =~ /(%)/);
colas@0
  2542
colas@0
  2543
    my $depth = shift;
colas@0
  2544
colas@0
  2545
    unless ( $depth ) {
colas@0
  2546
        my $mess = "Max recursive depth reached: $text";
colas@0
  2547
        $this->writeWarning( $mess );
colas@0
  2548
        # prevent recursive expansion that just has been detected
colas@0
  2549
        # from happening in the error message
colas@0
  2550
        $text =~ s/%(.*?)%/$1/go;
colas@0
  2551
        return $text;
colas@0
  2552
    }
colas@0
  2553
colas@0
  2554
    my $verbatim = {};
colas@0
  2555
    $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
colas@0
  2556
                                               $verbatim);
colas@0
  2557
colas@0
  2558
    # See Item1442
colas@0
  2559
    #my $percent = ($TranslationToken x 3).'%'.($TranslationToken x 3);
colas@0
  2560
colas@0
  2561
    my @queue = split( /(%)/, $text );
colas@0
  2562
    my @stack;
colas@0
  2563
    my $stackTop = ''; # the top stack entry. Done this way instead of
colas@0
  2564
    # referring to the top of the stack for efficiency. This var
colas@0
  2565
    # should be considered to be $stack[$#stack]
colas@0
  2566
colas@0
  2567
    while ( scalar( @queue )) {
colas@0
  2568
        my $token = shift( @queue );
colas@1
  2569
        #print STDERR ' ' x $tell,"PROCESSING $token \n";
colas@0
  2570
colas@0
  2571
        # each % sign either closes an existing stacked context, or
colas@0
  2572
        # opens a new context.
colas@0
  2573
        if ( $token eq '%' ) {
colas@1
  2574
            #print STDERR ' ' x $tell,"CONSIDER $stackTop\n";
colas@0
  2575
            # If this is a closing }%, try to rejoin the previous
colas@0
  2576
            # tokens until we get to a valid tag construct. This is
colas@0
  2577
            # a bit of a hack, but it's hard to think of a better
colas@0
  2578
            # way to do this without a full parse that takes % signs
colas@0
  2579
            # in tag parameters into account.
colas@0
  2580
            if ( $stackTop =~ /}$/s ) {
colas@0
  2581
                while ( scalar( @stack) &&
colas@0
  2582
                        $stackTop !~ /^%($regex{tagNameRegex}){.*}$/so ) {
colas@0
  2583
                    my $top = $stackTop;
colas@1
  2584
                    #print STDERR ' ' x $tell,"COLLAPSE $top \n";
colas@0
  2585
                    $stackTop = pop( @stack ) . $top;
colas@0
  2586
                }
colas@0
  2587
            }
colas@0
  2588
            # /s so you can have newlines in parameters
colas@0
  2589
            if ( $stackTop =~ m/^%(($regex{tagNameRegex})(?:{(.*)})?)$/so ) {
colas@0
  2590
                my( $expr, $tag, $args ) = ( $1, $2, $3 );
colas@1
  2591
                #print STDERR ' ' x $tell,"POP $tag\n";
colas@0
  2592
                my $e = &$tagf( $this, $tag, $args, @_ );
colas@0
  2593
colas@0
  2594
                if ( defined( $e )) {
colas@1
  2595
                    #print STDERR ' ' x $tell--,"EXPANDED $tag -> $e\n";
colas@0
  2596
                    $stackTop = pop( @stack );
colas@1
  2597
                    unless ($e =~ /(%)/) {
colas@1
  2598
                        #SMELL: this is a profiler speedup found by Sven on the last day of 4.2.1
colas@1
  2599
                        #TODO: I don't think this parser should be in this section - re-analysis desired.
colas@1
  2600
                        #print STDERR "no tags to recurse\n";
colas@1
  2601
                        $stackTop .= $e;
colas@1
  2602
                        next;
colas@1
  2603
                    }
colas@0
  2604
                    # Recursively expand tags in the expansion of $tag
colas@0
  2605
                    $stackTop .= _processTags($this, $e, $tagf, $depth-1, @_ );
colas@0
  2606
                } else { # expansion failed
colas@1
  2607
                    #print STDERR ' ' x $tell++,"EXPAND $tag FAILED\n";
colas@0
  2608
                    # To handle %NOP
colas@0
  2609
                    # correctly, we have to handle the %VAR% case differently
colas@0
  2610
                    # to the %VAR{}% case when a variable expansion fails.
colas@0
  2611
                    # This is so that recursively define variables e.g.
colas@0
  2612
                    # %A%B%D% expand correctly, but at the same time we ensure
colas@0
  2613
                    # that a mismatched }% can't accidentally close a context
colas@0
  2614
                    # that was left open when a tag expansion failed.
colas@0
  2615
                    # However Cairo didn't do this, so for compatibility
colas@0
  2616
                    # we have to accept that %NOP can never be fixed. if it
colas@0
  2617
                    # could, then we could uncomment the following:
colas@0
  2618
colas@0
  2619
                    #if( $stackTop =~ /}$/ ) {
colas@0
  2620
                    #    # %VAR{...}% case
colas@0
  2621
                    #    # We need to push the unexpanded expression back
colas@0
  2622
                    #    # onto the stack, but we don't want it to match the
colas@0
  2623
                    #    # tag expression again. So we protect the %'s
colas@0
  2624
                    #    $stackTop = $percent.$expr.$percent;
colas@0
  2625
                    #} else
colas@0
  2626
                    {
colas@0
  2627
                        # %VAR% case.
colas@0
  2628
                        # In this case we *do* want to match the tag expression
colas@0
  2629
                        # again, as an embedded %VAR% may have expanded to
colas@0
  2630
                        # create a valid outer expression. This is directly
colas@0
  2631
                        # at odds with the %VAR{...}% case.
colas@0
  2632
                        push( @stack, $stackTop );
colas@0
  2633
                        $stackTop = '%'; # open new context
colas@0
  2634
                    }
colas@0
  2635
                }
colas@0
  2636
            } else {
colas@0
  2637
                push( @stack, $stackTop );
colas@0
  2638
                $stackTop = '%'; # push a new context
colas@1
  2639
                #$tell++;
colas@0
  2640
            }
colas@0
  2641
        } else {
colas@0
  2642
            $stackTop .= $token;
colas@0
  2643
        }
colas@0
  2644
    }
colas@0
  2645
colas@0
  2646
    # Run out of input. Gather up everything in the stack.
colas@0
  2647
    while ( scalar( @stack )) {
colas@0
  2648
        my $expr = $stackTop;
colas@0
  2649
        $stackTop = pop( @stack );
colas@0
  2650
        $stackTop .= $expr;
colas@0
  2651
    }
colas@0
  2652
colas@0
  2653
    #$stackTop =~ s/$percent/%/go;
colas@0
  2654
colas@0
  2655
    $this->renderer->putBackBlocks( \$stackTop, $verbatim, 'verbatim' );
colas@0
  2656
colas@1
  2657
    #print STDERR "FINAL $stackTop\n";
colas@0
  2658
colas@0
  2659
    return $stackTop;
colas@0
  2660
}
colas@0
  2661
colas@0
  2662
# Handle expansion of a tag during topic rendering
colas@0
  2663
# $tag is the tag name
colas@0
  2664
# $args is the bit in the {} (if there are any)
colas@0
  2665
# $topic and $web should be passed for dynamic tags (not needed for
colas@0
  2666
# session or constant tags
colas@0
  2667
sub _expandTagOnTopicRendering {
colas@0
  2668
    my $this = shift;
colas@0
  2669
    my $tag = shift;
colas@0
  2670
    my $args = shift;
colas@0
  2671
    # my( $topic, $web, $meta ) = @_;
colas@0
  2672
    require TWiki::Attrs;
colas@0
  2673
colas@0
  2674
    my $e = $this->{prefs}->getPreferencesValue( $tag );
colas@0
  2675
    unless( defined( $e )) {
colas@0
  2676
        $e = $this->{SESSION_TAGS}{$tag};
colas@0
  2677
        if( !defined( $e ) && defined( $functionTags{$tag} )) {
colas@0
  2678
            $e = &{$functionTags{$tag}}
colas@0
  2679
              ( $this, new TWiki::Attrs(
colas@0
  2680
                  $args, $contextFreeSyntax{$tag} ), @_ );
colas@0
  2681
        }
colas@0
  2682
    }
colas@0
  2683
    return $e;
colas@0
  2684
}
colas@0
  2685
colas@0
  2686
# Handle expansion of a tag during new topic creation. When creating a
colas@0
  2687
# new topic from a template we only expand a subset of the available legal
colas@0
  2688
# tags, and we expand %NOP% differently.
colas@0
  2689
sub _expandTagOnTopicCreation {
colas@0
  2690
    my $this = shift;
colas@0
  2691
    # my( $tag, $args, $topic, $web ) = @_;
colas@0
  2692
colas@0
  2693
    # Required for Cairo compatibility. Ignore %NOP{...}%
colas@0
  2694
    # %NOP% is *not* ignored until all variable expansion is complete,
colas@0
  2695
    # otherwise them inside-out rule would remove it too early e.g.
colas@0
  2696
    # %GM%NOP%TIME -> %GMTIME -> 12:00. So we ignore it here and scrape it
colas@0
  2697
    # out later. We *have* to remove %NOP{...}% because it can foul up
colas@0
  2698
    # brace-matching.
colas@0
  2699
    return '' if $_[0] eq 'NOP' && defined $_[1];
colas@0
  2700
colas@0
  2701
    # Only expand a subset of legal tags. Warning: $this->{user} may be
colas@0
  2702
    # overridden during this call, when a new user topic is being created.
colas@0
  2703
    # This is what we want to make sure new user templates are populated
colas@0
  2704
    # correctly, but you need to think about this if you extend the set of
colas@0
  2705
    # tags expanded here.
colas@0
  2706
    return undef unless $_[0] =~ /^(URLPARAM|DATE|(SERVER|GM)TIME|(USER|WIKI)NAME|WIKIUSERNAME|USERINFO)$/;
colas@0
  2707
colas@0
  2708
    return _expandTagOnTopicRendering( $this, @_ );
colas@0
  2709
}
colas@0
  2710
colas@0
  2711
=pod
colas@0
  2712
colas@0
  2713
---++ ObjectMethod enterContext( $id, $val )
colas@0
  2714
colas@0
  2715
Add the context id $id into the set of active contexts. The $val
colas@0
  2716
can be anything you like, but should always evaluate to boolean
colas@0
  2717
TRUE.
colas@0
  2718
colas@0
  2719
An example of the use of contexts is in the use of tag
colas@0
  2720
expansion. The commonTagsHandler in plugins is called every
colas@0
  2721
time tags need to be expanded, and the context of that expansion
colas@0
  2722
is signalled by the expanding module using a context id. So the
colas@0
  2723
forms module adds the context id "form" before invoking common
colas@0
  2724
tags expansion.
colas@0
  2725
colas@0
  2726
Contexts are not just useful for tag expansion; they are also
colas@0
  2727
relevant when rendering.
colas@0
  2728
colas@0
  2729
Contexts are intended for use mainly by plugins. Core modules can
colas@0
  2730
use $session->inContext( $id ) to determine if a context is active.
colas@0
  2731
colas@0
  2732
=cut
colas@0
  2733
colas@0
  2734
sub enterContext {
colas@0
  2735
    my( $this, $id, $val ) = @_;
colas@0
  2736
    $val ||= 1;
colas@0
  2737
    $this->{context}->{$id} = $val;
colas@0
  2738
}
colas@0
  2739
colas@0
  2740
=pod
colas@0
  2741
colas@0
  2742
---++ ObjectMethod leaveContext( $id )
colas@0
  2743
colas@0
  2744
Remove the context id $id from the set of active contexts.
colas@0
  2745
(see =enterContext= for more information on contexts)
colas@0
  2746
colas@0
  2747
=cut
colas@0
  2748
colas@0
  2749
sub leaveContext {
colas@0
  2750
    my( $this, $id ) = @_;
colas@0
  2751
    my $res = $this->{context}->{$id};
colas@0
  2752
    delete $this->{context}->{$id};
colas@0
  2753
    return $res;
colas@0
  2754
}
colas@0
  2755
colas@0
  2756
=pod
colas@0
  2757
colas@0
  2758
---++ ObjectMethod inContext( $id )
colas@0
  2759
colas@0
  2760
Return the value for the given context id
colas@0
  2761
(see =enterContext= for more information on contexts)
colas@0
  2762
colas@0
  2763
=cut
colas@0
  2764
colas@0
  2765
sub inContext {
colas@0
  2766
    my( $this, $id ) = @_;
colas@0
  2767
    return $this->{context}->{$id};
colas@0
  2768
}
colas@0
  2769
colas@0
  2770
=pod
colas@0
  2771
colas@0
  2772
---++ StaticMethod registerTagHandler( $tag, $fnref )
colas@0
  2773
colas@0
  2774
STATIC Add a tag handler to the function tag handlers.
colas@0
  2775
   * =$tag= name of the tag e.g. MYTAG
colas@0
  2776
   * =$fnref= Function to execute. Will be passed ($session, \%params, $web, $topic )
colas@0
  2777
colas@0
  2778
=cut
colas@0
  2779
colas@0
  2780
sub registerTagHandler {
colas@0
  2781
    my ( $tag, $fnref, $syntax ) = @_;
colas@0
  2782
    $functionTags{$tag} = \&$fnref;
colas@0
  2783
    if( $syntax && $syntax eq 'context-free' ) {
colas@0
  2784
        $contextFreeSyntax{$tag} = 1;
colas@0
  2785
    }
colas@0
  2786
}
colas@0
  2787
colas@0
  2788
=pod=
colas@0
  2789
colas@0
  2790
---++ StaticMethod registerRESTHandler( $subject, $verb, \&fn )
colas@0
  2791
colas@0
  2792
Adds a function to the dispatch table of the REST interface 
colas@0
  2793
for a given subject. See TWikiScripts#rest for more info.
colas@0
  2794
colas@0
  2795
   * =$subject= - The subject under which the function will be registered.
colas@0
  2796
   * =$verb= - The verb under which the function will be registered.
colas@0
  2797
   * =\&fn= - Reference to the function.
colas@0
  2798
colas@0
  2799
The handler function must be of the form:
colas@0
  2800
<verbatim>
colas@0
  2801
sub handler(\%session,$subject,$verb) -> $text
colas@0
  2802
</verbatim>
colas@0
  2803
where:
colas@0
  2804
   * =\%session= - a reference to the TWiki session object (may be ignored)
colas@0
  2805
   * =$subject= - The invoked subject (may be ignored)
colas@0
  2806
   * =$verb= - The invoked verb (may be ignored)
colas@0
  2807
colas@0
  2808
*Since:* TWiki::Plugins::VERSION 1.1
colas@0
  2809
colas@0
  2810
=cut=
colas@0
  2811
colas@0
  2812
sub registerRESTHandler {