1# TWiki Enterprise Collaboration Platform, http://TWiki.org/ 2# 3# Copyright (C) 1999-2018 Peter Thoeny, peter[at]thoeny.org 4# Copyright (C) 2006-2018 TWiki Contributors. All Rights Reserved. 5# TWiki Contributors are listed in the AUTHORS file in the root of 6# this distribution. NOTE: Please extend that file, not this notice. 7# 8# Additional copyrights apply to some or all of the code in this 9# file as follows: 10# 11# Based on parts of Ward Cunninghams original Wiki and JosWiki. 12# Copyright (C) 1998 Markus Peter - SPiN GmbH (warpi@spin.de) 13# Some changes by Dave Harris (drh@bhresearch.co.uk) incorporated 14# 15# This program is free software; you can redistribute it and/or 16# modify it under the terms of the GNU General Public License 17# as published by the Free Software Foundation; either version 3 18# of the License, or (at your option) any later version. For 19# more details read LICENSE in the root of this distribution. 20# 21# This program is distributed in the hope that it will be useful, 22# but WITHOUT ANY WARRANTY; without even the implied warranty of 23# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 24# 25# As per the GPL, removal of this notice is prohibited. 26 27package TWiki; 28 29=pod 30 31---+ package TWiki 32 33TWiki operates by creating a singleton object (known as the Session 34object) that acts as a point of reference for all the different 35modules in the system. This package is the class for this singleton, 36and also contains the vast bulk of the basic constants and the per- 37site configuration mechanisms. 38 39Global variables are avoided wherever possible to avoid problems 40with CGI accelerators such as mod_perl. 41 42---+++!! Public Data members 43 * =request= Pointer to the TWiki::Request 44 * =response= Pointer to the TWiki::Respose 45 * =context= Hash of context ids 46 * moved: =loginManager= TWiki::LoginManager singleton (moved to TWiki::Users) 47 * =plugins= TWiki::Plugins singleton 48 * =prefs= TWiki::Prefs singleton 49 * =remoteUser= Login ID when using ApacheLogin. Maintained for 50 compatibility only, do not use. 51 * =requestedWebName= Name of web found in URL path or =web= URL parameter 52 * =sandbox= TWiki::Sandbox singleton 53 * =scriptUrlPath= URL path to the current script. May be dynamically 54 extracted from the URL path if {GetScriptUrlFromCgi}. 55 Only required to support {GetScriptUrlFromCgi} and 56 not consistently used. Avoid. 57 * =security= TWiki::Access singleton 58 * =SESSION_TAGS= Hash of TWiki variables whose value is specific to 59 the current request. 60 * =store= TWiki::Store singleton 61 * =topicName= Name of topic found in URL path or =topic= URL 62 parameter 63 * =urlHost= Host part of the URL (including the protocol) 64 determined during intialisation and defaulting to 65 {DefaultUrlHost} 66 * =user= Unique user ID of logged-in user 67 * =users= TWiki::Users singleton 68 * =webName= Name of web found in URL path, or =web= URL parameter, 69 or {UsersWebName} 70 71=cut 72 73use strict; 74use Assert; 75use Error qw( :try ); 76use CGI; 77$CGI::LIST_CONTEXT_WARN = 0; 78use TWiki::Response; 79use TWiki::Request; 80use TWiki::Time; 81 82require 5.010001; # Perl 5.10.1 83 84# Site configuration constants 85use vars qw( %cfg ); 86 87# Uncomment this and the __END__ to enable AutoLoader 88#use AutoLoader 'AUTOLOAD'; 89# You then need to autosplit TWiki.pm: 90# cd lib 91# perl -e 'use AutoSplit; autosplit("TWiki.pm", "auto")' 92 93# Other computed constants 94use vars qw( 95 $TranslationToken 96 $percentSubstitute 97 $twikiLibDir 98 %regex 99 %functionTags 100 %contextFreeSyntax 101 %restDispatch 102 $VERSION $RELEASE 103 $TRUE 104 $FALSE 105 $sandbox 106 $engine 107 $ifParser 108 %scriptOnMaster 109 %httpHiddenField 110 ); 111 112# Token character that must not occur in any normal text - converted 113# to a flag character if it ever does occur (very unlikely) 114# TWiki uses $TranslationToken to mark points in the text. This is 115# normally \0, which is not a useful character in any 8-bit character 116# set we can find, nor in UTF-8. But if you *do* encounter problems 117# with it, the workaround is to change $TranslationToken to something 118# longer that is unlikely to occur in your text - for example 119# muRfleFli5ble8leep (do *not* use punctuation characters or whitspace 120# in the string!) 121# See Codev.NationalCharTokenClash for more. 122$TranslationToken= "\0"; 123 124# Hack to substitute a % into a non-printable character so that a 125# search string can be passed from URLPARAM to SEARCH without variable 126# expansion, e.g. for a literal search. 127# (TWiki:Codev.NewModeSearchEncodingInENCODEandURLPARAM & Item7847) 128$percentSubstitute = "\x1a"; 129 130=pod 131 132---++ StaticMethod getTWikiLibDir() -> $path 133 134Returns the full path of the directory containing TWiki.pm 135 136=cut 137 138sub getTWikiLibDir { 139 if( $twikiLibDir ) { 140 return $twikiLibDir; 141 } 142 143 # FIXME: Should just use $INC{"TWiki.pm"} to get path used to load this 144 # module. 145 my $dir = ''; 146 foreach $dir ( @INC ) { 147 if( $dir && -e "$dir/TWiki.pm" ) { 148 $twikiLibDir = $dir; 149 last; 150 } 151 } 152 153 # fix path relative to location of called script 154 if( $twikiLibDir =~ /^\./ ) { 155 print STDERR "WARNING: TWiki lib path $twikiLibDir is relative; you should make it" 156 . " absolute, otherwise some scripts may not run from the command line."; 157 my $bin; 158 # TSA SMELL : Should not assume environment variables and get data from request 159 if( $ENV{SCRIPT_FILENAME} && 160 $ENV{SCRIPT_FILENAME} =~ /^(.+)\/[^\/]+$/ ) { 161 # CGI script name 162 $bin = $1; 163 } elsif ( $0 =~ /^(.*)\/.*?$/ ) { 164 # program name 165 $bin = $1; 166 } else { 167 # last ditch; relative to current directory. 168 require Cwd; 169 import Cwd qw( cwd ); 170 $bin = cwd(); 171 } 172 $twikiLibDir = "$bin/$twikiLibDir/"; 173 # normalize "/../" and "/./" 174 while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) { 175 }; 176 $twikiLibDir =~ s|([\\/])\.[\\/]|$1|g; 177 } 178 $twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/" 179 $twikiLibDir =~ s|[\\/]$||; # cut trailing "/" 180 181 return $twikiLibDir; 182} 183 184BEGIN { 185 require TWiki::Sandbox; # system command sandbox 186 require TWiki::Configure::Load; # read configuration files 187 188 $TRUE = 1; 189 $FALSE = 0; 190 191 if( DEBUG ) { 192 # If ASSERTs are on, then warnings are errors. Paranoid, 193 # but the only way to be sure we eliminate them all. 194 # Look out also for $cfg{WarningsAreErrors}, below, which 195 # is another way to install this handler without enabling 196 # ASSERTs 197 # ASSERTS are turned on by defining the environment variable 198 # TWIKI_ASSERTS. If ASSERTs are off, this is assumed to be a 199 # production environment, and no stack traces or paths are 200 # output to the browser. 201 $SIG{'__WARN__'} = sub { die @_ }; 202 $Error::Debug = 1; # verbose stack traces, please 203 } else { 204 $Error::Debug = 0; # no verbose stack traces 205 } 206 207 # DO NOT CHANGE THE FORMAT OF $VERSION 208 # The $VERSION is automatically expanded on checkin of this module 209 $VERSION = '$Date: 2018-07-16 12:09:47 +0900 (Mon, 16 Jul 2018) $ $Rev: 30610 (2018-07-16) $ '; 210 $RELEASE = 'TWiki-6.1.0'; 211 $VERSION =~ s/^.*?\((.*)\).*: (\d+) .*?$/$RELEASE, $1, build $2/; 212 213 # Default handlers for different %TAGS% 214 %functionTags = ( 215 ADDTOHEAD => \&ADDTOHEAD, 216 ALLVARIABLES => \&ALLVARIABLES, 217 ATTACHURL => \&ATTACHURL, 218 ATTACHURLPATH => \&ATTACHURLPATH, 219 BASETOPIC => \&BASETOPIC, 220 BASEWEB => \&BASEWEB, 221 CONTENTMODE => \&CONTENTMODE, 222 CRYPTTOKEN => \&CRYPTTOKEN, 223 DATE => \&DATE, 224 DISKID => \&DISKID, 225 DISPLAYTIME => \&DISPLAYTIME, 226 EDITFORM => \&EDITFORM, 227 EDITFORMFIELD => \&EDITFORMFIELD, 228 ENCODE => \&ENCODE, 229 ENTITY => \&ENTITY, 230 ENV => \&ENV, 231 FORM => \&FORM, 232 FORMFIELD => \&FORMFIELD, 233 GMTIME => \&GMTIME, 234 GROUPS => \&GROUPS, 235 HIDE => \&HIDE, 236 HIDEINPRINT => \&HIDEINPRINT, 237 HTTP_HOST => \&HTTP_HOST_deprecated, 238 HTTP => \&HTTP, 239 HTTPS => \&HTTPS, 240 ICON => \&ICON, 241 ICONURL => \&ICONURL, 242 ICONURLPATH => \&ICONURLPATH, 243 IF => \&IF, 244 INCLUDE => \&INCLUDE, 245 INCLUDINGTOPIC => \&INCLUDINGTOPIC, 246 INCLUDINGWEB => \&INCLUDINGWEB, 247 INTURLENCODE => \&INTURLENCODE_deprecated, 248 LANGUAGES => \&LANGUAGES, 249 MAKETEXT => \&MAKETEXT, 250 MDREPO => \&MDREPO, 251 META => \&META, 252 METASEARCH => \&METASEARCH, 253 NOP => \&NOP, 254 PARENTTOPIC => \&PARENTTOPIC, 255 PLUGINVERSION => \&PLUGINVERSION, 256 PUBURL => \&PUBURL, 257 PUBURLPATH => \&PUBURLPATH, 258 QUERYPARAMS => \&QUERYPARAMS, 259 QUERYSTRING => \&QUERYSTRING, 260 RELATIVETOPICPATH => \&RELATIVETOPICPATH, 261 REMOTE_ADDR => \&REMOTE_ADDR_deprecated, 262 REMOTE_PORT => \&REMOTE_PORT_deprecated, 263 REMOTE_USER => \&REMOTE_USER_deprecated, 264 RENDERHEAD => \&RENDERHEAD, 265 REVINFO => \&REVINFO, 266 REVTITLE => \&REVTITLE, 267 REVARG => \&REVARG, 268 SCRIPTNAME => \&SCRIPTNAME, 269 SCRIPTURL => \&SCRIPTURL, 270 SCRIPTURLPATH => \&SCRIPTURLPATH, 271 SEARCH => \&SEARCH, 272 SEP => \&SEP, 273 SERVERTIME => \&SERVERTIME, 274 SPACEDTOPIC => \&SPACEDTOPIC_deprecated, 275 SPACEOUT => \&SPACEOUT, 276 'TMPL:P' => \&TMPLP, 277 TOPIC => \&TOPIC, 278 TOPICLIST => \&TOPICLIST, 279 TOPICTITLE => \&TOPICTITLE, 280 TRASHWEB => \&TRASHWEB, 281 URLENCODE => \&ENCODE, 282 URLPARAM => \&URLPARAM, 283 LANGUAGE => \&LANGUAGE, 284 USERINFO => \&USERINFO, 285 USERNAME => \&USERNAME_deprecated, 286 VAR => \&VAR, 287 WEB => \&WEB, 288 WEBLIST => \&WEBLIST, 289 WIKINAME => \&WIKINAME_deprecated, 290 WIKIUSERNAME => \&WIKIUSERNAME_deprecated, 291 WIKIWEBMASTER => \&WIKIWEBMASTER, 292 WIKIWEBMASTERNAME => \&WIKIWEBMASTERNAME, 293 # Constant tag strings _not_ dependent on config. These get nicely 294 # optimised by the compiler. 295 ENDSECTION => sub { '' }, 296 WIKIVERSION => sub { $VERSION }, 297 STARTSECTION => sub { '' }, 298 STARTINCLUDE => sub { '' }, 299 STOPINCLUDE => sub { '' }, 300 ); 301 $contextFreeSyntax{IF} = 1; 302 303 unless( ( $TWiki::cfg{DetailedOS} = $^O ) ) { 304 require Config; 305 $TWiki::cfg{DetailedOS} = $Config::Config{'osname'}; 306 } 307 $TWiki::cfg{OS} = 'UNIX'; 308 if ($TWiki::cfg{DetailedOS} =~ /darwin/i) { # MacOS X 309 $TWiki::cfg{OS} = 'UNIX'; 310 } elsif ($TWiki::cfg{DetailedOS} =~ /Win/i) { 311 $TWiki::cfg{OS} = 'WINDOWS'; 312 } elsif ($TWiki::cfg{DetailedOS} =~ /vms/i) { 313 $TWiki::cfg{OS} = 'VMS'; 314 } elsif ($TWiki::cfg{DetailedOS} =~ /bsdos/i) { 315 $TWiki::cfg{OS} = 'UNIX'; 316 } elsif ($TWiki::cfg{DetailedOS} =~ /dos/i) { 317 $TWiki::cfg{OS} = 'DOS'; 318 } elsif ($TWiki::cfg{DetailedOS} =~ /^MacOS$/i) { # MacOS 9 or earlier 319 $TWiki::cfg{OS} = 'MACINTOSH'; 320 } elsif ($TWiki::cfg{DetailedOS} =~ /os2/i) { 321 $TWiki::cfg{OS} = 'OS2'; 322 } 323 324 # Validate and untaint Apache's SERVER_NAME Environment variable 325 # for use in referencing virtualhost-based paths for separate data/ and templates/ instances, etc 326 if ( $ENV{SERVER_NAME} && 327 $ENV{SERVER_NAME} =~ /^(([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6})$/ ) { 328 $ENV{SERVER_NAME} = 329 TWiki::Sandbox::untaintUnchecked( $ENV{SERVER_NAME} ); 330 } 331 332 # readConfig is defined in TWiki::Configure::Load to allow overriding it 333 TWiki::Configure::Load::readConfig(); 334 335 if( $TWiki::cfg{WarningsAreErrors} ) { 336 # Note: Warnings are always errors if ASSERTs are enabled 337 $SIG{'__WARN__'} = sub { die @_ }; 338 } 339 340 if( $TWiki::cfg{UseLocale} ) { 341 require locale; 342 import locale(); 343 } 344 345 # Constant tags dependent on the config 346 $functionTags{ALLOWLOGINNAME} = 347 sub { $TWiki::cfg{Register}{AllowLoginName} || 0 }; 348 $functionTags{AUTHREALM} = sub { $TWiki::cfg{AuthRealm} }; 349 $functionTags{DEFAULTURLHOST} = sub { $TWiki::cfg{DefaultUrlHost} }; 350 $functionTags{HOMETOPIC} = sub { $TWiki::cfg{HomeTopicName} }; 351 $functionTags{LOCALSITEPREFS} = sub { $TWiki::cfg{LocalSitePreferences} }; 352 $functionTags{NOFOLLOW} = 353 sub { $TWiki::cfg{NoFollow} ? 'rel='.$TWiki::cfg{NoFollow} : '' }; 354 $functionTags{NOTIFYTOPIC} = sub { $TWiki::cfg{NotifyTopicName} }; 355 $functionTags{SCRIPTSUFFIX} = sub { $TWiki::cfg{ScriptSuffix} }; 356 $functionTags{SITESTATISTICSTOPIC} = sub { $TWiki::cfg{Stats}{SiteStatsTopicName} }; 357 $functionTags{STATISTICSTOPIC} = sub { $TWiki::cfg{Stats}{TopicName} }; 358 $functionTags{SYSTEMWEB} = sub { $TWiki::cfg{SystemWebName} }; 359 # $functionTags{TRASHWEB} = sub { $TWiki::cfg{TrashWebName} }; 360 $functionTags{TWIKIADMINLOGIN} = sub { $TWiki::cfg{AdminUserLogin} }; 361 $functionTags{USERSWEB} = sub { $TWiki::cfg{UsersWebName} }; 362 $functionTags{WEBPREFSTOPIC} = sub { $TWiki::cfg{WebPrefsTopicName} }; 363 $functionTags{WIKIPREFSTOPIC} = sub { $TWiki::cfg{SitePrefsTopicName} }; 364 $functionTags{WIKIUSERSTOPIC} = sub { $TWiki::cfg{UsersTopicName} }; 365 if ( $TWiki::cfg{UserSubwebs}{Enabled} ) { 366 $functionTags{USERPREFSTOPIC} = 367 sub { $TWiki::cfg{UserSubwebs}{UserPrefsTopicName} }; 368 } 369 370 # Compatibility synonyms, deprecated in 4.2 but still used throughout 371 # the documentation. 372 $functionTags{MAINWEB} = $functionTags{USERSWEB}; 373 $functionTags{TWIKIWEB} = $functionTags{SYSTEMWEB}; 374 375 # locale setup 376 # 377 # 378 # Note that 'use locale' must be done in BEGIN block for regexes and 379 # sorting to work properly, although regexes can still work without 380 # this in 'non-locale regexes' mode. 381 382 if ( $TWiki::cfg{UseLocale} ) { 383 # Set environment variables for grep 384 $ENV{LC_CTYPE} = $TWiki::cfg{Site}{Locale}; 385 386 # Load POSIX for I18N support. 387 require POSIX; 388 import POSIX qw( locale_h LC_CTYPE LC_COLLATE ); 389 390 # SMELL: mod_perl compatibility note: If TWiki is running under Apache, 391 # won't this play with the Apache process's locale settings too? 392 # What effects would this have? 393 setlocale(&LC_CTYPE, $TWiki::cfg{Site}{Locale}); 394 setlocale(&LC_COLLATE, $TWiki::cfg{Site}{Locale}); 395 } 396 397 $functionTags{CHARSET} = sub { $TWiki::cfg{Site}{CharSet} || 398 'iso-8859-1' }; 399 400 # HTML 4.01 and XML refers to RFC 4646 with language specification. 401 # RFC 4646 dictates the delimiter to be a hyphen rather than an underscore. 402 my $lang = $TWiki::cfg{Site}{Lang}; 403 unless ( $lang ) { 404 if ( $TWiki::cfg{Site}{Locale} =~ m/^([a-z]+_[a-z]+)/i ) { 405 $lang = $1; 406 $lang =~ s/_/-/; 407 } 408 else { 409 $lang = 'en-US'; 410 } 411 } 412 $functionTags{LANG} = sub { $lang }; 413 414 # Set up pre-compiled regexes for use in rendering. All regexes with 415 # unchanging variables in match should use the '/o' option. 416 # In the regex hash, all precompiled REs have "Regex" at the 417 # end of the name. Anything else is a string, either intended 418 # for use as a character class, or as a sub-expression in 419 # another compiled RE. 420 421 # Build up character class components for use in regexes. 422 # Depends on locale mode and Perl version, and finally on 423 # whether locale-based regexes are turned off. 424 if ( not $TWiki::cfg{UseLocale} or $] < 5.006 425 or not $TWiki::cfg{Site}{LocaleRegexes} ) { 426 427 # No locales needed/working, or Perl 5.005, so just use 428 # any additional national characters defined in TWiki.cfg 429 $regex{upperAlpha} = 'A-Z'.$TWiki::cfg{UpperNational}; 430 $regex{lowerAlpha} = 'a-z'.$TWiki::cfg{LowerNational}; 431 $regex{numeric} = '\d'; 432 $regex{mixedAlpha} = $regex{upperAlpha}.$regex{lowerAlpha}; 433 } else { 434 # Perl 5.006 or higher with working locales 435 $regex{upperAlpha} = '[:upper:]'; 436 $regex{lowerAlpha} = '[:lower:]'; 437 $regex{numeric} = '[:digit:]'; 438 $regex{mixedAlpha} = '[:alpha:]'; 439 } 440 $regex{mixedAlphaNum} = $regex{mixedAlpha}.$regex{numeric}; 441 $regex{lowerAlphaNum} = $regex{lowerAlpha}.$regex{numeric}; 442 $regex{upperAlphaNum} = $regex{upperAlpha}.$regex{numeric}; 443 444 # Compile regexes for efficiency and ease of use 445 # Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl 446 # book at http://regex.info/. 447 448 $regex{linkProtocolPattern} = $TWiki::cfg{LinkProtocolPattern}; 449 450 # Header patterns based on '+++'. The '###' are reserved for numbered 451 # headers 452 # '---++ Header', '---## Header' 453 $regex{headerPatternDa} = qr/^---+(\++|\#+)(.*)$/m; 454 # '<h6>Header</h6> 455 $regex{headerPatternHt} = qr/^<h([1-6])>(.+?)<\/h\1>/mi; 456 # '---++!! Header' or '---++ Header %NOTOC% ^top' 457 $regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)'; 458 459 # TWiki concept regexes 460 $regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlphaNum}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/o; 461 $regex{webNameBaseRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}_]*/o; 462 if ($TWiki::cfg{EnableHierarchicalWebs}) { 463 $regex{webNameRegex} = qr/$regex{webNameBaseRegex}(?:(?:[\.\/]$regex{webNameBaseRegex})+)*/o; 464 } else { 465 $regex{webNameRegex} = $regex{webNameBaseRegex}; 466 } 467 $regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/o; 468 $regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/o; 469 $regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/o; 470 # used by _fixIncludeLink: (the last OR pattern is for Interwiki link fix Item6463) 471 $regex{excludeFixIncludeLinkRegex} = 472 qr/($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}:|\/|[$regex{upperAlpha}][$regex{mixedAlphaNum}]+:)/o; 473 474 # Simplistic email regex, e.g. for WebNotify processing - no i18n 475 # characters allowed 476 $regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_\']+\@[A-Za-z0-9\.\-]*[A-Za-z0-9])/; 477 478 # Filename regex to used to match invalid characters in attachments - allow 479 # alphanumeric characters, spaces, underscores, etc. 480 # TODO: Get this to work with I18N chars - currently used only with UseLocale off 481 $regex{filenameInvalidCharRegex} = qr/[^$regex{mixedAlphaNum}\. _-]/o; 482 483 # Multi-character alpha-based regexes 484 $regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/o; 485 486 # %TAG% name 487 $regex{tagNameRegex} = '['.$regex{mixedAlpha}.']['.$regex{mixedAlphaNum}.'_:]*'; 488 489 # Set statement in a topic 490 $regex{bulletRegex} = '^(?:\t| )+\*'; 491 $regex{setRegex} = $regex{bulletRegex}.'\s+(Set|Local)\s+'; 492 $regex{setVarRegex} = $regex{setRegex}.'('.$regex{tagNameRegex}.')\s*=\s*(.*)$'; 493 494 # Character encoding regexes 495 496 # 7-bit ASCII only 497 $regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o; 498 499 # Regex to match only a valid UTF-8 character, taking care to avoid 500 # security holes due to overlong encodings by excluding the relevant 501 # gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode 502 # Encodings section. Tested against Markus Kuhn's UTF-8 test file 503 # at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt. 504 $regex{validUtf8CharRegex} = qr{ 505 # Single byte - ASCII 506 [\x00-\x7F] 507 | 508 509 # 2 bytes 510 [\xC2-\xDF][\x80-\xBF] 511 | 512 513 # 3 bytes 514 515 # Avoid illegal codepoints - negative lookahead 516 (?!\xEF\xBF[\xBE\xBF]) 517 518 # Match valid codepoints 519 (?: 520 ([\xE0][\xA0-\xBF])| 521 ([\xE1-\xEC\xEE-\xEF][\x80-\xBF])| 522 ([\xED][\x80-\x9F]) 523 ) 524 [\x80-\xBF] 525 | 526 527 # 4 bytes 528 (?: 529 ([\xF0][\x90-\xBF])| 530 ([\xF1-\xF3][\x80-\xBF])| 531 ([\xF4][\x80-\x8F]) 532 ) 533 [\x80-\xBF][\x80-\xBF] 534 }xo; 535 536 $regex{validUtf8StringRegex} = 537 qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo; 538 539 # Check for unsafe search regex mode (affects filtering in) - default 540 # to safe mode 541 $TWiki::cfg{ForceUnsafeRegexes} = 0 unless defined $TWiki::cfg{ForceUnsafeRegexes}; 542 543 # scripts which cannot work for a slave web 544 if ( $TWiki::cfg{ReadOnlyAndMirrorWebs}{ScriptOnMaster} ) { 545 for my $script ( 546 split(/[\s,]+/, 547 $TWiki::cfg{ReadOnlyAndMirrorWebs}{ScriptOnMaster}) 548 ) { 549 $scriptOnMaster{$script} = 1; 550 } 551 } 552 553 # HTTP header fields not be exposed to users 554 if ( $TWiki::cfg{HTTP}{HiddenFields} ) { 555 for my $field ( 556 split(/[\s,]+/, 557 $TWiki::cfg{HTTP}{HiddenFields}) 558 ) { 559 $field = lc $field; 560 $field =~ s/_/-/g; 561 $httpHiddenField{$field} = 1; 562 } 563 } 564 565 # initialize lib directory early because of later 'cd's 566 getTWikiLibDir(); 567 568 # initialize the runtime engine 569 if (!defined $TWiki::cfg{Engine}) { 570 # Caller did not define an engine; try and work it out (mainly for 571 # the benefit of pre-5.0 CGI scripts) 572 if ( defined $ENV{GATEWAY_INTERFACE} or defined $ENV{MOD_PERL} ) { 573 $TWiki::cfg{Engine} = 'TWiki::Engine::CGI'; 574 use CGI::Carp qw(fatalsToBrowser); 575 $SIG{__DIE__} = \&CGI::Carp::confess; 576 } else { 577 $TWiki::cfg{Engine} = 'TWiki::Engine::CLI'; 578 require Carp; 579 $SIG{__DIE__} = \&Carp::confess; 580 } 581 } 582 $engine ||= eval qq(use $TWiki::cfg{Engine}; $TWiki::cfg{Engine}->new); 583 die $@ if $@; 584 585}; 586 587=pod 588 589---++ ObjectMethod UTF82SiteCharSet( $utf8 ) -> $ascii 590 591Auto-detect UTF-8 vs. site charset in string, and convert UTF-8 into site 592charset. 593 594=cut 595 596sub UTF82SiteCharSet { 597 my( $this, $text ) = @_; 598 599 return $text unless( defined $TWiki::cfg{Site}{CharSet} ); 600 601 # Detect character encoding of the full topic name from URL 602 return undef if( $text =~ $regex{validAsciiStringRegex} ); 603 604 # If not UTF-8 - assume in site character set, no conversion required 605 return undef unless( $text =~ $regex{validUtf8StringRegex} ); 606 607 # If site charset is already UTF-8, there is no need to convert anything: 608 if ( $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) { 609 # warn if using Perl older than 5.8 610 if( $] < 5.008 ) { 611 $this->writeWarning( 'UTF-8 not remotely supported on Perl '.$]. 612 ' - use Perl 5.8 or higher..' ); 613 } 614 615 return $text; 616 } 617 618 # Convert into ISO-8859-1 if it is the site charset. This conversion 619 # is *not valid for ISO-8859-15*. 620 if ( $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?1$/i ) { 621 # ISO-8859-1 maps onto first 256 codepoints of Unicode 622 # (conversion from 'perldoc perluniintro') 623 $text =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) / 624 chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F ) 625 /egx; 626 } else { 627 # Convert from UTF-8 into some other site charset 628 if( $] >= 5.008 ) { 629 require Encode; 630 import Encode qw(:fallbacks); 631 # Map $TWiki::cfg{Site}{CharSet} into real encoding name 632 my $charEncoding = 633 Encode::resolve_alias( $TWiki::cfg{Site}{CharSet} ); 634 if( not $charEncoding ) { 635 $this->writeWarning 636 ( 'Conversion to "'.$TWiki::cfg{Site}{CharSet}. 637 '" not supported, or name not recognised - check '. 638 '"perldoc Encode::Supported"' ); 639 } else { 640 # Convert text using Encode: 641 # - first, convert from UTF8 bytes into internal 642 # (UTF-8) characters 643 $text = Encode::decode('utf8', $text); 644 # - then convert into site charset from internal UTF-8, 645 # inserting \x{NNNN} for characters that can't be converted 646 $text = 647 Encode::encode( $charEncoding, $text, 648 &FB_PERLQQ() ); 649 } 650 } else { 651 require Unicode::MapUTF8; # Pre-5.8 Perl versions 652 my $charEncoding = $TWiki::cfg{Site}{CharSet}; 653 if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) { 654 $this->writeWarning 655 ( 'Conversion to "'.$TWiki::cfg{Site}{CharSet}. 656 '" not supported, or name not recognised - check '. 657 '"perldoc Unicode::MapUTF8"' ); 658 } else { 659 # Convert text 660 $text = 661 Unicode::MapUTF8::from_utf8({ 662 -string => $text, 663 -charset => $charEncoding 664 }); 665 # FIXME: Check for failed conversion? 666 } 667 } 668 } 669 return $text; 670} 671 672=pod 673 674---++ ObjectMethod writeCompletePage( $text, $pageType, $contentType, $status ) 675 676Write a complete HTML page with basic header to the browser. 677 * =$text= is the text of the page body (<html> to </html> if it's HTML) 678 * =$pageType= - May be "edit", which will cause headers to be generated that force 679 caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused 680 data loss with IE5 and IE6. 681 * =$contentType= - page content type | text/html 682 * =$status= - page status | 200 OK 683 684This method removes noautolink and nop tags before outputting the page unless 685$contentType is text/plain. 686 687=cut 688 689sub writeCompletePage { 690 my ( $this, $text, $pageType, $contentType, $status ) = @_; 691 692 # Item7197: Check utf-8 flag 693 if( $] >= 5.008 ) { 694 require Encode; 695 if( Encode::is_utf8( $text ) ) { 696 $this->writeWarning("UTF-8 flag is detected in the text (possibly from some plugins?), which should be remediated"); 697 $text = Encode::encode_utf8($text); 698 } 699 } 700 701 $contentType ||= 'text/html'; 702 703 if( $contentType ne 'text/plain' ) { 704 # Remove <nop> and <noautolink> tags 705 $text =~ s/([\t ]?)[ \t]*<\/?(nop|noautolink)\/?>/$1/gis; 706 $text .= "\n" unless $text =~ /\n$/s; 707 708 # If TWiki is enabled for CryptToken for CSRF kind of 709 # security issues, send all forms for adding token before 710 # presenting to the browser 711 if ($TWiki::cfg{CryptToken}{Enable}) { 712 $text =~ s/(<form.*?<\/form>)/$this->{users}->{loginManager}->addCryptTokeninForm($1)/geos; 713 } 714 715 my $htmlHeader = join( 716 "\n", 717 map { '<!--'.$_.'-->'.$this->{_HTMLHEADERS}{$_} } 718 keys %{$this->{_HTMLHEADERS}} ); 719 $text =~ s!(</head>)!$htmlHeader$1!i if $htmlHeader; 720 chomp($text); 721 } 722 723 $this->generateHTTPHeaders( $pageType, $contentType, $status ); 724 my $hdr; 725 foreach my $header ( keys %{ $this->{response}->headers } ) { 726 $hdr .= $header . ': ' . $_ . "\x0D0A" 727 foreach $this->{response}->getHeader($header); 728 } 729 $hdr .= "\x0D0A"; 730 731 # Call final handler 732 $this->{plugins}->dispatch( 733 'completePageHandler',$text, $hdr); 734 735 $this->{response}->body($text); 736} 737 738=pod 739 740---++ ObjectMethod generateHTTPHeaders ($pageType, $contentType, $status ) -> $header 741 742All parameters are optional. 743 744 * =$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. 745 * =$contentType= - page content type | text/html 746 * =$status= - page status | 200 OK 747 748Implements the post-Dec2001 release plugin API, which requires the 749writeHeaderHandler in plugin to return a string of HTTP headers, CR/LF 750delimited. Filters any illegal headers. Plugin headers will override 751core settings. 752 753Does *not* add a =Content-length= header. 754 755=cut 756 757sub generateHTTPHeaders { 758 my( $this, $pageType, $contentType, $status ) = @_; 759 760 my $query = $this->{request}; 761 762 # Handle Edit pages - future versions will extend to caching 763 # of other types of page, with expiry time driven by page type. 764 my( $pluginHeaders, $coreHeaders ); 765 766 my $hopts = {}; 767 768 if ($pageType && $pageType eq 'edit') { 769 # Get time now in HTTP header format 770 my $lastModifiedString = 771 TWiki::Time::formatTime(time, '$http', 'gmtime'); 772 773 # Expiry time is set high to avoid any data loss. Each instance of 774 # Edit page has a unique URL with time-string suffix (fix for 775 # RefreshEditPage), so this long expiry time simply means that the 776 # browser Back button always works. The next Edit on this page 777 # will use another URL and therefore won't use any cached 778 # version of this Edit page. 779 my $expireHours = 24; 780 my $expireSeconds = $expireHours * 60 * 60; 781 782 # and cache control headers, to ensure edit page 783 # is cached until required expiry time. 784 $hopts->{'last-modified'} = $lastModifiedString; 785 $hopts->{expires} = "+${expireHours}h"; 786 $hopts->{'cache-control'} = "max-age=$expireSeconds"; 787 } 788 789 # DEPRECATED plugins header handler. Plugins should use 790 # modifyHeaderHandler instead. 791 $pluginHeaders = $this->{plugins}->dispatch( 792 'writeHeaderHandler', $query ) || ''; 793 if( $pluginHeaders ) { 794 foreach ( split /\r?\n/, $pluginHeaders ) { 795 if ( m/^([\-a-z]+): (.*)$/i ) { 796 $hopts->{$1} = $2; 797 } 798 } 799 } 800 801 $contentType = 'text/html' unless $contentType; 802 if( defined( $TWiki::cfg{Site}{CharSet} )) { 803 $contentType .= '; charset='.$TWiki::cfg{Site}{CharSet}; 804 } 805 806 # use our version of the content type 807 $hopts->{'Content-Type'} = $contentType; 808 809 # Item7193: Disable XSS Protection to make JavaScript work when a topic is 810 # saved with JavaScript contained. 811 if ( isTrue( $TWiki::cfg{DisableXSSProtection} ) ) { 812 $hopts->{'X-XSS-Protection'} = '0'; 813 } 814 815 if ( $status ) { 816 $hopts->{Status} = $status; 817 } 818 819 # New (since 1.026) 820 $this->{plugins}->dispatch( 821 'modifyHeaderHandler', $hopts, $this->{request} ); 822 823 # add cookie(s) 824 $this->{users}->{loginManager}->modifyHeader( $hopts ); 825 826 $this->{response}->setDefaultHeaders( $hopts ); 827} 828 829=pod 830 831---++ StaticMethod isRedirectSafe($redirect) => $ok 832 833tests if the $redirect is an external URL, returning false if AllowRedirectUrl is denied 834 835=cut 836 837sub isRedirectSafe { 838 my $redirect = shift; 839 return 1 if ($TWiki::cfg{AllowRedirectUrl}); 840 841 #TODO: this should really use URI 842 if ( $redirect =~ m!^([^:]*://[^/]*)/*(.*)?$! ) { 843 my $host = $1; 844 #remove trailing /'s to match 845 $TWiki::cfg{DefaultUrlHost} =~ m!^([^:]*://[^/]*)/*(.*)?$!; 846 my $expected = $1; 847 return 1 if (uc($host) eq uc($expected)); 848 849 if (defined($TWiki::cfg{PermittedRedirectHostUrls} ) && $TWiki::cfg{PermittedRedirectHostUrls} ne '') { 850 my @permitted = 851 map { s!^([^:]*://[^/]*)/*(.*)?$!$1!; $1 } 852 split(/,\s*/, $TWiki::cfg{PermittedRedirectHostUrls}); 853 return 1 if ( grep ( { uc($host) eq uc($_) } @permitted)); 854 } 855 return 0; 856 } 857 858 return 1; 859} 860 861# _getRedirectUrl() => redirectURL set from the parameter 862# Reads a redirect url from CGI parameter 'redirectto'. 863# This function is used to get and test the 'redirectto' cgi parameter, 864# and then the calling function can set its own reporting if there is a 865# problem. 866sub _getRedirectUrl { 867 my $session = shift; 868 869 my $query = $session->{request}; 870 my $redirecturl = $query->param( 'redirectto' ); 871 return '' unless $redirecturl; 872 873 if ( $redirecturl =~ /AUTOINC/ && defined $session->{AUTOINC} ) { 874 $redirecturl =~ s//$session->{AUTOINC}/g; 875 } 876 my $sessionParam = { 877 web => $session->{webName}, 878 topic => $session->{topicName}, 879 }; 880 $redirecturl =~ s/\$\{([^{}]*)\}|\$(\w+)/ 881 my $v = ($1 || $2); 882 urlEncode($query->param($v) || $sessionParam->{$v} || '')/eg; 883 if( $redirecturl =~ m#^$regex{linkProtocolPattern}://#o ) { 884 # assuming URL 885 if (isRedirectSafe($redirecturl)) { 886 return $redirecturl; 887 } else { 888 return ''; 889 } 890 } 891 # assuming 'web.topic' or 'topic' 892 my $urlParams = ''; 893 if ( $redirecturl =~ /\?(.*)$/ ) { 894 $urlParams = $1; 895 $redirecturl =~ s///; 896 } 897 my ( $w, $t ) = $session->normalizeWebTopicName( $session->{webName}, $redirecturl ); 898 $redirecturl = $session->getScriptUrl( 1, 'view', $w, $t ); 899 return $redirecturl . ($urlParams eq '' ? '' : '?' . $urlParams); 900} 901 902 903=pod 904 905---++ ObjectMethod redirect( $url, $passthrough, $action_redirectto, $viaCache ) 906 907 * $url - url or twikitopic to redirect to 908 * $passthrough - (optional) parameter to **FILLMEIN** 909 * $action_redirectto - (optional) redirect to where ?redirectto= 910 points to (if it's valid) 911 * $viaCache - forcibly cache a redirect CGI query. It cuts off all 912 the params in a GET url and replace with a "?$cache=..." param. 913 914Redirects the request to =$url=, *unless* 915 1 It is overridden by a plugin declaring a =redirectCgiQueryHandler=. 916 1 =$session->{request}= is =undef= or 917 1 $query->param('noredirect') is set to a true value. 918Thus a redirect is only generated when in a CGI context. 919 920Normally this method will ignore parameters to the current query. Sometimes, 921for example when redirecting to a login page during authentication (and then 922again from the login page to the original requested URL), you want to make 923sure all parameters are passed on, and for this $passthrough should be set to 924true. In this case it will pass all parameters that were passed to the 925current query on to the redirect target. If the request_method for the 926current query was GET, then all parameters will be passed by encoding them 927in the URL (after ?). If the request_method was POST, then there is a risk the 928URL would be too big for the receiver, so it caches the form data and passes 929over a cache reference in the redirect GET. 930 931NOTE: Passthrough is only meaningful if the redirect target is on the same 932server. "$viaCache" is meaningful only if "$action_redirectto" is false and 933"$passthru" is true. 934 935=cut 936 937sub redirect { 938 my( $this, $url, $passthru, $action_redirectto, $viaCache ) = @_; 939 940 my $query = $this->{request}; 941 # if we got here without a query, there's not much more we can do 942 return unless $query; 943 944 # SMELL: if noredirect is set, don't generate the redirect, throw an 945 # exception instead. This is a HACK used to support TWikiDrawPlugin. 946 # It is deprecated and must be replaced by REST handlers in the plugin. 947 if( $query->param( 'noredirect' )) { 948 die "ERROR: $url"; 949 return; 950 } 951 952 if ($action_redirectto) { 953 my $redir = _getRedirectUrl($this); 954 $url = $redir if ($redir); 955 } 956 957 if ( $passthru && defined $query->request_method() ) { 958 my $existing = ''; 959 if ($url =~ s/\?(.*)$//) { 960 $existing = $1; 961 } 962 if ( $query->request_method() =~ /^POST$/i || $viaCache ) { 963 # Redirecting from a post to a get 964 my $cache = $this->cacheQuery(); 965 if ($cache) { 966 $url .= "?$cache"; 967 } 968 } else { 969 if ($query->query_string()) { 970 $url .= '?'.$query->query_string(); 971 } 972 if ($existing) { 973 if ($url =~ /\?/) { 974 $url .= ';'; 975 } else { 976 $url .= '?'; 977 } 978 $url .= $existing; 979 } 980 } 981 } 982 983 # prevent phishing by only allowing redirect to configured host 984 # do this check as late as possible to catch _any_ last minute hacks 985 # TODO: this should really use URI 986 if (!isRedirectSafe($url)) { 987 # goto oops if URL is trying to take us somewhere dangerous 988 $url = $this->getScriptUrl( 989 1, 'oops', 990 $this->{web} || $TWiki::cfg{UsersWebName}, 991 $this->{topic} || $TWiki::cfg{HomeTopicName}, 992 template => 'oopsaccessdenied', 993 def => 'topic_access', 994 param1 => 'redirect', 995 param2 => 'unsafe redirect to '.$url. 996 ': host does not match {DefaultUrlHost} , and is not in {PermittedRedirectHostUrls}"'. 997 $TWiki::cfg{DefaultUrlHost}.'"' 998 ); 999 } 1000 1001 1002 return if( $this->{plugins}->dispatch( 1003 'redirectCgiQueryHandler', $this->{response}, $url )); 1004 1005 # SMELL: this is a bad breaking of encapsulation: the loginManager 1006 # should just modify the url, then the redirect should only happen here. 1007 return !$this->{users}->{loginManager}->redirectCgiQuery( $query, $url ); 1008} 1009 1010=pod 1011 1012---++ ObjectMethod cacheQuery() -> $queryString 1013 1014Caches the current query in the params cache, and returns a rewritten 1015query string for the cache to be picked up again on the other side of a 1016redirect. 1017 1018We can't encode post params into a redirect, because they may exceed the 1019size of the GET request. So we cache the params, and reload them when the 1020redirect target is reached. 1021 1022=cut 1023 1024sub cacheQuery { 1025 my $this = shift; 1026 my $query = $this->{request}; 1027 1028 return '' unless (scalar($query->param())); 1029 # Don't double-cache 1030 return '' if ($query->param('twiki_redirect_cache')); 1031 1032 require Digest::MD5; 1033 my $md5 = new Digest::MD5(); 1034 $md5->add($$, time(), rand(time)); 1035 my $uid = $md5->hexdigest(); 1036 my $passthruFilename = "$TWiki::cfg{WorkingDir}/tmp/passthru_$uid"; 1037 1038 use Fcntl; 1039 #passthrough file is only written to once, so if it already exists, suspect a security hack (O_EXCL) 1040 sysopen(F, "$passthruFilename", O_RDWR|O_EXCL|O_CREAT, 0600) || 1041 die "Unable to open $TWiki::cfg{WorkingDir}/tmp for write; check the setting of" 1042 . " {WorkingDir} in configure, and check file permissions: $!"; 1043 $query->save(\*F); 1044 close(F); 1045 return 'twiki_redirect_cache='.$uid; 1046} 1047 1048=pod 1049 1050---++ StaticMethod isValidWikiWord( $name ) -> $boolean 1051 1052Check for a valid WikiWord or WikiName 1053 1054=cut 1055 1056sub isValidWikiWord { 1057 my $name = shift || ''; 1058 return ( $name =~ m/^$regex{wikiWordRegex}$/o ) 1059} 1060 1061=pod 1062 1063---++ StaticMethod isValidTopicName( $name ) -> $boolean 1064 1065Check for a valid topic name 1066 1067=cut 1068 1069sub isValidTopicName { 1070 my( $name ) = @_; 1071 1072 return isValidWikiWord( @_ ) || isValidAbbrev( @_ ); 1073} 1074 1075=pod 1076 1077---++ StaticMethod isValidAbbrev( $name ) -> $boolean 1078 1079Check for a valid ABBREV (acronym) 1080 1081=cut 1082 1083sub isValidAbbrev { 1084 my $name = shift || ''; 1085 return ( $name =~ m/^$regex{abbrevRegex}$/o ) 1086} 1087 1088=pod 1089 1090---++ StaticMethod isValidWebName( $name, $system ) -> $boolean 1091 1092STATIC Check for a valid web name. If $system is true, then 1093system web names are considered valid (names starting with _) 1094otherwise only user web names are valid 1095 1096If $TWiki::cfg{EnableHierarchicalWebs} is off, it will also return false 1097when a nested web name is passed to it. 1098 1099=cut 1100 1101sub isValidWebName { 1102 my $name = shift || ''; 1103 my $sys = shift; 1104 return 0 if ( $name =~ m/$TWiki::cfg{InvalidWebNameRegex}/o ); # Item7838 1105 return 1 if ( $sys && $name =~ m/^$regex{defaultWebNameRegex}$/o ); 1106 return ( $name =~ m/^$regex{webNameRegex}$/o ) 1107} 1108 1109=pod 1110 1111---++ ObjectMethod modeAndMaster( $web ) 1112Returns the following hash reference such as this: 1113<verbatim> 1114('', undef) 1115</verbatim> 1116 1117and this: 1118<verbatim> 1119('slave', { # master site data 1120 siteName => 'na', 1121 webScriptUrlTmpl => 'http://twiki.example.com/cgi-bin//Web', 1122 scriptSuffix => '', 1123 webViewUrl => 'http://twiki.example.com/Web', 1124}) 1125</verbatim> 1126 1127The first value is the mode of the web: either 'local', 'master', 'slave', 1128or 'read-only'. The second value is defined only when the master site is 1129defined for the web. 1130=cut 1131 1132sub modeAndMaster { 1133 my ($this, $web) = @_; 1134 my $mode = 'local'; # by default a web is local 1135 if ( !$TWiki::cfg{ReadOnlyAndMirrorWebs}{SiteName} ) { 1136 return ($mode, undef); 1137 } 1138 my $cache = $this->{modeAndMaster} ||= {}; 1139 if ( my $cached = $cache->{$web} ) { 1140 return @$cached 1141 } 1142 my $cacheHereToo; 1143 my $masterSite; 1144 my %master; 1145 if ( my $mdrepo = $this->{mdrepo} ) { 1146 my $tlweb = topLevelWeb($web); 1147 if ( my $cached = $cache->{$tlweb} ) { 1148 $cache->{$web} = $cached if ( $tlweb ne $web ); 1149 return @$cached; 1150 } 1151 $cacheHereToo = $tlweb ne $web ? $tlweb : ''; 1152 my $webRec = $mdrepo->getRec('webs', topLevelWeb($web)); 1153 if ( $webRec ) { 1154 if ( $masterSite = $webRec->{master} ) { 1155 $master{siteName} = $masterSite; 1156 my $siteRec = $mdrepo->getRec('sites', $masterSite); 1157 if ( $siteRec && $siteRec->{scripturl} ) { 1158 $master{webScriptUrlTmpl} = 1159 $siteRec->{scripturl} . '//' . $web; 1160 $master{scriptSuffix} = $siteRec->{scriptsuffix}; 1161 $master{webViewUrl} = $siteRec->{viewurl} . '/' . $web 1162 if ( $siteRec->{viewurl} ); 1163 } 1164 } 1165 } 1166 # If the metadata repository is in use and the web's record 1167 # doesn't exist or doesn't have the master field, then the web 1168 # is regarded as 'local'. 1169 # No fall back to the none metadata repository situation processed 1170 # below. 1171 } 1172 else { 1173 my $prefs = $this->{prefs}; 1174 $masterSite = $prefs->getWebPreferencesValue('MASTERSITENAME', $web); 1175 if ( $masterSite ) { 1176 $master{siteName} = $masterSite; 1177 $master{webScriptUrlTmpl} = 1178 $prefs->getWebPreferencesValue('MASTERWEBSCRIPTURLTMPL', $web); 1179 $master{scriptSuffix} = 1180 $prefs->getWebPreferencesValue('MASTERSCRIPTSUFFIX', $web); 1181 $master{webViewUrl} = 1182 $prefs->getWebPreferencesValue('MASTERWEBVIEWURL', $web); 1183 } 1184 } 1185 if ( $masterSite ) { 1186 if ( $masterSite eq $TWiki::cfg{ReadOnlyAndMirrorWebs}{SiteName} ) { 1187 $mode = 'master'; 1188 } 1189 else { 1190 if ( $master{webScriptUrlTmpl} ) { 1191 $mode = 'slave'; 1192 } 1193 else { 1194 $mode = 'read-only' 1195 } 1196 } 1197 } 1198 my $result = $cache->{$web} = [$mode, %master ? \%master : undef]; 1199 $cache->{$cacheHereToo} = $result if ( $cacheHereToo ); 1200 return @$result; 1201} 1202 1203=pod 1204 1205---++ ObjectMethod getSkin () -> $string 1206 1207Get the currently requested skin path 1208 1209=cut 1210 1211sub getSkin { 1212 my $this = shift; 1213 1214 my $skinpath = $this->{prefs}->getPreferencesValue( 'SKIN' ) || ''; 1215 1216 if( $this->{request} ) { 1217 my $resurface = $this->{request}->param( 'skin' ); 1218 $skinpath = $resurface if $resurface; 1219 } 1220 1221 my $epidermis = $this->{prefs}->getPreferencesValue( 'COVER' ); 1222 $skinpath = $epidermis.','.$skinpath if $epidermis; 1223 1224 if( $this->{request} ) { 1225 $epidermis = $this->{request}->param( 'cover' ); 1226 $skinpath = $epidermis.','.$skinpath if $epidermis; 1227 } 1228 1229 # Resolve TWiki variables if needed 1230 if( $skinpath =~ /\%[A-Z]/ ) { 1231 $skinpath = $this->handleCommonTags( $skinpath, $this->{webName}, 1232 $this->{topicName} ); 1233 } 1234 1235 # sanitize skin path 1236 $skinpath =~ s/[^A-Za-z0-9_\-\,\. ]//g; 1237 1238 return $skinpath; 1239} 1240 1241=pod 1242 1243---++ ObjectMethod getScriptUrl( $absolute, $script, $web, $topic, ... ) -> $scriptURL 1244 1245Returns the URL to a TWiki script, providing the web and topic as 1246"path info" parameters. The result looks something like this: 1247"http://host/twiki/bin/$script/$web/$topic". 1248 * =...= - an arbitrary number of name,value parameter pairs that will be 1249 url-encoded and added to the url. The special parameter name '#' is 1250 reserved for specifying an anchor. e.g. 1251 <tt>getScriptUrl('x','y','view','#'=>'XXX',a=>1,b=>2)</tt> will give 1252 <tt>.../view/x/y?a=1&b=2#XXX</tt> %BR% 1253 1254If $absolute is set, generates an absolute URL. $absolute is advisory only; 1255TWiki can decide to generate absolute URLs (for example when run from the 1256command-line) even when relative URLs have been requested. 1257 1258The default script url is taken from {ScriptUrlPath}, unless there is 1259an exception defined for the given script in {ScriptUrlPaths}. Both 1260{ScriptUrlPath} and {ScriptUrlPaths} may be absolute or relative URIs. If 1261they are absolute, then they will always generate absolute URLs. if they 1262are relative, then they will be converted to absolute when required (e.g. 1263when running from the command line, or when generating rss). If 1264$script is not given, absolute URLs will always be generated. 1265 1266If either the web or the topic is defined, will generate a full url 1267(including web and topic). Otherwise will generate only up to the script 1268name. An undefined web will default to the main web name. 1269 1270The returned URL takes ReadOnlyAndMirrorWebs into account. 1271If the specified =$web= is slave on this site, with the scripts 1272=edit=, =save=, =attach=, =upload=, and =rename=, this method returns 1273the URLs on the master site because it does not make sense to execute 1274those scripts on the master site of the web. 1275 1276Even with the other scripts, you may need to get the URLs on the master site. 1277You can get those URLs by providing =$master => 1= as a name value pair. 1278=cut 1279 1280sub getScriptUrl { 1281 my( $this, $absolute, $script, $web, $topic, @params ) = @_; 1282 1283 if( $web || $topic ) { 1284 if ( !$web && $topic !~ /[.\/]/ ) { 1285 $web = $this->{webName}; 1286 } 1287 else { 1288 ($web, $topic) = $this->normalizeWebTopicName( $web, $topic ); 1289 } 1290 } 1291 # the above is needed here because $web is crucial 1292 1293 # check if $master => X exists in @params and makes @params1 excluding it 1294 my $ofMaster = 0; 1295 my @params1; 1296 my $i = 0; 1297 while ( $i < @params ) { 1298 if ( $params[$i] eq '$master' ) { 1299 $ofMaster = 1 if ( $params[$i + 1] ); 1300 } 1301 else { 1302 push(@params1, @params[$i, $i+1]); 1303 } 1304 $i += 2; 1305 } 1306 1307 # determine if it's of the master and get the information of the master 1308 my ($contentMode, $master); 1309 if ( $web ) { 1310 ($contentMode, $master) = $this->modeAndMaster($web); 1311 if ( $master && $master->{webScriptUrlTmpl} ) { 1312 if ( $contentMode eq 'slave' ) { 1313 if ( $scriptOnMaster{$script} ) { 1314 # even if $script is null, no disaster happens 1315 $ofMaster = 1; 1316 } 1317 } 1318 else { 1319 # if not slave, the master URL is yielded regardless 1320 $ofMaster = 0; 1321 } 1322 } 1323 else { 1324 $ofMaster = 0; 1325 # if $master->{webScriptUrlTmpl} is not defined, 1326 # no way to get the URL for the master site, hence resort to 1327 # 'not of master' 1328 } 1329 } 1330 else { 1331 $ofMaster = 0; 1332 } 1333 1334 # SMELL: topics and webs that contain spaces? 1335 1336 my $url; 1337 if ( $ofMaster ) { 1338 $script ||= 'view'; 1339 # A web is specified explicitly or implicitly. 1340 # In that case, a URL having the web cannot be script neutral. 1341 $url = $master->{webScriptUrlTmpl}; 1342 if ( $script eq 'view' && $master->{webViewUrl} ) { 1343 $url = $master->{webViewUrl}; 1344 } 1345 else { 1346 my $suffix = $master->{scriptSuffix} || ''; 1347 $url =~ s:^(.*)//:$1/$script$suffix/:; 1348 } 1349 $url .= urlEncode( '/'.$topic ); 1350 $url .= _make_params(0, @params1); 1351 } 1352 else { 1353 # if $ofMaster is true, the URL needs to be absolute regardless. 1354 # So absolute checking is done here. 1355 $absolute ||= ($this->inContext( 'command_line' ) || 1356 $this->inContext( 'rss' ) || 1357 $this->inContext( 'absolute_urls' )); 1358 1359 if( defined $TWiki::cfg{ScriptUrlPaths} && $script) { 1360 $url = $TWiki::cfg{ScriptUrlPaths}{$script}; 1361 } 1362 unless( defined( $url )) { 1363 $url = $TWiki::cfg{ScriptUrlPath}; 1364 if( $script ) { 1365 $url .= '/' unless $url =~ /\/$/; 1366 $url .= $script; 1367 if ( rindex($url, $TWiki::cfg{ScriptSuffix}) != 1368 ( length($url) - length($TWiki::cfg{ScriptSuffix}) ) 1369 ) { 1370 $url .= $TWiki::cfg{ScriptSuffix} if $script; 1371 } 1372 } 1373 } 1374 1375 if( $absolute && $url !~ /^[a-z]+:/ ) { 1376 # See http://www.ietf.org/rfc/rfc2396.txt for the definition of 1377 # "absolute URI". TWiki bastardises this definition by assuming 1378 # that all relative URLs lack the <authority> component as well. 1379 $url = $this->{urlHost}.$url; 1380 } 1381 1382 if( $web || $topic ) { 1383 $url .= urlEncode( '/'.$web.'/'.$topic ); 1384 $url .= _make_params(0, @params1); 1385 } 1386 } 1387 1388 return $url; 1389} 1390 1391sub _make_params { 1392 my ( $notfirst, @args ) = @_; 1393 my $url = ''; 1394 my $ps = ''; 1395 my $anchor = ''; 1396 while( my $p = shift @args ) { 1397 if( $p eq '#' ) { 1398 $anchor .= '#' . shift( @args ); 1399 } else { 1400 my $arg = shift( @args ); 1401 $arg = '' unless defined( $arg ); 1402 $ps .= ";$p=" . urlEncode( $arg ); 1403 } 1404 } 1405 if( $ps ) { 1406 $ps =~ s/^;/?/ unless $notfirst; 1407 $url .= $ps; 1408 } 1409 $url .= $anchor; 1410 return $url; 1411} 1412 1413=pod 1414 1415---++ ObjectMethod getDiskInfo($web, $site, $diskID) -> ($dataDir, $pubDir, $diskID) 1416 1417You can specify either $web or $diskID, not both. 1418 1419=cut 1420 1421sub getDiskInfo { 1422 my( $this, $web, $site, $diskID ) = @_; 1423 if ( !$web ) { 1424 if ( $diskID ) { 1425 $web = ''; 1426 } 1427 else { 1428 $web = $this->{webName}; 1429 } 1430 } 1431 $site ||= $TWiki::cfg{ReadOnlyAndMirrorWebs}{SiteName} || ''; 1432 return $this->{store}->getDiskInfo($web, $site, $diskID); 1433} 1434 1435=pod 1436 1437---++ ObjectMethod getDiskList() -> ('', 1, 2, ...) 1438 1439=cut 1440 1441sub getDiskList { 1442 # my( $this ) = @_; 1443 return $_[0]->{store}->getDiskList(); 1444} 1445 1446=pod 1447 1448---++ ObjectMethod getDataDir($web, $diskID) -> $dataDir 1449 1450You can specify either $web or $diskID, not both. 1451 1452=cut 1453 1454sub getDataDir { 1455 # my( $this, $web, $diskID ) = @_; 1456 return 1457 $TWiki::cfg{MultipleDisks} ? (getDiskInfo($_[0], $_[1], '', $_[2]))[0] 1458 : $TWiki::cfg{DataDir}; 1459} 1460 1461=pod 1462 1463---++ ObjectMethod getPubDir($web, $diskID) -> $pubDir 1464 1465You can specify either $web or $diskID, not both. 1466 1467=cut 1468 1469sub getPubDir { 1470 # my( $this, $web, $diskID ) = @_; 1471 return 1472 $TWiki::cfg{MultipleDisks} ? (getDiskInfo($_[0], $_[1], '', $_[2]))[1] 1473 : $TWiki::cfg{PubDir}; 1474} 1475 1476=pod 1477 1478---++ ObjectMethod getPubUrl($absolute, $web, $topic, $attachment) -> $url 1479 1480Composes a pub url. If $absolute is set, returns an absolute URL. 1481If $absolute is set, generates an absolute URL. $absolute is advisory only; 1482TWiki can decide to generate absolute URLs (for example when run from the 1483command-line) even when relative URLs have been requested. 1484 1485$web, $topic and $attachment are optional. A partial URL path will be 1486generated if one or all is not given. 1487 1488=cut 1489 1490sub getPubUrl { 1491 my( $this, $absolute, $web, $topic, $attachment ) = @_; 1492 1493 $absolute ||= ($this->inContext( 'command_line' ) || 1494 $this->inContext( 'rss' ) || 1495 $this->inContext( 'absolute_urls' )); 1496 1497 my $url = ''; 1498 $url .= $TWiki::cfg{PubUrlPath}; 1499 if( $absolute && $url !~ /^[a-z]+:/ ) { 1500 # See http://www.ietf.org/rfc/rfc2396.txt for the definition of 1501 # "absolute URI". TWiki bastardises this definition by assuming 1502 # that all relative URLs lack the <authority> component as well. 1503 $url = $this->{urlHost}.$url; 1504 } 1505 if( $web || $topic || $attachment ) { 1506 ( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic ); 1507 1508 my $path = '/'.$web.'/'.$topic; 1509 if( $attachment ) { 1510 $path .= '/'.$attachment; 1511 # Attachments are served directly by web server, need to handle 1512 # URL encoding specially 1513 $url .= urlEncodeAttachment ( $path ); 1514 } else { 1515 $url .= urlEncode( $path ); 1516 } 1517 } 1518 1519 return $url; 1520} 1521 1522=pod 1523 1524---++ ObjectMethod cacheIconData( $action ) 1525 1526Cache icon data based on action: 1527 * 'delete' - delete cache file 1528 * 'read' - read cache file 1529 * 'expire' - expire (invalidate) cache if needed 1530 * 'save' - save cache file 1531 1532=cut 1533 1534sub cacheIconData { 1535 my( $this, $action, $web, $topic ) = @_; 1536 1537 my $cacheFile = $this->{store}->getWorkArea( 'VarICON' ) . '/icon_cache.txt'; 1538 1539 if( $action eq 'save' ) { 1540 if( open( FILE, ">$cacheFile" ) ) { 1541 print FILE "# Cached icon data; do not edit. See TWiki.TWikiDocGraphics\n"; 1542 my %seen; 1543 my %refs; 1544 foreach my $icn (sort keys %{ $this->{_ICONDATA} } ) { 1545 my $line = "$icn: "; 1546 if( $seen{ $this->{_ICONDATA}{$icn}{name} } ) { 1547 $refs{$icn} = $seen{ $this->{_ICONDATA}{$icn}{name} }; 1548 } else { 1549 $seen{ $this->{_ICONDATA}{$icn}{name} } = $icn; 1550 $line .= "$this->{_ICONDATA}{$icn}{name}, " 1551 . "$this->{_ICONDATA}{$icn}{web}, " 1552 . "$this->{_ICONDATA}{$icn}{topic}, " 1553 . "$this->{_ICONDATA}{$icn}{type}, " 1554 . "$this->{_ICONDATA}{$icn}{width}, " 1555 . "$this->{_ICONDATA}{$icn}{height}, " 1556 . "$this->{_ICONDATA}{$icn}{description}"; 1557 print FILE "$line\n"; 1558 } 1559 } 1560 # add hash aliases 1561 foreach my $icn (sort keys %refs ) { 1562 my $line = "$icn => $refs{$icn}"; 1563 print FILE "$line\n"; 1564 } 1565 print FILE "# EOF\n"; 1566 close( FILE); 1567 } 1568 1569 } elsif( $action eq 'read' ) { 1570 if( -e $cacheFile && open( FILE, "<$cacheFile" ) ) { 1571 local $_; 1572 my $icn; 1573 while( <FILE> ) { 1574 if( /^([^\:]+)\: ([^,]+), ([^,]+), ([^,]+), ([^,]+), ([^,]+), ([^,]+), ([^\n\r]+)/ ) { 1575 # icon record as hash 1576 $icn->{$1} = { 1577 name => $2, 1578 web => $3, 1579 topic => $4, 1580 type => $5, 1581 width => $6, 1582 height => $7, 1583 description => $8 1584 }; 1585 } elsif( /^([^ ]+) \=> *([^\n\r]+)/ ) { 1586 # icon as alias 1587 $icn->{$1} = $icn->{$2}; 1588 } 1589 } 1590 close( FILE ); 1591 $this->{_ICONDATA} = $icn if( $icn ); 1592 } 1593 1594 } elsif( $action eq 'expire' ) { 1595 # invoked by TWiki::Store::saveTopic after afterSaveHandler callback 1596 1597 if( $topic =~ /^(TWikiPreferences|WebPreferences)$/ ) { 1598 # Remove icon cache if preferences changed on site level or web level 1599 unlink( $cacheFile ); 1600 1601 } else { 1602 # Remove icon cache if any topic in the ICONTOPIC list changed 1603 my $topics = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' ); 1604 if( $topics ) { 1605 foreach my $iconTopic ( split( / *, */, $topics ) ) { 1606 my( $iWeb, $iTopic ) = $this->normalizeWebTopicName( $this->{webName}, $iconTopic ); 1607 if( ( $web eq $iWeb ) && ( $topic eq $iTopic ) ) { 1608 unlink( $cacheFile ); 1609 } 1610 } 1611 } 1612 } 1613 1614 } elsif( $action eq 'delete' ) { 1615 unlink( $cacheFile ); 1616 1617 } 1618} 1619 1620=pod 1621 1622---++ ObjectMethod formatIcon( $iconName, $format, $default ) -> $icon 1623 1624Format an icon based on name and format parameter. The format parameter handles 1625these variables (with example): 1626 * $name: Name of icon ('home') 1627 * $type: Type of icon ('gif') 1628 * $filename: Icon filename ('home.gif') 1629 * $web: Web where icon is located ('TWiki') 1630 * $topic: Topic where icon is located ('TWikiDocGraphics') 1631 * $description: Icon description ('Home') 1632 * $width: Width of icon ('16') 1633 * $height: Height of icon ('16') 1634 * $img: Full img tag of icon ('<img src="/pub/TWiki/TWikiDocGraphics/home.gif" ... />') 1635 * $url: URL of icon ('http://example.com/pub/TWiki/TWikiDocGraphics/home.gif') 1636 * $urlpath: URL path of icon ('/pub/TWiki/TWikiDocGraphics/home.gif') 1637 1638The optional default parameter specifies the icon name in case the icon is not defined. 1639Leave empty if you assume icon files exist in the default location. 1640 1641=cut 1642 1643sub formatIcon { 1644 my( $this, $iconName, $format, $default ) = @_; 1645 1646 if( $iconName eq 'action:refresh-cache' ) { 1647 $this->cacheIconData( 'delete' ); 1648 my $text = $format || 1649 "ICON cache is refreshed. " 1650 . "[[$this->{SESSION_TAGS}{BASEWEB}.$this->{SESSION_TAGS}{BASETOPIC}][OK]]."; 1651 return $text; 1652 } 1653 1654 unless( $this->{_ICONDATA} ) { 1655 # try to read cache 1656 $this->cacheIconData( 'read' ); 1657 } 1658 1659 unless( $this->{_ICONDATA} ) { 1660 # cache does not exist, so let's create it 1661 1662 # create one dummy entry in case icon info cannot be read 1663 # to void repeated retries 1664 $this->{_ICONDATA}->{_default} = { 1665 name => '_default', 1666 web => $TWiki::cfg{SystemWebName}, 1667 topic => 'TWikiDocGraphics', 1668 description => 'Default', 1669 type => 'gif', 1670 width => '16', 1671 height => '16', 1672 }; 1673 # read icon info 1674 my $i = 0; 1675 foreach my $iconTopic (split(/ *, */, $this->{prefs}->getPreferencesValue( 'ICONTOPIC' ))) { 1676 my( $web, $topic ) = $this->normalizeWebTopicName( $this->{webName}, $iconTopic ); 1677 my $text = $this->{store}->readTopicRaw( undef, $web, $topic ); 1678 if( $text ) { 1679 foreach my $line (split(/[\n\r]+/, $text)) { 1680 # sample line: 1681 # | %ICON{help}% | =%<nop>ICON{help}%=, =%<nop>H%= | Help | gif | 16x16 | info | 1682 if( $line =~ / %ICON\{[ "']*([^ "'}]+)[^\|]*\|[^\|]*\| *(.*?) *\| *(.*?) *\| *([0-9]+)x([0-9]+)([^\|]*\| *(.*?) *\|)?/ ) { 1683 my $name = $1; 1684 $this->{_ICONDATA}->{$name} = { 1685 name => $name, 1686 web => $web, 1687 topic => $topic, 1688 description => $2, 1689 type => $3, 1690 width => $4, 1691 height => $5, 1692 }; 1693 my $aliases = $7; 1694 if( $aliases ) { 1695 foreach my $alias (split(/[ ,]+/, $aliases)) { 1696 $this->{_ICONDATA}->{$alias} = $this->{_ICONDATA}->{$name}; 1697 } 1698 } 1699 } 1700 } 1701 if( $i++ < 2 ) { 1702 $this->{_ICONDATA}->{_default}{web} = $web; 1703 $this->{_ICONDATA}->{_default}{topic} = $topic; 1704 } 1705 } 1706 } 1707 1708 # cache icon info 1709 $this->cacheIconData( 'save' ); 1710 } 1711 1712 # cut file path/name, if any, and lowercase the file type 1713 $default =~ s/^.*\.(.*?)$/lc($1)/e; 1714 if( $iconName =~ s/^.*\.(.*?)$/lc($1)/e ) { 1715 # file icon path identified, set default unless defined 1716 $default = 'else' unless( $default ); 1717 } 1718 $iconName = 'empty' unless( $iconName ); 1719 1720 if( $iconName =~ /^list:/ ) { 1721 my @icons = (); 1722 if( $iconName =~ /all/ ) { 1723 @icons = sort grep { !/_default/ } keys %{ $this->{_ICONDATA} }; 1724 } else { # unique 1725 @icons = sort 1726 grep { !/_default/ } 1727 grep { /$this->{_ICONDATA}->{$_}->{name}/ } 1728 keys %{ $this->{_ICONDATA} }; 1729 } 1730 if( $iconName =~ /names/ ) { 1731 return join( ', ', @icons ); 1732 } elsif( $iconName =~ /icons/ ) { 1733 return join( ' ', map { '%ICON{'.$_.'}%' } @icons ); 1734 } elsif( $iconName =~ /info/ ) { 1735 return join( ' ', map { '%ICON{"'.$_.'" format="$info"}%' } @icons ); 1736 } else { # /table/ 1737 my $text = '| * * | *Name* | *Description* | *Type* | *Size* | *Defined in* |' . "\n"; 1738 my $i = 0; 1739 for my $icn ( @icons ) { 1740 $i++; 1741 $text .= "| \%ICON{$icn}\% | $icn "; 1742 $text .= "=> $this->{_ICONDATA}->{$icn}->{name} " if( $this->{_ICONDATA}->{$icn}->{name} ne $icn ); 1743 $text .= "| $this->{_ICONDATA}->{$icn}->{description} | $this->{_ICONDATA}->{$icn}->{type} " 1744 . "| $this->{_ICONDATA}->{$icn}->{width}x$this->{_ICONDATA}->{$icn}->{height} " 1745 . "| [[$this->{_ICONDATA}->{$icn}->{web}.$this->{_ICONDATA}->{$icn}->{topic}]] |\n"; 1746 } 1747 $text .= "| Total: | $i icons |||||\n"; 1748 return $text; 1749 } 1750 } 1751 1752 # determine icon 1753 my $icn = $this->{_ICONDATA}->{$iconName} || $this->{_ICONDATA}->{$default}; 1754 unless( $icn ) { 1755 # assume default location (attached to second topic in ICONTOPIC list) 1756 $icn = $this->{_ICONDATA}->{_default}; 1757 $icn->{name} = $iconName; 1758 $icn->{description} = $iconName; 1759 $icn->{description} =~ s/^(.)/uc($1)/eo; 1760 } 1761 1762 # format icon tag/url 1763 my $iconTag = '<img src="$urlpath" width="$width" height="$height" ' 1764 . 'alt="$description" title="$description" border="0" />'; 1765 my $iconInfo = '<img src="$urlpath" width="$width" height="$height" ' 1766 . 'alt="$name" title="%<nop>ICON{$name}% - <nop>$description, ' 1767 . 'defined in <nop>$web.$topic" border="0" />'; 1768 $format = '$img' unless( $format ); 1769 $format =~ s/\$img\b/$iconTag/go; 1770 $format =~ s/\$info\b/$iconInfo/go; 1771 $format =~ s/\$url\b/$this->getPubUrl( 1, $icn->{web}, $icn->{topic}, "$icn->{name}.$icn->{type}" )/geo; 1772 $format =~ s/\$urlpath\b/$this->getPubUrl( 0, $icn->{web}, $icn->{topic}, "$icn->{name}.$icn->{type}" )/geo; 1773 $format =~ s/\$name\b/$icn->{name}/go; 1774 $format =~ s/\$type\b/$icn->{type}/go; 1775 $format =~ s/\$filename\b/$icn->{name}.$icn->{type}/go; 1776 $format =~ s/\$web\b/$icn->{web}/go; 1777 $format =~ s/\$topic\b/$icn->{topic}/go; 1778 $format =~ s/\$description\b/$icn->{description}/go; 1779 $format =~ s/\$width\b/$icn->{width}/go; 1780 $format =~ s/\$height\b/$icn->{height}/go; 1781 1782 return $format; 1783} 1784 1785=pod 1786 1787---++ ObjectMethod normalizeWebTopicName( $theWeb, $theTopic ) -> ( $theWeb, $theTopic ) 1788 1789Normalize a Web<nop>.<nop>TopicName 1790 1791See TWikiFuncDotPm for a full specification of the expansion (not duplicated 1792here) 1793 1794*WARNING* if there is no web specification (in the web or topic parameters) 1795the web defaults to $TWiki::cfg{UsersWebName}. If there is no topic 1796specification, or the topic is '0', the topic defaults to the web home topic 1797name. 1798 1799=cut 1800 1801sub normalizeWebTopicName { 1802 my( $this, $web, $topic ) = @_; 1803 1804 ASSERT(defined $topic) if DEBUG; 1805 1806 if( $topic =~ m|^(.*)[./](.*?)$| ) { 1807 $web = $1; 1808 $topic = $2; 1809 } 1810 $web ||= $cfg{UsersWebName}; 1811 $topic ||= $cfg{HomeTopicName}; 1812 while( $web =~ s/%((MAIN|TWIKI|USERS|SYSTEM|DOC)WEB)%/_expandTagOnTopicRendering( $this,$1)||''/e ) { 1813 } 1814 $web =~ s#\.#/#go; 1815 return( $web, $topic ); 1816} 1817 1818sub _readUserPreferences { 1819 my ($this) = @_; 1820 # User preferences only available if we can get to a valid wikiname, 1821 # which depends on the user mapper. 1822 my $wn = $this->{users}->getWikiName( $this->{user} ); 1823 if( $wn ) { 1824 my $prefs = $this->{prefs}; 1825 my $userWeb = $TWiki::cfg{UsersWebName}.'/'.$wn; 1826 if ( $TWiki::cfg{UserSubwebs}{Enabled} && 1827 $this->{store}->topicExists($userWeb, 1828 $TWiki::cfg{UserSubwebs}{UserPrefsTopicName}) 1829 ) { 1830 $prefs->pushPreferences( $userWeb, 1831 $TWiki::cfg{UserSubwebs}{UserPrefsTopicName}, 1832 'USER ' . $wn ); 1833 } 1834 else { 1835 $prefs->pushPreferences( $TWiki::cfg{UsersWebName}, $wn, 1836 'USER ' . $wn ); 1837 } 1838 } 1839} 1840 1841sub _readExtraPreferences { 1842 my ($this) = @_; 1843 my $prefs = $this->{prefs}; 1844 my $topics = $prefs->getPreferencesValue( 'EXTRAPREFERENCES' ); 1845 # It's somewhat better to use getWebPreferencesValue() than 1846 # getPreferencesValue(). 1847 # But getWebPreferencesValue() causes re-processing of WebPreferences 1848 # of the current and parent webs. 1849 # The cost is too much for the marginal benefit of not picking 1850 # prefernces from an unitended place. 1851 if ( $topics ) { 1852 for my $topic ( split(/[,\s]+/, $topics) ) { 1853 my ($epWeb, $epTopic) = 1854 normalizeWebTopicName($this, $this->{webName}, $topic); 1855 $prefs->pushPreferences($epWeb, $epTopic, 'EXTRA'); 1856 } 1857 } 1858} 1859 1860=pod 1861 1862---++ ObjectMethod determineWebTopic($pathInfo, $web, $topic) -> ($web, $topic, $requestedWeb) 1863 1864Determine the web and topic names from PATH_INFO and web and topic names 1865explicitly provided. 1866And then sanitize them. 1867 1868=cut 1869 1870sub determineWebTopic { 1871 my ($this, $pathInfo, $web, $topic) = @_; 1872 if( $pathInfo =~ /\/((?:.*[\.\/])+)(.*)/ ) { 1873 # is 'bin/script/Webname/SomeTopic' or 'bin/script/Webname/' 1874 $web = $1 unless $web; 1875 $topic = $2 unless $topic; 1876 $web =~ s/\./\//go; 1877 $web =~ s/\/$//o; 1878 } elsif( $pathInfo =~ /\/(.*)/ ) { 1879 # is 'bin/script/Webname' or 'bin/script/' 1880 $web = $1 unless $web; 1881 } 1882 # All roads lead to WebHome 1883 $topic = $TWiki::cfg{HomeTopicName} if ( $topic =~ /\.\./ ); 1884 $topic =~ s/$TWiki::cfg{NameFilter}//go; 1885 $topic = $TWiki::cfg{HomeTopicName} unless $topic; 1886 $topic = TWiki::Sandbox::untaintUnchecked( $topic ); 1887 1888 $web =~ s/$TWiki::cfg{NameFilter}//go; 1889 my $requestedWeb = TWiki::Sandbox::untaintUnchecked( $web ); #can be an empty string 1890 $web = $TWiki::cfg{UsersWebName} unless $web; 1891 $web = TWiki::Sandbox::untaintUnchecked( $web ); 1892 1893 # Convert UTF-8 web and topic name from URL into site charset if necessary 1894 # SMELL: merge these two cases, browsers just don't mix two encodings in one URL 1895 # - can also simplify into 2 lines by making function return unprocessed text if no conversion 1896 my $webNameTemp = $this->UTF82SiteCharSet( $web ); 1897 if ( $webNameTemp ) { 1898 $web = $webNameTemp; 1899 } 1900 1901 my $topicNameTemp = $this->UTF82SiteCharSet( $topic ); 1902 if ( $topicNameTemp ) { 1903 $topic = $topicNameTemp; 1904 } 1905 return ($web, $topic, $requestedWeb); 1906} 1907 1908=pod 1909 1910---++ ClassMethod new( $loginName, $query, \%initialContext ) 1911 1912Constructs a new TWiki object. Parameters are taken from the query object. 1913 1914 * =$loginName= is the login username (*not* the wikiname) of the user you 1915 want to be logged-in if none is available from a session or browser. 1916 Used mainly for side scripts and debugging. 1917 * =$query= the TWiki::Request query (may be undef, in which case an empty query 1918 is used) 1919 * =\%initialContext= - reference to a hash containing context 1920 name=value pairs to be pre-installed in the context hash 1921 1922=cut 1923 1924sub new { 1925 my( $class, $login, $query, $initialContext ) = @_; 1926 ASSERT(!$query || UNIVERSAL::isa($query, 'TWiki::Request')); 1927 1928 # Compatibility; not used except maybe in plugins 1929 $TWiki::cfg{TempfileDir} = "$TWiki::cfg{WorkingDir}/tmp" 1930 unless defined($TWiki::cfg{TempfileDir}); 1931 1932 # Set command_line context if there is no query 1933 $initialContext ||= defined( $query ) ? {} : { command_line => 1 }; 1934 1935 $query ||= new TWiki::Request(); 1936 my $this = bless( {}, $class ); 1937 $this->{request} = $query; 1938 $this->{response} = new TWiki::Response(); 1939 1940 # Tell TWiki::Response which charset we are using if not default 1941 if( defined $TWiki::cfg{Site}{CharSet} && $TWiki::cfg{Site}{CharSet} !~ /^iso-?8859-?1$/io ) { 1942 $this->{response}->charset( $TWiki::cfg{Site}{CharSet} ); 1943 } 1944 1945 $this->{_HTMLHEADERS} = {}; 1946 $this->{context} = $initialContext; 1947 1948 # create the various sub-objects 1949 unless ($sandbox) { 1950 # "shared" between mod_perl instances 1951 $sandbox = new TWiki::Sandbox( $TWiki::cfg{OS}, $TWiki::cfg{DetailedOS} ); 1952 } 1953 require TWiki::Plugins; 1954 $this->{plugins} = new TWiki::Plugins( $this ); 1955 require TWiki::Store; 1956 $this->{store} = new TWiki::Store( $this ); 1957 1958 if( $TWiki::cfg{Mdrepo}{Store} && $TWiki::cfg{Mdrepo}{Dir} && 1959 $TWiki::cfg{Mdrepo}{Tables} 1960 ) { 1961 require TWiki::Mdrepo; 1962 $this->{mdrepo} = new TWiki::Mdrepo( $this ); 1963 } 1964 1965 $this->{remoteUser} = $login; #use login as a default (set when running from cmd line) 1966 require TWiki::Users; 1967 $this->{users} = new TWiki::Users( $this ); 1968 $this->{remoteUser} = $this->{users}->{remoteUser}; 1969 1970 # Make %ENV safer, preventing hijack of the search path 1971 # SMELL: can this be done in a BEGIN block? Or is the environment 1972 # set per-query? 1973 # Item4382: Default $ENV{PATH} must be untainted because TWiki runs 1974 # with use strict and calling external programs that writes on the disk 1975 # will fail unless Perl seens it as set to safe value. 1976 if( $TWiki::cfg{SafeEnvPath} ) { 1977 $ENV{PATH} = $TWiki::cfg{SafeEnvPath}; 1978 } else { 1979 $ENV{PATH} = TWiki::Sandbox::untaintUnchecked( $ENV{PATH} ); 1980 } 1981 delete $ENV{IFS}; 1982 delete $ENV{CDPATH}; 1983 delete $ENV{ENV}; 1984 delete $ENV{BASH_ENV}; 1985 1986 my $url = $query->url(); 1987 if( $url && $url =~ m{^([^:]*://[^/]*).*$} ) { 1988 $this->{urlHost} = $1; 1989 # If the urlHost in the url is localhost, this is a lot less 1990 # useful than the default url host. This is because new CGI("") 1991 # assigns this host by default - it's a default setting, used 1992 # when there is nothing better available. 1993 if( $this->{urlHost} eq 'http://localhost' ) { 1994 $this->{urlHost} = $TWiki::cfg{DefaultUrlHost}; 1995 } elsif( $TWiki::cfg{RemovePortNumber} ) { 1996 $this->{urlHost} =~ s/\:[0-9]+$//; 1997 } 1998 } else { 1999 $this->{urlHost} = $TWiki::cfg{DefaultUrlHost}; 2000 } 2001 if ( $TWiki::cfg{GetScriptUrlFromCgi} 2002 && $url 2003 && $url =~ m{^[^:]*://[^/]*(.*)/.*$} 2004 && $1 ) 2005 { 2006 2007 # SMELL: this is a really dangerous hack. It will fail 2008 # spectacularly with mod_perl. 2009 # SMELL: why not just use $query->script_name? 2010 $this->{scriptUrlPath} = $1; 2011 } 2012 2013 my $web = ''; 2014 my $topic = $query->param( 'topic' ); 2015 if( $topic ) { 2016 if( $topic =~ m#^$regex{linkProtocolPattern}://#o && 2017 $this->{request} ) { 2018 # redirect to URI 2019 $this->{webName} = ''; 2020 $this->redirect( $topic ); 2021 return $this; 2022 } elsif( $topic =~ /((?:.*[\.\/])+)(.*)/ ) { 2023 # is 'bin/script?topic=Webname.SomeTopic' 2024 $web = $1; 2025 $topic = $2; 2026 $web =~ s/\./\//go; 2027 $web =~ s/\/$//o; 2028 # jump to WebHome if 'bin/script?topic=Webname.' 2029 $topic = $TWiki::cfg{HomeTopicName} if( $web && ! $topic ); 2030 } 2031 # otherwise assume 'bin/script/Webname?topic=SomeTopic' 2032 } else { 2033 $topic = ''; 2034 } 2035 2036 my $pathInfo = $query->path_info(); 2037 2038 # Save the path info with tilde for a later process. 2039 # A login name may contain dots hence the entire pathInfo needs to be saved 2040 # before being processed. 2041 if ( $pathInfo =~ m:^/~: ) { 2042 $this->{pathInfoWithTilde} = $pathInfo; 2043 } 2044 2045 @$this{'webName', 'topicName', 'requestedWebName'} = 2046 $this->determineWebTopic($pathInfo, $web, $topic); 2047 2048 # Item3270 - here's the appropriate place to enforce TWiki spec: 2049 # All topic name sources are evaluated, site charset applied 2050 # SMELL: This untaint unchecked is duplicate of one just above 2051 $this->{topicName} = TWiki::Sandbox::untaintUnchecked(ucfirst $this->{topicName}); 2052 2053 $this->{scriptUrlPath} = $TWiki::cfg{ScriptUrlPath}; 2054 2055 require TWiki::Prefs; 2056 my $prefs = new TWiki::Prefs( $this ); 2057 $this->{prefs} = $prefs; 2058 2059 # Form definition cache 2060 $this->{forms} = {}; 2061 2062 # Push global preferences from TWiki.TWikiPreferences 2063 $prefs->pushGlobalPreferences(); 2064 2065 # SMELL: what happens if we move this into the TWiki::User::new? 2066 $this->{user} = $this->{users}->initialiseUser($this->{remoteUser}); 2067 2068 # Static session variables that can be expanded in topics when they 2069 # are enclosed in % signs 2070 # SMELL: should collapse these into one. The duplication is pretty 2071 # pointless. Could get rid of the SESSION_TAGS hash, might be 2072 # the easiest thing to do, but then that would allow other 2073 # upper-case named fields in the object to be accessed as well... 2074 $this->{SESSION_TAGS}{BASEWEB} = $this->{webName}; 2075 $this->{SESSION_TAGS}{BASETOPIC} = $this->{topicName}; 2076 $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $this->{topicName}; 2077 $this->{SESSION_TAGS}{INCLUDINGWEB} = $this->{webName}; 2078 $this->{SESSION_TAGS}{SITENAME} = 2079 $TWiki::cfg{ReadOnlyAndMirrorWebs}{SiteName} || ''; 2080 2081 # Push plugin settings 2082 $this->{plugins}->settings(); 2083 2084 # Now the rest of the preferences 2085 $prefs->pushGlobalPreferencesSiteSpecific(); 2086 $this->_readUserPreferences() unless ( $TWiki::cfg{DemoteUserPreferences} ); 2087 $prefs->pushWebPreferences( $this->{webName} ); 2088 $this->_readExtraPreferences(); 2089 $prefs->pushPreferences( $this->{webName}, $this->{topicName}, 'TOPIC' ); 2090 2091 $prefs->pushPreferenceValues( 'SESSION', 2092 $this->{users}->{loginManager}->getSessionValues() ); 2093 2094 $this->_readUserPreferences() if ( $TWiki::cfg{DemoteUserPreferences} ); 2095 2096 # Finish plugin initialization - register handlers 2097 $this->{plugins}->enable(); 2098 2099 # SMELL: Every place should localize it before use, so it's not necessary here. 2100 $TWiki::Plugins::SESSION = $this; 2101 2102 my ($mode, $master) = $this->modeAndMaster($this->{webName}); 2103 $this->{contentMode} = $mode; 2104 if ( $master ) { 2105 $this->{master} = $master; 2106 } 2107 2108 return $this; 2109} 2110 2111=begin twiki 2112 2113---++ ObjectMethod renderer() 2114Get a reference to the renderer object. Done lazily because not everyone 2115needs the renderer. 2116 2117=cut 2118 2119sub renderer { 2120 my( $this ) = @_; 2121 2122 unless( $this->{renderer} ) { 2123 require TWiki::Render; 2124 # requires preferences (such as LINKTOOLTIPINFO) 2125 $this->{renderer} = new TWiki::Render( $this ); 2126 } 2127 return $this->{renderer}; 2128} 2129 2130=begin twiki 2131 2132---++ ObjectMethod attach() 2133Get a reference to the attach object. Done lazily because not everyone 2134needs the attach. 2135 2136=cut 2137 2138sub attach { 2139 my( $this ) = @_; 2140 2141 unless( $this->{attach} ) { 2142 require TWiki::Attach; 2143 $this->{attach} = new TWiki::Attach( $this ); 2144 } 2145 return $this->{attach}; 2146} 2147 2148=begin twiki 2149 2150---++ ObjectMethod templates() 2151Get a reference to the templates object. Done lazily because not everyone 2152needs the templates. 2153 2154=cut 2155 2156sub templates { 2157 my( $this ) = @_; 2158 2159 unless( $this->{templates} ) { 2160 require TWiki::Templates; 2161 $this->{templates} = new TWiki::Templates( $this ); 2162 } 2163 return $this->{templates}; 2164} 2165 2166=begin twiki 2167 2168---++ ObjectMethod i18n() 2169Get a reference to the i18n object. Done lazily because not everyone 2170needs the i18ner. 2171 2172=cut 2173 2174sub i18n { 2175 my( $this ) = @_; 2176 2177 unless( $this->{i18n} ) { 2178 require TWiki::I18N; 2179 # language information; must be loaded after 2180 # *all possible preferences sources* are available 2181 $this->{i18n} = new TWiki::I18N( $this ); 2182 } 2183 return $this->{i18n}; 2184} 2185 2186=begin twiki 2187 2188---++ ObjectMethod search() 2189Get a reference to the search object. Done lazily because not everyone 2190needs the searcher. 2191 2192=cut 2193 2194sub search { 2195 my( $this ) = @_; 2196 2197 unless( $this->{search} ) { 2198 require TWiki::Search; 2199 $this->{search} = new TWiki::Search( $this ); 2200 } 2201 return $this->{search}; 2202} 2203 2204=begin twiki 2205 2206---++ ObjectMethod security() 2207Get a reference to the security object. Done lazily because not everyone 2208needs the security. 2209 2210=cut 2211 2212sub security { 2213 my( $this ) = @_; 2214 2215 unless( $this->{security} ) { 2216 require TWiki::Access; 2217 $this->{security} = new TWiki::Access( $this ); 2218 } 2219 return $this->{security}; 2220} 2221 2222=begin twiki 2223 2224---++ ObjectMethod net() 2225Get a reference to the net object. Done lazily because not everyone 2226needs the net. 2227 2228=cut 2229 2230sub net { 2231 my( $this ) = @_; 2232 2233 unless( $this->{net} ) { 2234 require TWiki::Net; 2235 $this->{net} = new TWiki::Net( $this ); 2236 } 2237 return $this->{net}; 2238} 2239 2240=begin twiki 2241 2242---++ ObjectMethod finish() 2243Break circular references. 2244 2245=cut 2246 2247# Note to developers; please undef *all* fields in the object explicitly, 2248# whether they are references or not. That way this method is "golden 2249# documentation" of the live fields in the object. 2250sub finish { 2251 my $this = shift; 2252 2253 $_->finish() foreach values %{$this->{forms}}; 2254 $this->{plugins}->finish() if $this->{plugins}; 2255 $this->{users}->finish() if $this->{users}; 2256 $this->{prefs}->finish() if $this->{prefs}; 2257 $this->{templates}->finish() if $this->{templates}; 2258 $this->{renderer}->finish() if $this->{renderer}; 2259 $this->{net}->finish() if $this->{net}; 2260 $this->{store}->finish() if $this->{store}; 2261 $this->{mdrepo}->finish() if $this->{mdrepo}; 2262 $this->{search}->finish() if $this->{search}; 2263 $this->{attach}->finish() if $this->{attach}; 2264 $this->{security}->finish() if $this->{security}; 2265 $this->{i18n}->finish() if $this->{i18n}; 2266 2267 undef $this->{_HTMLHEADERS}; 2268 undef $this->{request}; 2269 undef $this->{urlHost}; 2270 undef $this->{web}; 2271 undef $this->{topic}; 2272 undef $this->{webName}; 2273 undef $this->{topicName}; 2274 undef $this->{_ICONMAP}; 2275 undef $this->{context}; 2276 undef $this->{remoteUser}; 2277 undef $this->{requestedWebName}; # Web name before renaming 2278 undef $this->{scriptUrlPath}; 2279 undef $this->{user}; 2280 undef $this->{SESSION_TAGS}; 2281 undef $this->{_INCLUDES}; 2282 undef $this->{ignoreTOC}; 2283 undef $this->{response}; 2284 undef $this->{evaluating_if}; 2285 undef $this->{contentMode}; 2286 undef $this->{master}; 2287 undef $this->{modeAndMaster}; 2288} 2289 2290=pod 2291 2292---++ ObjectMethod writeLog( $action, $webTopic, $extra, $user ) 2293 2294 * =$action= - what happened, e.g. view, save, rename 2295 * =$wbTopic= - what it happened to 2296 * =$extra= - extra info, such as minor flag 2297 * =$user= - user who did the saving (user id) 2298Write the log for an event to the logfile 2299 2300=cut 2301 2302sub writeLog { 2303 my $this = shift; 2304 2305 my $action = shift || ''; 2306 my $webTopic = shift || ''; 2307 my $extra = shift || ''; 2308 my $user = shift || $this->{user}; 2309 2310 my $login = $user; 2311 if( $this->{users} ) { 2312 $login = $this->{users}->getLoginName( $user ) # fast 2313 || $this->{users}->getLoginName( 2314 $this->{users}->getCanonicalUserID( $user ) ) # slower 2315 || 'unknown'; 2316 } 2317 2318 my $cgiQuery = $this->{request}; 2319 if( $cgiQuery && $action eq 'view' ) { 2320 my $agent = $cgiQuery->user_agent(); 2321 if( $agent && $agent =~ m/([\w]+)/ ) { 2322 $extra = "$1 $extra"; 2323 $extra =~ s/ +$//; 2324 } 2325 } 2326 2327 my $remoteAddr = $this->{request}->remoteAddress() || ''; 2328 my $text = "$login | $action | $webTopic | $extra | $remoteAddr |"; 2329 2330 _writeReport( $this, $TWiki::cfg{LogFileName}, $text ); 2331} 2332 2333=pod 2334 2335---++ ObjectMethod writeWarning( $text ) 2336 2337Prints date, time, and contents $text to $TWiki::cfg{WarningFileName}, typically 2338'warnings.txt'. Use for warnings and errors that may require admin 2339intervention. Use this for defensive programming warnings (e.g. assertions). 2340 2341=cut 2342 2343sub writeWarning { 2344 my $this = shift; 2345 my $text = shift; 2346 $text =~ s/[\r\n]+$//s; 2347 _writeReport( $this, $TWiki::cfg{WarningFileName}, "$text |" ); 2348} 2349 2350=pod 2351 2352---++ ObjectMethod writeDebug( $text ) 2353 2354Prints date, time, and contents of $text to $TWiki::cfg{DebugFileName}, typically 2355'debug.txt'. Use for debugging messages. 2356 2357=cut 2358 2359sub writeDebug { 2360 my $this = shift; 2361 my $text = shift; 2362 _writeReport( $this, $TWiki::cfg{DebugFileName}, "$text |" ); 2363} 2364 2365# resolve %DATE% (and maybe other things in the future) in a "file name" config 2366# parameter 2367sub _fileNameToPath { 2368 my $path = shift; 2369 if ( $path =~ /%DATE%/ ) { 2370 $path =~ s//TWiki::Time::formatTime( time(), '$year$mo', 'gmtime')/ge; 2371 } 2372 return $path; 2373} 2374 2375# Concatenates date, time, and $text to a log file. 2376# The logfilename can optionally use a %DATE% variable to support 2377# logs that are rotated once a month. 2378# | =$log= | Base filename for log file | 2379# | =$message= | Message to print | 2380sub _writeReport { 2381 my ( $this, $log, $message ) = @_; 2382 2383 if ( $log ) { 2384 $log = _fileNameToPath( $log ); 2385 my $time = TWiki::Time::formatTime( time(), '$year-$mo-$day - $hour:$min:$sec' ); 2386 # ommitting the third argument ($outputTimeZone) to resort to $TWiki::cfg{DisplayTimeValues} as per Item7811 2387 2388 if( open( FILE, ">>$log" ) ) { 2389 print FILE "| $time | $message\n"; 2390 close( FILE ); 2391 } else { 2392 print STDERR 'Could not write "'.$message.'" to '."$log: $!\n"; 2393 } 2394 } 2395} 2396 2397sub _removeNewlines { 2398 my( $theTag ) = @_; 2399 $theTag =~ s/[\r\n]+/ /gs; 2400 return $theTag; 2401} 2402 2403# Convert relative URLs to absolute URIs 2404sub _rewriteURLInInclude { 2405 my( $theHost, $theAbsPath, $url ) = @_; 2406 2407 # leave out an eventual final non-directory component from the absolute path 2408 $theAbsPath =~ s/(.*?)[^\/]*$/$1/; 2409 2410 if( $url =~ /^\// ) { 2411 # fix absolute URL 2412 $url = $theHost.$url; 2413 } elsif( $url =~ /^\./ ) { 2414 # fix relative URL 2415 $url = $theHost.$theAbsPath.'/'.$url; 2416 } elsif( $url =~ /^$regex{linkProtocolPattern}:/o ) { 2417 # full qualified URL, do nothing 2418 } elsif( $url =~ /^#/ ) { 2419 # anchor. This needs to be left relative to the including topic 2420 # so do nothing 2421 } elsif( $url ) { 2422 # FIXME: is this test enough to detect relative URLs? 2423 $url = $theHost.$theAbsPath.'/'.$url; 2424 } 2425 2426 return $url; 2427} 2428 2429# Add a web reference to a [[...][...]] link in an included topic 2430sub _fixIncludeLink { 2431 my( $web, $link, $label ) = @_; 2432 2433 # Detect absolute and relative URLs, web-qualified wikinames and Interwiki links 2434 if( $link =~ m/^$regex{excludeFixIncludeLinkRegex}/o ) { 2435 if( $label ) { 2436 return "[[$link][$label]]"; 2437 } else { 2438 return "[[$link]]"; 2439 } 2440 } elsif( !$label ) { 2441 # Must be wikiword or spaced-out wikiword (or illegal link :-/) 2442 $label = $link; 2443 } 2444 return "[[$web.$link][$label]]"; 2445} 2446 2447# Replace web references in a topic. Called from forEachLine, applying to 2448# each non-verbatim and non-literal line. 2449sub _fixupIncludedTopic { 2450 my( $text, $options ) = @_; 2451 2452 my $fromWeb = $options->{web}; 2453 2454 unless( $options->{in_noautolink} || $options->{force_noautolink} ) { 2455 # Prefix web name to WikiWord to make links work, such as: 2456 # 'TopicName' to 'Web.TopicName' 2457 # TWikibug:Item6840: Exclude 'WikiWordWeb.TopicName' using translation token 2458 $text =~ s/(?:^|(?<=[\s(]))($regex{webNameRegex}\.($regex{wikiWordRegex}|$regex{abbrevRegex}))/-$TranslationToken$1/go; 2459 $text =~ s#(?:^|(?<=[\s(]))($regex{wikiWordRegex})#$fromWeb.$1#go; 2460 $text =~ s/-$TranslationToken//go; 2461 } 2462 2463 # Handle explicit [[]] everywhere 2464 # '[[TopicName][...]]' to '[[Web.TopicName][...]]' 2465 $text =~ s/\[\[([^]]+)\](?:\[([^]]+)\])?\]/ 2466 _fixIncludeLink( $fromWeb, $1, $2 )/geo; 2467 2468 return $text; 2469} 2470 2471# Clean-up HTML text so that it can be shown embedded in a topic 2472sub _cleanupIncludedHTML { 2473 my( $text, $host, $path, $options ) = @_; 2474 2475 # FIXME: Make aware of <base> tag 2476 2477 $text =~ s/^.*?<\/head>//is 2478 unless ( $options->{disableremoveheaders} ); # remove all HEAD 2479 $text =~ s/<script.*?<\/script>//gis 2480 unless ( $options->{disableremovescript} ); # remove all SCRIPTs 2481 $text =~ s/^.*?<body[^>]*>//is 2482 unless ( $options->{disableremovebody} ); # remove all to <BODY> 2483 $text =~ s/(?:\n)<\/body>.*//is 2484 unless ( $options->{disableremovebody} ); # remove </BODY> 2485 $text =~ s/(?:\n)<\/html>.*//is 2486 unless ( $options->{disableremoveheaders} ); # remove </HTML> 2487 $text =~ s/(<[^>]*>)/_removeNewlines($1)/ges 2488 unless ( $options->{disablecompresstags} ); # replace newlines in html tags with space 2489 $text =~ s/(\s(?:href|src|action)=(["']))(.*?)\2/$1._rewriteURLInInclude( $host, $path, $3 ).$2/geois 2490 unless ( $options->{disablerewriteurls} ); 2491 2492 return $text; 2493} 2494 2495=pod 2496 2497---++ StaticMethod applyPatternToIncludedText( $text, $pattern ) -> $text 2498 2499Apply a pattern on included text to extract a subset 2500 2501=cut 2502 2503sub applyPatternToIncludedText { 2504 my( $theText, $thePattern ) = @_; 2505 $thePattern =~ s/([^\\])([\$\@\%\&\#\'\`\/])/$1\\$2/g; # escape some special chars 2506 $thePattern = TWiki::Sandbox::untaintUnchecked( $thePattern ); 2507 $theText = '' unless( $theText =~ s/$thePattern/$1/is ); 2508 return $theText; 2509} 2510 2511# This is actually for encoding conversion rather than chararacter set. 2512# But following the usual terminology, 'charset' is used. 2513sub _convertCharsets { 2514 my ($this, $srcCharset, $dstCharset, $textRef) = @_; 2515 if ( $] >= 5.008 ) { # Perl 5.8 or later 2516 require Encode; 2517 my $srcCanonical = Encode::resolve_alias($srcCharset); 2518 my $dstCanonical = Encode::resolve_alias($dstCharset); 2519 if ( $srcCanonical && $dstCanonical ) { 2520 if ( $srcCanonical ne $dstCanonical ) { 2521 $$textRef = Encode::encode($dstCanonical, 2522 Encode::decode($srcCanonical, $$textRef)); 2523 } 2524 } 2525 else { 2526 $this->writeWarning( 2527 ($srcCanonical ? '' : "charset $srcCharset not supported. ") . 2528 ($dstCanonical ? '' : "charset $dstCharset not supported. ")); 2529 } 2530 } 2531 else { # Pre-5.8 Perl versions 2532 require Unicode::MapUTF8; 2533 my $srcOK = Unicode::MapUTF8::utf8_supported_charset($srcCharset); 2534 my $dstOK = Unicode::MapUTF8::utf8_supported_charset($dstCharset); 2535 if ( $srcOK && $dstOK ) { 2536 my $text = Unicode::MapUTF8::to_utf8( 2537 {-string => $$textRef, -charset => $srcCharset}); 2538 $$textRef = Unicode::MapUTF8::from_utf8( 2539 {-string => $text, -charset => $dstCharset}); 2540 } 2541 else { 2542 $this->writeWarning( 2543 ($srcOK ? '' : "charset $srcCharset not supported. ") . 2544 ($dstOK ? '' : "charset $dstCharset not supported. ")); 2545 } 2546 } 2547} 2548 2549# newline, encode, and nofinalnewline parameters 2550sub _includePostProcessing { 2551 my ($this, $textRef, $params) = @_; 2552 my $newLine = $params->{newline}; 2553 if( defined $newLine ) { 2554 $newLine =~ s/\$br\b/\0-br-\0/go; 2555 $newLine =~ s/\$n\b/\0-n-\0/go; 2556 $$textRef =~ s/\r?\n/$newLine/go; 2557 } 2558 if( my $encode = $params->{encode} ) { 2559 $$textRef = $this->ENCODE( { _DEFAULT => $$textRef, type => $encode } ); 2560 } 2561 if( defined $newLine ) { 2562 $$textRef =~ s/\0-br-\0/<br \/>/go; 2563 $$textRef =~ s/\0-n-\0/\n/go; 2564 } 2565 $$textRef =~ s/(\r?\n)+$// if ( isTrue($params->{nofinalnewline}) ); 2566} 2567 2568# Fetch content from a URL for inclusion by an INCLUDE 2569sub _includeUrl { 2570 my( $this, $url, $pattern, $web, $topic, $raw, $options, $warn, 2571 $allowAnyType, $charSetParam ) = @_; 2572 my $text = ''; 2573 2574 # For speed, read file directly if URL matches an attachment directory 2575 my $urlHostRegex = $TWiki::cfg{UrlHostRegex} || $this->{urlHost}; 2576 if( $url =~ /^$urlHostRegex$TWiki::cfg{PubUrlPath}\/($regex{webNameRegex})\/([^\/\.]+)\/([^\/]+)$/o ) { 2577 my $incWeb = $1; 2578 my $incTopic = $2; 2579 my $incAtt = $3; 2580 my $mimeType = suffixToMimeType($incAtt); 2581 if( $allowAnyType || $mimeType =~ /^text\/(html|plain|css)/ ) { 2582 unless( $this->{store}->attachmentExists( 2583 $incWeb, $incTopic, $incAtt )) { 2584 return _includeWarning( $this, $warn, 'bad_attachment', $url ); 2585 } 2586 if( $incWeb ne $web || $incTopic ne $topic ) { 2587 # CODE_SMELL: Does not account for not yet authenticated user 2588 unless( $this->security->checkAccessPermission( 2589 'VIEW', $this->{user}, undef, undef, $incTopic, $incWeb ) ) { 2590 return _includeWarning( $this, $warn, 'access_denied', 2591 "$incWeb.$incTopic" ); 2592 } 2593 } 2594 $text = $this->{store}->readAttachment( undef, $incWeb, $incTopic, 2595 $incAtt ); 2596 $text = _cleanupIncludedHTML( $text, $this->{urlHost}, 2597 $TWiki::cfg{PubUrlPath}, $options ) 2598 unless $raw; 2599 $text = applyPatternToIncludedText( $text, $pattern ) 2600 if( $pattern ); 2601 $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} ); 2602 return $text; 2603 } 2604 else { 2605 return _includeWarning( $this, $warn, 'bad_content', $mimeType ); 2606 } 2607 } 2608 2609 return _includeWarning( $this, $warn, 'urls_not_allowed' ) 2610 unless $TWiki::cfg{INCLUDE}{AllowURLs}; 2611 2612 # SMELL: should use the URI module from CPAN to parse the URL 2613 # SMELL: but additional CPAN adds to code bloat 2614 unless ($url =~ m!^https?:!) { 2615 $text = _includeWarning( $this, $warn, 'bad_protocol', $url ); 2616 return $text; 2617 } 2618 2619 # Item7570. This causes both false positive and false negative 2620 if ( $url =~ /^$urlHostRegex/o ) { 2621 if ( $topic eq $cfg{HomeTopicName} ) { 2622 if ( $url =~ m:/$web\b: ) { 2623 return _includeWarning( $this, $warn, 'recursive_include', $url ); 2624 } 2625 } 2626 else { 2627 if ( $url =~ m:/$web[./]$topic\b: ) { 2628 return _includeWarning( $this, $warn, 'recursive_include', $url ); 2629 } 2630 } 2631 } 2632 2633 my $response = $this->net->getExternalResource( $url ); 2634 if( !$response->is_error()) { 2635 my $contentType = $response->header('content-type') || 2636 'application/octet-stream'; # RFC2616 section 7.2.1 2637 $text = $response->content(); 2638 # converting character encodings 2639 my $siteCharset = $TWiki::cfg{Site}{CharSet} || 'iso-8859-1'; 2640 my $includedCharset = ''; 2641 if ( $charSetParam ) { 2642 $includedCharset = $charSetParam; 2643 } 2644 else { 2645 if ( $contentType =~ /charset=([\w-]+)/i ) { 2646 $includedCharset = $1; 2647 } 2648 elsif ( $text =~ 2649 /<meta\s+http-equiv=[^>]+content-type[^>]+charset=([-\w]+)/i 2650 ) { 2651 $includedCharset = $1; 2652 } 2653 else { 2654 $includedCharset = 'iso-8859-1'; 2655 } 2656 } 2657 $this->_convertCharsets($includedCharset, $siteCharset, \$text); 2658 if( $contentType =~ /^text\/html/ ) { 2659 if (!$raw) { 2660 $url =~ m!^([a-z]+:/*[^/]*)(/[^#?]*)!; 2661 $text = _cleanupIncludedHTML( $text, $1, $2, $options ); 2662 } 2663 } elsif( $contentType =~ /^text\/(plain|css)/ ) { 2664 # do nothing 2665 } else { 2666 unless ( $allowAnyType ) { 2667 $text = _includeWarning( $this, $warn, 'bad_content', 2668 $contentType ); 2669 } 2670 } 2671 $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern ); 2672 $text = "<literal>\n" . $text . "\n</literal>" if ( $options->{literal} ); 2673 $this->_includePostProcessing(\$text, $options); 2674 } else { 2675 $text = _includeWarning( $this, $warn, 'geturl_failed', 2676 $url.' '.$response->message() ); 2677 } 2678 2679 return $text; 2680} 2681 2682# 2683# SMELL: this is _not_ a tag handler in the sense of other builtin tags, 2684# because it requires far more context information (the text of the topic) 2685# than any handler. 2686# SMELL: as a tag handler that also semi-renders the topic to extract the 2687# headings, this handler would be much better as a preRenderingHandler in 2688# a plugin (where head, script and verbatim sections are already protected) 2689# 2690# * $text : ref to the text of the current topic 2691# * $topic : the topic we are in 2692# * $web : the web we are in 2693# * $args : 'Topic' [web='Web'] [depth='N'] 2694# Return value: $tableOfContents 2695# Handles %<nop>TOC{...}% syntax. Creates a table of contents 2696# using TWiki bulleted 2697# list markup, linked to the section headings of a topic. A section heading is 2698# entered in one of the following forms: 2699# * $headingPatternSp : \t++... spaces section heading 2700# * $headingPatternDa : ---++... dashes section heading 2701# * $headingPatternHt : <h[1-6]> HTML section heading </h[1-6]> 2702sub _TOC { 2703 my ( $this, $text, $defaultTopic, $defaultWeb, $args ) = @_; 2704 2705 return '' if( $this->{ignoreTOC} ); # prevent infinite recursion 2706 2707 require TWiki::Attrs; 2708 2709 my $params = new TWiki::Attrs( $args ); 2710 # get the topic name attribute 2711 my $topic = $params->{_DEFAULT} || $defaultTopic; 2712 2713 # get the web name attribute 2714 $defaultWeb =~ s#/#.#g; 2715 my $web = $params->{web} || $defaultWeb; 2716 2717 my $isSameTopic = $web eq $defaultWeb && $topic eq $defaultTopic; 2718 2719 $web =~ s#/#\.#g; 2720 my $webPath = $web; 2721 $webPath =~ s/\./\//g; 2722 2723 # get the depth limit attribute 2724 my $maxDepth = $params->{depth} || $this->{prefs}->getPreferencesValue('TOC_MAX_DEPTH') || 6; 2725 my $minDepth = $params->{mindepth} || $this->{prefs}->getPreferencesValue('TOC_MIN_DEPTH') || 1; 2726 2727 # get the title attribute 2728 my $title = $params->{title} || $this->{prefs}->getPreferencesValue('TOC_TITLE') || ''; 2729 $title = CGI::span( { class => 'twikiTocTitle' }, $title ) if( $title ); 2730 2731 # get the style attribute 2732 my $style = $params->{style} || $this->{prefs}->getPreferencesValue('TOC_STYLE') || ''; 2733 2734 # Item7286: Load topic text if TOC is built for another topic, 2735 # or if in skin context of the current topic 2736 unless( $isSameTopic && $this->inContext( 'body_text' ) ) { 2737 unless( $this->security->checkAccessPermission 2738 ( 'VIEW', $this->{user}, undef, undef, $topic, $web ) ) { 2739 return $this->inlineAlert( 'alerts', 'access_denied', $web, $topic ); 2740 } 2741 my $meta; 2742 ( $meta, $text ) = $this->{store}->readTopic( $this->{user}, $web, $topic ); 2743 # prevent infinite recursion - could happen if there is a TOC in the text or in INCLUDE 2744 $this->{ignoreTOC} = 1; 2745 # Item6864: 2012-03-29 TWiki:Main.GertjanVanOosten, gertjan at west dot nl: 2746 # Handle common tags, as the text may contain variables etc. that need 2747 # to be expanded before generating the TOC for another topic. 2748 $text = $this->handleCommonTags( $text, $web, $topic, $meta ); 2749 $this->{ignoreTOC} = undef; 2750 } 2751 2752 my $insidePre = 0; 2753 my $insideVerbatim = 0; 2754 my $highest = 99; 2755 my $result = ''; 2756 my $verbatim = {}; 2757 $text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim); 2758 $text = $this->renderer->takeOutBlocks( $text, 'pre', $verbatim); 2759 2760 # Find URL parameters 2761 my $query = $this->{request}; 2762 my @qparams = (); 2763 foreach my $name ( $query->param ) { 2764 next if ($name eq 'keywords'); 2765 next if ($name eq 'topic'); 2766 next if ($name eq 'text'); 2767 push @qparams, $name => $query->param($name); 2768 } 2769 2770 # clear the set of unique anchornames in order to inhibit the 'relabeling' of 2771 # anchor names if the same topic is processed more than once, cf. explanation 2772 # in handleCommonTags() 2773 $this->renderer->_eraseAnchorNameMemory(); 2774 2775 # NB: While we're processing $text line by line here, 2776 # $this->renderer->getRendereredVersion() 'allocates' unique anchor names by 2777 # first replacing '#WikiWord', followed by regex{headerPatternHt} and 2778 # regex{headerPatternDa}. In order to stay in sync and not 'clutter'/slow 2779 # down the renderer code, we have to adhere to this order here as well 2780 my @regexps = ('^(\#)('.$regex{wikiWordRegex}.')', 2781 $regex{headerPatternHt}, 2782 $regex{headerPatternDa}); 2783 my @lines = split( /\r?\n/, $text ); 2784 my %anchors = (); 2785 my %headings = (); 2786 my %levels = (); 2787 for my $i (0 .. $#regexps) { 2788 my $lineno = 0; 2789 # SMELL: use forEachLine 2790 foreach my $line (@lines) { 2791 $lineno++; 2792 if ($line =~ m/$regexps[$i]/) { 2793 my ($level, $heading) = ($1, $2); 2794 my $anchor = $this->renderer->makeUniqueAnchorName($web, $topic, $heading); 2795 2796 if ($i > 0) { 2797 # SMELL: needed only because Render::_makeAnchorHeading uses it 2798 my $compatAnchor = $this->renderer->makeAnchorName($anchor, 1); 2799 $compatAnchor = $this->renderer->makeUniqueAnchorName($web, $topic, $anchor, 1) 2800 if ($compatAnchor ne $anchor); 2801 2802 $heading =~ s/\s*$regex{headerPatternNoTOC}.+$//go; 2803 next unless $heading; 2804 2805 $level = length $level if ($i == 2); 2806 if( ($level >= $minDepth) && ($level <= $maxDepth) ) { 2807 $anchors{$lineno} = $anchor; 2808 $headings{$lineno} = $heading; 2809 $levels{$lineno} = $level; 2810 } 2811 } 2812 } 2813 } 2814 } 2815 2816 # SMELL: this handling of <pre> is archaic. 2817 foreach my $lineno (sort{$a <=> $b}(keys %headings)) { 2818 my ($level, $line, $anchor) = ($levels{$lineno}, $headings{$lineno}, $anchors{$lineno}); 2819 $highest = $level if( $level < $highest ); 2820 my $tabs = "\t" x $level; 2821 # Remove *bold*, _italic_ and =fixed= formatting 2822 $line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g; 2823 $line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g; 2824 $line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g; 2825 # Prevent WikiLinks 2826 $line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g; # '[[...][...]]' 2827 $line =~ s/\[\[(.*?)\]\]/$1/ge; # '[[...]]' 2828 $line =~ s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1<nop>$3/go; # 'Web.TopicName' 2829 $line =~ s/([\s\(])($regex{wikiWordRegex})/$1<nop>$2/go; # 'TopicName' 2830 $line =~ s/([\s\(])($regex{abbrevRegex})/$1<nop>$2/go; # 'TLA' 2831 $line =~ s/([\s\-\*\(])([$regex{mixedAlphaNum}]+\:)/$1<nop>$2/go; # 'Site:page' Interwiki link 2832 # Prevent manual links 2833 $line =~ s/<[\/]?a\b[^>]*>//gi; 2834 # create linked bullet item, using a relative link to anchor 2835 my $target = $isSameTopic ? 2836 _make_params(0, '#'=>$anchor,@qparams) : 2837 $this->getScriptUrl(0,'view',$web,$topic,'#'=>$anchor,@qparams); 2838 $line = $tabs.'* ' . CGI::a({href=>$target},$line); 2839 $result .= "\n".$line; 2840 } 2841 2842 if( $result ) { 2843 if( $highest > 1 ) { 2844 # left shift TOC 2845 $highest--; 2846 $result =~ s/^\t{$highest}//gm; 2847 } 2848 my $args; 2849 $args->{class} = 'twikiToc'; 2850 $args->{style} = $style if( $style ); 2851 return CGI::div( $args, "$title$result\n" ); 2852 } else { 2853 return ''; 2854 } 2855} 2856 2857=pod 2858 2859---++ ObjectMethod inlineAlert($template, $def, ... ) -> $string 2860 2861Format an error for inline inclusion in rendered output. The message string 2862is obtained from the template 'oops'.$template, and the DEF $def is 2863selected. The parameters (...) are used to populate %PARAM1%..%PARAMn% 2864 2865=cut 2866 2867sub inlineAlert { 2868 my $this = shift; 2869 my $template = shift; 2870 my $def = shift; 2871 2872 my $text = $this->templates->readTemplate( 'oops'.$template, 2873 $this->getSkin() ); 2874 if( $text ) { 2875 my $blah = $this->templates->expandTemplate( $def ); 2876 $text =~ s/%INSTANTIATE%/$blah/; 2877 # web and topic can be anything; they are not used 2878 $text = $this->handleCommonTags( $text, $this->{webName}, 2879 $this->{topicName} ); 2880 my $n = 1; 2881 while( defined( my $param = shift )) { 2882 $text =~ s/%PARAM$n%/$param/g; 2883 $n++; 2884 } 2885 2886 } else { 2887 $text = CGI::h1('TWiki Installation Error') 2888 . 'Template "'.$template.'" not found.'.CGI::p() 2889 . 'Check your configuration settings for {TemplateDir} and {TemplatePath}'; 2890 } 2891 2892 $text =~ s/^\s+//s; 2893 $text =~ s/\s+$//s; 2894 2895 return $text; 2896} 2897 2898=pod 2899 2900---++ StaticMethod parseSections($text) -> ($string,$sectionlistref) 2901 2902Generic parser for sections within a topic. Sections are delimited 2903by STARTSECTION and ENDSECTION, which may be nested, overlapped or 2904otherwise abused. The parser builds an array of sections, which is 2905ordered by the order of the STARTSECTION within the topic. It also 2906removes all the SECTION tags from the text, and returns the text 2907and the array of sections. 2908 2909Each section is a =TWiki::Attrs= object, which contains the attributes 2910{type, name, start, end} 2911where start and end are character offsets in the 2912string *after all section tags have been removed*. All sections 2913are required to be uniquely named; if a section is unnamed, it 2914will be given a generated name. Sections may overlap or nest. 2915 2916See test/unit/Fn_SECTION.pm for detailed testcases that 2917round out the spec. 2918 2919=cut 2920 2921sub parseSections { 2922 #my( $text _ = @_; 2923 my %sections; 2924 my @list = (); 2925 2926 my $seq = 0; 2927 my $ntext = ''; 2928 my $offset = 0; 2929 foreach my $bit (split(/(%(?:START|END)SECTION(?:{.*?})?%)/, $_[0] )) { 2930 if( $bit =~ /^%STARTSECTION(?:{(.*)})?%$/) { 2931 require TWiki::Attrs; 2932 my $attrs = new TWiki::Attrs( $1 ); 2933 $attrs->{type} ||= 'section'; 2934 $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} || '_SECTION'.$seq++; 2935 delete $attrs->{_DEFAULT}; 2936 my $id = $attrs->{type}.':'.$attrs->{name}; 2937 if( $sections{$id} ) { 2938 # error, this named section already defined, ignore 2939 next; 2940 } 2941 # close open unnamed sections of the same type 2942 foreach my $s ( @list ) { 2943 if( $s->{end} < 0 && $s->{type} eq $attrs->{type} && 2944 $s->{name} =~ /^_SECTION\d+$/ ) { 2945 $s->{end} = $offset; 2946 } 2947 } 2948 $attrs->{start} = $offset; 2949 $attrs->{end} = -1; # open section 2950 $sections{$id} = $attrs; 2951 push( @list, $attrs ); 2952 } elsif( $bit =~ /^%ENDSECTION(?:{(.*)})?%$/ ) { 2953 require TWiki::Attrs; 2954 my $attrs = new TWiki::Attrs( $1 ); 2955 $attrs->{type} ||= 'section'; 2956 $attrs->{name} = $attrs->{_DEFAULT} || $attrs->{name} || ''; 2957 delete $attrs->{_DEFAULT}; 2958 unless( $attrs->{name} ) { 2959 # find the last open unnamed section of this type 2960 foreach my $s ( reverse @list ) { 2961 if( $s->{end} == -1 && 2962 $s->{type} eq $attrs->{type} && 2963 $s->{name} =~ /^_SECTION\d+$/ ) { 2964 $attrs->{name} = $s->{name}; 2965 last; 2966 } 2967 } 2968 # ignore it if no matching START found 2969 next unless $attrs->{name}; 2970 } 2971 my $id = $attrs->{type}.':'.$attrs->{name}; 2972 if( !$sections{$id} || $sections{$id}->{end} >= 0 ) { 2973 # error, no such open section, ignore 2974 next; 2975 } 2976 $sections{$id}->{end} = $offset; 2977 } else { 2978 $ntext .= $bit; 2979 $offset = length( $ntext ); 2980 } 2981 } 2982 2983 # close open sections 2984 foreach my $s ( @list ) { 2985 $s->{end} = $offset if $s->{end} < 0; 2986 } 2987 2988 return( $ntext, \@list ); 2989} 2990 2991=pod 2992 2993---++ ObjectMethod expandVariablesOnTopicCreation ( $text, $user, $web, $topic ) -> $text 2994 2995 * =$text= - text to expand 2996 * =$user= - This is the user expanded in e.g. %USERNAME. Optional, defaults to logged-in user. 2997 * =$web= - name of web, optional 2998 * =$topic= - name of topic, optional 2999 3000Expand limited set of variables during topic creation. These are variables 3001expected in templates that must be statically expanded in new content. 3002 3003# SMELL: no plugin handler 3004 3005=cut 3006 3007sub expandVariablesOnTopicCreation { 3008 my ( $this, $text, $user, $theWeb, $theTopic ) = @_; 3009 3010 $user ||= $this->{user}; 3011 $theWeb ||= $this->{SESSION_TAGS}{WEB} || $this->{SESSION_TAGS}{BASEWEB}; 3012 $theTopic ||= $this->{SESSION_TAGS}{TOPIC} || $this->{SESSION_TAGS}{BASETOPIC}; 3013 3014 # Chop out templateonly sections 3015 my( $ntext, $sections ) = parseSections( $text ); 3016 if( scalar( @$sections )) { 3017 # Note that if named templateonly sections overlap, the behaviour is undefined. 3018 foreach my $s ( reverse @$sections ) { 3019 if( $s->{type} eq 'templateonly' ) { 3020 $ntext = substr($ntext, 0, $s->{start}) 3021 . substr($ntext, $s->{end}, length($ntext)); 3022 } else { 3023 # put back non-templateonly sections 3024 my $start = $s->remove('start'); 3025 my $end = $s->remove('end'); 3026 $ntext = substr($ntext, 0, $start) 3027 . '%STARTSECTION{'.$s->stringify() . '}%' 3028 . substr($ntext, $start, $end - $start) 3029 . '%ENDSECTION{' . $s->stringify().'}%' 3030 . substr($ntext, $end, length($ntext)); 3031 } 3032 } 3033 $text = $ntext; 3034 } 3035 3036 # Make sure func works, for registered tag handlers 3037 $TWiki::Plugins::SESSION = $this; 3038 3039 # Note: it may look dangerous to override the user this way, but 3040 # it's actually quite safe, because only a subset of tags are 3041 # expanded during topic creation. if the set of tags expanded is 3042 # extended, then the impact has to be considered. 3043 my $safe = $this->{user}; 3044 $this->{user} = $user; 3045 $text = _processTags( $this, $text, \&_expandTagOnTopicCreation, 16 ); 3046 3047 # expand all variables for type="expandvariables" sections 3048 ( $ntext, $sections ) = parseSections( $text ); 3049 if( scalar( @$sections )) { 3050 $theWeb ||= $this->{session}->{webName}; 3051 $theTopic ||= $this->{session}->{topicName}; 3052 foreach my $s ( reverse @$sections ) { 3053 if( $s->{type} eq 'expandvariables' ) { 3054 my $etext = substr( $ntext, $s->{start}, $s->{end} - $s->{start} ); 3055 expandAllTags( $this, \$etext, $theTopic, $theWeb ); 3056 $ntext = substr( $ntext, 0, $s->{start}) 3057 . $etext 3058 . substr( $ntext, $s->{end}, length($ntext) ); 3059 } else { 3060 # put back non-expandvariables sections 3061 my $start = $s->remove('start'); 3062 my $end = $s->remove('end'); 3063 $ntext = substr($ntext, 0, $start) 3064 . '%STARTSECTION{' . $s->stringify().'}%' 3065 . substr($ntext, $start, $end - $start) 3066 . '%ENDSECTION{' . $s->stringify().'}%' 3067 . substr($ntext, $end, length($ntext)); 3068 } 3069 } 3070 $text = $ntext; 3071 } 3072 3073 # kill markers used to prevent variable expansion 3074 $text =~ s/%NOP%//g; 3075 $this->{user} = $safe; 3076 return $text; 3077} 3078 3079=pod 3080 3081---++ StaticMethod entityEncode( $text, $extras ) -> $encodedText 3082 3083Escape special characters to HTML numeric entities. This is *not* a generic 3084encoding, it is tuned specifically for use in TWiki. 3085 3086HTML4.0 spec: 3087"Certain characters in HTML are reserved for use as markup and must be 3088escaped to appear literally. The "<" character may be represented with 3089an <em>entity</em>, <strong class=html>&lt;</strong>. Similarly, ">" 3090is escaped as <strong class=html>&gt;</strong>, and "&" is escaped 3091as <strong class=html>&amp;</strong>. If an attribute value contains a 3092double quotation mark and is delimited by double quotation marks, then the 3093quote should be escaped as <strong class=html>&quot;</strong>.</p> 3094 3095Other entities exist for special characters that cannot easily be entered 3096with some keyboards..." 3097 3098This method encodes HTML special and any non-printable ascii 3099characters (except for \n and \r) using numeric entities. 3100 3101FURTHER this method also encodes characters that are special in TWiki 3102meta-language. 3103 3104$extras is an optional param that may be used to include *additional* 3105characters in the set of encoded characters. It should be a string 3106containing the additional chars. 3107 3108=cut 3109 3110sub entityEncode { 3111 my( $text, $extra) = @_; 3112 $extra ||= ''; 3113 3114 # encode all non-printable 7-bit chars (< \x1f), 3115 # except \n (\xa) and \r (\xd) 3116 # encode HTML special characters '>', '<', '&', ''' and '"'. 3117 # encode TML special characters '%', '|', '[', ']', '@', '_', 3118 # '*', and '=' 3119 $text =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|$extra])/'&#'.ord($1).';'/ge; 3120 return $text; 3121} 3122 3123=pod 3124 3125---++ StaticMethod entityDecode ( $encodedText ) -> $text 3126 3127Decodes all numeric entities (e.g. &#123;). _Does not_ decode 3128named entities such as &amp; (use HTML::Entities for that) 3129 3130=cut 3131 3132sub entityDecode { 3133 my $text = shift; 3134 3135 $text =~ s/&#(\d+);/chr($1)/ge; 3136 return $text; 3137} 3138 3139=pod 3140 3141---++ StaticMethod urlEncodeAttachment ( $text ) 3142 3143For attachments, URL-encode specially to 'freeze' any characters >127 in the 3144site charset (e.g. ISO-8859-1 or KOI8-R), by doing URL encoding into native 3145charset ($siteCharset) - used when generating attachment URLs, to enable the 3146web server to serve attachments, including images, directly. 3147 3148This encoding is required to handle the cases of: 3149 3150 - browsers that generate UTF-8 URLs automatically from site charset URLs - now quite common 3151 - web servers that directly serve attachments, using the site charset for 3152 filenames, and cannot convert UTF-8 URLs into site charset filenames 3153 3154The aim is to prevent the browser from converting a site charset URL in the web 3155page to a UTF-8 URL, which is the default. Hence we 'freeze' the URL into the 3156site character set through URL encoding. 3157 3158In two cases, no URL encoding is needed: For EBCDIC mainframes, we assume that 3159site charset URLs will be translated (outbound and inbound) by the web server to/from an 3160EBCDIC character set. For sites running in UTF-8, there's no need for TWiki to 3161do anything since all URLs and attachment filenames are already in UTF-8. 3162 3163=cut 3164 3165sub urlEncodeAttachment { 3166 my( $text ) = @_; 3167 3168 my $usingEBCDIC = ( 'A' eq chr(193) ); # Only true on EBCDIC mainframes 3169 3170 if( (defined($TWiki::cfg{Site}{CharSet}) and $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) or $usingEBCDIC ) { 3171 # Just let browser do UTF-8 URL encoding 3172 return $text; 3173 } 3174 3175 # Freeze into site charset through URL encoding 3176 return urlEncode( $text ); 3177} 3178 3179 3180=pod 3181 3182---++ StaticMethod urlEncode( $string ) -> encoded string 3183 3184Encode by converting characters that are illegal in URLs to 3185their %NN equivalents. This method is used for encoding 3186strings that must be embedded _verbatim_ in URLs; it cannot 3187be applied to URLs themselves, as it escapes reserved 3188characters such as = and ?. 3189 3190RFC 1738, Dec. '94: 3191 <verbatim> 3192 ...Only alphanumerics [0-9a-zA-Z], the special 3193 characters $-_.+!*'(), and reserved characters used for their 3194 reserved purposes may be used unencoded within a URL. 3195 </verbatim> 3196 3197Reserved characters are $&+,/:;=?@ - these are _also_ encoded by 3198this method. 3199 3200This URL-encoding handles all character encodings including ISO-8859-*, 3201KOI8-R, EUC-* and UTF-8. 3202 3203This may not handle EBCDIC properly, as it generates an EBCDIC URL-encoded 3204URL, but mainframe web servers seem to translate this outbound before it hits browser 3205- see CGI::Util::escape for another approach. 3206 3207=cut 3208 3209sub urlEncode { 3210 my $text = shift; 3211 3212 $text =~ s/([^0-9a-zA-Z-_.:~!*\/])/'%'.sprintf('%02x',ord($1))/ge; 3213 3214 return $text; 3215} 3216 3217=pod 3218 3219---++ StaticMethod urlDecode( $string ) -> decoded string 3220 3221Reverses the encoding done in urlEncode. 3222 3223=cut 3224 3225sub urlDecode { 3226 my $text = shift; 3227 3228 $text =~ s/%u([\da-f]+)/chr(hex($1))/eig; 3229 $text =~ s/%([\da-f]{2})/chr(hex($1))/gei; 3230 return $text; 3231} 3232 3233=pod 3234 3235---++ StaticMethod isTrue( $value, $default ) -> $boolean 3236 3237Returns 1 if =$value= is true, and 0 otherwise. "true" means set to 3238something with a Perl true value, with the special cases that "off", 3239"false" and "no" (case insensitive) are forced to false. Leading and 3240trailing spaces in =$value= are ignored. 3241 3242If the value is undef, then =$default= is returned. If =$default= is 3243not specified it is taken as 0. 3244 3245=cut 3246 3247sub isTrue { 3248 my( $value, $default ) = @_; 3249 3250 $default ||= 0; 3251 3252 return $default unless defined( $value ); 3253 3254 $value =~ s/^\s*(.*?)\s*$/$1/gi; 3255 $value =~ s/off//gi; 3256 $value =~ s/no//gi; 3257 $value =~ s/false//gi; 3258 return ( $value ) ? 1 : 0; 3259} 3260 3261=pod 3262 3263---++ StaticMethod topLevelWeb( $web ) -> top level web of $web 3264 3265If $web is a top level web, it returns $web. 3266If $web is a subweb, it returns the top level web of $web. 3267 3268=cut 3269 3270sub topLevelWeb { 3271 my( $web ) = @_; 3272 return '' if ( !defined($web) ); 3273 $web =~ /^(\w*)/; 3274 return $1; 3275} 3276 3277=pod 3278 3279---++ StaticMethod spaceOutWikiWord( $word, $sep ) -> $string 3280 3281Spaces out a wiki word by inserting a string between each word component. 3282Word component boundaries are transitions from lowercase to uppercase or numeric, 3283from numeric to uppercase or lowercase, and from uppercase to numeric characters. 3284 3285Parameter $sep defines the separator between the word components, the default is a space. 3286 3287Example: "ABC2015ProjectCharter" results in "ABC 2015 Project Charter" 3288 3289=cut 3290 3291sub spaceOutWikiWord { 3292 my $word = shift || ''; 3293 my $sep = shift || ' '; 3294 $word =~ s/([$regex{lowerAlpha}])([$regex{upperAlpha}$regex{numeric}])/$1$sep$2/go; 3295 $word =~ s/([$regex{numeric}])([$regex{upperAlpha}$regex{lowerAlpha}])/$1$sep$2/go; 3296 $word =~ s/([$regex{upperAlpha}])([$regex{numeric}])/$1$sep$2/go; 3297 return $word; 3298} 3299 3300=pod 3301 3302---++ ObjectMethod expandAllTags(\$text, $topic, $web, $meta) 3303Expands variables by replacing the variables with their 3304values. Some example variables: %<nop>TOPIC%, %<nop>SCRIPTURL%, 3305%<nop>WIKINAME%, etc. 3306$web and $incs are passed in for recursive include expansion. They can 3307safely be undef. 3308The rules for tag expansion are: 3309 1 Tags are expanded left to right, in the order they are encountered. 3310 1 Tags are recursively expanded as soon as they are encountered - 3311 the algorithm is inherently single-pass 3312 1 A tag is not "encountered" until the matching }% has been seen, by 3313 which time all tags in parameters will have been expanded 3314 1 Tag expansions that create new tags recursively are limited to a 3315 set number of hierarchical levels of expansion 3316 3317=cut 3318 3319sub expandAllTags { 3320 my $this = shift; 3321 my $textRef = shift; # reference 3322 my ( $topic, $web, $meta ) = @_; 3323 $web =~ s#\.#/#go; 3324 3325 # push current context 3326 my $memTopic = $this->{SESSION_TAGS}{TOPIC}; 3327 my $memWeb = $this->{SESSION_TAGS}{WEB}; 3328 3329 $this->{SESSION_TAGS}{TOPIC} = $topic; 3330 $this->{SESSION_TAGS}{WEB} = $web; 3331 3332 # Escape ' !%VARIABLE%' 3333 $$textRef =~ s/(?<=\s)!%($regex{tagNameRegex})/%$1/g; 3334 3335 # Make sure func works, for registered tag handlers 3336 $TWiki::Plugins::SESSION = $this; 3337 3338 # NOTE TO DEBUGGERS 3339 # The depth parameter in the following call controls the maximum number 3340 # of levels of expansion. If it is set to 1 then only tags in the 3341 # topic will be expanded; tags that they in turn generate will be 3342 # left unexpanded. If it is set to 2 then the expansion will stop after 3343 # the first recursive inclusion, and so on. This is incredible useful 3344 # when debugging. The default is set to 16 3345 # to match the original limit on search expansion, though this of 3346 # course applies to _all_ tags and not just search. 3347 $$textRef = _processTags( $this, $$textRef, \&_expandTagOnTopicRendering, 3348 16, $topic, $web, $meta, $textRef ); 3349 3350 # restore previous context 3351 $this->{SESSION_TAGS}{TOPIC} = $memTopic; 3352 $this->{SESSION_TAGS}{WEB} = $memWeb; 3353} 3354 3355# Process TWiki %TAGS{}% by parsing the input tokenised into 3356# % separated sections. The parser is a simple stack-based parse, 3357# sufficient to ensure nesting of tags is correct, but no more 3358# than that. 3359# $depth limits the number of recursive expansion steps that 3360# can be performed on expanded tags. 3361sub _processTags { 3362 my $this = shift; 3363 my $text = shift; 3364 my $tagFunction = shift; 3365 # my ( $topic, $web, $meta, $fullTextRef ) = @_; 3366 3367 my $tell = 0; 3368 3369 return '' if ( 3370 (!defined( $text )) || 3371 ($text eq '') 3372 ); 3373 3374 #no tags to process 3375 return $text unless ($text =~ /(%)/); 3376 3377 my $depth = shift; 3378 3379 unless ( $depth ) { 3380 my $loc = ''; 3381 if ( defined($_[0]) && defined($_[1]) ) { 3382 $loc = " at $_[1].$_[0]" 3383 } 3384 my $mess = "Max recursive depth reached$loc: $text"; 3385 $this->writeWarning( $mess ); 3386 # prevent recursive expansion that just has been detected 3387 # from happening in the error message 3388 $text =~ s/%(.*?)%/$1/go; 3389 return $text; 3390 } 3391 3392 my $verbatim = {}; 3393 $text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim); 3394 3395 # See Item1442 3396 #my $percent = ($TranslationToken x 3).'%'.($TranslationToken x 3); 3397 3398 my @queue = split( /(%)/, $text ); 3399 my @stack; 3400 my $stackTop = ''; # the top stack entry. Done this way instead of 3401 # referring to the top of the stack for efficiency. This var 3402 # should be considered to be $stack[$#stack] 3403 3404 while ( scalar( @queue )) { 3405 my $token = shift( @queue ); 3406 #print STDERR ' ' x $tell,"PROCESSING $token \n"; 3407 3408 # each % sign either closes an existing stacked context, or 3409 # opens a new context. 3410 if ( $token eq '%' ) { 3411 #print STDERR ' ' x $tell,"CONSIDER $stackTop\n"; 3412 # If this is a closing }%, try to rejoin the previous 3413 # tokens until we get to a valid tag construct. This is 3414 # a bit of a hack, but it's hard to think of a better 3415 # way to do this without a full parse that takes % signs 3416 # in tag parameters into account. 3417 if ( $stackTop =~ /}$/s ) { 3418 while ( scalar( @stack) && $stackTop !~ /^%($regex{tagNameRegex})\{.*}$/so ) { 3419 my $top = $stackTop; 3420 #print STDERR ' ' x $tell,"COLLAPSE $top \n"; 3421 $stackTop = pop( @stack ) . $top; 3422 } 3423 } 3424 # /s so you can have newlines in parameters 3425 if ( $stackTop =~ m/^%(($regex{tagNameRegex})(?:{(.*)})?)$/so ) { 3426 my( $expr, $tag, $args ) = ( $1, $2, $3 ); 3427 #print STDERR ' ' x $tell,"POP $tag\n"; 3428 3429 # Call tag function. @_ is( $topic, $web, $meta, $fullTextRef ), 3430 # values may be undef. $meta and $text are passed along so that 3431 # they can be referenced by tag handlers. $fullTextRef is a 3432 # reference to the full text, it cannot be updated because text 3433 # is reconstructed via $stackTop. 3434 my $e = &$tagFunction( $this, $tag, $args, @_ ); 3435 3436 if ( defined( $e )) { 3437 #print STDERR ' ' x $tell--,"EXPANDED $tag -> $e\n"; 3438 $stackTop = pop( @stack ); 3439 unless ($e =~ /(%)/) { 3440 #SMELL: this is a profiler speedup found by Sven on the last day of 4.2.1 3441 #TODO: I don't think this parser should be in this section - re-analysis desired. 3442 #print STDERR "no tags to recurse\n"; 3443 $stackTop .= $e; 3444 next; 3445 } 3446 # Recursively expand tags in the expansion of $tag 3447 $stackTop .= _processTags($this, $e, $tagFunction, $depth-1, @_ ); 3448 3449 } else { # expansion failed 3450 #print STDERR ' ' x $tell++,"EXPAND $tag FAILED\n"; 3451 # To handle %NOP 3452 # correctly, we have to handle the %VAR% case differently 3453 # to the %VAR{}% case when a variable expansion fails. 3454 # This is so that recursively define variables e.g. 3455 # %A%B%D% expand correctly, but at the same time we ensure 3456 # that a mismatched }% can't accidentally close a context 3457 # that was left open when a tag expansion failed. 3458 # However Cairo didn't do this, so for compatibility 3459 # we have to accept that %NOP can never be fixed. if it 3460 # could, then we could uncomment the following: 3461 3462 #if( $stackTop =~ /}$/ ) { 3463 # # %VAR{...}% case 3464 # # We need to push the unexpanded expression back 3465 # # onto the stack, but we don't want it to match the 3466 # # tag expression again. So we protect the %'s 3467 # $stackTop = $percent.$expr.$percent; 3468 #} else 3469 { 3470 # %VAR% case. 3471 # In this case we *do* want to match the tag expression 3472 # again, as an embedded %VAR% may have expanded to 3473 # create a valid outer expression. This is directly 3474 # at odds with the %VAR{...}% case. 3475 push( @stack, $stackTop ); 3476 $stackTop = '%'; # open new context 3477 } 3478 } 3479 3480 } else { 3481 push( @stack, $stackTop ); 3482 $stackTop = '%'; # push a new context 3483 #$tell++; 3484 } 3485 3486 } else { 3487 $stackTop .= $token; 3488 } 3489 } 3490 3491 # Run out of input. Gather up everything in the stack. 3492 while ( scalar( @stack )) { 3493 my $expr = $stackTop; 3494 $stackTop = pop( @stack ); 3495 $stackTop .= $expr; 3496 } 3497 3498 #$stackTop =~ s/$percent/%/go; 3499 3500 $this->renderer->putBackBlocks( \$stackTop, $verbatim, 'verbatim' ); 3501 3502 #print STDERR "FINAL $stackTop\n"; 3503 3504 return $stackTop; 3505} 3506 3507# Handle expansion of a tag during topic rendering 3508# $tag is the tag name 3509# $args is the bit in the {} (if there are any) 3510# $topic and $web should be passed for dynamic tags (not needed for 3511# session or constant tags 3512sub _expandTagOnTopicRendering { 3513 my $this = shift; 3514 my $tag = shift; 3515 my $args = shift; 3516 # my( $topic, $web, $meta ) = @_; 3517 require TWiki::Attrs; 3518 3519 my $opv = $this->{prefs}->getPreferencesValue( 3520 'OVERRIDABLEPREDEFINEDVARIABLES'); 3521 $opv = 'all' unless ( defined($opv) ); # for backward compatibility 3522 unless ( $opv =~ /\ball\b/i ) { 3523 my %p = map { $_ => 1 } split(/[,\s]+/, $opv); 3524 if ( !$p{$tag} && defined( $functionTags{$tag} ) ) { 3525 return &{$functionTags{$tag}} 3526 ( $this, 3527 new TWiki::Attrs( $args, $contextFreeSyntax{$tag} ), 3528 @_ ); 3529 } 3530 } 3531 my $e = $this->{prefs}->getPreferencesValue( $tag ); 3532 if( defined( $e ) ) { 3533 if( $args ) { 3534 # Codev.ParameterizedVariables feature 3535 my $attrs = new TWiki::Attrs( $args, $contextFreeSyntax{$tag} ); 3536 # Not possible to define a _DEFAULT setting, so use DEFAULT: 3537 if( ! defined $attrs->{DEFAULT} && defined $attrs->{_DEFAULT} ) { 3538 $attrs->{DEFAULT} = $attrs->{_DEFAULT}; 3539 } 3540 while( my ( $key, $value ) = each( %$attrs ) ) { 3541 $e =~ s/%${key}(\{ *default="(.*?[^\\]?)" *})?%/_unescapeQuotes( $value )/ge; 3542 } 3543 } 3544 # In parameterized variables, expand %ALL_UNUSED_TAGS{ default="..." }% to defaults 3545 # FIXME: Quick hack; do proper variable parsing 3546 $e =~ s/%($regex{tagNameRegex})\{ *default="(.*?[^\\]?)" *}%/_unescapeQuotes( $2 )/ge; 3547 3548 } else { 3549 $e = $this->{SESSION_TAGS}{$tag} unless( $args ); 3550 if( !defined( $e ) && defined( $functionTags{$tag} )) { 3551 $e = &{$functionTags{$tag}} 3552 ( $this, new TWiki::Attrs( 3553 $args, $contextFreeSyntax{$tag} ), @_ ); 3554 } 3555 } 3556 return $e; 3557} 3558 3559sub _unescapeQuotes { 3560 my $text = shift; 3561 $text =~ s/\\(["'])/$1/g; 3562 return $text; 3563} 3564 3565# Handle expansion of a tag during new topic creation. When creating a 3566# new topic from a template we only expand a subset of the available legal 3567# tags, and we expand %NOP% differently. 3568sub _expandTagOnTopicCreation { 3569 my $this = shift; 3570 # my( $tag, $args, $topic, $web ) = @_; 3571 3572 # Required for Cairo compatibility. Ignore %NOP{...}% 3573 # %NOP% is *not* ignored until all variable expansion is complete, 3574 # otherwise them inside-out rule would remove it too early e.g. 3575 # %GM%NOP%TIME -> %GMTIME -> 12:00. So we ignore it here and scrape it 3576 # out later. We *have* to remove %NOP{...}% because it can foul up 3577 # brace-matching. 3578 return '' if $_[0] eq 'NOP' && defined $_[1]; 3579 3580 # You may want to expand arbitrary tags on topic creation. 3581 # By prepending EOTC__ (EOTC stands for Expand On Topic Creation), you 3582 # can achieve that. 3583 if ( $_[0] =~ /^EOTC__(\w+)$/ ) { 3584 $_[0] = $1; 3585 return _expandTagOnTopicRendering( $this, @_ ); 3586 } 3587 3588 # Only expand a subset of legal tags. Warning: $this->{user} may be 3589 # overridden during this call, when a new user topic is being created. 3590 # This is what we want to make sure new user templates are populated 3591 # correctly, but you need to think about this if you extend the set of 3592 # tags expanded here. 3593 return undef unless $_[0] =~ /^(URLPARAM|DATE|(SERVER|GM)TIME|(USER|WIKI)NAME|WIKIUSERNAME|USERINFO)$/; 3594 3595 return _expandTagOnTopicRendering( $this, @_ ); 3596} 3597 3598=pod 3599 3600---++ ObjectMethod enterContext( $id, $val ) 3601 3602Add the context id $id into the set of active contexts. The $val 3603can be anything you like, but should always evaluate to boolean 3604TRUE. 3605 3606An example of the use of contexts is in the use of tag 3607expansion. The commonTagsHandler in plugins is called every 3608time tags need to be expanded, and the context of that expansion 3609is signalled by the expanding module using a context id. So the 3610forms module adds the context id "form" before invoking common 3611tags expansion. 3612 3613Contexts are not just useful for tag expansion; they are also 3614relevant when rendering. 3615 3616Contexts are intended for use mainly by plugins. Core modules can 3617use $session->inContext( $id ) to determine if a context is active. 3618 3619=cut 3620 3621sub enterContext { 3622 my( $this, $id, $val ) = @_; 3623 $val ||= 1; 3624 $this->{context}->{$id} = $val; 3625} 3626 3627=pod 3628 3629---++ ObjectMethod leaveContext( $id ) 3630 3631Remove the context id $id from the set of active contexts. 3632(see =enterContext= for more information on contexts) 3633 3634=cut 3635 3636sub leaveContext { 3637 my( $this, $id ) = @_; 3638 my $res = $this->{context}->{$id}; 3639 delete $this->{context}->{$id}; 3640 return $res; 3641} 3642 3643=pod 3644 3645---++ ObjectMethod inContext( $id ) 3646 3647Return the value for the given context id 3648(see =enterContext= for more information on contexts) 3649 3650=cut 3651 3652sub inContext { 3653 my( $this, $id ) = @_; 3654 return $this->{context}->{$id}; 3655} 3656 3657=pod 3658 3659---++ StaticMethod registerTagHandler( $tag, $fnref ) 3660 3661STATIC Add a tag handler to the function tag handlers. 3662 * =$tag= name of the tag e.g. MYTAG 3663 * =$fnref= Function to execute. Will be passed ($session, \%params, $web, $topic ) 3664 3665=cut 3666 3667sub registerTagHandler { 3668 my ( $tag, $fnref, $syntax ) = @_; 3669 $functionTags{$tag} = \&$fnref; 3670 if( $syntax && $syntax eq 'context-free' ) { 3671 $contextFreeSyntax{$tag} = 1; 3672 } 3673} 3674 3675=pod= 3676 3677---++ StaticMethod registerRESTHandler( $subject, $verb, \&fn ) 3678 3679Adds a function to the dispatch table of the REST interface 3680for a given subject. See TWikiScripts#rest for more info. 3681 3682 * =$subject= - The subject under which the function will be registered. 3683 * =$verb= - The verb under which the function will be registered. 3684 * =\&fn= - Reference to the function. 3685 3686The handler function must be of the form: 3687<verbatim> 3688sub handler(\%session,$subject,$verb) -> $text 3689</verbatim> 3690where: 3691 * =\%session= - a reference to the TWiki session object (may be ignored) 3692 * =$subject= - The invoked subject (may be ignored) 3693 * =$verb= - The invoked verb (may be ignored) 3694 3695*Since:* TWiki::Plugins::VERSION 1.1 3696 3697=cut= 3698 3699sub registerRESTHandler { 3700 my ( $subject, $verb, $fnref) = @_; 3701 $restDispatch{$subject}{$verb} = \&$fnref; 3702} 3703 3704=pod 3705 3706---++ ObjectMethod handleCommonTags( $text, $web, $topic, $meta ) -> $text 3707 3708Processes %<nop>VARIABLE%, and %<nop>TOC% syntax; also includes 3709'commonTagsHandler' plugin hook. 3710 3711Returns the text of the topic, after file inclusion, variable substitution, 3712table-of-contents generation, and any plugin changes from commonTagsHandler. 3713 3714$meta may be undef when, for example, expanding templates, or one-off strings 3715at a time when meta isn't available. 3716 3717=cut 3718 3719sub handleCommonTags { 3720 my( $this, $text, $theWeb, $theTopic, $meta ) = @_; 3721 3722 ASSERT($theWeb) if DEBUG; 3723 ASSERT($theTopic) if DEBUG; 3724 3725 return $text unless $text; 3726 3727 my $verbatim={}; 3728 # Plugin Hook (for cache Plugins only) 3729 $this->{plugins}->dispatch( 'beforeCommonTagsHandler', $text, $theTopic, $theWeb, $meta ); 3730 3731 #use a "global var", so included topics can extract and putback 3732 #their verbatim blocks safetly. 3733 $text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim); 3734 3735 my $memW = $this->{SESSION_TAGS}{INCLUDINGWEB}; 3736 my $memT = $this->{SESSION_TAGS}{INCLUDINGTOPIC}; 3737 $this->{SESSION_TAGS}{INCLUDINGWEB} = $theWeb; 3738 $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $theTopic; 3739 3740 expandAllTags( $this, \$text, $theTopic, $theWeb, $meta ); 3741 3742 $text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim); 3743 3744 # Plugin Hook 3745 $this->{plugins}->dispatch( 'commonTagsHandler', $text, $theTopic, $theWeb, 0, $meta ); 3746 3747 # process tags again because plugin hook may have added more in 3748 expandAllTags( $this, \$text, $theTopic, $theWeb, $meta ); 3749 3750 $this->{SESSION_TAGS}{INCLUDINGWEB} = $memW; 3751 $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $memT; 3752 3753 # 'Special plugin tag' TOC hack, must be done after all other expansions 3754 # are complete, and has to reprocess the entire topic. 3755 3756 # We need to keep track of the 'TOC topics' here in order to ensure that each 3757 # of these topics is only processed once (this is due to the fact that the 3758 # renaming of ambiguous anchors has to work context-less and cannot recognize 3759 # whether a particular heading has been converted before)--alternatively, we 3760 # could just clear the 'anchorname memory' and keep reprocessing topics 3761 # (the latter solution is slower if th same TOC is included multiple times) 3762 # current solution: let _TOC() clear the hash which holds the anchornames 3763 $text =~ s/%TOC(?:{(.*?)})?%/$this->_TOC($text, $theTopic, $theWeb, $1)/ge; 3764 3765 # Codev.FormattedSearchWithConditionalOutput: remove <nop> lines, 3766 # possibly introduced by SEARCHes with conditional CALC. This needs 3767 # to be done after CALC and before table rendering in order to join 3768 # table rows properly 3769 $text =~ s/^<nop>\r?\n//gm; 3770 3771 $this->renderer->putBackBlocks( \$text, $verbatim, 'verbatim' ); 3772 3773 # TWiki Plugin Hook (for cache Plugins only) 3774 $this->{plugins}->dispatch( 'afterCommonTagsHandler', $text, $theTopic, $theWeb, $meta ); 3775 3776 return $text; 3777} 3778 3779=pod 3780 3781---++ ObjectMethod ADDTOHEAD( $args ) 3782 3783Add =$html= to the HEAD tag of the page currently being generated. 3784 3785Note that TWiki variables may be used in the HEAD. They will be expanded 3786according to normal variable expansion rules. 3787 3788---+++ =%<nop>ADDTOHEAD%= 3789You can write =%ADDTOHEAD{...}%= in a topic or template. This variable accepts the following parameters: 3790 * =_DEFAULT= optional, id of the head block. Used to generate a comment in the output HTML. 3791 * =text= optional, text to use for the head block. Mutually exclusive with =topic=. 3792 * =topic= optional, full TWiki path name of a topic that contains the full text to use for the head block. Mutually exclusive with =text=. Example: =topic="%WEB%.MyTopic"=. 3793 * =requires= optional, comma-separated list of id's of other head blocks this one depends on. 3794=%<nop>ADDTOHEAD%= expands in-place to the empty string, unless there is an error in which case the variable expands to an error string. 3795 3796Use =%<nop>RENDERHEAD%= to generate the sorted head tags. 3797 3798=cut 3799 3800sub ADDTOHEAD { 3801 my ($this, $args, $topic, $web) = @_; 3802 3803 my $_DEFAULT = $args->{_DEFAULT}; 3804 my $text = $args->{text}; 3805 $topic = $args->{topic}; 3806 my $section = $args->{section} || ''; 3807 my $requires = $args->{requires}; 3808 if( defined $topic ) { 3809 ( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic ); 3810 3811 # generate TML only and delay expansion until this is rendered 3812 $text = '%INCLUDE{"' . $web . '.' . $topic . '"'; 3813 $text .= ' section="' . $section . '"' if( $section ); 3814 $text .= ' warn="off"}%'; 3815 } 3816 $text = $_DEFAULT unless defined $text; 3817 $text = '' unless defined $text; 3818 3819 $this->addToHEAD($_DEFAULT, $text, $requires); 3820 return ''; 3821} 3822 3823sub addToHEAD { 3824 my( $this, $tag, $header, $requires ) = @_; 3825 3826 # Expand TWiki variables in the header 3827 $header = $this->handleCommonTags( $header, $this->{webName}, $this->{topicName} ); 3828 3829 $this->{_SORTEDHEADS} ||= {}; 3830 $tag ||= ''; 3831 3832 $requires ||= ''; 3833 my $debug = ''; 3834 3835 # Resolve to references to build DAG 3836 my @requires; 3837 foreach my $req (split(/,\s*/, $requires)) { 3838 unless ($this->{_SORTEDHEADS}->{$req}) { 3839 $this->{_SORTEDHEADS}->{$req} = { 3840 tag => $req, 3841 requires => [], 3842 header => '', 3843 }; 3844 } 3845 push(@requires, $this->{_SORTEDHEADS}->{$req}); 3846 } 3847 my $record = $this->{_SORTEDHEADS}->{$tag}; 3848 unless ($record) { 3849 $record = { tag => $tag }; 3850 $this->{_SORTEDHEADS}->{$tag} = $record; 3851 } 3852 $record->{requires} = \@requires; 3853 $record->{header} = $header; 3854 3855 # Temporary, for compatibility until %RENDERHEAD% is embedded 3856 # in the skins 3857 $this->{_HTMLHEADERS}{GENERATED_HEADERS} = _genHeaders($this); 3858} 3859 3860sub _visit { 3861 my ($v, $visited, $list) = @_; 3862 return if $visited->{$v}; 3863 foreach my $r (@{$v->{requires}}) { 3864 _visit($r, $visited, $list); 3865 } 3866 push(@$list, $v); 3867 $visited->{$v} = 1; 3868} 3869 3870sub _genHeaders { 3871 my ($this) = @_; 3872 return '' unless $this->{_SORTEDHEADS}; 3873 3874 # Loop through the vertices of the graph, in any order, initiating 3875 # a depth-first search for any vertex that has not already been 3876 # visited by a previous search. The desired topological sorting is 3877 # the reverse postorder of these searches. That is, we can construct 3878 # the ordering as a list of vertices, by adding each vertex to the 3879 # start of the list at the time when the depth-first search is 3880 # processing that vertex and has returned from processing all children 3881 # of that vertex. Since each edge and vertex is visited once, the 3882 # algorithm runs in linear time. 3883 my %visited; 3884 my @total; 3885 foreach my $v (values %{$this->{_SORTEDHEADS}}) { 3886 _visit($v, \%visited, \@total); 3887 } 3888 3889 return join( 3890 "\n", 3891 map { "<!-- $_->{tag} --> $_->{header}" } 3892 @total 3893 ); 3894} 3895 3896=pod 3897 3898---+++ %<nop>RENDERHEAD% 3899=%RENDERHEAD%= should be written where you want the sorted head tags to be generated. This will normally be in a template. The variable expands to a sorted list of the head blocks added up to the point the RENDERHEAD variable is expanded. Each expanded head block is preceded by an HTML comment that records the ID of the head block. 3900 3901Head blocks are sorted to satisfy all their =requires= constraints. 3902The output order of blocks with no =requires= value is undefined. If cycles 3903exist in the dependency order, the cycles will be broken but the resulting 3904order of blocks in the cycle is undefined. 3905 3906=cut 3907 3908sub RENDERHEAD { 3909 my $this = shift; 3910 return _genHeaders($this); 3911} 3912 3913=pod 3914 3915---++ StaticMethod initialize( $pathInfo, $remoteUser, $topic, $url, $query ) -> ($topicName, $webName, $scriptUrlPath, $userName, $dataDir) 3916 3917Return value: ( $topicName, $webName, $TWiki::cfg{ScriptUrlPath}, $userName, $TWiki::cfg{DataDir} ) 3918 3919Static method to construct a new singleton session instance. 3920It creates a new TWiki and sets the Plugins $SESSION variable to 3921point to it, so that TWiki::Func methods will work. 3922 3923This method is *DEPRECATED* but is maintained for script compatibility. 3924 3925Note that $theUrl, if specified, must be identical to $query->url() 3926 3927=cut 3928 3929sub initialize { 3930 my ( $pathInfo, $theRemoteUser, $topic, $theUrl, $query ) = @_; 3931 3932 if( !$query ) { 3933 $query = new TWiki::Request( {} ); 3934 } 3935 if( $query->path_info() ne $pathInfo ) { 3936 $query->path_info( "/$0/" . $pathInfo ); 3937 } 3938 if( $topic ) { 3939 $query->param( -name => 'topic', -value => '' ); 3940 } 3941 # can't do much if $theUrl is specified and it is inconsistent with 3942 # the query. We are trying to get to all parameters passed in the 3943 # query. 3944 if( $theUrl && $theUrl ne $query->url()) { 3945 die 'Sorry, this version of TWiki does not support the url parameter to' 3946 . ' TWiki::initialize being different to the url in the query'; 3947 } 3948 my $twiki = new TWiki( $theRemoteUser, $query ); 3949 3950 # Force the new session into the plugins context. 3951 $TWiki::Plugins::SESSION = $twiki; 3952 3953 return ( $twiki->{topicName}, $twiki->{webName}, $twiki->{scriptUrlPath}, 3954 $twiki->{userName}, $twiki->getDatadir ); 3955} 3956 3957=pod 3958 3959---++ StaticMethod readFile( $filename ) -> $text 3960 3961Returns the entire contents of the given file, which can be specified in any 3962format acceptable to the Perl open() function. Fast, but inherently unsafe. 3963 3964WARNING: Never, ever use this for accessing topics or attachments! Use the 3965Store API for that. This is for global control files only, and should be 3966used *only* if there is *absolutely no alternative*. 3967 3968=cut 3969 3970sub readFile { 3971 my $name = shift; 3972 open( IN_FILE, "<$name" ) || return ''; 3973 local $/ = undef; 3974 my $data = <IN_FILE>; 3975 close( IN_FILE ); 3976 $data = '' unless( defined( $data )); 3977 return $data; 3978} 3979 3980=pod 3981 3982---++ StaticMethod suffixToMimeType( $filename ) -> $mimeType 3983 3984Returns the MIME type corresponding to the extension of the $filename based on 3985the file specified by {MimeTypesFileName}. If there is no extension or the 3986extension is not found in the {MimeTypesFileName} file, 'text/plain' is 3987returned. 3988 3989=cut 3990 3991sub suffixToMimeType { 3992 my( $theFilename ) = @_; 3993 3994 my $mimeType = 'text/plain'; 3995 if( $theFilename =~ /\.([^.]+)$/ ) { 3996 my $suffix = $1; 3997 my @types = grep{ s/^\s*([^\s]+).*?\s$suffix\s.*$/$1/i } 3998 map { $_.' ' } 3999 split( /[\n\r]/, readFile( $TWiki::cfg{MimeTypesFileName} ) ); 4000 $mimeType = $types[0] if( @types ); 4001 } 4002 return $mimeType; 4003} 4004 4005=pod 4006 4007---++ StaticMethod expandStandardEscapes($str) -> $unescapedStr 4008 4009Expands standard escapes used in parameter values to block evaluation. The following escapes 4010are handled: 4011 4012| *Escape:* | *Expands To:* | 4013| =$n= or =$n()= | New line. Use =$n()= if followed by alphanumeric character, e.g. write =Foo$n()Bar= instead of =Foo$nBar= | 4014| =$nop= or =$nop()= | Is a "no operation". | 4015| =$quot= | Double quote (="=) | 4016| =$aquot= | Apostrophe quote (='=) | 4017| =$percnt= | Percent sign (=%=) | 4018| =$dollar= | Dollar sign (=$=) | 4019| =$lt= | Less than sign (=<=) | 4020| =$gt= | Greater than sign (=>=) | 4021 4022=cut 4023 4024sub expandStandardEscapes { 4025 my $text = shift; 4026 $text =~ s/\$n\(\)/\n/gos; # expand '$n()' to new line 4027 $text =~ s/\$n([^$regex{mixedAlpha}]|$)/\n$1/gos; # expand '$n' to new line 4028 $text =~ s/\$nop(\(\))?//gos; # remove filler, useful for nested search 4029 $text =~ s/\$quot(\(\))?/\"/gos; # expand double quote 4030 $text =~ s/\$aquot(\(\))?/\'/gos; # expand apostrophe quote 4031 $text =~ s/\$percnt(\(\))?/\%/gos; # expand percent 4032 $text =~ s/\$dollar(\(\))?/\$/gos; # expand dollar 4033 $text =~ s/\$lt\b(\(\))?/\</gos; # expand less than sign 4034 $text =~ s/\$gt\b(\(\))?/\>/gos; # expand greater than sign 4035 return $text; 4036} 4037 4038# generate an include warning 4039# SMELL: varying number of parameters idiotic to handle for customized $warn 4040sub _includeWarning { 4041 my $this = shift; 4042 my $warn = shift; 4043 my $message = shift; 4044 4045 if( $warn eq 'on' ) { 4046 return $this->inlineAlert( 'alerts', $message, @_ ); 4047 } elsif( isTrue( $warn )) { 4048 # different inlineAlerts need different argument counts 4049 my $argument = ''; 4050 if ($message eq 'topic_not_found') { 4051 my ($web,$topic) = @_; 4052 $argument = "$web.$topic"; 4053 4054 } else { 4055 $argument = shift; 4056 } 4057 $warn =~ s/\$topic/$argument/go if $argument; 4058 return $warn; 4059 } # else fail silently 4060 return ''; 4061} 4062 4063#------------------------------------------------------------------- 4064# Tag Handlers 4065#------------------------------------------------------------------- 4066 4067sub BASETOPIC { 4068 my $this = shift; 4069 return $this->{SESSION_TAGS}{BASETOPIC}; 4070} 4071 4072sub BASEWEB { 4073 my ( $this, $params ) = @_; 4074 return _handleWebTag( $this->{SESSION_TAGS}{BASEWEB}, $params ); 4075} 4076 4077sub INCLUDINGTOPIC { 4078 my $this = shift; 4079 return $this->{SESSION_TAGS}{INCLUDINGTOPIC}; 4080} 4081 4082sub INCLUDINGWEB { 4083 my ( $this, $params ) = @_; 4084 return _handleWebTag( $this->{SESSION_TAGS}{INCLUDINGWEB}, $params ); 4085} 4086 4087sub TOPIC { 4088 my $this = shift; 4089 return $this->{SESSION_TAGS}{TOPIC}; 4090} 4091 4092sub WEB { 4093 my ( $this, $params ) = @_; 4094 return _handleWebTag( $this->{SESSION_TAGS}{WEB}, $params ); 4095} 4096 4097sub _handleWebTag { 4098 my( $theWeb, $params ) = @_; 4099 my $format = $params->{format} || $params->{_DEFAULT}; 4100 if( $format ) { 4101 my $web = $theWeb; 4102 my @w = split( /[\/\.]/, $theWeb ); 4103 my $size = scalar( @w ); 4104 my $parents = ''; 4105 if( $size > 1 && $web =~ /^(.*)[\/\.]/ ) { 4106 $parents = $1; 4107 } 4108 $theWeb = $format; 4109 $theWeb =~ s/\$web/$web/go; 4110 $theWeb =~ s/\$parents?/$parents/go; 4111 $theWeb =~ s/\$current/$w[-1]/go; 4112 $theWeb =~ s/\$(item|last)\(0\)//go; 4113 $theWeb =~ s/\$item\(([0-9]+)\)/$1 > $size ? '' : $w[$1-1]/geo; 4114 $theWeb =~ s/\$last\(([0-9]+)\)/my @t = @w; join('\/', splice( @t, ($1 > $size ? -$size : -$1), 99))/geo; 4115 $theWeb =~ s/\$top\(([0-9]+)\)/my @t = @w; join( '\/', splice( @t, 0, $1 ) )/geo; 4116 $theWeb =~ s/\$top/$w[0]/go; 4117 $theWeb =~ s/\$list/join( ', ', @w)/geo; 4118 $theWeb =~ s/\$size/$size/go; 4119 } 4120 return $theWeb; 4121} 4122 4123sub TOPICTITLE { 4124 my ( $this, $params, $topic, $web ) = @_; 4125 # optional $params->{topic} can be "TopicName" or "Web.TopicName" 4126 $topic = $params->{topic} || $params->{_DEFAULT} || $topic; 4127 # normalize web and topic name 4128 ( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic ); 4129 my $text = $topic; 4130 if( $this->{store}->topicExists( $web, $topic )) { 4131 my $meta = $this->inContext( 'can_render_meta' ); 4132 if( $meta && $web eq $this->{SESSION_TAGS}{BASEWEB} && 4133 $topic eq $this->{SESSION_TAGS}{BASETOPIC} ) { 4134 # use meta data of base topic 4135 $text = $meta->topicTitle(); 4136 } else { 4137 # not base topic, need to read meta data to get topic title 4138 try { 4139 my $dummyText; 4140 ( $meta, $dummyText ) = $this->{store}->readTopic( 4141 $this->{session}->{user}, $web, $topic ); 4142 $text = $meta->topicTitle() if( $meta ); 4143 } catch TWiki::AccessControlException with { 4144 # Ignore access exceptions 4145 }; 4146 } 4147 } 4148 if( $params->{encode} ) { 4149 $text = $this->ENCODE( { _DEFAULT => $text, type => $params->{encode} } ); 4150 } 4151 return $text; 4152} 4153 4154sub FORM { 4155 my ( $this, $params, $topic, $web ) = @_; 4156 my $cgiQuery = $this->{request}; 4157 my $cgiRev = $cgiQuery->param('rev') if( $cgiQuery ); 4158 $params->{rev} = $cgiRev unless( defined $params->{rev} ); 4159 return $this->renderer->renderFORM( $params, $topic, $web ); 4160} 4161 4162sub FORMFIELD { 4163 my ( $this, $params, $topic, $web ) = @_; 4164 my $cgiQuery = $this->{request}; 4165 my $cgiRev = $cgiQuery->param('rev') if( $cgiQuery ); 4166 $params->{rev} = $cgiRev unless( defined $params->{rev} ); 4167 return $this->renderer->renderFORMFIELD( $params, $topic, $web ); 4168} 4169 4170sub EDITFORM { 4171 my ( $this, $params, $topic, $web ) = @_; 4172 return $this->renderer->renderEDITFORM( $params, $topic, $web ); 4173} 4174 4175sub EDITFORMFIELD { 4176 my ( $this, $params, $topic, $web ) = @_; 4177 return $this->renderer->renderEDITFORMFIELD( $params, $topic, $web ); 4178} 4179 4180sub TMPLP { 4181 my( $this, $params ) = @_; 4182 return $this->templates->tmplP( $params ); 4183} 4184 4185sub VAR { 4186 my( $this, $params, $intopic, $inweb ) = @_; 4187 my $key = $params->{_DEFAULT}; 4188 my $default = $params->{default}; 4189 $default = '' unless ( defined($default) ); 4190 return $default unless $key; 4191 my $ignoreNull = TWiki::Func::isTrue($params->{ignorenull}); 4192 my $web = $params->{web}; 4193 my $topic = $params->{topic}; 4194 my $val; 4195 # always return a value, even when the key isn't defined 4196 if ( $topic ) { 4197 ( $web, $topic ) = $this->normalizeWebTopicName( $web || $inweb, 4198 $topic ); 4199 $val = $this->{prefs}->getTopicPreferencesValue( $key, $web, $topic ); 4200 } 4201 elsif ( $web ) { 4202 # handle %USERSWEB%-type cases 4203 ( $web, $topic ) = $this->normalizeWebTopicName( $web, $intopic ); 4204 $val = $this->{prefs}->getWebPreferencesValue( $key, $web ); 4205 } 4206 else { 4207 $val = $this->{prefs}->getPreferencesValue($key); 4208 return $val if ( defined($val) && ($val ne '' || !$ignoreNull) ); 4209 $val = $this->{SESSION_TAGS}{$key}; 4210 } 4211 return $val if ( defined($val) && ($val ne '' || !$ignoreNull) ); 4212 return $default; 4213} 4214 4215sub PLUGINVERSION { 4216 my( $this, $params ) = @_; 4217 $this->{plugins}->getPluginVersion( $params->{_DEFAULT} ); 4218} 4219 4220sub IF { 4221 my ( $this, $params, $topic, $web, $meta ) = @_; 4222 4223 unless( $ifParser ) { 4224 require TWiki::If::Parser; 4225 $ifParser = new TWiki::If::Parser(); 4226 } 4227 4228 my $texpr = $params->{_DEFAULT}; 4229 my $expr; 4230 my $result; 4231 4232 if ( defined($texpr) && ($texpr =~ /^\s*$/ || $texpr =~ /^\s*0\s*$/) ) { 4233 # shortcut for a null string or 0 condition - compatibility with 4234 # TWiki 4.1 and consistency with a "1" condition. 4235 $params->{else} = '' unless defined $params->{else}; 4236 return expandStandardEscapes( $params->{else} ); 4237 } 4238 4239 # Recursion block. 4240 $this->{evaluating_if} ||= {}; 4241 # Block after 5 levels. 4242 if ($this->{evaluating_if}->{$texpr} && 4243 $this->{evaluating_if}->{$texpr} > 5) { 4244 delete $this->{evaluating_if}->{$texpr}; 4245 return ''; 4246 } 4247 $this->{evaluating_if}->{$texpr}++; 4248 4249 try { 4250 $expr = $ifParser->parse( $texpr ); 4251 unless( $meta ) { 4252 require TWiki::Meta; 4253 $meta = new TWiki::Meta( $this, $web, $topic ); 4254 } 4255 if( $expr->evaluate( tom=>$meta, data=>$meta )) { 4256 $params->{then} = '' unless defined $params->{then}; 4257 $result = expandStandardEscapes( $params->{then} ); 4258 } else { 4259 $params->{else} = '' unless defined $params->{else}; 4260 $result = expandStandardEscapes( $params->{else} ); 4261 } 4262 } catch TWiki::Infix::Error with { 4263 my $e = shift; 4264 $result = $this->inlineAlert( 4265 'alerts', 'generic', 'IF{', $params->stringify(), '}:', 4266 $e->{-text} ); 4267 } finally { 4268 delete $this->{evaluating_if}->{$texpr}; 4269 }; 4270 return $result; 4271} 4272 4273sub HIDE { 4274 # return empty string 4275 return ''; 4276} 4277 4278sub HIDEINPRINT { 4279 # enclose content in div to hide when printing 4280 my ( $this, $params ) = @_; 4281 return '<div class="hideInPrint"> ' . $params->{_DEFAULT} . ' </div>'; 4282} 4283 4284sub _fixHeadingOffset 4285{ 4286 my ( $prefix, $level, $offset ) = @_; 4287 $level += $offset; 4288 $level = 1 if( $level < 1); 4289 $level = 6 if( $level > 6); 4290 return $prefix . '+' x $level; 4291} 4292 4293# Processes a specific instance %<nop>INCLUDE{...}% syntax. 4294# Returns the text to be inserted in place of the INCLUDE command. 4295# $topic and $web should be for the immediate parent topic in the 4296# include hierarchy. Works for both URLs and absolute server paths. 4297sub INCLUDE { 4298 my ( $this, $params, $includingTopic, $includingWeb ) = @_; 4299 4300 # remember args for the key before mangling the params 4301 my $args = $params->stringify(); 4302 4303 # Remove params, so they don't get expanded in the included page 4304 my $path = $params->remove('_DEFAULT') || ''; 4305 my $attachment = $params->remove('attachment') || ''; 4306 my $pattern = $params->remove('pattern'); 4307 my $headingoffset = $params->remove('headingoffset') || ''; 4308 my $hidetoc = isTrue( $params->remove('hidetoc') ) 4309 || isTrue( $this->{prefs}->getPreferencesValue( 'TOC_HIDE_IF_INCLUDED' ) ); 4310 my $rev = $params->remove('rev'); 4311 my $section = $params->remove('section'); 4312 my $disableFixLinks = $params->remove('disablefixlinks') || ''; 4313 4314 # no sense in considering an empty string as an unfindable section: 4315 undef $section if (defined($section) && $section eq ''); 4316 4317 my $raw = $params->remove('raw') || ''; 4318 my $warn = $params->remove('warn') 4319 || $this->{prefs}->getPreferencesValue( 'INCLUDEWARNING' ); 4320 my $allowAnyType = isTrue( $params->remove('allowanytype') ); 4321 my $charSet = $params->remove('charset') || ''; 4322 4323 if( $path =~ /^https?\:/ ) { 4324 # include web page 4325 return _includeUrl( 4326 $this, $path, $pattern, $includingWeb, $includingTopic, 4327 $raw, $params, $warn, $allowAnyType, $charSet ); 4328 } 4329 4330 if ( $path eq '' && $attachment ne '' ) { 4331 $path = $includingTopic; 4332 } 4333 $path =~ s/$TWiki::cfg{NameFilter}//go; # zap anything suspicious 4334 if( $TWiki::cfg{DenyDotDotInclude} ) { 4335 # Filter out '..' from filename, this is to 4336 # prevent includes of '../../file' 4337 $path =~ s/\.+/\./g; 4338 } else { 4339 # danger, could include .htpasswd with relative path 4340 $path =~ s/passwd//gi; # filter out passwd filename 4341 } 4342 4343 # make sure we have something to include. If we don't do this, then 4344 # normalizeWebTopicName will default to WebHome. Item2209. 4345 unless( $path ) { 4346 # SMELL: could do with a different message here, but don't want to 4347 # add one right now because translators are already working 4348 return _includeWarning( $this, $warn, 'topic_not_found', '""','""' ); 4349 } 4350 4351 my $text = ''; 4352 my $meta = ''; 4353 my $includedWeb; 4354 my $includedTopic = $path; 4355 $includedTopic =~ s/\.txt$//; # strip optional (undocumented) .txt 4356 4357 ($includedWeb, $includedTopic) = 4358 $this->normalizeWebTopicName($includingWeb, $includedTopic); 4359 4360 # See Codev.FailedIncludeWarning for the history. 4361 unless( $this->{store}->topicExists($includedWeb, $includedTopic)) { 4362 return _includeWarning( $this, $warn, 'topic_not_found', 4363 $includedWeb, $includedTopic ); 4364 } 4365 4366 # prevent recursive includes. Note that the inclusion of a topic into 4367 # itself is not blocked; however subsequent attempts to include the 4368 # topic will fail. There is a hard block of 99 on any recursive include. 4369 my $key = $includingWeb.'.'.$includingTopic; 4370 my $count = keys %{$this->{_INCLUDES}}; 4371 $key .= $args; 4372 if( $this->{_INCLUDES}->{$key} || $count > 99) { 4373 return _includeWarning( $this, $warn, 'already_included', 4374 "$includedWeb.$includedTopic", '' ); 4375 } 4376 4377 my %saveTags = %{$this->{SESSION_TAGS}}; 4378 my $prefsMark = $this->{prefs}->mark(); 4379 4380 $this->{_INCLUDES}->{$key} = 1; 4381 $this->{SESSION_TAGS}{INCLUDINGWEB} = $includingWeb; 4382 $this->{SESSION_TAGS}{INCLUDINGTOPIC} = $includingTopic; 4383 4384 ( $meta, $text ) = 4385 $this->{store}->readTopic( undef, $includedWeb, $includedTopic, $rev ); 4386 4387 # Simplify leading, and remove trailing, newlines. If we don't remove 4388 # trailing, it becomes impossible to %INCLUDE a topic into a table. 4389 $text =~ s/^[\r\n]+/\n/; 4390 $text =~ s/[\r\n]+$//; 4391 4392 unless( 4393 ($includingTopic eq $includedTopic && $includingWeb eq $includedWeb) || 4394 # you may include itself, in which case permission check needs to be 4395 # omitted for efficiency 4396 $this->security->checkAccessPermission( 4397 'VIEW', $this->{user}, $text, $meta, $includedTopic, $includedWeb ) 4398 ) { 4399 if( isTrue( $warn )) { 4400 return $this->inlineAlert( 'alerts', 'access_denied', 4401 "[[$includedWeb.$includedTopic]]" ); 4402 } # else fail silently 4403 return ''; 4404 } 4405 4406 if ( $attachment ne '' ) { 4407 my $mimeType = suffixToMimeType($attachment); 4408 if( $allowAnyType || $mimeType =~ /^text\/(html|plain|css)/ ) { 4409 unless( $this->{store}->attachmentExists( 4410 $includedWeb, $includedTopic, $attachment )) { 4411 return _includeWarning( $this, $warn, 'bad_attachment', 4412 $attachment); 4413 } 4414 $text = $this->{store}->readAttachment( 4415 undef, $includedWeb, $includedTopic, $attachment, $rev ); 4416 } 4417 else { 4418 return _includeWarning( $this, $warn, 'bad_content', $mimeType ); 4419 } 4420 } 4421 if ( $charSet ) { 4422 my $siteCharset = $TWiki::cfg{Site}{CharSet} || 'iso-8859-1'; 4423 $this->_convertCharsets($charSet, $siteCharset, \$text); 4424 } 4425 4426 return $text if ( $raw ); 4427 4428 # remove everything before and after the default include block unless 4429 # a section is explicitly defined 4430 if( !$section ) { 4431 $text =~ s/.*?%STARTINCLUDE%//s; 4432 $text =~ s/%STOPINCLUDE%.*//s; 4433 } 4434 4435 # handle sections 4436 my( $ntext, $sections ) = parseSections( $text ); 4437 4438 my $interesting = ( defined $section ); 4439 if( $interesting || scalar( @$sections )) { 4440 # Rebuild the text from the interesting sections 4441 $text = ''; 4442 foreach my $s ( @$sections ) { 4443 if( $section && $s->{type} eq 'section' && $s->{name} eq $section) { 4444 $text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} ); 4445 $disableFixLinks = 1 if( $s->{disablefixlinks} ); 4446 $interesting = 1; 4447 last; 4448 } elsif( $s->{type} eq 'include' && !$section ) { 4449 $text .= substr( $ntext, $s->{start}, $s->{end}-$s->{start} ); 4450 $interesting = 1; 4451 } 4452 } 4453 } 4454 # If there were no interesting sections, restore the whole text 4455 $text = $ntext unless $interesting; 4456 4457 $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern ); 4458 4459 # Do not show TOC in included topic if hidetoc parameter or 4460 # TOC_HIDE_IF_INCLUDED preference setting has been set 4461 if( $hidetoc ) { 4462 $text =~ s/%TOC(?:{(.*?)})?%//g; 4463 } 4464 4465 # Codev.IncludeParametersWithDefault feature: 4466 # Change %ALLTAGS{ default="..." }% to %ALLTAGS% and capture tags with defaults 4467 # FIXME: Quick hack; do proper variable parsing 4468 my $verbatim = {}; 4469 $text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim ); 4470 my $tagsWithDefault = undef; 4471 $text =~ s/(%)($regex{tagNameRegex})(\{ *default=")(.*?[^\\]?)(" *\})(%)/ 4472 $tagsWithDefault->{$2} = _unescapeQuotes( $4 ); 4473 "$1$2$6"/ge; 4474 $this->renderer->putBackBlocks( \$text, $verbatim, 'verbatim' ); 4475 4476 foreach my $k ( keys %$params ) { 4477 next if( $k eq '_RAW' ); 4478 # copy params into session tags 4479 $this->{SESSION_TAGS}{$k} = $params->{$k}; 4480 # remove captured tag with default 4481 delete $tagsWithDefault->{$k}; 4482 } 4483 foreach my $k ( keys %$tagsWithDefault ) { 4484 # copy left over captured tags with default into session tags 4485 $this->{SESSION_TAGS}{$k} = $tagsWithDefault->{$k}; 4486 } 4487 4488 expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta ); 4489 4490 # 4th parameter tells plugin that its called for an included file 4491 $this->{plugins}->dispatch( 4492 'commonTagsHandler', $text, $includedTopic, $includedWeb, 1, $meta ); 4493 4494 # We have to expand tags again, because a plugin may have inserted additional 4495 # tags. 4496 expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta ); 4497 4498 # If needed, fix all 'TopicNames' to 'Web.TopicNames' to get the 4499 # right context so that links continue to work properly 4500 if( $includedWeb ne $includingWeb && !$disableFixLinks ) { 4501 my $removed = {}; 4502 my $noautolink = isTrue( $this->{prefs}->getPreferencesValue( 'NOAUTOLINK' ) ); 4503 4504 $text = $this->renderer->forEachLine( 4505 $text, \&_fixupIncludedTopic, { web => $includedWeb, 4506 force_noautolink => $noautolink, # TWikibug:Item7188 4507 pre => 1, 4508 noautolink => 1} ); 4509 # handle tags again because of plugin hook 4510 expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta ); 4511 } 4512 4513 if( $headingoffset =~ s/.*?([-+]?[0-9]).*/$1/ ) { 4514 $text =~ s/^(---*)(\++)/_fixHeadingOffset( $1, length( $2 ), $headingoffset )/gem; 4515 } 4516 4517 $this->_includePostProcessing(\$text, $params); 4518 4519 # restore the tags 4520 delete $this->{_INCLUDES}->{$key}; 4521 %{$this->{SESSION_TAGS}} = %saveTags; 4522 4523 $this->{prefs}->restore( $prefsMark ); 4524 4525 return $text; 4526} 4527 4528sub _http { 4529 my( $this, $params, $https ) = @_; 4530 my $res; 4531 my $field = $params->{_DEFAULT}; 4532 if ( $field ) { 4533 my $f = lc $field; 4534 $f =~ s/_/-/g; 4535 return '' if $httpHiddenField{$f}; 4536 $res = $https ? $this->{request}->https( $field ) 4537 : $this->{request}->http( $field ); 4538 } 4539 $res = '' unless defined( $res ); 4540 return $res; 4541} 4542 4543sub HTTP { 4544 return _http($_[0], $_[1], 0); 4545} 4546 4547sub HTTPS { 4548 return _http($_[0], $_[1], 1); 4549} 4550 4551#deprecated functionality, now implemented using %ENV% 4552#move to compatibility plugin in TWiki5 4553sub HTTP_HOST_deprecated { 4554 return $_[0]->{request}->header('Host') || ''; 4555} 4556 4557#deprecated functionality, now implemented using %ENV% 4558#move to compatibility plugin in TWiki5 4559sub REMOTE_ADDR_deprecated { 4560 return $_[0]->{request}->remoteAddress() || ''; 4561} 4562 4563#deprecated functionality, now implemented using %ENV% 4564#move to compatibility plugin in TWiki5 4565sub REMOTE_PORT_deprecated { 4566# CGI/1.1 (RFC 3875) doesn't specify REMOTE_PORT, 4567# but some webservers implement it. However, since 4568# it's not RFC compliant, TWiki should not rely on 4569# it. So we get more portability. 4570 return ''; 4571} 4572 4573#deprecated functionality, now implemented using %ENV% 4574#move to compatibility plugin in TWiki5 4575sub REMOTE_USER_deprecated { 4576 return $_[0]->{request}->remoteUser() || ''; 4577} 4578 4579# Only does simple search for topicmoved at present, can be expanded when required 4580# SMELL: this violates encapsulation of Store and Meta, by exporting 4581# the assumption that meta-data is stored embedded inside topic 4582# text. 4583sub METASEARCH { 4584 my( $this, $params ) = @_; 4585 4586 return $this->{store}->searchMetaData( $params ); 4587} 4588 4589sub DATE { 4590 my $this = shift; 4591 return TWiki::Time::formatTime(time(), $TWiki::cfg{DefaultDateFormat}, $TWiki::cfg{DisplayTimeValues}); 4592} 4593 4594sub GMTIME { 4595 my( $this, $params ) = @_; 4596 return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'gmtime' ); 4597} 4598 4599sub SERVERTIME { 4600 my( $this, $params ) = @_; 4601 return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', 'servertime' ); 4602} 4603 4604sub DISPLAYTIME { 4605 my( $this, $params ) = @_; 4606 return TWiki::Time::formatTime( time(), $params->{_DEFAULT} || '', $TWiki::cfg{DisplayTimeValues} ); 4607} 4608 4609#| $web | web and | 4610#| $topic | topic to display the name for | 4611#| $formatString | twiki format string (like in search) | 4612sub REVINFO { 4613 my ( $this, $params, $theTopic, $theWeb ) = @_; 4614 my $format = $params->{_DEFAULT} || $params->{format}; 4615 my $web = $params->{web} || $theWeb; 4616 my $topic = $params->{topic} || $theTopic; 4617 my $cgiQuery = $this->{request}; 4618 my $cgiRev = ''; 4619 $cgiRev = $cgiQuery->param('rev') if( $cgiQuery ); 4620 my $rev = $params->{rev} || $cgiRev || ''; 4621 4622 return $this->renderer->renderRevisionInfo( $web, $topic, undef, 4623 $rev, $format ); 4624} 4625 4626sub REVTITLE { 4627 my ( $this, $params, $theTopic, $theWeb ) = @_; 4628 my $request = $this->{request}; 4629 my $out = ''; 4630 if( $request ) { 4631 my $rev = $this->{store}->cleanUpRevID( $request->param( 'rev' ) ); 4632 $out = '(r'.$rev.')' if ($rev); 4633 } 4634 return $out; 4635} 4636 4637sub REVARG { 4638 my ( $this, $params, $theTopic, $theWeb ) = @_; 4639 my $request = $this->{request}; 4640 my $out = ''; 4641 if( $request ) { 4642 my $rev = $this->{store}->cleanUpRevID( $request->param( 'rev' ) ); 4643 $out = '&rev='.$rev if ($rev); 4644 } 4645 return $out; 4646} 4647 4648sub ENCODE { 4649 my( $this, $params ) = @_; 4650 my $type = $params->{type} || 'url'; 4651 my $extra = $params->{extra} || ''; 4652 my $text = $params->{_DEFAULT}; 4653 $text = '' unless( defined $text && $text ne '' ); 4654 my $newLine = $params->{newline}; 4655 if( defined $newLine ) { 4656 $newLine =~ s/\$br\b/\0-br-\0/go; 4657 $newLine =~ s/\$n\b/\0-n-\0/go; 4658 $text =~ s/\r?\n/$newLine/go; 4659 } 4660 my $encoded = _encode( $type, $text, expandStandardEscapes( $extra ) ); 4661 if( defined $newLine ) { 4662 $encoded =~ s/\0-br-\0/<br \/>/go; 4663 $encoded =~ s/\0-n-\0/\n/go; 4664 } 4665 return $encoded; 4666} 4667 4668sub ENTITY { 4669 my( $this, $params ) = @_; 4670 my $text = $params->{_DEFAULT}; 4671 $text = '' unless( defined $text && $text ne '' ); 4672 return _encode( 'html', $text ); 4673} 4674 4675sub _encode { 4676 my( $type, $text, $extra ) = @_; 4677 4678 if ( $type =~ /^entit(y|ies)$/i ) { 4679 # entity encode 4680 return entityEncode( $text, $extra ); 4681 } elsif ( $type =~ /^html$/i ) { 4682 # entity encode, encode also space, newline and linefeed 4683 return entityEncode( $text, " \n\r" ); 4684 } elsif ( $type =~ /^quotes?$/i ) { 4685 # escape quotes with backslash (Item3383) 4686 $text =~ s/\"/\\"/go; 4687 return $text; 4688 } elsif ( $type =~ /^search$/i ) { 4689 # substitue % with \x1a (Item7847), also escape quotes with backslash 4690 $text =~ s/\"/\\"/go; 4691 $text =~ s/%/$percentSubstitute/go; 4692 return $text; 4693 } elsif ($type =~ /^url$/i) { 4694 # legacy 4695 $text =~ s/\r*\n\r*/<br \/>/g; 4696 return urlEncode( $text ); 4697 } elsif ( $type =~ /^(off|none)$/i ) { 4698 # no encoding 4699 return $text; 4700 } elsif ($type =~ /^moderate$/i) { 4701 # entity encode ' " < and > 4702 $text =~ s/([<>'"])/'&#'.ord($1).';'/ge; 4703 return $text; 4704 } elsif ($type =~ /^csv$/i) { 4705 # escape for CSV use: Repeat ' and " 4706 $text =~ s/(['"])/$1$1/g; 4707 return $text; 4708 } elsif ($type =~ /^json$/i) { 4709 # escape for JSON string use: Double quotes, backslashes and non-printable chars 4710 $text =~ s/(["\\])/\\$1/go; 4711 $text =~ s/[\b]/\\b/go; 4712 $text =~ s/\f/\\f/go; 4713 $text =~ s/\n/\\n/go; 4714 $text =~ s/\r/\\r/go; 4715 $text =~ s/\t/\\t/go; 4716 $text =~ s/([\x00-\x1F])/sprintf( '\u%04x', ord($1) )/geo; 4717 return $text; 4718 } else { # safe or default 4719 # entity encode ' " < > and % 4720 $text =~ s/([<>%'"])/'&#'.ord($1).';'/ge; 4721 return $text; 4722 } 4723} 4724 4725sub ENV { 4726 my ($this, $params) = @_; 4727 4728 my $key = $params->{_DEFAULT}; 4729 return '' unless $key && defined $TWiki::cfg{AccessibleENV} && $key =~ /$TWiki::cfg{AccessibleENV}/o; 4730 my $val; 4731 if ( $key =~ /^HTTPS?_(.*)/ ) { 4732 $val = $this->{request}->header($1); 4733 } 4734 elsif ( $key eq 'REQUEST_METHOD' ) { 4735 $val = $this->{request}->request_method; 4736 } 4737 elsif ( $key eq 'REMOTE_USER' ) { 4738 $val = $this->{request}->remoteUser; 4739 } 4740 elsif ( $key eq 'REMOTE_ADDR' ) { 4741 $val = $this->{request}->remoteAddress; 4742 } 4743 else { 4744 # TSA SMELL: TWiki::Request doesn't support 4745 # SERVER_\w+, REMOTE_HOST and REMOTE_IDENT. 4746 # Use %ENV as fallback, but for ones above 4747 # wil probably not behave as expected if 4748 # running with non-CGI engine. 4749 $val = $ENV{$key}; 4750 } 4751 return defined $val ? $val : 'not set'; 4752} 4753 4754sub SEARCH { 4755 my ( $this, $params, $topic, $web ) = @_; 4756 # pass on all attrs, and add some more 4757 #$params->{_callback} = undef; 4758 $params->{inline} = 1; 4759 $params->{baseweb} = $web; 4760 $params->{basetopic} = $topic; 4761 $params->{search} = $params->{_DEFAULT} if( $params->{_DEFAULT} ); 4762 $params->{type} = $this->{prefs}->getPreferencesValue( 'SEARCHVARDEFAULTTYPE' ) unless( $params->{type} ); 4763 my $s; 4764 try { 4765 $s = $this->search->searchWeb( %$params ); 4766 if( my $encode = $params->{encode} ) { 4767 $s = $this->ENCODE( { _DEFAULT => $s, type => $encode } ); 4768 } 4769 } catch Error::Simple with { 4770 my $message = (DEBUG) ? shift->stringify() : shift->{-text}; 4771 # Block recursions kicked off by the text being repeated in the 4772 # error message 4773 $message =~ s/%([A-Z]*[{%])/%<nop>$1/g; 4774 $s = $this->inlineAlert( 'alerts', 'bad_search', $message ); 4775 }; 4776 return $s; 4777} 4778 4779sub WEBLIST { 4780 my( $this, $params ) = @_; 4781 my $format = $params->{_DEFAULT} || $params->{'format'} || '$name'; 4782 my $separator = expandStandardEscapes($params->{separator} || "\n"); 4783 my $web = $params->{web} || ''; 4784 my $webs = $params->{webs} || 'public'; 4785 my $exclude = $params->{exclude} || ''; 4786 my $selection = $params->{selection} || ''; 4787 $selection =~ s/\,/ /g; 4788 $selection = " $selection "; 4789 my $showWeb = $params->{subwebs} || ''; 4790 my $limit = $params->{limit} || '32000'; 4791 my $overlimit = $params->{overlimit} || ''; 4792 my $depth = $params->{depth}; 4793 my $reverse = isTrue($params->{reverse}); 4794 if ( defined($depth) ) { 4795 if ( $depth =~ /^(\d+)/ ) { 4796 $depth = $1; 4797 } 4798 else { 4799 $depth = undef; 4800 } 4801 } 4802 my $marker = $params->{marker} || 'selected="selected"'; 4803 $web =~ s#\.#/#go; 4804 4805 my @list = (); 4806 my @webslist = split( /,\s*/, $webs ); 4807 foreach my $aweb ( @webslist ) { 4808 if( $aweb eq 'public' ) { 4809 push( @list, $this->{store}->getListOfWebs( 'user,public,allowed', $showWeb, $depth ) ); 4810 } elsif ( $aweb eq 'canmoveto' ) { 4811 push( @list, $this->{store}->getListOfWebs( 'user,public,allowed,canmoveto', $showWeb, $depth ) ); 4812 } elsif ( $aweb eq 'cancopyto' ) { 4813 push( @list, $this->{store}->getListOfWebs( 'user,public,allowed,cancopyto', $showWeb, $depth ) ); 4814 } elsif( $aweb eq 'webtemplate' ) { 4815 push( @list, $this->{store}->getListOfWebs( 'template,allowed', $showWeb, $depth )); 4816 } else { 4817 push( @list, $aweb ) if( $this->{store}->webExists( $aweb ) ); 4818 } 4819 } 4820 4821 if( $exclude ) { 4822 # turn exclude into a regex: 4823 $exclude =~ s/,\s*/|/g; # change comma list to regex "or" 4824 $exclude =~ s/[^$regex{mixedAlphaNum}\_\.\/\*\|]//g; # filter out illegal chars 4825 $exclude =~ s/\*/.*/g; # change wildcard to regex 4826 } 4827 my @items; 4828 my $indent = CGI::span({class=>'twikiWebIndent'},''); 4829 my $i = 0; 4830 @list = reverse @list if ( $reverse ); 4831 foreach my $item ( @list ) { 4832 if( $exclude && $item =~ /^($exclude)$/ ) { 4833 next; 4834 } 4835 if( $i++ >= $limit ) { 4836 push( @items, $overlimit ) if $overlimit; 4837 last; 4838 } 4839 my $line = $format; 4840 $line =~ s/\$web\b/$web/g; 4841 $line =~ s/\$name\b/$item/g; 4842 $line =~ s/\$qname/"$item"/g; 4843 my $indenteditem = $item; 4844 $indenteditem =~ s#/$##g; 4845 $indenteditem =~ s#\w+/#$indent#g; 4846 $line =~ s/\$indentedname/$indenteditem/g; 4847 my $listindent = ' ' x 4848 (($item =~ tr:/::) - 4849 ($showWeb eq '' ? 0 : ($showWeb =~ tr:/::) + 1)); 4850 # $s =~ tr:/:: doesn't modify $s 4851 $line =~ s/\$listindent\b/$listindent/g; 4852 my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : ''; 4853 $line =~ s/\$marker/$mark/g; 4854 $line = expandStandardEscapes($line); 4855 push( @items, $line ); 4856 } 4857 return join( $separator, @items); 4858} 4859 4860sub TOPICLIST { 4861 my( $this, $params ) = @_; 4862 my $format = $params->{_DEFAULT} || $params->{'format'} || '$topic'; 4863 my $separator = $params->{separator} || "\n"; 4864 $separator =~ s/\$n/\n/; 4865 my $web = $params->{web} || $this->{webName}; 4866 my $selection = $params->{selection} || ''; 4867 $selection =~ s/\,/ /g; 4868 $selection = " $selection "; 4869 my $marker = $params->{marker} || 'selected="selected"'; 4870 $web =~ s#\.#/#go; 4871 4872 return '' if 4873 $web ne $this->{webName} && 4874 $this->{prefs}->getWebPreferencesValue( 'NOSEARCHALL', $web ); 4875 4876 my @items; 4877 foreach my $item ( $this->{store}->getTopicNames( $web ) ) { 4878 my $line = $format; 4879 $line =~ s/\$web\b/$web/g; 4880 $line =~ s/\$topic\b/$item/g; 4881 $line =~ s/\$name\b/$item/g; # Undocumented, DO NOT REMOVE 4882 $line =~ s/\$qname/"$item"/g; # Undocumented, DO NOT REMOVE 4883 my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : ''; 4884 $line =~ s/\$marker/$mark/g; 4885 $line = expandStandardEscapes( $line ); 4886 push( @items, $line ); 4887 } 4888 return join( $separator, @items); 4889} 4890 4891sub QUERYSTRING { 4892 my $this = shift; 4893 my $qs = $this->{request}->queryString(); 4894 # Item7595: Sanitize QUERYSTRING to counter XSS exploits 4895 $qs =~ s/(['\/<>])/'%'.sprintf('%02x', ord($1))/ge; 4896 return $qs; 4897} 4898 4899sub QUERYPARAMS { 4900 my ( $this, $params ) = @_; 4901 return '' unless $this->{request}; 4902 4903 my $format = defined $params->{format} ? $params->{format} : '$name=$value'; 4904 my $separator = defined $params->{separator} ? $params->{separator} : "\n"; 4905 # Item6621: Deprecate encoding="", add encode="". Do NOT remove encoding=""! 4906 my $encoding = $params->{encode} || $params->{encoding} || ''; 4907 4908 my @list; 4909 foreach my $name ( $this->{request}->param() ) { 4910 # clean parameter names of illegal characters 4911 $name =~ s/['"<>].*//; 4912 # Issues multi-valued parameters as separate hiddens 4913 if( $name ) { 4914 foreach my $value ( $this->{request}->param( $name ) ) { 4915 $value = '' unless defined $value; 4916 $value = _encode( $encoding, $value ) if( $encoding ); 4917 my $entry = $format; 4918 $entry =~ s/\$name/$name/g; 4919 $entry =~ s/\$value/$value/; 4920 push( @list, $entry ); 4921 } 4922 } 4923 } 4924 return expandStandardEscapes(join($separator, @list)); 4925} 4926 4927sub URLPARAM { 4928 my( $this, $params ) = @_; 4929 my $param = $params->{_DEFAULT} || ''; 4930 my $newLine = $params->{newline}; 4931 my $encode = $params->{encode} || 'safe'; 4932 my $multiple = $params->{multiple}; 4933 my $format = $params->{format} || '$value'; 4934 my $separator = $params->{separator}; 4935 $separator="\n" unless (defined $separator); 4936 4937 my $value; 4938 if( $this->{request} ) { 4939 if( TWiki::isTrue( $multiple )) { 4940 my @valueArray = $this->{request}->param( $param ); 4941 if( @valueArray ) { 4942 # join multiple values properly 4943 unless( $multiple =~ m/^on$/i ) { 4944 my $item = ''; 4945 @valueArray = map { 4946 $item = $_; 4947 $_ = $multiple; 4948 $_ .= $item unless( s/\$item/$item/go ); 4949 $_ 4950 } @valueArray; 4951 } 4952 $value = join ( $separator, @valueArray ); 4953 } 4954 } else { 4955 $value = $this->{request}->param( $param ); 4956 } 4957 } 4958 if( defined $value ) { 4959 $format =~ s/\$value/$value/go; 4960 $value = $format; 4961 if( defined $newLine ) { 4962 $newLine =~ s/\$br\b/\0-br-\0/go; 4963 $newLine =~ s/\$n\b/\0-n-\0/go; 4964 $value =~ s/\r?\n/$newLine/go; 4965 $value = _encode( $encode, $value ); 4966 $value =~ s/\0-br-\0/<br \/>/go; 4967 $value =~ s/\0-n-\0/\n/go; 4968 } else { 4969 $value = _encode( $encode, $value ); 4970 } 4971 } 4972 unless( defined $value && $value ne '' ) { 4973 $value = $params->{default}; 4974 $value = '' unless defined $value; 4975 } 4976 # Block expansion of %URLPARAM in the value to prevent recursion 4977 $value =~ s/%URLPARAM\{/%<nop>URLPARAM{/g; 4978 return $value; 4979} 4980 4981# This routine was introduced to URL encode Mozilla UTF-8 POST URLs in the 4982# TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now 4983# directly supported, but it is provided for backward compatibility with 4984# skins that may still be using the deprecated %INTURLENCODE%. 4985sub INTURLENCODE_deprecated { 4986 my( $this, $params ) = @_; 4987 # Just strip double quotes, no URL encoding - Mozilla UTF-8 URLs 4988 # directly supported now 4989 return $params->{_DEFAULT} || ''; 4990} 4991 4992# This routine is deprecated as of DakarRelease, 4993# and is maintained only for backward compatibility. 4994# Spacing of WikiWords is now done with %SPACEOUT% 4995# (and the private routine _SPACEOUT). 4996# Move to compatibility module in TWiki5 4997sub SPACEDTOPIC_deprecated { 4998 my ( $this, $params, $theTopic ) = @_; 4999 my $topic = spaceOutWikiWord( $theTopic ); 5000 $topic =~ s/ / */g; 5001 return urlEncode( $topic ); 5002} 5003 5004sub SPACEOUT { 5005 my ( $this, $params ) = @_; 5006 my $spaceOutTopic = $params->{_DEFAULT}; 5007 my $sep = $params->{'separator'}; 5008 $spaceOutTopic = spaceOutWikiWord( $spaceOutTopic, $sep ); 5009 return $spaceOutTopic; 5010} 5011 5012sub ICON { 5013 my( $this, $params ) = @_; 5014 my $iconName = $params->{_DEFAULT} || ''; 5015 my $format = $params->{format} || '$img'; 5016 my $default = $params->{default} || ''; 5017 5018 return $this->formatIcon( $iconName, $format, $default ); 5019} 5020 5021sub ICONURL { 5022 my( $this, $params ) = @_; 5023 my $iconName = ( $params->{_DEFAULT} || '' ); 5024 my $default = $params->{default} || ''; 5025 5026 return $this->formatIcon( $iconName, '$url', $default ); 5027} 5028 5029sub ICONURLPATH { 5030 my( $this, $params ) = @_; 5031 my $iconName = ( $params->{_DEFAULT} || '' ); 5032 my $default = $params->{default} || ''; 5033 5034 return $this->formatIcon( $iconName, '$urlpath', $default ); 5035} 5036 5037sub RELATIVETOPICPATH { 5038 my ( $this, $params, $theTopic, $web ) = @_; 5039 my $topic = $params->{_DEFAULT}; 5040 5041 return '' unless $topic; 5042 5043 my $theRelativePath; 5044 # if there is no dot in $topic, no web has been specified 5045 if ( index( $topic, '.' ) == -1 ) { 5046 # add local web 5047 $theRelativePath = $web . '/' . $topic; 5048 } else { 5049 $theRelativePath = $topic; #including dot 5050 } 5051 # replace dot by slash is not necessary; TWiki.MyTopic is a valid url 5052 # add ../ if not already present to make a relative file reference 5053 if ( $theRelativePath !~ m!^../! ) { 5054 $theRelativePath = "../$theRelativePath"; 5055 } 5056 return $theRelativePath; 5057} 5058 5059sub ATTACHURLPATH { 5060 my ( $this, $params, $topic, $web ) = @_; 5061 return $this->getPubUrl(0, $web, $topic); 5062} 5063 5064sub ATTACHURL { 5065 my ( $this, $params, $topic, $web ) = @_; 5066 return $this->getPubUrl(1, $web, $topic); 5067} 5068 5069sub LANGUAGE { 5070 my $this = shift; 5071 return $this->i18n->language(); 5072} 5073 5074sub LANGUAGES { 5075 my ( $this , $params ) = @_; 5076 my $format = $params->{format} || " * \$langname"; 5077 my $separator = $params->{separator} || "\n"; 5078 $separator =~ s/\\n/\n/g; 5079 my $selection = $params->{selection} || ''; 5080 $selection =~ s/\,/ /g; 5081 $selection = " $selection "; 5082 my $marker = $params->{marker} || 'selected="selected"'; 5083 5084 # $languages is a hash reference: 5085 my $languages = $this->i18n->enabled_languages(); 5086 5087 my @tags = sort(keys(%{$languages})); 5088 5089 my $result = ''; 5090 my $i = 0; 5091 foreach my $lang (@tags) { 5092 my $item = $format; 5093 my $name = ${$languages}{$lang}; 5094 $item =~ s/\$langname/$name/g; 5095 $item =~ s/\$langtag/$lang/g; 5096 my $mark = ( $selection =~ / \Q$lang\E / ) ? $marker : ''; 5097 $item =~ s/\$marker/$mark/g; 5098 $result .= $separator if $i; 5099 $result .= $item; 5100 $i++; 5101 } 5102 5103 return $result; 5104} 5105 5106sub MAKETEXT { 5107 my( $this, $params ) = @_; 5108 5109 my $str = $params->{_DEFAULT} || $params->{string} || ""; 5110 return "" unless $str; 5111 5112 # escape everything: 5113 $str =~ s/\[/~[/g; 5114 $str =~ s/\]/~]/g; 5115 5116 # restore already escaped stuff: 5117 $str =~ s/~~+\[/~[/g; 5118 $str =~ s/~~+\]/~]/g; 5119 5120 # unescape parameters and calculate highest parameter number: 5121 my $max = 0; 5122 my $min = 1; 5123 $str =~ s/~\[(\_(\d+))~\]/ 5124 $max = $2 if ($2 > $max); 5125 $min = $2 if ($2 < $min); 5126 "[$1]"/ge; 5127 $str =~ s/~\[(\*,\_(\d+),[^,]+(,([^,]+))?)~\]/ 5128 $max = $2 if ($2 > $max); 5129 $min = $2 if ($2 < $min); 5130 "[$1]"/ge; 5131 5132 # Item7080: Sanitize MAKETEXT variable: 5133 return "MAKETEXT error: No more than 32 parameters are allowed" if( $max > 32 ); 5134 return "MAKETEXT error: Parameter 0 is not allowed" if( $min < 1 ); 5135 if( $TWiki::cfg{UserInterfaceInternationalisation} ) { 5136 eval { require Locale::Maketext; }; 5137 no warnings('numeric'); 5138 $str =~ s#\\#\\\\#g if( $@ || !$@ && $Locale::Maketext::VERSION < 1.23 ); 5139 } 5140 5141 # get the args to be interpolated. 5142 my $argsStr = $params->{args} || ""; 5143 5144 my @args = split (/\s*,\s*/, $argsStr) ; 5145 # fill omitted args with zeros 5146 while ((scalar @args) < $max) { 5147 push(@args, 0); 5148 } 5149 5150 # do the magic: 5151 my $result = $this->i18n->maketext($str, @args); 5152 5153 # replace accesskeys: 5154 $result =~ s#(^|[^&])&([a-zA-Z])#$1<span class='twikiAccessKey'>$2</span>#g; 5155 5156 # replace escaped amperstands: 5157 $result =~ s/&&/\&/g; 5158 5159 return $result; 5160} 5161 5162sub SCRIPTNAME { 5163 return $_[0]->{request}->action; 5164} 5165 5166sub scriptUrlSub { 5167 my ( $this, $params, $absolute ) = @_; 5168 my $script = $params->{_DEFAULT} || ''; 5169 my $web = $params->{web}; 5170 my $topic = $params->{topic}; 5171 $topic = '' if ( !defined($topic) ); 5172 my @optParams; 5173 if ( isTrue($params->{master}) ) { 5174 push(@optParams, '$master', 1); 5175 } 5176 my $url = $this->getScriptUrl($absolute, $script, $web, $topic, @optParams); 5177 if ( $web && !$topic ) { 5178 $url = substr($url, 0, -length($cfg{HomeTopicName})-1); 5179 } 5180 return $url; 5181} 5182 5183sub SCRIPTURL { 5184# my ( $this, $params, $topic, $web ) = @_; 5185 return scriptUrlSub($_[0], $_[1], 1); 5186} 5187 5188sub SCRIPTURLPATH { 5189# my ( $this, $params, $topic, $web ) = @_; 5190 return scriptUrlSub($_[0], $_[1], 0); 5191} 5192 5193sub PUBURL { 5194 my $this = shift; 5195 return $this->getPubUrl(1); 5196} 5197 5198sub PUBURLPATH { 5199 my $this = shift; 5200 return $this->getPubUrl(0); 5201} 5202 5203sub getContentMode { 5204 my ( $this, $web ) = @_; 5205 if ( !defined($web) || $web eq '' || $web eq $this->{webName} ) { 5206 return $this->{contentMode}; 5207 } 5208 else { 5209 return ($this->modeAndMaster($web))[0]; 5210 } 5211} 5212 5213sub webWritable { 5214 my ( $this, $web ) = @_; 5215 my $mode = $this->getContentMode($web); 5216 return ($mode eq 'slave' || $mode eq 'read-only') ? 0 : 1; 5217} 5218 5219sub CONTENTMODE { 5220 #my ( $this, $params ) = @_; 5221 return $_[0]->getContentMode($_[1]->{web}); 5222} 5223 5224sub ALLVARIABLES { 5225 return shift->{prefs}->stringify(); 5226} 5227 5228sub META { 5229 my ( $this, $params, $topic, $web ) = @_; 5230 5231 5232 # TWikibug:Item6438: %META uses current web.topic scope, but base topic's meta data. 5233 # ==> Quirky spec for compatibility with pre 5.0 releases where base topic is used 5234 # by default instead of current topic because meta data is pulled from base topic. 5235 $web = $this->{SESSION_TAGS}{BASEWEB} || $web; 5236 $topic = $this->{SESSION_TAGS}{BASETOPIC} || $topic; 5237 my $meta = $this->inContext( 'can_render_meta' ); 5238 5239 my $paramTopic = $params->{topic}; 5240 if( $paramTopic ) { 5241 ( $web, $topic ) = $this->normalizeWebTopicName( $web, $paramTopic ); 5242 try { 5243 my $dummyText; 5244 ( $meta, $dummyText ) = $this->{store}->readTopic( 5245 $this->{session}->{user}, $web, $topic ); 5246 } catch TWiki::AccessControlException with { 5247 # Ignore access exceptions 5248 return ''; 5249 }; 5250 } 5251 return '' unless $meta; 5252 5253 my $result = ''; 5254 my $option = $params->{_DEFAULT} || ''; 5255 if( $option eq 'form' ) { 5256 # META:FORM and META:FIELD 5257 $result = $meta->renderFormForDisplay( $this->templates ); 5258 } elsif ( $option eq 'formfield' ) { 5259 # a formfield from within topic text 5260 $result = $meta->renderFormFieldForDisplay( $params->get('name'), '$value', $params ); 5261 } elsif( $option eq 'attachments' ) { 5262 # renders attachment tables 5263 $result = $this->attach->renderMetaData( $web, $topic, $meta, $params ); 5264 } elsif( $option eq 'moved' ) { 5265 $result = $this->renderer->renderMoved( $web, $topic, $meta, $params ); 5266 } elsif( $option eq 'parent' ) { 5267 $result = $this->renderer->renderParent( $web, $topic, $meta, $params ); 5268 } 5269 5270 return expandStandardEscapes($result); 5271} 5272 5273sub PARENTTOPIC { 5274 my ( $this, $params, $topic, $web ) = @_; 5275 my $metaParams = { 5276 _DEFAULT => 'parent', 5277 format => $params->{format} || '$topic', 5278 topic => $params->{topic} || "$web.$topic", 5279 dontrecurse => 'on', 5280 }; 5281 return $this->META( $metaParams, $topic, $web ); 5282} 5283 5284# Remove NOP tag in template topics but show content. Used in template 5285# _topics_ (not templates, per se, but topics used as templates for new 5286# topics) 5287sub NOP { 5288 my ( $this, $params, $topic, $web ) = @_; 5289 5290 return '<nop>' unless $params->{_RAW}; 5291 5292 return $params->{_RAW}; 5293} 5294 5295# Shortcut to %TMPL:P{"sep"}% 5296sub SEP { 5297 my $this = shift; 5298 return $this->templates->expandTemplate('sep'); 5299} 5300 5301#deprecated functionality, now implemented using %USERINFO% 5302#move to compatibility plugin in TWiki5 5303sub WIKINAME_deprecated { 5304 my ( $this, $params ) = @_; 5305 5306 $params->{format} = $this->{prefs}->getPreferencesValue( 'WIKINAME' ) || '$wikiname'; 5307 5308 return $this->USERINFO($params); 5309} 5310 5311#deprecated functionality, now implemented using %USERINFO% 5312#move to compatibility plugin in TWiki5 5313sub USERNAME_deprecated { 5314 my ( $this, $params ) = @_; 5315 5316 $params->{format} = $this->{prefs}->getPreferencesValue( 'USERNAME' ) || '$username'; 5317 5318 return $this->USERINFO($params); 5319} 5320 5321#deprecated functionality, now implemented using %USERINFO% 5322#move to compatibility plugin in TWiki5 5323sub WIKIUSERNAME_deprecated { 5324 my ( $this, $params ) = @_; 5325 5326 $params->{format} = 5327 $this->{prefs}->getPreferencesValue( 'WIKIUSERNAME' ) || '$wikiusername'; 5328 5329 return $this->USERINFO($params); 5330} 5331 5332sub USERINFO { 5333 my ( $this, $params ) = @_; 5334 my $format = $params->{format} || '$username, $wikiusername, $emails'; 5335 5336 my $user = $this->{user}; 5337 5338 if( $params->{_DEFAULT} ) { 5339 $user = $params->{_DEFAULT}; 5340 return '' if !$user; 5341 # map wikiname to a login name 5342 $user = $this->{users}->getCanonicalUserID($user); 5343 return '' unless $user; 5344 return '' if( $TWiki::cfg{AntiSpam}{HideUserDetails} && 5345 !$this->{users}->isAdmin( $this->{user} ) && 5346 $user ne $this->{user} ); 5347 } 5348 5349 return '' unless $user; 5350 5351 my $info = $format; 5352 5353 if ($info =~ /\$username/) { 5354 my $username = $this->{users}->getLoginName($user); 5355 $username = 'unknown' unless defined $username; 5356 $info =~ s/\$username/$username/g; 5357 } 5358 if ($info =~ /\$wikiname/) { 5359 my $wikiname = $this->{users}->getWikiName( $user ); 5360 $wikiname = 'UnknownUser' unless defined $wikiname; 5361 $info =~ s/\$wikiname/$wikiname/g; 5362 } 5363 if ($info =~ /\$wikiusername/) { 5364 my $wikiusername = $this->{users}->webDotWikiName($user); 5365 $wikiusername = "$TWiki::cfg{UsersWebName}.UnknownUser" unless defined $wikiusername; 5366 $info =~ s/\$wikiusername/$wikiusername/g; 5367 } 5368 if ($info =~ /\$emails/) { 5369 my $emails = join(', ', $this->{users}->getEmails($user)); 5370 $info =~ s/\$emails/$emails/g; 5371 } 5372 if ($info =~ /\$groups/) { 5373 my @groupNames; 5374 my $it = $this->{users}->eachMembership( $user ); 5375 while( $it->hasNext()) { 5376 my $group = $it->next(); 5377 push( @groupNames, $group); 5378 } 5379 my $groups = join(', ', @groupNames); 5380 $info =~ s/\$groups/$groups/g; 5381 } 5382 if ($info =~ /\$cUID/) { 5383 my $cUID = $user; 5384 $info =~ s/\$cUID/$cUID/g; 5385 } 5386 if ($info =~ /\$admin/) { 5387 my $admin = $this->{users}->isAdmin($user) ? 'true' : 'false'; 5388 $info =~ s/\$admin/$admin/g; 5389 } 5390 5391 return $info; 5392} 5393 5394sub GROUPS { 5395 my ( $this, $params ) = @_; 5396 5397 my $format = $params->{format} || '| $grouplink | $members |'; 5398 my $separator = expandStandardEscapes( $params->{separator} || "\n" ); 5399 my $memberSeparator = expandStandardEscapes( $params->{memberseparator} || ", " ); 5400 my $memberFormat = $params->{memberformat} || '[[$wikiusername][$wikiname]]'; 5401 my $limit_output = $params->{memberlimit} || 32; 5402 $limit_output = 32000 if( $limit_output eq 'all' ); 5403 my $header = $params->{header}; 5404 $header = '| *' . $this->i18n->maketext( 'Group' ) 5405 . '* | *' . $this->i18n->maketext( 'Members' ) . '* |' unless( defined $header ); 5406 $header = '' if( $header eq 'none' ); 5407 $header = expandStandardEscapes( $header ); 5408 $header .= $separator unless( $header eq '' ); 5409 my $groups = $this->{users}->eachGroup(); 5410 my @table = (); 5411 while( $groups->hasNext() ) { 5412 my $group = $groups->next(); 5413 # Nop it to prevent wikiname expansion unless the topic exists. 5414 my $groupLink = "<nop>$group"; 5415 if( $this->{store}->topicExists( $TWiki::cfg{UsersWebName}, $group ) ) { 5416 $groupLink = '[['.$TWiki::cfg{UsersWebName}.".$group][$group]]"; 5417 } 5418 my $it = $this->{users}->eachGroupMember( $group ); 5419 my @members = (); 5420 my $i = 0; 5421 while( $it->hasNext() ) { 5422 $i++; 5423 last if( $i > $limit_output ); 5424 push( @members, $it->next() ); 5425 } 5426 @members = map { 5427 my $user = $_; 5428 $_ = $memberFormat; 5429 s/\$cuid/$user/go; 5430 s/\$wikiname/$this->{users}->getWikiName( $user )/geo; 5431 s/\$wikiusername/$this->{users}->webDotWikiName( $user )/geo; 5432 $_; 5433 } @members; 5434 @members = sort @members if ( isTrue($params->{sort}) ); 5435 my $members = join( $memberSeparator, @members ); 5436 $members .= $memberSeparator . '...' if( $i > $limit_output ); 5437 my $line = $format; 5438 $line =~ s/\$grouplink/$groupLink/go; 5439 $line =~ s/\$group/$group/go; 5440 $line =~ s/\$members/$members/go; 5441 $line = expandStandardEscapes( $line ); 5442 push( @table, $line ); 5443 } 5444 5445 # add hardcoded AllUsersGroup 5446 my $line = $format; 5447 my $group = 'AllUsersGroup'; 5448 my $groupLink = '[['.$TWiki::cfg{UsersWebName}.".$group][$group]]"; 5449 my $members = $this->i18n->maketext( 'All users including unauthenticated users.' ); 5450 $line =~ s/\$grouplink/$groupLink/go; 5451 $line =~ s/\$group/$group/go; 5452 $line =~ s/\$members/$members/go; 5453 $line = expandStandardEscapes( $line ); 5454 push( @table, $line ); 5455 # add hardcoded AllAuthUsersGroup 5456 $line = $format; 5457 $group = 'AllAuthUsersGroup'; 5458 $groupLink = '[['.$TWiki::cfg{UsersWebName}.".$group][$group]]"; 5459 $members = $this->i18n->maketext( 'All authenticated users.' ); 5460 $line =~ s/\$grouplink/$groupLink/go; 5461 $line =~ s/\$group/$group/go; 5462 $line =~ s/\$members/$members/go; 5463 $line = expandStandardEscapes( $line ); 5464 push( @table, $line ); 5465 5466 return $header . join( $separator, sort @table ); 5467} 5468 5469sub CRYPTTOKEN { 5470 my ($this ) = @_; 5471 return $this->{users}->{loginManager}->createCryptToken(); 5472} 5473 5474sub _getMdrepoField { 5475 my ($rec, $recId, $fieldName) = @_; 5476 if ( $fieldName eq '' ) { 5477 return $recId; 5478 } 5479 elsif ( $fieldName eq '_' ) { 5480 return join(" ", map { "$_=$rec->{$_}" } sort keys %$rec); 5481 } 5482 return $rec->{$fieldName} || ''; 5483} 5484 5485sub _mdrepoFieldCond { 5486 my ($neg, $val, $ifMet) = @_; 5487 if ( $neg ) { 5488 return $val ? '' : $ifMet; 5489 } 5490 else { 5491 return $val ? $ifMet : ''; 5492 } 5493} 5494 5495sub _mdrepoExpand { 5496 my ($rec, $id, $fmt, $selection, $marker) = @_; 5497 my $m = $id eq $selection ? $marker : ''; 5498 $fmt =~ s/\?(!?)(\w+)([!#%'\/:?@^`|~])(.*?)\3/_mdrepoFieldCond($1, $rec->{$2}, $4)/ge; 5499 $fmt =~ s/\$marker(\(\))?/$m/g; 5500 $fmt =~ s/\$_(\w*)(\(\))?/_getMdrepoField($rec, $id, $1)/ge; 5501 $fmt =~ s/\$question\(\)/\?/g; 5502 $fmt =~ s/\$question\b/\?/g; 5503 return expandStandardEscapes($fmt); 5504} 5505 5506sub MDREPO { 5507 my ( $this, $params ) = @_; 5508 my $mdrepo = $this->{mdrepo}; 5509 return '' unless ( $mdrepo ); 5510 if ( my $web = $params->{web} ) { 5511 $web = topLevelWeb($web); 5512 my $rec = $mdrepo->getRec('webs', $web); 5513 unless ( $rec ) { 5514 return $params->{default} || ''; 5515 } 5516 my $format = $params->{_DEFAULT} || '$__'; 5517 return _mdrepoExpand($rec, $web, $format, ''); 5518 } 5519 my $table = $params->{_DEFAULT} || $params->{table} || ''; 5520 my $filter = $params->{filter} || ''; 5521 my $format = $params->{format} || '| $_ | $__ |'; 5522 my $separator = $params->{separator}; 5523 if ( defined($separator) ) { 5524 $separator = expandStandardEscapes($separator); 5525 } 5526 else { 5527 $separator = "\n"; 5528 } 5529 my $exclude = $params->{exclude} || ''; 5530 my $selection = $params->{selection} || ''; 5531 my $marker = $params->{marker} || 'selected'; 5532 my @excludes; 5533 if ( $exclude ) { 5534 for my $i ( split(/,\s*/, $exclude) ) { 5535 push(@excludes, qr/^$i$/); 5536 } 5537 } 5538 my @recIds = $mdrepo->getList($table); 5539 if ( $filter ) { 5540 @recIds = grep { $_ =~ /$filter/i } @recIds; 5541 } 5542 my @ents; 5543 RECID_LOOP: 5544 for my $i ( sort { lc $a cmp lc $b } @recIds ) { 5545 for my $e ( @excludes ) { 5546 next RECID_LOOP if ( $i =~ $e ); 5547 } 5548 my $rec = $mdrepo->getRec($table, $i); 5549 push(@ents, _mdrepoExpand($rec, $i, $format, $selection, $marker)); 5550 } 5551 join($separator, @ents); 5552} 5553 5554sub DISKID { 5555 my ( $this, $params ) = @_; 5556 my $web = $params->{web} || $this->{webName}; 5557 return ($this->getStorageInfo($web))[2]; 5558} 5559 5560sub trashWebName { 5561 my ( $this, %param ) = @_; 5562 if ( !$TWiki::cfg{MultipleDisks} ) { 5563 return $TWiki::cfg{TrashWebName}; 5564 } 5565 my $diskID; 5566 if ( defined($param{disk}) ) { 5567 $diskID = $param{disk}; 5568 } 5569 else { 5570 $diskID = ($this->getDiskInfo($param{web}))[2]; 5571 } 5572 my $name = $TWiki::cfg{TrashWebName}; 5573 $name .= 'x' . $diskID . 'x' if ( $diskID ); 5574 return $name; 5575} 5576 5577sub TRASHWEB { 5578 my ( $this, $params, $topic, $web ) = @_; 5579 my $w = $params->{web} || $web; 5580 return $this->trashWebName(web => $w); 5581} 5582 5583sub _wikiWebMaster { 5584 my ( $this, $params, $name ) = @_; 5585 my $web = $params->{web} || $this->{webName}; 5586 my $topic = $params->{topic} || $this->{topicName}; 5587 my $mapping = $this->{users}{mapping}; 5588 my $result = ''; 5589 if ( $mapping->can('wikiWebMaster') ) { 5590 $result = $mapping->wikiWebMaster($web, $topic, $name); 5591 } 5592 if ( $result ) { 5593 return $result; 5594 } 5595 else { 5596 return $name ? $TWiki::cfg{WebMasterName} : $TWiki::cfg{WebMasterEmail}; 5597 } 5598} 5599 5600sub WIKIWEBMASTER { 5601 return _wikiWebMaster(@_[0, 1], 0); 5602} 5603 5604sub WIKIWEBMASTERNAME { 5605 return _wikiWebMaster(@_[0, 1], 1); 5606} 5607 56081; 5609