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