1 # See bottom of file for license and copyright information
8 TWiki operates by creating a singleton object (known as the Session
9 object) that acts as a point of reference for all the different
10 modules in the system. This package is the class for this singleton,
11 and also contains the vast bulk of the basic constants and the per-
12 site configuration mechanisms.
14 Global variables are avoided wherever possible to avoid problems
15 with CGI accelerators such as mod_perl.
17 ---++ Public Data members
18 * =cgiQuery= Pointer to the CGI::
19 * =context= Hash of context ids
20 * moved: =loginManager= TWiki::LoginManager singleton (moved to TWiki::Users)
21 * =plugins= TWiki::Plugins singleton
22 * =prefs= TWiki::Prefs singleton
23 * =remoteUser= Login ID when using ApacheLogin. Maintained for
24 compatibility only, do not use.
25 * =requestedWebName= Name of web found in URL path or =web= URL parameter
26 * =sandbox= TWiki::Sandbox singleton
27 * =scriptUrlPath= URL path to the current script. May be dynamically
28 extracted from the URL path if {GetScriptUrlFromCgi}.
29 Only required to support {GetScriptUrlFromCgi} and
30 not consistently used. Avoid.
31 * =security= TWiki::Access singleton
32 * =SESSION_TAGS= Hash of TWiki variables whose value is specific to
33 the current CGI request.
34 * =store= TWiki::Store singleton
35 * =topicName= Name of topic found in URL path or =topic= URL
37 * =urlHost= Host part of the URL (including the protocol)
38 determined during intialisation and defaulting to
40 * =user= Unique user ID of logged-in user
41 * =users= TWiki::Users singleton
42 * =webName= Name of web found in URL path, or =web= URL parameter,
50 use CGI; # Always required to get the CGI object
52 require 5.005; # For regex objects and internationalisation
54 # Site configuration constants
57 # Uncomment this and the __END__ to enable AutoLoader
58 #use AutoLoader 'AUTOLOAD';
59 # You then need to autosplit TWiki.pm:
61 # perl -e 'use AutoSplit; autosplit("TWiki.pm", "auto")'
63 # Other computed constants
78 # Token character that must not occur in any normal text - converted
79 # to a flag character if it ever does occur (very unlikely)
80 # TWiki uses $TranslationToken to mark points in the text. This is
81 # normally \0, which is not a useful character in any 8-bit character
82 # set we can find, nor in UTF-8. But if you *do* encounter problems
83 # with it, the workaround is to change $TranslationToken to something
84 # longer that is unlikely to occur in your text - for example
85 # muRfleFli5ble8leep (do *not* use punctuation characters or whitspace
87 # See Codev.NationalCharTokenClash for more.
88 $TranslationToken= "\0";
92 ---++ StaticMethod getTWikiLibDir() -> $path
94 Returns the full path of the directory containing TWiki.pm
103 # FIXME: Should just use $INC{"TWiki.pm"} to get path used to load this
106 foreach $dir ( @INC ) {
107 if( $dir && -e "$dir/TWiki.pm" ) {
113 # fix path relative to location of called script
114 if( $twikiLibDir =~ /^\./ ) {
115 print STDERR "WARNING: TWiki lib path $twikiLibDir is relative; you should make it absolute, otherwise some scripts may not run from the command line.";
117 if( $ENV{SCRIPT_FILENAME} &&
118 $ENV{SCRIPT_FILENAME} =~ /^(.+)\/[^\/]+$/ ) {
121 } elsif ( $0 =~ /^(.*)\/.*?$/ ) {
125 # last ditch; relative to current directory.
127 import Cwd qw( cwd );
130 $twikiLibDir = "$bin/$twikiLibDir/";
131 # normalize "/../" and "/./"
132 while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) {
134 $twikiLibDir =~ s|([\\/])\.[\\/]|$1|g;
136 $twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/"
137 $twikiLibDir =~ s|[\\/]$||; # cut trailing "/"
144 require TWiki::Sandbox; # system command sandbox
145 require TWiki::Configure::Load; # read configuration files
151 # If ASSERTs are on, then warnings are errors. Paranoid,
152 # but the only way to be sure we eliminate them all.
153 # Look out also for $cfg{WarningsAreErrors}, below, which
154 # is another way to install this handler without enabling
156 # ASSERTS are turned on by defining the environment variable
157 # TWIKI_ASSERTS. If ASSERTs are off, this is assumed to be a
158 # production environment, and no stack traces or paths are
159 # output to the browser.
160 $SIG{'__WARN__'} = sub { die @_ };
161 $Error::Debug = 1; # verbose stack traces, please
163 $Error::Debug = 0; # no verbose stack traces
166 # DO NOT CHANGE THE FORMAT OF $VERSION
167 # Automatically expanded on checkin of this module
168 $VERSION = '$Date: 2008-08-06 09:54:52 +1000 (Wed, 06 Aug 2008) $ $Rev: 17396 (11 Aug 2008) $ ';
169 $RELEASE = 'TWiki-4.2.2';
170 $VERSION =~ s/^.*?\((.*)\).*: (\d+) .*?$/$RELEASE, $1, build $2/;
172 # Default handlers for different %TAGS%
174 ALLVARIABLES => \&ALLVARIABLES,
175 ATTACHURL => \&ATTACHURL,
176 ATTACHURLPATH => \&ATTACHURLPATH,
178 DISPLAYTIME => \&DISPLAYTIME,
181 FORMFIELD => \&FORMFIELD,
184 HTTP_HOST => \&HTTP_HOST_deprecated,
188 ICONURL => \&ICONURL,
189 ICONURLPATH => \&ICONURLPATH,
191 INCLUDE => \&INCLUDE,
192 INTURLENCODE => \&INTURLENCODE_deprecated,
193 LANGUAGES => \&LANGUAGES,
194 MAKETEXT => \&MAKETEXT,
196 METASEARCH => \&METASEARCH,
198 PLUGINVERSION => \&PLUGINVERSION,
200 PUBURLPATH => \&PUBURLPATH,
201 QUERYPARAMS => \&QUERYPARAMS,
202 QUERYSTRING => \&QUERYSTRING,
203 RELATIVETOPICPATH => \&RELATIVETOPICPATH,
204 REMOTE_ADDR => \&REMOTE_ADDR_deprecated,
205 REMOTE_PORT => \&REMOTE_PORT_deprecated,
206 REMOTE_USER => \&REMOTE_USER_deprecated,
207 REVINFO => \&REVINFO,
208 REVTITLE => \&REVTITLE,
210 SCRIPTNAME => \&SCRIPTNAME,
211 SCRIPTURL => \&SCRIPTURL,
212 SCRIPTURLPATH => \&SCRIPTURLPATH,
215 SERVERTIME => \&SERVERTIME,
216 SPACEDTOPIC => \&SPACEDTOPIC_deprecated,
217 SPACEOUT => \&SPACEOUT,
219 TOPICLIST => \&TOPICLIST,
220 URLENCODE => \&ENCODE,
221 URLPARAM => \&URLPARAM,
222 LANGUAGE => \&LANGUAGE,
223 USERINFO => \&USERINFO,
224 USERNAME => \&USERNAME_deprecated,
226 WEBLIST => \&WEBLIST,
227 WIKINAME => \&WIKINAME_deprecated,
228 WIKIUSERNAME => \&WIKIUSERNAME_deprecated,
229 # Constant tag strings _not_ dependent on config. These get nicely
230 # optimised by the compiler.
231 ENDSECTION => sub { '' },
232 WIKIVERSION => sub { $VERSION },
233 STARTSECTION => sub { '' },
234 STARTINCLUDE => sub { '' },
235 STOPINCLUDE => sub { '' },
237 $contextFreeSyntax{IF} = 1;
239 unless( ( $TWiki::cfg{DetailedOS} = $^O ) ) {
241 $TWiki::cfg{DetailedOS} = $Config::Config{'osname'};
243 $TWiki::cfg{OS} = 'UNIX';
244 if ($TWiki::cfg{DetailedOS} =~ /darwin/i) { # MacOS X
245 $TWiki::cfg{OS} = 'UNIX';
246 } elsif ($TWiki::cfg{DetailedOS} =~ /Win/i) {
247 $TWiki::cfg{OS} = 'WINDOWS';
248 } elsif ($TWiki::cfg{DetailedOS} =~ /vms/i) {
249 $TWiki::cfg{OS} = 'VMS';
250 } elsif ($TWiki::cfg{DetailedOS} =~ /bsdos/i) {
251 $TWiki::cfg{OS} = 'UNIX';
252 } elsif ($TWiki::cfg{DetailedOS} =~ /dos/i) {
253 $TWiki::cfg{OS} = 'DOS';
254 } elsif ($TWiki::cfg{DetailedOS} =~ /^MacOS$/i) { # MacOS 9 or earlier
255 $TWiki::cfg{OS} = 'MACINTOSH';
256 } elsif ($TWiki::cfg{DetailedOS} =~ /os2/i) {
257 $TWiki::cfg{OS} = 'OS2';
260 # Validate and untaint Apache's SERVER_NAME Environment variable
261 # for use in referencing virtualhost-based paths for separate data/ and templates/ instances, etc
262 if ( $ENV{SERVER_NAME} &&
263 $ENV{SERVER_NAME} =~ /^(([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6})$/ ) {
265 TWiki::Sandbox::untaintUnchecked( $ENV{SERVER_NAME} );
268 # readConfig is defined in TWiki::Configure::Load to allow overriding it
269 TWiki::Configure::Load::readConfig();
271 if( $TWiki::cfg{WarningsAreErrors} ) {
272 # Note: Warnings are always errors if ASSERTs are enabled
273 $SIG{'__WARN__'} = sub { die @_ };
276 if( $TWiki::cfg{UseLocale} ) {
281 # Constant tags dependent on the config
282 $functionTags{ALLOWLOGINNAME} =
283 sub { $TWiki::cfg{Register}{AllowLoginName} || 0 };
284 $functionTags{AUTHREALM} = sub { $TWiki::cfg{AuthRealm} };
285 $functionTags{DEFAULTURLHOST} = sub { $TWiki::cfg{DefaultUrlHost} };
286 $functionTags{HOMETOPIC} = sub { $TWiki::cfg{HomeTopicName} };
287 $functionTags{LOCALSITEPREFS} = sub { $TWiki::cfg{LocalSitePreferences} };
288 $functionTags{NOFOLLOW} =
289 sub { $TWiki::cfg{NoFollow} ? 'rel='.$TWiki::cfg{NoFollow} : '' };
290 $functionTags{NOTIFYTOPIC} = sub { $TWiki::cfg{NotifyTopicName} };
291 $functionTags{SCRIPTSUFFIX} = sub { $TWiki::cfg{ScriptSuffix} };
292 $functionTags{STATISTICSTOPIC} = sub { $TWiki::cfg{Stats}{TopicName} };
293 $functionTags{SYSTEMWEB} = sub { $TWiki::cfg{SystemWebName} };
294 $functionTags{TRASHWEB} = sub { $TWiki::cfg{TrashWebName} };
295 $functionTags{TWIKIADMINLOGIN} = sub { $TWiki::cfg{AdminUserLogin} };
296 $functionTags{USERSWEB} = sub { $TWiki::cfg{UsersWebName} };
297 $functionTags{WEBPREFSTOPIC} = sub { $TWiki::cfg{WebPrefsTopicName} };
298 $functionTags{WIKIPREFSTOPIC} = sub { $TWiki::cfg{SitePrefsTopicName} };
299 $functionTags{WIKIUSERSTOPIC} = sub { $TWiki::cfg{UsersTopicName} };
300 $functionTags{WIKIWEBMASTER} = sub { $TWiki::cfg{WebMasterEmail} };
301 $functionTags{WIKIWEBMASTERNAME} = sub { $TWiki::cfg{WebMasterName} };
303 # Compatibility synonyms, deprecated in 4.2 but still used throughout
305 $functionTags{MAINWEB} = $functionTags{USERSWEB};
306 $functionTags{TWIKIWEB} = $functionTags{SYSTEMWEB};
311 # Note that 'use locale' must be done in BEGIN block for regexes and
312 # sorting to work properly, although regexes can still work without
313 # this in 'non-locale regexes' mode.
315 if ( $TWiki::cfg{UseLocale} ) {
316 # Set environment variables for grep
317 $ENV{LC_CTYPE} = $TWiki::cfg{Site}{Locale};
319 # Load POSIX for I18N support.
321 import POSIX qw( locale_h LC_CTYPE LC_COLLATE );
323 # SMELL: mod_perl compatibility note: If TWiki is running under Apache,
324 # won't this play with the Apache process's locale settings too?
325 # What effects would this have?
326 setlocale(&LC_CTYPE, $TWiki::cfg{Site}{Locale});
327 setlocale(&LC_COLLATE, $TWiki::cfg{Site}{Locale});
330 $functionTags{CHARSET} = sub { $TWiki::cfg{Site}{CharSet} ||
333 $functionTags{LANG} = sub {
334 $TWiki::cfg{Site}{Locale} =~ m/^([a-z]+_[a-z]+)/i ? $1 : 'en_US'; };
336 # Set up pre-compiled regexes for use in rendering. All regexes with
337 # unchanging variables in match should use the '/o' option.
338 # In the regex hash, all precompiled REs have "Regex" at the
339 # end of the name. Anything else is a string, either intended
340 # for use as a character class, or as a sub-expression in
341 # another compiled RE.
343 # Build up character class components for use in regexes.
344 # Depends on locale mode and Perl version, and finally on
345 # whether locale-based regexes are turned off.
346 if ( not $TWiki::cfg{UseLocale} or $] < 5.006
347 or not $TWiki::cfg{Site}{LocaleRegexes} ) {
349 # No locales needed/working, or Perl 5.005, so just use
350 # any additional national characters defined in TWiki.cfg
351 $regex{upperAlpha} = 'A-Z'.$TWiki::cfg{UpperNational};
352 $regex{lowerAlpha} = 'a-z'.$TWiki::cfg{LowerNational};
353 $regex{numeric} = '\d';
354 $regex{mixedAlpha} = $regex{upperAlpha}.$regex{lowerAlpha};
356 # Perl 5.006 or higher with working locales
357 $regex{upperAlpha} = '[:upper:]';
358 $regex{lowerAlpha} = '[:lower:]';
359 $regex{numeric} = '[:digit:]';
360 $regex{mixedAlpha} = '[:alpha:]';
362 $regex{mixedAlphaNum} = $regex{mixedAlpha}.$regex{numeric};
363 $regex{lowerAlphaNum} = $regex{lowerAlpha}.$regex{numeric};
364 $regex{upperAlphaNum} = $regex{upperAlpha}.$regex{numeric};
366 # Compile regexes for efficiency and ease of use
367 # Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl
368 # book at http://regex.info/.
370 $regex{linkProtocolPattern} =
371 $TWiki::cfg{LinkProtocolPattern};
373 # Header patterns based on '+++'. The '###' are reserved for numbered
375 # '---++ Header', '---## Header'
376 $regex{headerPatternDa} = qr/^---+(\++|\#+)(.*)$/m;
378 $regex{headerPatternHt} = qr/^<h([1-6])>(.+?)<\/h\1>/mi;
379 # '---++!! Header' or '---++ Header %NOTOC% ^top'
380 $regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)';
382 # TWiki concept regexes
383 $regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlphaNum}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/o;
384 $regex{webNameBaseRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}_]*/o;
385 if ($TWiki::cfg{EnableHierarchicalWebs}) {
386 $regex{webNameRegex} = qr/$regex{webNameBaseRegex}(?:(?:[\.\/]$regex{webNameBaseRegex})+)*/o;
388 $regex{webNameRegex} = $regex{webNameBaseRegex};
390 $regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/o;
391 $regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/o;
392 $regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/o;
394 # Simplistic email regex, e.g. for WebNotify processing - no i18n
396 $regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_]+\@[A-Za-z0-9\.\-]+)/;
398 # Filename regex to used to match invalid characters in attachments - allow
399 # alphanumeric characters, spaces, underscores, etc.
400 # TODO: Get this to work with I18N chars - currently used only with UseLocale off
401 $regex{filenameInvalidCharRegex} = qr/[^$regex{mixedAlphaNum}\. _-]/o;
403 # Multi-character alpha-based regexes
404 $regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/o;
407 $regex{tagNameRegex} = '['.$regex{mixedAlpha}.']['.$regex{mixedAlphaNum}.'_:]*';
409 # Set statement in a topic
410 $regex{bulletRegex} = '^(?:\t| )+\*';
411 $regex{setRegex} = $regex{bulletRegex}.'\s+(Set|Local)\s+';
412 $regex{setVarRegex} = $regex{setRegex}.'('.$regex{tagNameRegex}.')\s*=\s*(.*)$';
414 # Character encoding regexes
417 $regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o;
419 # Regex to match only a valid UTF-8 character, taking care to avoid
420 # security holes due to overlong encodings by excluding the relevant
421 # gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode
422 # Encodings section. Tested against Markus Kuhn's UTF-8 test file
423 # at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
424 $regex{validUtf8CharRegex} = qr{
425 # Single byte - ASCII
430 [\xC2-\xDF][\x80-\xBF]
435 # Avoid illegal codepoints - negative lookahead
436 (?!\xEF\xBF[\xBE\xBF])
438 # Match valid codepoints
441 ([\xE1-\xEC\xEE-\xEF][\x80-\xBF])|
450 ([\xF1-\xF3][\x80-\xBF])|
453 [\x80-\xBF][\x80-\xBF]
456 $regex{validUtf8StringRegex} =
457 qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo;
459 # Check for unsafe search regex mode (affects filtering in) - default
461 $TWiki::cfg{ForceUnsafeRegexes} = 0 unless defined $TWiki::cfg{ForceUnsafeRegexes};
463 # initialize lib directory early because of later 'cd's
466 Monitor::MARK('Static configuration loaded');
471 ---++ StaticMethod UTF82SiteCharSet( $utf8 ) -> $ascii
473 Auto-detect UTF-8 vs. site charset in string, and convert UTF-8 into site
478 sub UTF82SiteCharSet {
481 return $text unless( defined $TWiki::cfg{Site}{CharSet} );
483 # Detect character encoding of the full topic name from URL
484 return undef if( $text =~ $regex{validAsciiStringRegex} );
486 # If not UTF-8 - assume in site character set, no conversion required
487 return undef unless( $text =~ $regex{validUtf8StringRegex} );
489 # If site charset is already UTF-8, there is no need to convert anything:
490 if ( $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) {
491 # warn if using Perl older than 5.8
493 print STDERR 'UTF-8 not remotely supported on Perl ', $],
494 ' - use Perl 5.8 or higher..' ;
497 # We still don't have Codev.UnicodeSupport
498 print STDERR 'UTF-8 not yet supported as site charset -',
499 'TWiki is likely to have problems';
503 # Convert into ISO-8859-1 if it is the site charset. This conversion
504 # is *not valid for ISO-8859-15*.
505 if ( $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?1$/i ) {
506 # ISO-8859-1 maps onto first 256 codepoints of Unicode
507 # (conversion from 'perldoc perluniintro')
508 $text =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) /
509 chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F )
512 # Convert from UTF-8 into some other site charset
515 import Encode qw(:fallbacks);
516 # Map $TWiki::cfg{Site}{CharSet} into real encoding name
518 Encode::resolve_alias( $TWiki::cfg{Site}{CharSet} );
519 if( not $charEncoding ) {
521 'Conversion to "',$TWiki::cfg{Site}{CharSet},
522 '" not supported, or name not recognised - check ',
523 '"perldoc Encode::Supported"';
525 # Convert text using Encode:
526 # - first, convert from UTF8 bytes into internal
528 $text = Encode::decode('utf8', $text);
529 # - then convert into site charset from internal UTF-8,
530 # inserting \x{NNNN} for characters that can't be converted
532 Encode::encode( $charEncoding, $text,
536 require Unicode::MapUTF8; # Pre-5.8 Perl versions
537 my $charEncoding = $TWiki::cfg{Site}{CharSet};
538 if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) {
539 print STDERR 'Conversion to "',$TWiki::cfg{Site}{CharSet},
540 '" not supported, or name not recognised - check ',
541 '"perldoc Unicode::MapUTF8"';
545 Unicode::MapUTF8::from_utf8({
547 -charset => $charEncoding
549 # FIXME: Check for failed conversion?
558 ---++ ObjectMethod writeCompletePage( $text, $pageType, $contentType )
560 Write a complete HTML page with basic header to the browser.
561 * =$text= is the text of the page body (<html> to </html> if it's HTML)
562 * =$pageType= - May be "edit", which will cause headers to be generated that force
563 caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused
564 data loss with IE5 and IE6.
565 * =$contentType= - page content type | text/html
567 This method removes noautolink and nop tags before outputting the page unless
568 $contentType is text/plain.
572 sub writeCompletePage {
573 my ( $this, $text, $pageType, $contentType ) = @_;
574 $contentType ||= 'text/html';
576 if( $contentType ne 'text/plain' ) {
577 # Remove <nop> and <noautolink> tags
578 $text =~ s/([\t ]?)[ \t]*<\/?(nop|noautolink)\/?>/$1/gis;
579 $text .= "\n" unless $text =~ /\n$/s;
581 my $htmlHeader = join(
583 map { '<!--'.$_.'-->'.$this->{_HTMLHEADERS}{$_} }
584 keys %{$this->{_HTMLHEADERS}} );
585 $text =~ s!(</head>)!$htmlHeader$1!i if $htmlHeader;
589 my $hdr = $this->generateHTTPHeaders( undef, $pageType, $contentType );
592 $this->{plugins}->completePageHandler($text, $hdr);
594 # HTTP1.1 says a content-length should _not_ be specified unless
595 # the length is known. There is a bug in Netscape such that it
596 # interprets a 0 content-length as "download until disconnect"
597 # but that is a bug. The correct way is to not set a content-length.
598 unless( $this->inContext('command_line') ) {
599 # FIXME: Defer next line until we have Codev.UnicodeSupport
600 # - too 5.8 dependent
601 # my $len = do { use bytes; length( $text ); };
602 my $len = length($text);
603 $hdr =~ s/\n$/Content-Length: $len\n\n/s if $len;
613 ---++ ObjectMethod generateHTTPHeaders( $query, $pageType, $contentType, $contentLength ) -> $header
615 All parameters are optional.
617 * =$query= CGI query object | Session CGI query (there is no good reason to set this)
618 * =$pageType= - May be "edit", which will cause headers to be generated that force caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused data loss with IE5 and IE6.
619 * =$contentType= - page content type | text/html
620 * =$contentLength= - content-length | no content-length will be set if this is undefined, as required by HTTP1.1
622 Implements the post-Dec2001 release plugin API, which requires the
623 writeHeaderHandler in plugin to return a string of HTTP headers, CR/LF
624 delimited. Filters any illegal headers. Plugin headers will override
627 Does *not* add a =Content-length= header.
631 sub generateHTTPHeaders {
632 my( $this, $query, $pageType, $contentType ) = @_;
634 $query = $this->{cgiQuery} unless $query;
636 # Handle Edit pages - future versions will extend to caching
637 # of other types of page, with expiry time driven by page type.
638 my( $pluginHeaders, $coreHeaders );
642 if ($pageType && $pageType eq 'edit') {
643 # Get time now in HTTP header format
645 my $lastModifiedString =
646 TWiki::Time::formatTime(time, '$http', 'gmtime');
648 # Expiry time is set high to avoid any data loss. Each instance of
649 # Edit page has a unique URL with time-string suffix (fix for
650 # RefreshEditPage), so this long expiry time simply means that the
651 # browser Back button always works. The next Edit on this page
652 # will use another URL and therefore won't use any cached
653 # version of this Edit page.
654 my $expireHours = 24;
655 my $expireSeconds = $expireHours * 60 * 60;
657 # and cache control headers, to ensure edit page
658 # is cached until required expiry time.
659 $hopts->{'last-modified'} = $lastModifiedString;
660 $hopts->{expires} = "+${expireHours}h";
661 $hopts->{'cache-control'} = "max-age=$expireSeconds";
664 # DEPRECATED plugins header handler. Plugins should use
665 # modifyHeaderHandler instead.
666 $pluginHeaders = $this->{plugins}->writeHeaderHandler( $query ) || '';
667 if( $pluginHeaders ) {
668 foreach ( split /\r?\n/, $pluginHeaders ) {
669 if ( m/^([\-a-z]+): (.*)$/i ) {
675 $contentType = 'text/html' unless $contentType;
676 if( defined( $TWiki::cfg{Site}{CharSet} )) {
677 $contentType .= '; charset='.$TWiki::cfg{Site}{CharSet};
680 # use our version of the content type
681 $hopts->{'Content-Type'} = $contentType;
684 $this->{plugins}->modifyHeaderHandler( $hopts, $this->{cgiQuery} );
687 $this->{users}->{loginManager}->modifyHeader( $hopts );
689 return CGI::header( $hopts );
694 ---++ StaticMethod isRedirectSafe($redirect) => $ok
696 tests if the $redirect is an external URL, returning false if AllowRedirectUrl is denied
701 my $redirect = shift;
703 #TODO: this should really use URI
704 if ((!$TWiki::cfg{AllowRedirectUrl}) && ( $redirect =~ m!^([^:]*://[^/]*)/*(.*)?$! )) {
706 #remove trailing /'s to match
707 $TWiki::cfg{DefaultUrlHost} =~ m!^([^:]*://[^/]*)/*(.*)?$!;
710 if (defined($TWiki::cfg{PermittedRedirectHostUrls} ) && $TWiki::cfg{PermittedRedirectHostUrls} ne '') {
712 map { s!^([^:]*://[^/]*)/*(.*)?$!$1!; $1 }
713 split(/,\s*/, $TWiki::cfg{PermittedRedirectHostUrls});
714 return 1 if ( grep ( { uc($host) eq uc($_) } @permitted));
716 return (uc($host) eq uc($expected));
721 # _getRedirectUrl() => redirectURL set from the parameter
722 # Reads a redirect url from CGI parameter 'redirectto'.
723 # This function is used to get and test the 'redirectto' cgi parameter,
724 # and then the calling function can set its own reporting if there is a
726 sub _getRedirectUrl {
729 my $query = $session->{cgiQuery};
730 my $redirecturl = $query->param( 'redirectto' );
731 return '' unless $redirecturl;
733 if( $redirecturl =~ m#^$regex{linkProtocolPattern}://#o ) {
735 if (isRedirectSafe($redirecturl)) {
741 # assuming 'web.topic' or 'topic'
742 my ( $w, $t ) = $session->normalizeWebTopicName( $session->{webName}, $redirecturl );
743 $redirecturl = $session->getScriptUrl( 1, 'view', $w, $t );
750 ---++ ObjectMethod redirect( $url, $passthrough, $action_redirectto )
752 * $url - url or twikitopic to redirect to
753 * $passthrough - (optional) parameter to **FILLMEIN**
754 * $action_redirectto - (optional) redirect to where ?redirectto=
755 points to (if it's valid)
757 Redirects the request to =$url=, *unless*
758 1 It is overridden by a plugin declaring a =redirectCgiQueryHandler=.
759 1 =$session->{cgiQuery}= is =undef= or
760 1 $query->param('noredirect') is set to a true value.
761 Thus a redirect is only generated when in a CGI context.
763 Normally this method will ignore parameters to the current query. Sometimes,
764 for example when redirecting to a login page during authentication (and then
765 again from the login page to the original requested URL), you want to make
766 sure all parameters are passed on, and for this $passthrough should be set to
767 true. In this case it will pass all parameters that were passed to the
768 current query on to the redirect target. If the request_method for the
769 current query was GET, then all parameters will be passed by encoding them
770 in the URL (after ?). If the request_method was POST, then there is a risk the
771 URL would be too big for the receiver, so it caches the form data and passes
772 over a cache reference in the redirect GET.
774 NOTE: Passthrough is only meaningful if the redirect target is on the same
780 my( $this, $url, $passthru, $action_redirectto ) = @_;
782 my $query = $this->{cgiQuery};
783 # if we got here without a query, there's not much more we can do
784 return unless $query;
786 # SMELL: if noredirect is set, don't generate the redirect, throw an
787 # exception instead. This is a HACK used to support TWikiDrawPlugin.
788 # It is deprecated and must be replaced by REST handlers in the plugin.
789 if( $query->param( 'noredirect' )) {
794 if ($action_redirectto) {
795 my $redir = _getRedirectUrl($this);
796 $url = $redir if ($redir);
799 if ($passthru && defined $ENV{REQUEST_METHOD}) {
801 if ($url =~ s/\?(.*)$//) {
804 if ($ENV{REQUEST_METHOD} eq 'POST') {
805 # Redirecting from a post to a get
806 my $cache = $this->cacheQuery();
811 if ($query->query_string()) {
812 $url .= '?'.$query->query_string();
825 # prevent phishing by only allowing redirect to configured host
826 # do this check as late as possible to catch _any_ last minute hacks
827 # TODO: this should really use URI
828 if (!isRedirectSafe($url)) {
829 # goto oops if URL is trying to take us somewhere dangerous
830 $url = $this->getScriptUrl(
832 $this->{web} || $TWiki::cfg{UsersWebName},
833 $this->{topic} || $TWiki::cfg{HomeTopicName},
834 template => 'oopsaccessdenied',
835 def => 'topic_access',
836 param1 => 'redirect',
837 param2 => 'unsafe redirect to '.$url.
838 ': host does not match {DefaultUrlHost} , and is not in {PermittedRedirectHostUrls}"'.
839 $TWiki::cfg{DefaultUrlHost}.'"'
844 return if( $this->{plugins}->redirectCgiQueryHandler( $query, $url ));
846 # SMELL: this is a bad breaking of encapsulation: the loginManager
847 # should just modify the url, then the redirect should only happen here.
848 return if( $this->{users}->{loginManager}->redirectCgiQuery( $query, $url ) );
849 die "Login manager returned 0 from redirectCgiQuery";
854 ---++ ObjectMethod cacheQuery() -> $queryString
856 Caches the current query in the params cache, and returns a rewritten
857 query string for the cache to be picked up again on the other side of a
860 We can't encode post params into a redirect, because they may exceed the
861 size of the GET request. So we cache the params, and reload them when the
862 redirect target is reached.
868 my $query = $this->{cgiQuery};
870 return '' unless (scalar($query->param()));
872 return '' if ($query->param('twiki_redirect_cache'));
875 my $md5 = new Digest::MD5();
876 $md5->add($$, time(), rand(time));
877 my $uid = $md5->hexdigest();
878 my $passthruFilename = "$TWiki::cfg{WorkingDir}/tmp/passthru_$uid";
881 #passthrough file is only written to once, so if it already exists, suspect a security hack (O_EXCL)
882 sysopen(F, "$passthruFilename", O_RDWR|O_EXCL|O_CREAT, 0600) ||
883 die "Unable to open $TWiki::cfg{WorkingDir}/tmp for write; check the setting of {WorkingDir} in configure, and check file permissions: $!";
886 return 'twiki_redirect_cache='.$uid;
891 ---++ StaticMethod isValidWikiWord( $name ) -> $boolean
893 Check for a valid WikiWord or WikiName
897 sub isValidWikiWord {
898 my $name = shift || '';
899 return ( $name =~ m/^$regex{wikiWordRegex}$/o )
904 ---++ StaticMethod isValidTopicName( $name ) -> $boolean
906 Check for a valid topic name
910 sub isValidTopicName {
913 return isValidWikiWord( @_ ) || isValidAbbrev( @_ );
918 ---++ StaticMethod isValidAbbrev( $name ) -> $boolean
920 Check for a valid ABBREV (acronym)
925 my $name = shift || '';
926 return ( $name =~ m/^$regex{abbrevRegex}$/o )
931 ---++ StaticMethod isValidWebName( $name, $system ) -> $boolean
933 STATIC Check for a valid web name. If $system is true, then
934 system web names are considered valid (names starting with _)
935 otherwise only user web names are valid
937 If $TWiki::cfg{EnableHierarchicalWebs} is off, it will also return false
938 when a nested web name is passed to it.
943 my $name = shift || '';
945 return 1 if ( $sys && $name =~ m/^$regex{defaultWebNameRegex}$/o );
946 return ( $name =~ m/^$regex{webNameRegex}$/o )
951 ---++ ObjectMethod readOnlyMirrorWeb( $theWeb ) -> ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote )
953 If this is a mirrored web, return information about the mirror. The info
954 is returned in a quadruple:
956 | site name | URL | link | note |
960 sub readOnlyMirrorWeb {
961 my( $this, $theWeb ) = @_;
964 my @mirrorInfo = ( '', '', '', '' );
965 if( $TWiki::cfg{SiteWebTopicName} ) {
967 $this->{prefs}->getWebPreferencesValue( 'MIRRORSITENAME', $theWeb );
968 if( $mirrorSiteName && $mirrorSiteName ne $TWiki::cfg{SiteWebTopicName} ) {
970 $this->{prefs}->getWebPreferencesValue( 'MIRRORVIEWURL', $theWeb );
971 my $mirrorLink = $this->templates->readTemplate( 'mirrorlink' );
972 $mirrorLink =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
973 $mirrorLink =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
974 $mirrorLink =~ s/\s*$//g;
975 my $mirrorNote = $this->templates->readTemplate( 'mirrornote' );
976 $mirrorNote =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
977 $mirrorNote =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
978 $mirrorNote = $this->renderer->getRenderedVersion
979 ( $mirrorNote, $theWeb, $TWiki::cfg{HomeTopic} );
980 $mirrorNote =~ s/\s*$//g;
981 @mirrorInfo = ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote );
989 ---++ ObjectMethod getSkin () -> $string
991 Get the currently requested skin path
999 my $skinpath = $this->{prefs}->getPreferencesValue( 'SKIN' ) || '';
1001 if( $this->{cgiQuery} ) {
1002 my $resurface = $this->{cgiQuery}->param( 'skin' );
1003 $skinpath = $resurface if $resurface;
1006 my $epidermis = $this->{prefs}->getPreferencesValue( 'COVER' );
1007 $skinpath = $epidermis.','.$skinpath if $epidermis;
1009 if( $this->{cgiQuery} ) {
1010 $epidermis = $this->{cgiQuery}->param( 'cover' );
1011 $skinpath = $epidermis.','.$skinpath if $epidermis;
1019 ---++ ObjectMethod getScriptUrl( $absolute, $script, $web, $topic, ... ) -> $scriptURL
1021 Returns the URL to a TWiki script, providing the web and topic as
1022 "path info" parameters. The result looks something like this:
1023 "http://host/twiki/bin/$script/$web/$topic".
1024 * =...= - an arbitrary number of name,value parameter pairs that will be url-encoded and added to the url. The special parameter name '#' is reserved for specifying an anchor. e.g. <tt>getScriptUrl('x','y','view','#'=>'XXX',a=>1,b=>2)</tt> will give <tt>.../view/x/y?a=1&b=2#XXX</tt>
1026 If $absolute is set, generates an absolute URL. $absolute is advisory only;
1027 TWiki can decide to generate absolute URLs (for example when run from the
1028 command-line) even when relative URLs have been requested.
1030 The default script url is taken from {ScriptUrlPath}, unless there is
1031 an exception defined for the given script in {ScriptUrlPaths}. Both
1032 {ScriptUrlPath} and {ScriptUrlPaths} may be absolute or relative URIs. If
1033 they are absolute, then they will always generate absolute URLs. if they
1034 are relative, then they will be converted to absolute when required (e.g.
1035 when running from the command line, or when generating rss). If
1036 $script is not given, absolute URLs will always be generated.
1038 If either the web or the topic is defined, will generate a full url (including web and topic). Otherwise will generate only up to the script name. An undefined web will default to the main web name.
1043 my( $this, $absolute, $script, $web, $topic, @params ) = @_;
1045 $absolute ||= ($this->inContext( 'command_line' ) ||
1046 $this->inContext( 'rss' ) ||
1047 $this->inContext( 'absolute_urls' ));
1049 # SMELL: topics and webs that contain spaces?
1052 if( defined $TWiki::cfg{ScriptUrlPaths} && $script) {
1053 $url = $TWiki::cfg{ScriptUrlPaths}{$script};
1055 unless( defined( $url )) {
1056 $url = $TWiki::cfg{ScriptUrlPath};
1058 $url .= '/' unless $url =~ /\/$/;
1060 $url .= $TWiki::cfg{ScriptSuffix} if $script;
1064 if( $absolute && $url !~ /^[a-z]+:/ ) {
1065 # See http://www.ietf.org/rfc/rfc2396.txt for the definition of
1066 # "absolute URI". TWiki bastardises this definition by assuming
1067 # that all relative URLs lack the <authority> component as well.
1068 $url = $this->{urlHost}.$url;
1071 if( $web || $topic ) {
1073 $this->normalizeWebTopicName( $web, $topic );
1075 $url .= urlEncode( '/'.$web.'/'.$topic );
1077 $url .= _make_params(0, @params);
1084 my ( $notfirst, @args ) = @_;
1088 while( my $p = shift @args ) {
1090 $anchor .= '#' . shift( @args );
1092 $ps .= ';' . $p.'='.urlEncode(shift( @args )||'');
1096 $ps =~ s/^;/?/ unless $notfirst;
1105 ---++ ObjectMethod getPubUrl($absolute, $web, $topic, $attachment) -> $url
1107 Composes a pub url. If $absolute is set, returns an absolute URL.
1108 If $absolute is set, generates an absolute URL. $absolute is advisory only;
1109 TWiki can decide to generate absolute URLs (for example when run from the
1110 command-line) even when relative URLs have been requested.
1112 $web, $topic and $attachment are optional. A partial URL path will be
1113 generated if one or all is not given.
1118 my( $this, $absolute, $web, $topic, $attachment ) = @_;
1120 $absolute ||= ($this->inContext( 'command_line' ) ||
1121 $this->inContext( 'rss' ) ||
1122 $this->inContext( 'absolute_urls' ));
1125 $url .= $TWiki::cfg{PubUrlPath};
1126 if( $absolute && $url !~ /^[a-z]+:/ ) {
1127 # See http://www.ietf.org/rfc/rfc2396.txt for the definition of
1128 # "absolute URI". TWiki bastardises this definition by assuming
1129 # that all relative URLs lack the <authority> component as well.
1130 $url = $this->{urlHost}.$url;
1132 if( $web || $topic || $attachment ) {
1134 $this->normalizeWebTopicName( $web, $topic );
1136 my $path = '/'.$web.'/'.$topic;
1138 $path .= '/'.$attachment;
1139 # Attachments are served directly by web server, need to handle
1140 # URL encoding specially
1141 $url .= urlEncodeAttachment ( $path );
1143 $url .= urlEncode( $path );
1152 ---++ ObjectMethod getIconUrl( $absolute, $iconName ) -> $iconURL
1154 Map an icon name to a URL path.
1159 my( $this, $absolute, $iconName ) = @_;
1161 my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
1162 my( $web, $topic) = $this->normalizeWebTopicName(
1163 $this->{webName}, $iconTopic );
1164 $iconName =~ s/^.*\.(.*?)$/$1/;
1165 return $this->getPubUrl( $absolute, $web, $topic, $iconName.'.gif' );
1170 ---++ ObjectMethod mapToIconFileName( $fileName, $default ) -> $fileName
1172 Maps from a filename (or just the extension) to the name of the
1173 file that contains the image for that file type.
1177 sub mapToIconFileName {
1178 my( $this, $fileName, $default ) = @_;
1180 my @bits = ( split( /\./, $fileName ) );
1181 my $fileExt = lc $bits[$#bits];
1183 unless( $this->{_ICONMAP} ) {
1184 my $iconTopic = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
1185 my( $web, $topic) = $this->normalizeWebTopicName(
1186 $this->{webName}, $iconTopic );
1189 my $icons = $this->{store}->getAttachmentStream(
1190 undef, $web, $topic, '_filetypes.txt' );
1191 %{$this->{_ICONMAP}} = split( /\s+/, <$icons> );
1193 } catch Error::Simple with {
1194 %{$this->{_ICONMAP}} = ();
1198 return $this->{_ICONMAP}->{$fileExt} || $default || 'else';
1203 ---++ ObjectMethod normalizeWebTopicName( $theWeb, $theTopic ) -> ( $theWeb, $theTopic )
1205 Normalize a Web<nop>.<nop>TopicName
1207 See TWikiFuncDotPm for a full specification of the expansion (not duplicated
1210 *WARNING* if there is no web specification (in the web or topic parameters)
1211 the web defaults to $TWiki::cfg{UsersWebName}. If there is no topic
1212 specification, or the topic is '0', the topic defaults to the web home topic
1217 sub normalizeWebTopicName {
1218 my( $this, $web, $topic ) = @_;
1220 ASSERT(defined $topic) if DEBUG;
1222 if( $topic =~ m|^(.*)[./](.*?)$| ) {
1226 $web ||= $cfg{UsersWebName};
1227 $topic ||= $cfg{HomeTopicName};
1228 while( $web =~ s/%((MAIN|TWIKI|USERS|SYSTEM|DOC)WEB)%/_expandTagOnTopicRendering( $this,$1)||''/e ) {
1231 return( $web, $topic );
1236 ---++ ClassMethod new( $loginName, $query, \%initialContext )
1238 Constructs a new TWiki object. Parameters are taken from the query object.
1240 * =$loginName= is the login username (*not* the wikiname) of the user you
1241 want to be logged-in if none is available from a session or browser.
1242 Used mainly for side scripts and debugging.
1243 * =$query= the CGI query (may be undef, in which case an empty query
1245 * =\%initialContext= - reference to a hash containing context
1246 name=value pairs to be pre-installed in the context hash
1251 my( $class, $login, $query, $initialContext ) = @_;
1253 Monitor::MARK("Static compilation complete");
1255 # Compatibility; not used except maybe in plugins
1256 $TWiki::cfg{TempfileDir} = "$TWiki::cfg{WorkingDir}/tmp"
1257 unless defined($TWiki::cfg{TempfileDir});
1259 # Set command_line context if there is no query
1260 $initialContext ||= defined( $query ) ? {} : { command_line => 1 };
1262 $query ||= new CGI( {} );
1263 my $this = bless( {}, $class );
1265 # Tell CGI.pm which charset we are using if not default
1266 if( defined $TWiki::cfg{Site}{CharSet} &&
1267 $TWiki::cfg{Site}{CharSet} !~ /^iso-?8859-?1$/io ) {
1268 # Item5710: A bug in CGI::charset means we cannot use $query->charset
1269 CGI::charset( $TWiki::cfg{Site}{CharSet} );
1272 $this->{_HTMLHEADERS} = {};
1273 $this->{context} = $initialContext;
1275 # create the various sub-objects
1277 # "shared" between mod_perl instances
1278 $sandbox = new TWiki::Sandbox(
1279 $TWiki::cfg{OS}, $TWiki::cfg{DetailedOS} );
1281 require TWiki::Plugins;
1282 $this->{plugins} = new TWiki::Plugins( $this );
1283 require TWiki::Store;
1284 $this->{store} = new TWiki::Store( $this );
1285 # cache CGI information in the session object
1286 $this->{cgiQuery} = $query;
1288 $this->{remoteUser} = $login; #use login as a default (set when running from cmd line)
1289 require TWiki::Users;
1290 $this->{users} = new TWiki::Users( $this );
1291 $this->{remoteUser} = $this->{users}->{remoteUser};
1293 # Make %ENV safer, preventing hijack of the search path
1294 # SMELL: can this be done in a BEGIN block? Or is the environment
1296 # Item4382: Default $ENV{PATH} must be untainted because TWiki runs
1297 # with use strict and calling external programs that writes on the disk
1298 # will fail unless Perl seens it as set to safe value.
1299 if( $TWiki::cfg{SafeEnvPath} ) {
1300 $ENV{PATH} = $TWiki::cfg{SafeEnvPath};
1302 $ENV{PATH} = TWiki::Sandbox::untaintUnchecked( $ENV{PATH} );
1304 delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };
1306 my $url = $query->url();
1307 if( $url && $url =~ m{^([^:]*://[^/]*).*$} ) {
1308 $this->{urlHost} = $1;
1309 # If the urlHost in the url is localhost, this is a lot less
1310 # useful than the default url host. This is because new CGI("")
1311 # assigns this host by default - it's a default setting, used
1312 # when there is nothing better available.
1313 if( $this->{urlHost} eq 'http://localhost' ) {
1314 $this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
1315 } elsif( $TWiki::cfg{RemovePortNumber} ) {
1316 $this->{urlHost} =~ s/\:[0-9]+$//;
1319 $this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
1321 if ( $TWiki::cfg{GetScriptUrlFromCgi}
1323 && $url =~ m{^[^:]*://[^/]*(.*)/.*$}
1327 # SMELL: this is a really dangerous hack. It will fail
1328 # spectacularly with mod_perl.
1329 # SMELL: why not just use $query->script_name?
1330 $this->{scriptUrlPath} = $1;
1334 my $topic = $query->param( 'topic' );
1336 if( $topic =~ m#^$regex{linkProtocolPattern}://#o &&
1337 $this->{cgiQuery} ) {
1339 print $this->redirect( $topic );
1340 exit; #we seriously don't want to go through normal TWiki operations if we're redirecting..
1341 } elsif( $topic =~ /((?:.*[\.\/])+)(.*)/ ) {
1342 # is 'bin/script?topic=Webname.SomeTopic'
1347 # jump to WebHome if 'bin/script?topic=Webname.'
1348 $topic = $TWiki::cfg{HomeTopicName} if( $web && ! $topic );
1350 # otherwise assume 'bin/script/Webname?topic=SomeTopic'
1355 # SMELL: "The Microsoft Internet Information Server is broken with
1356 # respect to additional path information. If you use the Perl DLL
1357 # library, the IIS server will attempt to execute the additional
1358 # path information as a Perl script. If you use the ordinary file
1359 # associations mapping, the path information will be present in the
1360 # environment, but incorrect. The best thing to do is to avoid using
1361 # additional path information."
1363 # Clean up PATH_INFO problems, e.g. Support.CobaltRaqInstall. A valid
1364 # PATH_INFO is '/Main/WebHome', i.e. the text after the script name;
1365 # invalid PATH_INFO is often a full path starting with '/cgi-bin/...'.
1366 my $pathInfo = $query->path_info();
1367 my $cgiScriptName = $ENV{SCRIPT_NAME} || '';
1368 $pathInfo =~ s!$cgiScriptName/!/!i;
1370 # Get the web and topic names from PATH_INFO
1371 if( $pathInfo =~ /\/((?:.*[\.\/])+)(.*)/ ) {
1372 # is 'bin/script/Webname/SomeTopic' or 'bin/script/Webname/'
1373 $web = $1 unless $web;
1374 $topic = $2 unless $topic;
1377 } elsif( $pathInfo =~ /\/(.*)/ ) {
1378 # is 'bin/script/Webname' or 'bin/script/'
1379 $web = $1 unless $web;
1382 # All roads lead to WebHome
1383 $topic = $TWiki::cfg{HomeTopicName} if ( $topic =~ /\.\./ );
1384 $topic =~ s/$TWiki::cfg{NameFilter}//go;
1385 $topic = $TWiki::cfg{HomeTopicName} unless $topic;
1386 $this->{topicName} = TWiki::Sandbox::untaintUnchecked( $topic );
1388 $web =~ s/$TWiki::cfg{NameFilter}//go;
1389 $this->{requestedWebName} = TWiki::Sandbox::untaintUnchecked( $web ); #can be an empty string
1390 $web = $TWiki::cfg{UsersWebName} unless $web;
1391 $this->{webName} = TWiki::Sandbox::untaintUnchecked( $web );
1393 # Convert UTF-8 web and topic name from URL into site charset if necessary
1394 # SMELL: merge these two cases, browsers just don't mix two encodings in one URL
1395 # - can also simplify into 2 lines by making function return unprocessed text if no conversion
1396 my $webNameTemp = UTF82SiteCharSet( $this->{webName} );
1397 if ( $webNameTemp ) {
1398 $this->{webName} = $webNameTemp;
1401 my $topicNameTemp = UTF82SiteCharSet( $this->{topicName} );
1402 if ( $topicNameTemp ) {
1403 $this->{topicName} = $topicNameTemp;
1406 # Item3270 - here's the appropriate place to enforce TWiki spec:
1407 # All topic name sources are evaluated, site charset applied
1408 # SMELL: This untaint unchecked is duplicate of one just above
1409 $this->{topicName} =
1410 TWiki::Sandbox::untaintUnchecked(ucfirst $this->{topicName});
1412 $this->{scriptUrlPath} = $TWiki::cfg{ScriptUrlPath};
1414 require TWiki::Prefs;
1415 my $prefs = new TWiki::Prefs( $this );
1416 $this->{prefs} = $prefs;
1418 # Form definition cache
1419 $this->{forms} = {};
1421 # Push global preferences from TWiki.TWikiPreferences
1422 $prefs->pushGlobalPreferences();
1424 #TODO: what happens if we move this into the TWiki::User::new?
1425 $this->{user} = $this->{users}->initialiseUser($this->{remoteUser});
1427 # Static session variables that can be expanded in topics when they
1428 # are enclosed in % signs
1429 # SMELL: should collapse these into one. The duplication is pretty
1430 # pointless. Could get rid of the SESSION_TAGS hash, might be
1431 # the easiest thing to do, but then that would allow other
1432 # upper-case named fields in the object to be accessed as well...
1433 $this->{SESSION_TAGS}{BASEWEB} = $this->{webName};
1434 $this->{SESSION_TAGS}{BASETOPIC} = $this->{topicName};
1435 $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $this->{topicName};
1436 $this->{SESSION_TAGS}{INCLUDINGWEB} = $this->{webName};
1438 # Push plugin settings
1439 $this->{plugins}->settings();
1441 # Now the rest of the preferences
1442 $prefs->pushGlobalPreferencesSiteSpecific();
1444 # User preferences only available if we can get to a valid wikiname,
1445 # which depends on the user mapper.
1446 my $wn = $this->{users}->getWikiName( $this->{user} );
1448 $prefs->pushPreferences(
1449 $TWiki::cfg{UsersWebName}, $wn,
1453 $prefs->pushWebPreferences( $this->{webName} );
1455 $prefs->pushPreferences(
1456 $this->{webName}, $this->{topicName}, 'TOPIC' );
1458 $prefs->pushPreferenceValues( 'SESSION',
1459 $this->{users}->{loginManager}->getSessionValues() );
1461 # Finish plugin initialization - register handlers
1462 $this->{plugins}->enable();
1464 $TWiki::Plugins::SESSION = $this;
1466 Monitor::MARK("TWiki session created");
1473 ---++ ObjectMethod renderer()
1474 Get a reference to the renderer object. Done lazily because not everyone
1482 unless( $this->{renderer} ) {
1483 require TWiki::Render;
1484 # requires preferences (such as LINKTOOLTIPINFO)
1485 $this->{renderer} = new TWiki::Render( $this );
1487 return $this->{renderer};
1492 ---++ ObjectMethod attach()
1493 Get a reference to the attach object. Done lazily because not everyone
1501 unless( $this->{attach} ) {
1502 require TWiki::Attach;
1503 $this->{attach} = new TWiki::Attach( $this );
1505 return $this->{attach};
1510 ---++ ObjectMethod templates()
1511 Get a reference to the templates object. Done lazily because not everyone
1512 needs the templates.
1519 unless( $this->{templates} ) {
1520 require TWiki::Templates;
1521 $this->{templates} = new TWiki::Templates( $this );
1523 return $this->{templates};
1528 ---++ ObjectMethod i18n()
1529 Get a reference to the i18n object. Done lazily because not everyone
1537 unless( $this->{i18n} ) {
1538 require TWiki::I18N;
1539 # language information; must be loaded after
1540 # *all possible preferences sources* are available
1541 $this->{i18n} = new TWiki::I18N( $this );
1543 return $this->{i18n};
1548 ---++ ObjectMethod search()
1549 Get a reference to the search object. Done lazily because not everyone
1557 unless( $this->{search} ) {
1558 require TWiki::Search;
1559 $this->{search} = new TWiki::Search( $this );
1561 return $this->{search};
1566 ---++ ObjectMethod security()
1567 Get a reference to the security object. Done lazily because not everyone
1575 unless( $this->{security} ) {
1576 require TWiki::Access;
1577 $this->{security} = new TWiki::Access( $this );
1579 return $this->{security};
1584 ---++ ObjectMethod net()
1585 Get a reference to the net object. Done lazily because not everyone
1593 unless( $this->{net} ) {
1595 $this->{net} = new TWiki::Net( $this );
1597 return $this->{net};
1602 ---++ ObjectMethod finish()
1603 Break circular references.
1607 # Note to developers; please undef *all* fields in the object explicitly,
1608 # whether they are references or not. That way this method is "golden
1609 # documentation" of the live fields in the object.
1613 map { $_->finish() } values %{$this->{forms}};
1614 $this->{plugins}->finish() if $this->{plugins};
1615 $this->{users}->finish() if $this->{users};
1616 $this->{prefs}->finish() if $this->{prefs};
1617 $this->{templates}->finish() if $this->{templates};
1618 $this->{renderer}->finish() if $this->{renderer};
1619 $this->{net}->finish() if $this->{net};
1620 $this->{store}->finish() if $this->{store};
1621 $this->{search}->finish() if $this->{search};
1622 $this->{attach}->finish() if $this->{attach};
1623 $this->{security}->finish() if $this->{security};
1624 $this->{i18n}->finish() if $this->{i18n};
1626 undef $this->{_HTMLHEADERS};
1627 undef $this->{cgiQuery};
1628 undef $this->{urlHost};
1630 undef $this->{topic};
1631 undef $this->{webName};
1632 undef $this->{topicName};
1633 undef $this->{_ICONMAP};
1634 undef $this->{context};
1635 undef $this->{remoteUser};
1636 undef $this->{requestedWebName}; # Web name before renaming
1637 undef $this->{scriptUrlPath};
1638 undef $this->{user};
1639 undef $this->{SESSION_TAGS};
1640 undef $this->{_INCLUDES};
1641 undef $this->{evaluating_if};
1646 ---++ ObjectMethod writeLog( $action, $webTopic, $extra, $user )
1648 * =$action= - what happened, e.g. view, save, rename
1649 * =$wbTopic= - what it happened to
1650 * =$extra= - extra info, such as minor flag
1651 * =$user= - user who did the saving (user id)
1652 Write the log for an event to the logfile
1659 my $action = shift || '';
1660 my $webTopic = shift || '';
1661 my $extra = shift || '';
1664 $user ||= $this->{user};
1665 $user = ($this->{users}->getLoginName( $user ) || 'unknown')
1666 if ($this->{users});
1668 if( $user eq $cfg{DefaultUserLogin} ) {
1669 my $cgiQuery = $this->{cgiQuery};
1671 my $agent = $cgiQuery->user_agent();
1673 $agent =~ m/([\w]+)/;
1679 my $remoteAddr = $ENV{REMOTE_ADDR} || '';
1680 my $text = "$user | $action | $webTopic | $extra | $remoteAddr |";
1682 _writeReport( $this, $TWiki::cfg{LogFileName}, $text );
1687 ---++ ObjectMethod writeWarning( $text )
1689 Prints date, time, and contents $text to $TWiki::cfg{WarningFileName}, typically
1690 'warnings.txt'. Use for warnings and errors that may require admin
1691 intervention. Use this for defensive programming warnings (e.g. assertions).
1697 _writeReport( $this, $TWiki::cfg{WarningFileName}, @_ );
1702 ---++ ObjectMethod writeDebug( $text )
1704 Prints date, time, and contents of $text to $TWiki::cfg{DebugFileName}, typically
1705 'debug.txt'. Use for debugging messages.
1711 _writeReport( $this, $TWiki::cfg{DebugFileName}, @_ );
1714 # Concatenates date, time, and $text to a log file.
1715 # The logfilename can optionally use a %DATE% variable to support
1716 # logs that are rotated once a month.
1717 # | =$log= | Base filename for log file |
1718 # | =$message= | Message to print |
1720 my ( $this, $log, $message ) = @_;
1723 require TWiki::Time;
1725 TWiki::Time::formatTime( time(), '$year$mo', 'servertime');
1726 $log =~ s/%DATE%/$time/go;
1727 $time = TWiki::Time::formatTime( time(), undef, 'servertime' );
1729 if( open( FILE, ">>$log" ) ) {
1730 print FILE "| $time | $message\n";
1733 print STDERR 'Could not write "'.$message.'" to '."$log: $!\n";
1738 sub _removeNewlines {
1740 $theTag =~ s/[\r\n]+/ /gs;
1744 # Convert relative URLs to absolute URIs
1745 sub _rewriteURLInInclude {
1746 my( $theHost, $theAbsPath, $url ) = @_;
1748 # leave out an eventual final non-directory component from the absolute path
1749 $theAbsPath =~ s/(.*?)[^\/]*$/$1/;
1751 if( $url =~ /^\// ) {
1753 $url = $theHost.$url;
1754 } elsif( $url =~ /^\./ ) {
1756 $url = $theHost.$theAbsPath.'/'.$url;
1757 } elsif( $url =~ /^$regex{linkProtocolPattern}:/o ) {
1758 # full qualified URL, do nothing
1759 } elsif( $url =~ /^#/ ) {
1760 # anchor. This needs to be left relative to the including topic
1763 # FIXME: is this test enough to detect relative URLs?
1764 $url = $theHost.$theAbsPath.'/'.$url;
1770 # Add a web reference to a [[...][...]] link in an included topic
1771 sub _fixIncludeLink {
1772 my( $web, $link, $label ) = @_;
1774 # Detect absolute and relative URLs and web-qualified wikinames
1775 if( $link =~ m#^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}:|/)#o ) {
1777 return "[[$link][$label]]";
1781 } elsif( !$label ) {
1782 # Must be wikiword or spaced-out wikiword (or illegal link :-/)
1785 return "[[$web.$link][$label]]";
1788 # Replace web references in a topic. Called from forEachLine, applying to
1789 # each non-verbatim and non-literal line.
1790 sub _fixupIncludedTopic {
1791 my( $text, $options ) = @_;
1793 my $fromWeb = $options->{web};
1795 unless( $options->{in_noautolink} ) {
1796 # 'TopicName' to 'Web.TopicName'
1797 $text =~ s#(?:^|(?<=[\s(]))($regex{wikiWordRegex})(?=\s|\)|$)#$fromWeb.$1#go;
1800 # Handle explicit [[]] everywhere
1801 # '[[TopicName][...]]' to '[[Web.TopicName][...]]'
1802 $text =~ s/\[\[([^]]+)\](?:\[([^]]+)\])?\]/
1803 _fixIncludeLink( $fromWeb, $1, $2 )/geo;
1808 # Clean-up HTML text so that it can be shown embedded in a topic
1809 sub _cleanupIncludedHTML {
1810 my( $text, $host, $path, $options ) = @_;
1812 # FIXME: Make aware of <base> tag
1814 $text =~ s/^.*?<\/head>//is
1815 unless ( $options->{disableremoveheaders} ); # remove all HEAD
1816 $text =~ s/<script.*?<\/script>//gis
1817 unless ( $options->{disableremovescript} ); # remove all SCRIPTs
1818 $text =~ s/^.*?<body[^>]*>//is
1819 unless ( $options->{disableremovebody} ); # remove all to <BODY>
1820 $text =~ s/(?:\n)<\/body>.*//is
1821 unless ( $options->{disableremovebody} ); # remove </BODY>
1822 $text =~ s/(?:\n)<\/html>.*//is
1823 unless ( $options->{disableremoveheaders} ); # remove </HTML>
1824 $text =~ s/(<[^>]*>)/_removeNewlines($1)/ges
1825 unless ( $options->{disablecompresstags} ); # replace newlines in html tags with space
1826 $text =~ s/(\s(?:href|src|action)=(["']))(.*?)\2/$1._rewriteURLInInclude( $host, $path, $3 ).$2/geois
1827 unless ( $options->{disablerewriteurls} );
1834 ---++ StaticMethod applyPatternToIncludedText( $text, $pattern ) -> $text
1836 Apply a pattern on included text to extract a subset
1840 sub applyPatternToIncludedText {
1841 my( $theText, $thePattern ) = @_;
1842 $thePattern =~ s/([^\\])([\$\@\%\&\#\'\`\/])/$1\\$2/g; # escape some special chars
1843 $thePattern = TWiki::Sandbox::untaintUnchecked( $thePattern );
1844 $theText = '' unless( $theText =~ s/$thePattern/$1/is );
1848 # Fetch content from a URL for inclusion by an INCLUDE
1850 my( $this, $url, $pattern, $web, $topic, $raw, $options, $warn ) = @_;
1853 # For speed, read file directly if URL matches an attachment directory
1854 if( $url =~ /^$this->{urlHost}$TWiki::cfg{PubUrlPath}\/($regex{webNameRegex})\/([^\/\.]+)\/([^\/]+)$/ ) {
1858 # FIXME: Check for MIME type, not file suffix
1859 if( $incAtt =~ m/\.(txt|html?)$/i ) {
1860 unless( $this->{store}->attachmentExists(
1861 $incWeb, $incTopic, $incAtt )) {
1862 return _includeWarning( $this, $warn, 'bad_attachment', $url );
1864 if( $incWeb ne $web || $incTopic ne $topic ) {
1865 # CODE_SMELL: Does not account for not yet authenticated user
1866 unless( $this->security->checkAccessPermission(
1867 'VIEW', $this->{user}, undef, undef, $incTopic, $incWeb ) ) {
1868 return _includeWarning( $this, $warn, 'access_denied',
1869 "$incWeb.$incTopic" );
1872 $text = $this->{store}->readAttachment( undef, $incWeb, $incTopic,
1874 $text = _cleanupIncludedHTML( $text, $this->{urlHost},
1875 $TWiki::cfg{PubUrlPath}, $options )
1877 $text = applyPatternToIncludedText( $text, $pattern )
1879 $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
1882 # fall through; try to include file over http based on MIME setting
1885 return _includeWarning( $this, $warn, 'urls_not_allowed' )
1886 unless $TWiki::cfg{INCLUDE}{AllowURLs};
1888 # SMELL: should use the URI module from CPAN to parse the URL
1889 # SMELL: but additional CPAN adds to code bloat
1890 unless ($url =~ m!^https?:!) {
1891 $text = _includeWarning( $this, $warn, 'bad_protocol', $url );
1895 my $response = $this->net->getExternalResource( $url );
1896 if( !$response->is_error()) {
1897 my $contentType = $response->header('content-type');
1898 $text = $response->content();
1899 if( $contentType =~ /^text\/html/ ) {
1901 $url =~ m!^([a-z]+:/*[^/]*)(/[^#?]*)!;
1902 $text = _cleanupIncludedHTML( $text, $1, $2, $options );
1904 } elsif( $contentType =~ /^text\/(plain|css)/ ) {
1907 $text = _includeWarning(
1908 $this, $warn, 'bad_content', $contentType );
1910 $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
1911 $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} );
1913 $text = _includeWarning( $this, $warn, 'geturl_failed',
1914 $url.' '.$response->message() );
1921 # SMELL: this is _not_ a tag handler in the sense of other builtin tags,
1922 # because it requires far more context information (the text of the topic)
1924 # SMELL: as a tag handler that also semi-renders the topic to extract the
1925 # headings, this handler would be much better as a preRenderingHandler in
1926 # a plugin (where head, script and verbatim sections are already protected)
1928 # * $text : ref to the text of the current topic
1929 # * $topic : the topic we are in
1930 # * $web : the web we are in
1931 # * $args : 'Topic' [web='Web'] [depth='N']
1932 # Return value: $tableOfContents
1933 # Handles %<nop>TOC{...}% syntax. Creates a table of contents
1934 # using TWiki bulleted
1935 # list markup, linked to the section headings of a topic. A section heading is
1936 # entered in one of the following forms:
1937 # * $headingPatternSp : \t++... spaces section heading
1938 # * $headingPatternDa : ---++... dashes section heading
1939 # * $headingPatternHt : <h[1-6]> HTML section heading </h[1-6]>
1941 my ( $this, $text, $defaultTopic, $defaultWeb, $args ) = @_;
1943 require TWiki::Attrs;
1945 my $params = new TWiki::Attrs( $args );
1946 # get the topic name attribute
1947 my $topic = $params->{_DEFAULT} || $defaultTopic;
1949 # get the web name attribute
1950 $defaultWeb =~ s#/#.#g;
1951 my $web = $params->{web} || $defaultWeb;
1953 my $isSameTopic = $web eq $defaultWeb && $topic eq $defaultTopic;
1957 $webPath =~ s/\./\//g;
1959 # get the depth limit attribute
1960 my $maxDepth = $params->{depth} || $this->{prefs}->getPreferencesValue('TOC_MAX_DEPTH') || 6;
1961 my $minDepth = $this->{prefs}->getPreferencesValue('TOC_MIN_DEPTH') || 1;
1963 # get the title attribute
1964 my $title = $params->{title} || $this->{prefs}->getPreferencesValue('TOC_TITLE') || '';
1965 $title = CGI::span( { class => 'twikiTocTitle' }, $title ) if( $title );
1967 if( $web ne $defaultWeb || $topic ne $defaultTopic ) {
1968 unless( $this->security->checkAccessPermission
1969 ( 'VIEW', $this->{user}, undef, undef, $topic, $web ) ) {
1970 return $this->inlineAlert( 'alerts', 'access_denied',
1975 $this->{store}->readTopic( $this->{user}, $web, $topic );
1979 my $insideVerbatim = 0;
1983 $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
1985 $text = $this->renderer->takeOutBlocks( $text, 'pre',
1988 # Find URL parameters
1989 my $query = $this->{cgiQuery};
1991 foreach my $name ( $query->param ) {
1992 next if ($name eq 'keywords');
1993 next if ($name eq 'topic');
1994 next if ($name eq 'text');
1995 push @qparams, $name => $query->param($name);
1998 # SMELL: this handling of <pre> is archaic.
1999 # SMELL: use forEachLine
2000 foreach my $line ( split( /\r?\n/, $text ) ) {
2002 if ( $line =~ m/$regex{headerPatternDa}/o ) {
2005 } elsif ( $line =~ m/$regex{headerPatternHt}/io ) {
2012 if( $line && ($level >= $minDepth) && ($level <= $maxDepth) ) {
2013 # cut TOC exclude '---+ heading !! exclude this bit'
2014 $line =~ s/\s*$regex{headerPatternNoTOC}.+$//go;
2016 my $anchor = $this->renderer->makeAnchorName( $line );
2017 $highest = $level if( $level < $highest );
2018 my $tabs = "\t" x $level;
2019 # Remove *bold*, _italic_ and =fixed= formatting
2020 $line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
2021 $line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
2022 $line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
2024 $line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g; # '[[...][...]]'
2025 $line =~ s/\[\[(.*?)\]\]/$1/ge; # '[[...]]'
2026 $line =~ s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1<nop>$3/go; # 'Web.TopicName'
2027 $line =~ s/([\s\(])($regex{wikiWordRegex})/$1<nop>$2/go; # 'TopicName'
2028 $line =~ s/([\s\(])($regex{abbrevRegex})/$1<nop>$2/go; # 'TLA'
2029 $line =~ s/([\s\-\*\(])([$regex{mixedAlphaNum}]+\:)/$1<nop>$2/go; # 'Site:page' Interwiki link
2030 # Prevent manual links
2031 $line =~ s/<[\/]?a\b[^>]*>//gi;
2032 # create linked bullet item, using a relative link to anchor
2033 my $target = $isSameTopic ?
2034 _make_params(0, '#'=>$anchor,@qparams) :
2035 $this->getScriptUrl(0,'view',$web,$topic,'#'=>$anchor,@qparams);
2036 $line = $tabs.'* ' . CGI::a({href=>$target},$line);
2037 $result .= "\n".$line;
2042 if( $highest > 1 ) {
2045 $result =~ s/^\t{$highest}//gm;
2047 return CGI::div( { class=>'twikiToc' }, "$title$result\n" );
2055 ---++ ObjectMethod inlineAlert($template, $def, ... ) -> $string
2057 Format an error for inline inclusion in rendered output. The message string
2058 is obtained from the template 'oops'.$template, and the DEF $def is
2059 selected. The parameters (...) are used to populate %PARAM1%..%PARAMn%
2065 my $template = shift;
2068 my $text = $this->templates->readTemplate( 'oops'.$template,
2071 my $blah = $this->templates->expandTemplate( $def );
2072 $text =~ s/%INSTANTIATE%/$blah/;
2073 # web and topic can be anything; they are not used
2074 $text = $this->handleCommonTags( $text, $this->{webName},
2075 $this->{topicName} );
2077 while( defined( my $param = shift )) {
2078 $text =~ s/%PARAM$n%/$param/g;
2083 $text = CGI::h1('TWiki Installation Error')
2084 . 'Template "'.$template.'" not found.'.CGI::p()
2085 . 'Check your configuration settings for {TemplateDir} and {TemplatePath}';
2093 ---++ StaticMethod parseSections($text) -> ($string,$sectionlistref)
2095 Generic parser for sections within a topic. Sections are delimited
2096 by STARTSECTION and ENDSECTION, which may be nested, overlapped or
2097 otherwise abused. The parser builds an array of sections, which is
2098 ordered by the order of the STARTSECTION within the topic. It also
2099 removes all the SECTION tags from the text, and returns the text
2100 and the array of sections.
2102 Each section is a =TWiki::Attrs= object, which contains the attributes
2103 {type, name, start, end}
2104 where start and end are character offsets in the
2105 string *after all section tags have been removed*. All sections
2106 are required to be uniquely named; if a section is unnamed, it
2107 will be given a generated name. Sections may overlap or nest.
2109 See test/unit/Fn_SECTION.pm for detailed testcases that
2122 foreach my $bit (split(/(%(?:START|END)SECTION(?:{.*?})?%)/, $_[0] )) {
2123 if( $bit =~ /^%STARTSECTION(?:{(.*)})?%$/) {
2124 require TWiki::Attrs;
2125 my $attrs = new TWiki::Attrs( $1 );
2126 $attrs->{type} ||= 'section';
2127 $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} ||
2129 delete $attrs->{_DEFAULT};
2130 my $id = $attrs->{type}.':'.$attrs->{name};
2131 if( $sections{$id} ) {
2132 # error, this named section already defined, ignore
2135 # close open unnamed sections of the same type
2136 foreach my $s ( @list ) {
2137 if( $s->{end} < 0 && $s->{type} eq $attrs->{type} &&
2138 $s->{name} =~ /^_SECTION\d+$/ ) {
2139 $s->{end} = $offset;
2142 $attrs->{start} = $offset;
2143 $attrs->{end} = -1; # open section
2144 $sections{$id} = $attrs;
2145 push( @list, $attrs );
2146 } elsif( $bit =~ /^%ENDSECTION(?:{(.*)})?%$/ ) {
2147 require TWiki::Attrs;
2148 my $attrs = new TWiki::Attrs( $1 );
2149 $attrs->{type} ||= 'section';
2150 $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} || '';
2151 delete $attrs->{_DEFAULT};
2152 unless( $attrs->{name} ) {
2153 # find the last open unnamed section of this type
2154 foreach my $s ( reverse @list ) {
2155 if( $s->{end} == -1 &&
2156 $s->{type} eq $attrs->{type} &&
2157 $s->{name} =~ /^_SECTION\d+$/ ) {
2158 $attrs->{name} = $s->{name};
2162 # ignore it if no matching START found
2163 next unless $attrs->{name};
2165 my $id = $attrs->{type}.':'.$attrs->{name};
2166 if( !$sections{$id} || $sections{$id}->{end} >= 0 ) {
2167 # error, no such open section, ignore
2170 $sections{$id}->{end} = $offset;
2173 $offset = length( $ntext );
2177 # close open sections
2178 foreach my $s ( @list ) {
2179 $s->{end} = $offset if $s->{end} < 0;
2182 return( $ntext, \@list );
2187 ---++ ObjectMethod expandVariablesOnTopicCreation ( $text, $user, $web, $topic ) -> $text
2189 * =$text= - text to expand
2190 * =$user= - This is the user expanded in e.g. %USERNAME. Optional, defaults to logged-in user.
2191 Expand limited set of variables during topic creation. These are variables
2192 expected in templates that must be statically expanded in new content.
2193 * =$web= - name of web
2194 * =$topic= - name of topic
2196 # SMELL: no plugin handler
2200 sub expandVariablesOnTopicCreation {
2201 my ( $this, $text, $user, $theWeb, $theTopic ) = @_;
2203 $user ||= $this->{user};
2205 # Chop out templateonly sections
2206 my( $ntext, $sections ) = parseSections( $text );
2207 if( scalar( @$sections )) {
2208 # Note that if named templateonly sections overlap, the behaviour is undefined.
2209 foreach my $s ( reverse @$sections ) {
2210 if( $s->{type} eq 'templateonly' ) {
2211 $ntext = substr($ntext, 0, $s->{start})
2212 . substr($ntext, $s->{end}, length($ntext));
2214 # put back non-templateonly sections
2215 my $start = $s->remove('start');
2216 my $end = $s->remove('end');
2217 $ntext = substr($ntext, 0, $start).
2218 '%STARTSECTION{'.$s->stringify().'}%'.
2219 substr($ntext, $start, $end - $start).
2220 '%ENDSECTION{'.$s->stringify().'}%'.
2221 substr($ntext, $end, length($ntext));
2227 # Make sure func works, for registered tag handlers
2228 $TWiki::Plugins::SESSION = $this;
2230 # Note: it may look dangerous to override the user this way, but
2231 # it's actually quite safe, because only a subset of tags are
2232 # expanded during topic creation. if the set of tags expanded is
2233 # extended, then the impact has to be considered.
2234 my $safe = $this->{user};
2235 $this->{user} = $user;
2236 $text = _processTags( $this, $text, \&_expandTagOnTopicCreation, 16 );
2238 # expand all variables for type="expandvariables" sections
2239 ( $ntext, $sections ) = parseSections( $text );
2240 if( scalar( @$sections )) {
2241 $theWeb ||= $this->{session}->{webName};
2242 $theTopic ||= $this->{session}->{topicName};
2243 foreach my $s ( reverse @$sections ) {
2244 if( $s->{type} eq 'expandvariables' ) {
2245 my $etext = substr( $ntext, $s->{start}, $s->{end} - $s->{start} );
2246 expandAllTags( $this, \$etext, $theTopic, $theWeb );
2247 $ntext = substr( $ntext, 0, $s->{start})
2249 . substr( $ntext, $s->{end}, length($ntext) );
2251 # put back non-expandvariables sections
2252 my $start = $s->remove('start');
2253 my $end = $s->remove('end');
2254 $ntext = substr($ntext, 0, $start).
2255 '%STARTSECTION{'.$s->stringify().'}%'.
2256 substr($ntext, $start, $end - $start).
2257 '%ENDSECTION{'.$s->stringify().'}%'.
2258 substr($ntext, $end, length($ntext));
2264 # kill markers used to prevent variable expansion
2265 $text =~ s/%NOP%//g;
2266 $this->{user} = $safe;
2272 ---++ StaticMethod entityEncode( $text, $extras ) -> $encodedText
2274 Escape special characters to HTML numeric entities. This is *not* a generic
2275 encoding, it is tuned specifically for use in TWiki.
2278 "Certain characters in HTML are reserved for use as markup and must be
2279 escaped to appear literally. The "<" character may be represented with
2280 an <em>entity</em>, <strong class=html>&lt;</strong>. Similarly, ">"
2281 is escaped as <strong class=html>&gt;</strong>, and "&" is escaped
2282 as <strong class=html>&amp;</strong>. If an attribute value contains a
2283 double quotation mark and is delimited by double quotation marks, then the
2284 quote should be escaped as <strong class=html>&quot;</strong>.</p>
2286 Other entities exist for special characters that cannot easily be entered
2287 with some keyboards..."
2289 This method encodes HTML special and any non-printable ascii
2290 characters (except for \n and \r) using numeric entities.
2292 FURTHER this method also encodes characters that are special in TWiki
2295 $extras is an optional param that may be used to include *additional*
2296 characters in the set of encoded characters. It should be a string
2297 containing the additional chars.
2302 my( $text, $extra) = @_;
2305 # encode all non-printable 7-bit chars (< \x1f),
2306 # except \n (\xa) and \r (\xd)
2307 # encode HTML special characters '>', '<', '&', ''' and '"'.
2308 # encode TML special characters '%', '|', '[', ']', '@', '_',
2310 $text =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|$extra])/'&#'.ord($1).';'/ge;
2316 ---++ StaticMethod entityDecode ( $encodedText ) -> $text
2318 Decodes all numeric entities (e.g. &#123;). _Does not_ decode
2319 named entities such as &amp; (use HTML::Entities for that)
2326 $text =~ s/&#(\d+);/chr($1)/ge;
2332 ---++ StaticMethod urlEncodeAttachment ( $text )
2334 For attachments, URL-encode specially to 'freeze' any characters >127 in the
2335 site charset (e.g. ISO-8859-1 or KOI8-R), by doing URL encoding into native
2336 charset ($siteCharset) - used when generating attachment URLs, to enable the
2337 web server to serve attachments, including images, directly.
2339 This encoding is required to handle the cases of:
2341 - browsers that generate UTF-8 URLs automatically from site charset URLs - now quite common
2342 - web servers that directly serve attachments, using the site charset for
2343 filenames, and cannot convert UTF-8 URLs into site charset filenames
2345 The aim is to prevent the browser from converting a site charset URL in the web
2346 page to a UTF-8 URL, which is the default. Hence we 'freeze' the URL into the
2347 site character set through URL encoding.
2349 In two cases, no URL encoding is needed: For EBCDIC mainframes, we assume that
2350 site charset URLs will be translated (outbound and inbound) by the web server to/from an
2351 EBCDIC character set. For sites running in UTF-8, there's no need for TWiki to
2352 do anything since all URLs and attachment filenames are already in UTF-8.
2356 sub urlEncodeAttachment {
2359 my $usingEBCDIC = ( 'A' eq chr(193) ); # Only true on EBCDIC mainframes
2361 if( (defined($TWiki::cfg{Site}{CharSet}) and $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) or $usingEBCDIC ) {
2362 # Just let browser do UTF-8 URL encoding
2366 # Freeze into site charset through URL encoding
2367 return urlEncode( $text );
2373 ---++ StaticMethod urlEncode( $string ) -> encoded string
2375 Encode by converting characters that are illegal in URLs to
2376 their %NN equivalents. This method is used for encoding
2377 strings that must be embedded _verbatim_ in URLs; it cannot
2378 be applied to URLs themselves, as it escapes reserved
2379 characters such as = and ?.
2383 ...Only alphanumerics [0-9a-zA-Z], the special
2384 characters $-_.+!*'(), and reserved characters used for their
2385 reserved purposes may be used unencoded within a URL.
2388 Reserved characters are $&+,/:;=?@ - these are _also_ encoded by
2391 This URL-encoding handles all character encodings including ISO-8859-*,
2392 KOI8-R, EUC-* and UTF-8.
2394 This may not handle EBCDIC properly, as it generates an EBCDIC URL-encoded
2395 URL, but mainframe web servers seem to translate this outbound before it hits browser
2396 - see CGI::Util::escape for another approach.
2403 $text =~ s/([^0-9a-zA-Z-_.:~!*'\/%])/'%'.sprintf('%02x',ord($1))/ge;
2410 ---++ StaticMethod urlDecode( $string ) -> decoded string
2412 Reverses the encoding done in urlEncode.
2419 $text =~ s/%([\da-f]{2})/chr(hex($1))/gei;
2426 ---++ StaticMethod isTrue( $value, $default ) -> $boolean
2428 Returns 1 if =$value= is true, and 0 otherwise. "true" means set to
2429 something with a Perl true value, with the special cases that "off",
2430 "false" and "no" (case insensitive) are forced to false. Leading and
2431 trailing spaces in =$value= are ignored.
2433 If the value is undef, then =$default= is returned. If =$default= is
2434 not specified it is taken as 0.
2439 my( $value, $default ) = @_;
2443 return $default unless defined( $value );
2445 $value =~ s/^\s*(.*?)\s*$/$1/gi;
2446 $value =~ s/off//gi;
2448 $value =~ s/false//gi;
2449 return ( $value ) ? 1 : 0;
2454 ---++ StaticMethod spaceOutWikiWord( $word, $sep ) -> $string
2456 Spaces out a wiki word by inserting a string (default: one space) between each word component.
2457 With parameter $sep any string may be used as separator between the word components; if $sep is undefined it defaults to a space.
2461 sub spaceOutWikiWord {
2462 my $word = shift || '';
2463 my $sep = shift || ' ';
2464 $word =~ s/([$regex{lowerAlpha}])([$regex{upperAlpha}$regex{numeric}]+)/$1$sep$2/go;
2465 $word =~ s/([$regex{numeric}])([$regex{upperAlpha}])/$1$sep$2/go;
2471 ---++ ObjectMethod expandAllTags(\$text, $topic, $web, $meta)
2472 Expands variables by replacing the variables with their
2473 values. Some example variables: %<nop>TOPIC%, %<nop>SCRIPTURL%,
2474 %<nop>WIKINAME%, etc.
2475 $web and $incs are passed in for recursive include expansion. They can
2477 The rules for tag expansion are:
2478 1 Tags are expanded left to right, in the order they are encountered.
2479 1 Tags are recursively expanded as soon as they are encountered -
2480 the algorithm is inherently single-pass
2481 1 A tag is not "encountered" until the matching }% has been seen, by
2482 which time all tags in parameters will have been expanded
2483 1 Tag expansions that create new tags recursively are limited to a
2484 set number of hierarchical levels of expansion
2490 my $text = shift; # reference
2491 my ( $topic, $web, $meta ) = @_;
2494 # push current context
2495 my $memTopic = $this->{SESSION_TAGS}{TOPIC};
2496 my $memWeb = $this->{SESSION_TAGS}{WEB};
2498 $this->{SESSION_TAGS}{TOPIC} = $topic;
2499 $this->{SESSION_TAGS}{WEB} = $web;
2501 # Escape ' !%VARIABLE%'
2502 $$text =~ s/(?<=\s)!%($regex{tagNameRegex})/%$1/g;
2504 # Make sure func works, for registered tag handlers
2505 $TWiki::Plugins::SESSION = $this;
2508 # The depth parameter in the following call controls the maximum number
2509 # of levels of expansion. If it is set to 1 then only tags in the
2510 # topic will be expanded; tags that they in turn generate will be
2511 # left unexpanded. If it is set to 2 then the expansion will stop after
2512 # the first recursive inclusion, and so on. This is incredible useful
2513 # when debugging. The default is set to 16
2514 # to match the original limit on search expansion, though this of
2515 # course applies to _all_ tags and not just search.
2516 $$text = _processTags( $this, $$text, \&_expandTagOnTopicRendering,
2519 # restore previous context
2520 $this->{SESSION_TAGS}{TOPIC} = $memTopic;
2521 $this->{SESSION_TAGS}{WEB} = $memWeb;
2524 # Process TWiki %TAGS{}% by parsing the input tokenised into
2525 # % separated sections. The parser is a simple stack-based parse,
2526 # sufficient to ensure nesting of tags is correct, but no more
2528 # $depth limits the number of recursive expansion steps that
2529 # can be performed on expanded tags.
2537 (!defined( $text )) ||
2541 return $text unless ($text =~ /(%)/);
2546 my $mess = "Max recursive depth reached: $text";
2547 $this->writeWarning( $mess );
2548 # prevent recursive expansion that just has been detected
2549 # from happening in the error message
2550 $text =~ s/%(.*?)%/$1/go;
2555 $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
2559 #my $percent = ($TranslationToken x 3).'%'.($TranslationToken x 3);
2561 my @queue = split( /(%)/, $text );
2563 my $stackTop = ''; # the top stack entry. Done this way instead of
2564 # referring to the top of the stack for efficiency. This var
2565 # should be considered to be $stack[$#stack]
2567 while ( scalar( @queue )) {
2568 my $token = shift( @queue );
2569 #print STDERR ' ' x $tell,"PROCESSING $token \n";
2571 # each % sign either closes an existing stacked context, or
2572 # opens a new context.
2573 if ( $token eq '%' ) {
2574 #print STDERR ' ' x $tell,"CONSIDER $stackTop\n";
2575 # If this is a closing }%, try to rejoin the previous
2576 # tokens until we get to a valid tag construct. This is
2577 # a bit of a hack, but it's hard to think of a better
2578 # way to do this without a full parse that takes % signs
2579 # in tag parameters into account.
2580 if ( $stackTop =~ /}$/s ) {
2581 while ( scalar( @stack) &&
2582 $stackTop !~ /^%($regex{tagNameRegex}){.*}$/so ) {
2583 my $top = $stackTop;
2584 #print STDERR ' ' x $tell,"COLLAPSE $top \n";
2585 $stackTop = pop( @stack ) . $top;
2588 # /s so you can have newlines in parameters
2589 if ( $stackTop =~ m/^%(($regex{tagNameRegex})(?:{(.*)})?)$/so ) {
2590 my( $expr, $tag, $args ) = ( $1, $2, $3 );
2591 #print STDERR ' ' x $tell,"POP $tag\n";
2592 my $e = &$tagf( $this, $tag, $args, @_ );
2594 if ( defined( $e )) {
2595 #print STDERR ' ' x $tell--,"EXPANDED $tag -> $e\n";
2596 $stackTop = pop( @stack );
2597 unless ($e =~ /(%)/) {
2598 #SMELL: this is a profiler speedup found by Sven on the last day of 4.2.1
2599 #TODO: I don't think this parser should be in this section - re-analysis desired.
2600 #print STDERR "no tags to recurse\n";
2604 # Recursively expand tags in the expansion of $tag
2605 $stackTop .= _processTags($this, $e, $tagf, $depth-1, @_ );
2606 } else { # expansion failed
2607 #print STDERR ' ' x $tell++,"EXPAND $tag FAILED\n";
2609 # correctly, we have to handle the %VAR% case differently
2610 # to the %VAR{}% case when a variable expansion fails.
2611 # This is so that recursively define variables e.g.
2612 # %A%B%D% expand correctly, but at the same time we ensure
2613 # that a mismatched }% can't accidentally close a context
2614 # that was left open when a tag expansion failed.
2615 # However Cairo didn't do this, so for compatibility
2616 # we have to accept that %NOP can never be fixed. if it
2617 # could, then we could uncomment the following:
2619 #if( $stackTop =~ /}$/ ) {
2621 # # We need to push the unexpanded expression back
2622 # # onto the stack, but we don't want it to match the
2623 # # tag expression again. So we protect the %'s
2624 # $stackTop = $percent.$expr.$percent;
2628 # In this case we *do* want to match the tag expression
2629 # again, as an embedded %VAR% may have expanded to
2630 # create a valid outer expression. This is directly
2631 # at odds with the %VAR{...}% case.
2632 push( @stack, $stackTop );
2633 $stackTop = '%'; # open new context
2637 push( @stack, $stackTop );
2638 $stackTop = '%'; # push a new context
2642 $stackTop .= $token;
2646 # Run out of input. Gather up everything in the stack.
2647 while ( scalar( @stack )) {
2648 my $expr = $stackTop;
2649 $stackTop = pop( @stack );
2653 #$stackTop =~ s/$percent/%/go;
2655 $this->renderer->putBackBlocks( \$stackTop, $verbatim, 'verbatim' );
2657 #print STDERR "FINAL $stackTop\n";
2662 # Handle expansion of a tag during topic rendering
2663 # $tag is the tag name
2664 # $args is the bit in the {} (if there are any)
2665 # $topic and $web should be passed for dynamic tags (not needed for
2666 # session or constant tags
2667 sub _expandTagOnTopicRendering {
2671 # my( $topic, $web, $meta ) = @_;
2672 require TWiki::Attrs;
2674 my $e = $this->{prefs}->getPreferencesValue( $tag );
2675 unless( defined( $e )) {
2676 $e = $this->{SESSION_TAGS}{$tag};
2677 if( !defined( $e ) && defined( $functionTags{$tag} )) {
2678 $e = &{$functionTags{$tag}}
2679 ( $this, new TWiki::Attrs(
2680 $args, $contextFreeSyntax{$tag} ), @_ );
2686 # Handle expansion of a tag during new topic creation. When creating a
2687 # new topic from a template we only expand a subset of the available legal
2688 # tags, and we expand %NOP% differently.
2689 sub _expandTagOnTopicCreation {
2691 # my( $tag, $args, $topic, $web ) = @_;
2693 # Required for Cairo compatibility. Ignore %NOP{...}%
2694 # %NOP% is *not* ignored until all variable expansion is complete,
2695 # otherwise them inside-out rule would remove it too early e.g.
2696 # %GM%NOP%TIME -> %GMTIME -> 12:00. So we ignore it here and scrape it
2697 # out later. We *have* to remove %NOP{...}% because it can foul up
2699 return '' if $_[0] eq 'NOP' && defined $_[1];
2701 # Only expand a subset of legal tags. Warning: $this->{user} may be
2702 # overridden during this call, when a new user topic is being created.
2703 # This is what we want to make sure new user templates are populated
2704 # correctly, but you need to think about this if you extend the set of
2705 # tags expanded here.
2706 return undef unless $_[0] =~ /^(URLPARAM|DATE|(SERVER|GM)TIME|(USER|WIKI)NAME|WIKIUSERNAME|USERINFO)$/;
2708 return _expandTagOnTopicRendering( $this, @_ );
2713 ---++ ObjectMethod enterContext( $id, $val )
2715 Add the context id $id into the set of active contexts. The $val
2716 can be anything you like, but should always evaluate to boolean
2719 An example of the use of contexts is in the use of tag
2720 expansion. The commonTagsHandler in plugins is called every
2721 time tags need to be expanded, and the context of that expansion
2722 is signalled by the expanding module using a context id. So the
2723 forms module adds the context id "form" before invoking common
2726 Contexts are not just useful for tag expansion; they are also
2727 relevant when rendering.
2729 Contexts are intended for use mainly by plugins. Core modules can
2730 use $session->inContext( $id ) to determine if a context is active.
2735 my( $this, $id, $val ) = @_;
2737 $this->{context}->{$id} = $val;
2742 ---++ ObjectMethod leaveContext( $id )
2744 Remove the context id $id from the set of active contexts.
2745 (see =enterContext= for more information on contexts)
2750 my( $this, $id ) = @_;
2751 my $res = $this->{context}->{$id};
2752 delete $this->{context}->{$id};
2758 ---++ ObjectMethod inContext( $id )
2760 Return the value for the given context id
2761 (see =enterContext= for more information on contexts)
2766 my( $this, $id ) = @_;
2767 return $this->{context}->{$id};
2772 ---++ StaticMethod registerTagHandler( $tag, $fnref )
2774 STATIC Add a tag handler to the function tag handlers.
2775 * =$tag= name of the tag e.g. MYTAG
2776 * =$fnref= Function to execute. Will be passed ($session, \%params, $web, $topic )
2780 sub registerTagHandler {
2781 my ( $tag, $fnref, $syntax ) = @_;
2782 $functionTags{$tag} = \&$fnref;
2783 if( $syntax && $syntax eq 'context-free' ) {
2784 $contextFreeSyntax{$tag} = 1;
2790 ---++ StaticMethod registerRESTHandler( $subject, $verb, \&fn )
2792 Adds a function to the dispatch table of the REST interface
2793 for a given subject. See TWikiScripts#rest for more info.
2795 * =$subject= - The subject under which the function will be registered.
2796 * =$verb= - The verb under which the function will be registered.
2797 * =\&fn= - Reference to the function.
2799 The handler function must be of the form:
2801 sub handler(\%session,$subject,$verb) -> $text
2804 * =\%session= - a reference to the TWiki session object (may be ignored)
2805 * =$subject= - The invoked subject (may be ignored)
2806 * =$verb= - The invoked verb (may be ignored)
2808 *Since:* TWiki::Plugins::VERSION 1.1
2812 sub registerRESTHandler {
2813 my ( $subject, $verb, $fnref) = @_;
2814 $restDispatch{$subject}{$verb} = \&$fnref;
2819 ---++ StaticMethod restDispatch( $subject, $verb) => \&fn
2821 Returns the handler function associated to the given $subject and $werb,
2822 or undef if none is found.
2824 *Since:* TWiki::Plugins::VERSION 1.1
2829 my ( $subject, $verb) = @_;
2830 my $s=$restDispatch{$subject};
2832 return $restDispatch{$subject}{$verb};
2840 ---++ ObjectMethod handleCommonTags( $text, $web, $topic, $meta ) -> $text
2842 Processes %<nop>VARIABLE%, and %<nop>TOC% syntax; also includes
2843 'commonTagsHandler' plugin hook.
2845 Returns the text of the topic, after file inclusion, variable substitution,
2846 table-of-contents generation, and any plugin changes from commonTagsHandler.
2848 $meta may be undef when, for example, expanding templates, or one-off strings
2849 at a time when meta isn't available.
2853 sub handleCommonTags {
2854 my( $this, $text, $theWeb, $theTopic, $meta ) = @_;
2856 ASSERT($theWeb) if DEBUG;
2857 ASSERT($theTopic) if DEBUG;
2859 return $text unless $text;
2861 # Plugin Hook (for cache Plugins only)
2862 $this->{plugins}->beforeCommonTagsHandler(
2863 $text, $theTopic, $theWeb, $meta );
2865 #use a "global var", so included topics can extract and putback
2866 #their verbatim blocks safetly.
2867 $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
2870 my $memW = $this->{SESSION_TAGS}{INCLUDINGWEB};
2871 my $memT = $this->{SESSION_TAGS}{INCLUDINGTOPIC};
2872 $this->{SESSION_TAGS}{INCLUDINGWEB} = $theWeb;
2873 $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $theTopic;
2875 expandAllTags( $this, \$text, $theTopic, $theWeb, $meta );
2877 $text = $this->renderer->takeOutBlocks( $text, 'verbatim',
2882 $this->{plugins}->commonTagsHandler( $text, $theTopic, $theWeb, 0, $meta );
2884 # process tags again because plugin hook may have added more in
2885 expandAllTags( $this, \$text, $theTopic, $theWeb, $meta );
2887 $this->{SESSION_TAGS}{INCLUDINGWEB} = $memW;
2888 $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $memT;
2890 # 'Special plugin tag' TOC hack, must be done after all other expansions
2891 # are complete, and has to reprocess the entire topic.
2892 $text =~ s/%TOC(?:{(.*?)})?%/$this->_TOC($text, $theTopic, $theWeb, $1)/ge;
2894 # Codev.FormattedSearchWithConditionalOutput: remove <nop> lines,
2895 # possibly introduced by SEARCHes with conditional CALC. This needs
2896 # to be done after CALC and before table rendering in order to join
2897 # table rows properly
2898 $text =~ s/^<nop>\r?\n//gm;
2900 $this->renderer->putBackBlocks( \$text, $verbatim, 'verbatim' );
2902 # TWiki Plugin Hook (for cache Plugins only)
2903 $this->{plugins}->afterCommonTagsHandler(
2904 $text, $theTopic, $theWeb, $meta );
2911 ---++ ObjectMethod addToHEAD( $id, $html )
2913 Add =$html= to the HEAD tag of the page currently being generated.
2915 Note that TWiki variables may be used in the HEAD. They will be expanded
2916 according to normal variable expansion rules.
2918 The 'id' is used to ensure that multiple adds of the same block of HTML don't
2919 result in it being added many times.
2924 my ($this, $tag, $header) = @_;
2926 $header = $this->handleCommonTags( $header, $this->{webName},
2927 $this->{topicName} );
2929 $this->{_HTMLHEADERS}{$tag} = $header;
2934 ---++ StaticMethod initialize( $pathInfo, $remoteUser, $topic, $url, $query ) -> ($topicName, $webName, $scriptUrlPath, $userName, $dataDir)
2936 Return value: ( $topicName, $webName, $TWiki::cfg{ScriptUrlPath}, $userName, $TWiki::cfg{DataDir} )
2938 Static method to construct a new singleton session instance.
2939 It creates a new TWiki and sets the Plugins $SESSION variable to
2940 point to it, so that TWiki::Func methods will work.
2942 This method is *DEPRECATED* but is maintained for script compatibility.
2944 Note that $theUrl, if specified, must be identical to $query->url()
2949 my ( $pathInfo, $theRemoteUser, $topic, $theUrl, $query ) = @_;
2952 $query = new CGI( {} );
2954 if( $query->path_info() ne $pathInfo ) {
2955 $query->path_info( $pathInfo );
2958 $query->param( -name => 'topic', -value => '' );
2960 # can't do much if $theUrl is specified and it is inconsistent with
2961 # the query. We are trying to get to all parameters passed in the
2963 if( $theUrl && $theUrl ne $query->url()) {
2964 die 'Sorry, this version of TWiki does not support the url parameter to TWiki::initialize being different to the url in the query';
2966 my $twiki = new TWiki( $theRemoteUser, $query );
2968 # Force the new session into the plugins context.
2969 $TWiki::Plugins::SESSION = $twiki;
2971 return ( $twiki->{topicName}, $twiki->{webName}, $twiki->{scriptUrlPath},
2972 $twiki->{userName}, $TWiki::cfg{DataDir} );
2977 ---++ StaticMethod readFile( $filename ) -> $text
2979 Returns the entire contents of the given file, which can be specified in any
2980 format acceptable to the Perl open() function. Fast, but inherently unsafe.
2982 WARNING: Never, ever use this for accessing topics or attachments! Use the
2983 Store API for that. This is for global control files only, and should be
2984 used *only* if there is *absolutely no alternative*.
2990 open( IN_FILE, "<$name" ) || return '';
2992 my $data = <IN_FILE>;
2994 $data = '' unless( defined( $data ));
3000 ---++ StaticMethod expandStandardEscapes($str) -> $unescapedStr
3002 Expands standard escapes used in parameter values to block evaluation. The following escapes
3005 | *Escape:* | *Expands To:* |
3006 | =$n= or =$n()= | New line. Use =$n()= if followed by alphanumeric character, e.g. write =Foo$n()Bar= instead of =Foo$nBar= |
3007 | =$nop= or =$nop()= | Is a "no operation". |
3008 | =$quot= | Double quote (="=) |
3009 | =$percnt= | Percent sign (=%=) |
3010 | =$dollar= | Dollar sign (=$=) |
3014 sub expandStandardEscapes {
3016 $text =~ s/\$n\(\)/\n/gos; # expand '$n()' to new line
3017 $text =~ s/\$n([^$regex{mixedAlpha}]|$)/\n$1/gos; # expand '$n' to new line
3018 $text =~ s/\$nop(\(\))?//gos; # remove filler, useful for nested search
3019 $text =~ s/\$quot(\(\))?/\"/gos; # expand double quote
3020 $text =~ s/\$percnt(\(\))?/\%/gos; # expand percent
3021 $text =~ s/\$dollar(\(\))?/\$/gos; # expand dollar
3025 # generate an include warning
3026 # SMELL: varying number of parameters idiotic to handle for customized $warn
3027 sub _includeWarning {
3030 my $message = shift;
3032 if( $warn eq 'on' ) {
3033 return $this->inlineAlert( 'alerts', $message, @_ );
3034 } elsif( isTrue( $warn )) {
3035 # different inlineAlerts need different argument counts
3037 if ($message eq 'topic_not_found') {
3038 my ($web,$topic) = @_;
3039 $argument = "$web.$topic";
3044 $warn =~ s/\$topic/$argument/go if $argument;
3046 } # else fail silently
3050 #-------------------------------------------------------------------
3052 #-------------------------------------------------------------------
3055 my ( $this, $params, $topic, $web ) = @_;
3056 my $cgiQuery = $this->{cgiQuery};
3057 my $cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
3058 $params->{rev} = $cgiRev;
3059 return $this->renderer->renderFORMFIELD( $params, $topic, $web );
3063 my( $this, $params ) = @_;
3064 return $this->templates->tmplP( $params );
3068 my( $this, $params, $topic, $inweb ) = @_;
3069 my $key = $params->{_DEFAULT};
3070 return '' unless $key;
3071 my $web = $params->{web} || $inweb;
3072 # handle %USERSWEB%-type cases
3073 ( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
3074 # always return a value, even when the key isn't defined
3075 return $this->{prefs}->getWebPreferencesValue( $key, $web ) || '';
3079 my( $this, $params ) = @_;
3080 $this->{plugins}->getPluginVersion( $params->{_DEFAULT} );
3084 my ( $this, $params, $topic, $web, $meta ) = @_;
3086 unless( $ifParser ) {
3087 require TWiki::If::Parser;
3088 $ifParser = new TWiki::If::Parser();
3091 my $texpr = $params->{_DEFAULT};
3096 $this->{evaluating_if} ||= {};
3097 # Block after 5 levels.
3098 if ($this->{evaluating_if}->{$texpr} &&
3099 $this->{evaluating_if}->{$texpr} > 5) {
3100 delete $this->{evaluating_if}->{$texpr};
3103 $this->{evaluating_if}->{$texpr}++;
3106 $expr = $ifParser->parse( $texpr );
3108 require TWiki::Meta;
3109 $meta = new TWiki::Meta( $this, $web, $topic );
3111 if( $expr->evaluate( tom=>$meta, data=>$meta )) {
3112 $params->{then} = '' unless defined $params->{then};
3113 $result = expandStandardEscapes( $params->{then} );
3115 $params->{else} = '' unless defined $params->{else};
3116 $result = expandStandardEscapes( $params->{else} );
3118 } catch TWiki::Infix::Error with {
3120 $result = $this->inlineAlert(
3121 'alerts', 'generic', 'IF{', $params->stringify(), '}:',
3124 delete $this->{evaluating_if}->{$texpr};
3129 # Processes a specific instance %<nop>INCLUDE{...}% syntax.
3130 # Returns the text to be inserted in place of the INCLUDE command.
3131 # $topic and $web should be for the immediate parent topic in the
3132 # include hierarchy. Works for both URLs and absolute server paths.
3134 my ( $this, $params, $includingTopic, $includingWeb ) = @_;
3136 # remember args for the key before mangling the params
3137 my $args = $params->stringify();
3139 # Remove params, so they don't get expanded in the included page
3140 my $path = $params->remove('_DEFAULT') || '';
3141 my $pattern = $params->remove('pattern');
3142 my $rev = $params->remove('rev');
3143 my $section = $params->remove('section');
3144 undef $section if (defined($section) && $section eq ''); #no sense in considering an empty string as an unfindable section
3145 my $raw = $params->remove('raw') || '';
3146 my $warn = $params->remove('warn')
3147 || $this->{prefs}->getPreferencesValue( 'INCLUDEWARNING' );
3149 if( $path =~ /^https?\:/ ) {
3152 $this, $path, $pattern, $includingWeb, $includingTopic,
3153 $raw, $params, $warn );
3156 $path =~ s/$TWiki::cfg{NameFilter}//go; # zap anything suspicious
3157 if( $TWiki::cfg{DenyDotDotInclude} ) {
3158 # Filter out '..' from filename, this is to
3159 # prevent includes of '../../file'
3160 $path =~ s/\.+/\./g;
3162 # danger, could include .htpasswd with relative path
3163 $path =~ s/passwd//gi; # filter out passwd filename
3166 # make sure we have something to include. If we don't do this, then
3167 # normalizeWebTopicName will default to WebHome. Item2209.
3169 # SMELL: could do with a different message here, but don't want to
3170 # add one right now because translators are already working
3171 return _includeWarning( $this, $warn, 'topic_not_found', '""','""' );
3177 my $includedTopic = $path;
3178 $includedTopic =~ s/\.txt$//; # strip optional (undocumented) .txt
3180 ($includedWeb, $includedTopic) =
3181 $this->normalizeWebTopicName($includingWeb, $includedTopic);
3183 # See Codev.FailedIncludeWarning for the history.
3184 unless( $this->{store}->topicExists($includedWeb, $includedTopic)) {
3185 return _includeWarning( $this, $warn, 'topic_not_found',
3186 $includedWeb, $includedTopic );
3189 # prevent recursive includes. Note that the inclusion of a topic into
3190 # itself is not blocked; however subsequent attempts to include the
3191 # topic will fail. There is a hard block of 99 on any recursive include.
3192 my $key = $includingWeb.'.'.$includingTopic;
3193 my $count = grep( $key, keys %{$this->{_INCLUDES}});
3195 if( $this->{_INCLUDES}->{$key} || $count > 99) {
3196 return _includeWarning( $this, $warn, 'already_included',
3197 "$includedWeb.$includedTopic", '' );
3200 my %saveTags = %{$this->{SESSION_TAGS}};
3201 my $prefsMark = $this->{prefs}->mark();
3203 $this->{_INCLUDES}->{$key} = 1;
3204 $this->{SESSION_TAGS}{INCLUDINGWEB} = $includingWeb;
3205 $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $includingTopic;
3207 # copy params into session tags
3208 foreach my $k ( keys %$params ) {
3209 $this->{SESSION_TAGS}{$k} = $params->{$k};
3213 $this->{store}->readTopic( undef, $includedWeb, $includedTopic, $rev );
3215 # Simplify leading, and remove trailing, newlines. If we don't remove
3216 # trailing, it becomes impossible to %INCLUDE a topic into a table.
3217 $text =~ s/^[\r\n]+/\n/;
3218 $text =~ s/[\r\n]+$//;
3220 unless( $this->security->checkAccessPermission(
3221 'VIEW', $this->{user}, $text, $meta, $includedTopic, $includedWeb )) {
3222 if( isTrue( $warn )) {
3223 return $this->inlineAlert( 'alerts', 'access_denied',
3224 "[[$includedWeb.$includedTopic]]" );
3225 } # else fail silently
3229 # remove everything before and after the default include block unless
3230 # a section is explicitly defined
3232 $text =~ s/.*?%STARTINCLUDE%//s;
3233 $text =~ s/%STOPINCLUDE%.*//s;
3237 my( $ntext, $sections ) = parseSections( $text );
3239 my $interesting = ( defined $section );
3240 if( $interesting || scalar( @$sections )) {
3241 # Rebuild the text from the interesting sections
3243 foreach my $s ( @$sections ) {
3244 if( $section && $s->{type} eq 'section' &&
3245 $s->{name} eq $section) {
3246 $text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} );
3249 } elsif( $s->{type} eq 'include' && !$section ) {
3250 $text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} );
3255 # If there were no interesting sections, restore the whole text
3256 $text = $ntext unless $interesting;
3258 $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
3260 # Do not show TOC in included topic if TOC_HIDE_IF_INCLUDED
3261 # preference has been set
3262 if( isTrue( $this->{prefs}->getPreferencesValue( 'TOC_HIDE_IF_INCLUDED' ))) {
3263 $text =~ s/%TOC(?:{(.*?)})?%//g;
3266 expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
3268 # 4th parameter tells plugin that its called for an included file
3269 $this->{plugins}->commonTagsHandler( $text, $includedTopic,
3270 $includedWeb, 1, $meta );
3272 # We have to expand tags again, because a plugin may have inserted additional
3274 expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
3276 # If needed, fix all 'TopicNames' to 'Web.TopicNames' to get the
3277 # right context so that links continue to work properly
3278 if( $includedWeb ne $includingWeb ) {
3281 $text = $this->renderer->forEachLine(
3282 $text, \&_fixupIncludedTopic, { web => $includedWeb,
3285 # handle tags again because of plugin hook
3286 expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
3290 delete $this->{_INCLUDES}->{$key};
3291 %{$this->{SESSION_TAGS}} = %saveTags;
3293 $this->{prefs}->restore( $prefsMark );
3299 my( $this, $params ) = @_;
3301 if( $params->{_DEFAULT} ) {
3302 $res = $this->{cgiQuery}->http( $params->{_DEFAULT} );
3304 $res = '' unless defined( $res );
3309 my( $this, $params ) = @_;
3311 if( $params->{_DEFAULT} ) {
3312 $res = $this->{cgiQuery}->https( $params->{_DEFAULT} );
3314 $res = '' unless defined( $res );
3318 #deprecated functionality, now implemented using %ENV%
3319 #move to compatibility plugin in TWiki5
3320 sub HTTP_HOST_deprecated {
3321 return $ENV{HTTP_HOST} || '';
3324 #deprecated functionality, now implemented using %ENV%
3325 #move to compatibility plugin in TWiki5
3326 sub REMOTE_ADDR_deprecated {
3327 return $ENV{REMOTE_ADDR} || '';
3330 #deprecated functionality, now implemented using %ENV%
3331 #move to compatibility plugin in TWiki5
3332 sub REMOTE_PORT_deprecated {
3333 return $ENV{REMOTE_PORT} || '';
3336 #deprecated functionality, now implemented using %ENV%
3337 #move to compatibility plugin in TWiki5
3338 sub REMOTE_USER_deprecated {
3339 return $ENV{REMOTE_USER} || '';
3342 # Only does simple search for topicmoved at present, can be expanded when required
3343 # SMELL: this violates encapsulation of Store and Meta, by exporting
3344 # the assumption that meta-data is stored embedded inside topic
3347 my( $this, $params ) = @_;
3349 return $this->{store}->searchMetaData( $params );
3354 return TWiki::Time::formatTime(time(), $TWiki::cfg{DefaultDateFormat}, $TWiki::cfg{DisplayTimeValues});
3358 my( $this, $params ) = @_;
3359 return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'gmtime' );
3363 my( $this, $params ) = @_;
3364 return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'servertime' );
3368 my( $this, $params ) = @_;
3369 return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', $TWiki::cfg{DisplayTimeValues} );
3373 #| $topic | topic to display the name for |
3374 #| $formatString | twiki format string (like in search) |
3376 my ( $this, $params, $theTopic, $theWeb ) = @_;
3377 my $format = $params->{_DEFAULT} || $params->{format};
3378 my $web = $params->{web} || $theWeb;
3379 my $topic = $params->{topic} || $theTopic;
3380 my $cgiQuery = $this->{cgiQuery};
3382 $cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
3383 my $rev = $params->{rev} || $cgiRev || '';
3385 return $this->renderer->renderRevisionInfo( $web, $topic, undef,
3390 my ( $this, $params, $theTopic, $theWeb ) = @_;
3391 my $cgiQuery = $this->{cgiQuery};
3394 my $cgiRev = $cgiQuery->param('rev');
3395 $out = '(r'.$cgiRev.')' if ($cgiRev);
3400 my ( $this, $params, $theTopic, $theWeb ) = @_;
3401 my $cgiQuery = $this->{cgiQuery};
3404 my $cgiRev = $cgiQuery->param('rev');
3405 $out = '&rev='.$cgiRev if ($cgiRev);
3411 my( $this, $params ) = @_;
3412 my $type = $params->{type} || 'url';
3413 my $text = $params->{_DEFAULT} || '';
3414 return _encode($type, $text);
3418 my ($type, $text) = @_;
3420 if ( $type =~ /^entit(y|ies)$/i ) {
3421 return entityEncode( $text );
3422 } elsif ( $type =~ /^html$/i ) {
3423 return entityEncode( $text, "\n\r" );
3424 } elsif ( $type =~ /^quotes?$/i ) {
3425 # escape quotes with backslash (Bugs:Item3383 fix)
3426 $text =~ s/\"/\\"/go;
3428 } elsif ($type =~ /^url$/i) {
3429 $text =~ s/\r*\n\r*/<br \/>/; # Legacy.
3430 return urlEncode( $text );
3435 my ($this, $params) = @_;
3437 return '' unless $params->{_DEFAULT} &&
3438 defined $TWiki::cfg{AccessibleENV} &&
3439 $params->{_DEFAULT} =~ /$TWiki::cfg{AccessibleENV}/o;
3440 my $val = $ENV{$params->{_DEFAULT}};
3441 return 'not set' unless defined $val;
3446 my ( $this, $params, $topic, $web ) = @_;
3447 # pass on all attrs, and add some more
3448 #$params->{_callback} = undef;
3449 $params->{inline} = 1;
3450 $params->{baseweb} = $web;
3451 $params->{basetopic} = $topic;
3452 $params->{search} = $params->{_DEFAULT} if( $params->{_DEFAULT} );
3453 $params->{type} = $this->{prefs}->getPreferencesValue( 'SEARCHVARDEFAULTTYPE' ) unless( $params->{type} );
3456 $s = $this->search->searchWeb( %$params );
3457 } catch Error::Simple with {
3458 my $message = (DEBUG) ? shift->stringify() : shift->{-text};
3459 # Block recursions kicked off by the text being repeated in the
3461 $message =~ s/%([A-Z]*[{%])/%<nop>$1/g;
3462 $s = $this->inlineAlert( 'alerts', 'bad_search', $message );
3468 my( $this, $params ) = @_;
3469 my $format = $params->{_DEFAULT} || $params->{'format'} || '$name';
3470 $format ||= '$name';
3471 my $separator = $params->{separator} || "\n";
3472 $separator =~ s/\$n/\n/;
3473 my $web = $params->{web} || '';
3474 my $webs = $params->{webs} || 'public';
3475 my $selection = $params->{selection} || '';
3476 my $showWeb = $params->{subwebs} || '';
3477 $selection =~ s/\,/ /g;
3478 $selection = " $selection ";
3479 my $marker = $params->{marker} || 'selected="selected"';
3483 my @webslist = split( /,\s*/, $webs );
3484 foreach my $aweb ( @webslist ) {
3485 if( $aweb eq 'public' ) {
3486 push( @list, $this->{store}->getListOfWebs( 'user,public,allowed', $showWeb ) );
3487 } elsif( $aweb eq 'webtemplate' ) {
3488 push( @list, $this->{store}->getListOfWebs( 'template,allowed', $showWeb ));
3490 push( @list, $aweb ) if( $this->{store}->webExists( $aweb ) );
3495 my $indent = CGI::span({class=>'twikiWebIndent'},'');
3496 foreach my $item ( @list ) {
3498 $line =~ s/\$web\b/$web/g;
3499 $line =~ s/\$name\b/$item/g;
3500 $line =~ s/\$qname/"$item"/g;
3501 my $indenteditem = $item;
3502 $indenteditem =~ s#/$##g;
3503 $indenteditem =~ s#\w+/#$indent#g;
3504 $line =~ s/\$indentedname/$indenteditem/g;
3505 my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
3506 $line =~ s/\$marker/$mark/g;
3507 push(@items, $line);
3509 return join( $separator, @items);
3513 my( $this, $params ) = @_;
3514 my $format = $params->{_DEFAULT} || $params->{'format'} || '$topic';
3515 my $separator = $params->{separator} || "\n";
3516 $separator =~ s/\$n/\n/;
3517 my $web = $params->{web} || $this->{webName};
3518 my $selection = $params->{selection} || '';
3519 $selection =~ s/\,/ /g;
3520 $selection = " $selection ";
3521 my $marker = $params->{marker} || 'selected="selected"';
3525 $web ne $this->{webName} &&
3526 $this->{prefs}->getWebPreferencesValue( 'NOSEARCHALL', $web );
3529 foreach my $item ( $this->{store}->getTopicNames( $web ) ) {
3531 $line =~ s/\$web\b/$web/g;
3532 $line =~ s/\$topic\b/$item/g;
3533 $line =~ s/\$name\b/$item/g; # Undocumented, DO NOT REMOVE
3534 $line =~ s/\$qname/"$item"/g; # Undocumented, DO NOT REMOVE
3535 my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
3536 $line =~ s/\$marker/$mark/g;
3537 $line = expandStandardEscapes( $line );
3538 push( @items, $line );
3540 return join( $separator, @items);
3545 return $this->{cgiQuery}->query_string();
3549 my ( $this, $params ) = @_;
3550 return '' unless $this->{cgiQuery};
3551 my $format = defined $params->{format} ? $params->{format} :
3553 my $separator = defined $params->{separator} ? $params->{separator} : "\n";
3554 my $encoding = $params->{encoding} || '';
3557 foreach my $name ( $this->{cgiQuery}->param() ) {
3558 # Issues multi-valued parameters as separate hiddens
3559 my $value = $this->{cgiQuery}->param( $name );
3561 $value = _encode($encoding, $value);
3563 my $entry = $format;
3564 $entry =~ s/\$name/$name/g;
3565 $entry =~ s/\$value/$value/;
3566 push(@list, $entry);
3568 return expandStandardEscapes(join($separator, @list));
3572 my( $this, $params ) = @_;
3573 my $param = $params->{_DEFAULT} || '';
3574 my $newLine = $params->{newline};
3575 my $encode = $params->{encode};
3576 my $multiple = $params->{multiple};
3577 my $separator = $params->{separator};
3578 $separator="\n" unless (defined $separator);
3581 if( $this->{cgiQuery} ) {
3582 if( TWiki::isTrue( $multiple )) {
3583 my @valueArray = $this->{cgiQuery}->param( $param );
3585 # join multiple values properly
3586 unless( $multiple =~ m/^on$/i ) {
3591 $_ .= $item unless( s/\$item/$item/go );
3595 $value = join ( $separator, @valueArray );
3598 $value = $this->{cgiQuery}->param( $param );
3601 if( defined $value ) {
3602 $value =~ s/\r?\n/$newLine/go if( defined $newLine );
3604 if ( $encode =~ /^entit(y|ies)$/i ) {
3605 $value = entityEncode( $value );
3606 } elsif ( $encode =~ /^quotes?$/i ) {
3607 $value =~ s/\"/\\"/go; # escape quotes with backslash (Bugs:Item3383 fix)
3609 $value =~ s/\r*\n\r*/<br \/>/; # Legacy
3610 $value = urlEncode( $value );
3614 unless( defined $value ) {
3615 $value = $params->{default};
3616 $value = '' unless defined $value;
3618 # Block expansion of %URLPARAM in the value to prevent recursion
3619 $value =~ s/%URLPARAM{/%<nop>URLPARAM{/g;
3623 # This routine was introduced to URL encode Mozilla UTF-8 POST URLs in the
3624 # TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now
3625 # directly supported, but it is provided for backward compatibility with
3626 # skins that may still be using the deprecated %INTURLENCODE%.
3627 sub INTURLENCODE_deprecated {
3628 my( $this, $params ) = @_;
3629 # Just strip double quotes, no URL encoding - Mozilla UTF-8 URLs
3630 # directly supported now
3631 return $params->{_DEFAULT} || '';
3634 # This routine is deprecated as of DakarRelease,
3635 # and is maintained only for backward compatibility.
3636 # Spacing of WikiWords is now done with %SPACEOUT%
3637 # (and the private routine _SPACEOUT).
3638 # Move to compatibility module in TWiki5
3639 sub SPACEDTOPIC_deprecated {
3640 my ( $this, $params, $theTopic ) = @_;
3641 my $topic = spaceOutWikiWord( $theTopic );
3643 return urlEncode( $topic );
3647 my ( $this, $params ) = @_;
3648 my $spaceOutTopic = $params->{_DEFAULT};
3649 my $sep = $params->{'separator'};
3650 $spaceOutTopic = spaceOutWikiWord( $spaceOutTopic, $sep );
3651 return $spaceOutTopic;
3655 my( $this, $params ) = @_;
3656 my $file = $params->{_DEFAULT} || '';
3657 # Try to map the file name to see if there is a matching filetype image
3658 # If no mapping could be found, use the file name that was passed
3659 my $iconFileName = $this->mapToIconFileName( $file, $file );
3660 return CGI::img( { src => $this->getIconUrl( 0, $iconFileName ),
3661 width => 16, height=>16,
3662 align => 'top', alt => $iconFileName, border => 0 });
3666 my( $this, $params ) = @_;
3667 my $file = ( $params->{_DEFAULT} || '' );
3669 return $this->getIconUrl( 1, $file );
3673 my( $this, $params ) = @_;
3674 my $file = ( $params->{_DEFAULT} || '' );
3676 return $this->getIconUrl( 0, $file );
3679 sub RELATIVETOPICPATH {
3680 my ( $this, $params, $theTopic, $web ) = @_;
3681 my $topic = $params->{_DEFAULT};
3683 return '' unless $topic;
3685 my $theRelativePath;
3686 # if there is no dot in $topic, no web has been specified
3687 if ( index( $topic, '.' ) == -1 ) {
3689 $theRelativePath = $web . '/' . $topic;
3691 $theRelativePath = $topic; #including dot
3693 # replace dot by slash is not necessary; TWiki.MyTopic is a valid url
3694 # add ../ if not already present to make a relative file reference
3695 if ( $theRelativePath !~ m!^../! ) {
3696 $theRelativePath = "../$theRelativePath";
3698 return $theRelativePath;
3702 my ( $this, $params, $topic, $web ) = @_;
3703 return $this->getPubUrl(0, $web, $topic);
3707 my ( $this, $params, $topic, $web ) = @_;
3708 return $this->getPubUrl(1, $web, $topic);
3713 return $this->i18n->language();
3717 my ( $this , $params ) = @_;
3718 my $format = $params->{format} || " * \$langname";
3719 my $separator = $params->{separator} || "\n";
3720 $separator =~ s/\\n/\n/g;
3721 my $selection = $params->{selection} || '';
3722 $selection =~ s/\,/ /g;
3723 $selection = " $selection ";
3724 my $marker = $params->{marker} || 'selected="selected"';
3726 # $languages is a hash reference:
3727 my $languages = $this->i18n->enabled_languages();
3729 my @tags = sort(keys(%{$languages}));
3733 foreach my $lang (@tags) {
3735 my $name = ${$languages}{$lang};
3736 $item =~ s/\$langname/$name/g;
3737 $item =~ s/\$langtag/$lang/g;
3738 my $mark = ( $selection =~ / \Q$lang\E / ) ? $marker : '';
3739 $item =~ s/\$marker/$mark/g;
3740 $result .= $separator if $i;
3749 my( $this, $params ) = @_;
3751 my $str = $params->{_DEFAULT} || $params->{string} || "";
3752 return "" unless $str;
3754 # escape everything:
3758 # restore already escaped stuff:
3759 $str =~ s/~~\[/~[/g;
3760 $str =~ s/~~\]/~]/g;
3762 # unescape parameters and calculate highest parameter number:
3764 $str =~ s/~\[(\_(\d+))~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
3765 $str =~ s/~\[(\*,\_(\d+),[^,]+(,([^,]+))?)~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
3767 # get the args to be interpolated.
3768 my $argsStr = $params->{args} || "";
3770 my @args = split (/\s*,\s*/, $argsStr) ;
3771 # fill omitted args with zeros
3772 while ((scalar @args) < $max) {
3777 my $result = $this->i18n->maketext($str, @args);
3779 # replace accesskeys:
3780 $result =~ s#(^|[^&])&([a-zA-Z])#$1<span class='twikiAccessKey'>$2</span>#g;
3782 # replace escaped amperstands:
3783 $result =~ s/&&/\&/g;
3789 #my ( $this, $params, $theTopic, $theWeb ) = @_;
3790 # try SCRIPT_FILENAME
3791 my $value = $ENV{SCRIPT_FILENAME};
3793 $value =~ s!.*/([^/]+)$!$1!o;
3796 # try SCRIPT_URL (won't work with url rewriting)
3797 $value = $ENV{SCRIPT_URL};
3799 # e.g. '/cgi-bin/view.cgi/TWiki/WebHome'
3800 # cut URL path to get 'view.cgi/TWiki/WebHome'
3801 $value =~ s|^$TWiki::cfg{ScriptUrlPath}/?||o;
3802 # cut extended path to get 'view.cgi'
3811 my ( $this, $params, $topic, $web ) = @_;
3812 my $script = $params->{_DEFAULT} || '';
3814 return $this->getScriptUrl( 1, $script );
3818 my ( $this, $params, $topic, $web ) = @_;
3819 my $script = $params->{_DEFAULT} || '';
3821 return $this->getScriptUrl( 0, $script );
3826 return $this->getPubUrl(1);
3831 return $this->getPubUrl(0);
3835 return shift->{prefs}->stringify();
3839 my ( $this, $params, $topic, $web ) = @_;
3841 my $meta = $this->inContext( 'can_render_meta' );
3843 return '' unless $meta;
3845 my $option = $params->{_DEFAULT} || '';
3848 if( $option eq 'form' ) {
3849 # META:FORM and META:FIELD
3850 $result = $meta->renderFormForDisplay( $this->templates );
3851 } elsif ( $option eq 'formfield' ) {
3852 # a formfield from within topic text
3853 $result = $meta->renderFormFieldForDisplay( $params->get('name'), '$value', $params );
3854 } elsif( $option eq 'attachments' ) {
3855 # renders attachment tables
3856 $result = $this->attach->renderMetaData( $web, $topic, $meta, $params );
3857 } elsif( $option eq 'moved' ) {
3858 $result = $this->renderer->renderMoved( $web, $topic, $meta, $params );
3859 } elsif( $option eq 'parent' ) {
3860 $result = $this->renderer->renderParent( $web, $topic, $meta, $params );
3863 return expandStandardEscapes($result);
3866 # Remove NOP tag in template topics but show content. Used in template
3867 # _topics_ (not templates, per se, but topics used as templates for new
3870 my ( $this, $params, $topic, $web ) = @_;
3872 return '<nop>' unless $params->{_RAW};
3874 return $params->{_RAW};
3877 # Shortcut to %TMPL:P{"sep"}%
3880 return $this->templates->expandTemplate('sep');
3883 #deprecated functionality, now implemented using %USERINFO%
3884 #move to compatibility plugin in TWiki5
3885 sub WIKINAME_deprecated {
3886 my ( $this, $params ) = @_;
3888 $params->{format} = $this->{prefs}->getPreferencesValue( 'WIKINAME' ) ||
3891 return $this->USERINFO($params);
3894 #deprecated functionality, now implemented using %USERINFO%
3895 #move to compatibility plugin in TWiki5
3896 sub USERNAME_deprecated {
3897 my ( $this, $params ) = @_;
3899 $params->{format} = $this->{prefs}->getPreferencesValue( 'USERNAME' ) ||
3902 return $this->USERINFO($params);
3905 #deprecated functionality, now implemented using %USERINFO%
3906 #move to compatibility plugin in TWiki5
3907 sub WIKIUSERNAME_deprecated {
3908 my ( $this, $params ) = @_;
3911 $this->{prefs}->getPreferencesValue( 'WIKIUSERNAME' ) ||
3914 return $this->USERINFO($params);
3918 my ( $this, $params ) = @_;
3919 my $format = $params->{format} || '$username, $wikiusername, $emails';
3921 my $user = $this->{user};
3923 if( $params->{_DEFAULT} ) {
3924 $user = $params->{_DEFAULT};
3925 return '' if !$user;
3926 # map wikiname to a login name
3927 $user = $this->{users}->getCanonicalUserID($user);
3928 return '' unless $user;
3929 return '' if( $TWiki::cfg{AntiSpam}{HideUserDetails} &&
3930 !$this->{users}->isAdmin( $this->{user} ) &&
3931 $user ne $this->{user} );
3934 return '' unless $user;
3938 if ($info =~ /\$username/) {
3939 my $username = $this->{users}->getLoginName($user);
3940 $username = 'unknown' unless defined $username;
3941 $info =~ s/\$username/$username/g;
3943 if ($info =~ /\$wikiname/) {
3944 my $wikiname = $this->{users}->getWikiName( $user );
3945 $wikiname = 'UnknownUser' unless defined $wikiname;
3946 $info =~ s/\$wikiname/$wikiname/g;
3948 if ($info =~ /\$wikiusername/) {
3949 my $wikiusername = $this->{users}->webDotWikiName($user);
3950 $wikiusername = "$TWiki::cfg{UsersWebName}.UnknownUser"
3951 unless defined $wikiusername;
3952 $info =~ s/\$wikiusername/$wikiusername/g;
3954 if ($info =~ /\$emails/) {
3955 my $emails = join(', ', $this->{users}->getEmails($user));
3956 $info =~ s/\$emails/$emails/g;
3958 if ($info =~ /\$groups/) {
3960 my $it = $this->{users}->eachMembership( $user );
3961 while( $it->hasNext()) {
3962 my $group = $it->next();
3963 push( @groupNames, $group);
3965 my $groups = join(', ', @groupNames);
3966 $info =~ s/\$groups/$groups/g;
3968 if ($info =~ /\$cUID/) {
3970 $info =~ s/\$cUID/$cUID/g;
3972 if ($info =~ /\$admin/) {
3973 my $admin = $this->{users}->isAdmin($user) ? 'true' : 'false';
3974 $info =~ s/\$admin/$admin/g;
3981 my ( $this, $params ) = @_;
3983 my $groups = $this->{users}->eachGroup();
3985 while( $groups->hasNext() ) {
3986 my $group = $groups->next();
3987 # Nop it to prevent wikiname expansion unless the topic exists.
3988 my $groupLink = "<nop>$group";
3989 $groupLink = '[['.$TWiki::cfg{UsersWebName}.".$group][$group]]" if ($this->{store}->topicExists($TWiki::cfg{UsersWebName}, $group));
3990 my $descr = "| $groupLink |";
3991 my $it = $this->{users}->eachGroupMember( $group );
3992 my $limit_output = 32;
3993 while( $it->hasNext() ) {
3994 my $user = $it->next();
3995 $descr .= ' [['.$this->{users}->webDotWikiName($user).']['.
3996 $this->{users}->getWikiName( $user ).']]';
3997 if ($limit_output == 0) {
3998 $descr .= '<div>%MAKETEXT{"user list truncated"}%</div>';
4003 push( @table, "$descr |");
4006 return '| *Group* | *Members* |'."\n".join("\n", sort @table);
4011 # TWiki Enterprise Collaboration Platform, http://TWiki.org/
4013 # Copyright (C) 1999-2007 Peter Thoeny, peter@thoeny.org
4014 # and TWiki Contributors. All Rights Reserved. TWiki Contributors
4015 # are listed in the AUTHORS file in the root of this distribution.
4016 # NOTE: Please extend that file, not this notice.
4018 # Additional copyrights apply to some or all of the code in this
4021 # Based on parts of Ward Cunninghams original Wiki and JosWiki.
4022 # Copyright (C) 1998 Markus Peter - SPiN GmbH (warpi@spin.de)
4023 # Some changes by Dave Harris (drh@bhresearch.co.uk) incorporated
4025 # This program is free software; you can redistribute it and/or
4026 # modify it under the terms of the GNU General Public License
4027 # as published by the Free Software Foundation; either version 2
4028 # of the License, or (at your option) any later version. For
4029 # more details read LICENSE in the root of this distribution.
4031 # This program is distributed in the hope that it will be useful,
4032 # but WITHOUT ANY WARRANTY; without even the implied warranty of
4033 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
4035 # As per the GPL, removal of this notice is prohibited.