1 rizwank 1.1 # Main Module of TWiki Collaboration Platform, http://TWiki.org/
2 # ($wikiversion has version info)
3 #
4 # Copyright (C) 1999-2004 Peter Thoeny, peter@thoeny.com
5 #
6 # Based on parts of Ward Cunninghams original Wiki and JosWiki.
7 # Copyright (C) 1998 Markus Peter - SPiN GmbH (warpi@spin.de)
8 # Some changes by Dave Harris (drh@bhresearch.co.uk) incorporated
9 #
10 # For licensing info read license.txt file in the TWiki root.
11 # This program is free software; you can redistribute it and/or
12 # modify it under the terms of the GNU General Public License
13 # as published by the Free Software Foundation; either version 2
14 # of the License, or (at your option) any later version.
15 #
16 # This program is distributed in the hope that it will be useful,
17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 # GNU General Public License for more details, published at
20 # http://www.gnu.org/copyleft/gpl.html
21 #
22 rizwank 1.1 # Notes:
23 # - Latest version at http://twiki.org/
24 # - Installation instructions in $dataDir/TWiki/TWikiDocumentation.txt
25 # - Customize variables in TWiki.cfg when installing TWiki.
26 # - Optionally create a new plugin or customize DefaultPlugin.pm for
27 # custom rendering rules.
28 # - Upgrading TWiki is easy as long as you only customize DefaultPlugin.pm.
29 # - Check web server error logs for errors, i.e. % tail /var/log/httpd/error_log
30 #
31 # 20000501 Kevin Kinnell : changed beta0404 to have many new search
32 # capabilities. This file had a new hash added
33 # for month name-to-number look-ups, a slight
34 # change in the parameter list for the search
35 # script call in &handleSearchWeb, and a new
36 # sub -- &revDate2EpSecs -- for calculating the
37 # epoch seconds from a rev date (the only way
38 # to sort dates.)
39
40 =begin twiki
41
42 ---+ TWiki Package
43 rizwank 1.1 This package stores all TWiki subroutines that haven't been modularized
44 into any of the others.
45
46 =cut
47
48
49 package TWiki;
50
51 use strict;
52
53 use Time::Local; # Added for revDate2EpSecs
54 use Cwd qw( cwd ); # Added for getTWikiLibDir
55
56 require 5.005; # For regex objects and internationalisation
57
58 # ===========================
59 # TWiki config variables from TWiki.cfg:
60 use vars qw(
61 $defaultUserName $wikiHomeUrl $defaultUrlHost
62 $scriptUrlPath $pubUrlPath $pubDir $templateDir $dataDir $logDir
63 $siteWebTopicName $wikiToolName $securityFilter $uploadFilter
64 rizwank 1.1 $debugFilename $warningFilename $htpasswdFilename
65 $logFilename $remoteUserFilename $wikiUsersTopicname
66 $userListFilename $doMapUserToWikiName
67 $twikiWebname $mainWebname $mainTopicname $notifyTopicname
68 $wikiPrefsTopicname $webPrefsTopicname
69 $statisticsTopicname $statsTopViews $statsTopContrib $doDebugStatistics
70 $numberOfRevisions $editLockTime $scriptSuffix
71 $safeEnvPath $mailProgram $noSpamPadding $mimeTypesFilename
72 $doKeepRevIfEditLock $doGetScriptUrlFromCgi $doRemovePortNumber
73 $doRemoveImgInMailnotify $doRememberRemoteUser $doPluralToSingular
74 $doHidePasswdInRegistration $doSecureInclude
75 $doLogTopicView $doLogTopicEdit $doLogTopicSave $doLogRename
76 $doLogTopicAttach $doLogTopicUpload $doLogTopicRdiff
77 $doLogTopicChanges $doLogTopicSearch $doLogRegistration
78 $superAdminGroup $doSuperAdminGroup $OS
79 $disableAllPlugins $attachAsciiPath $displayTimeValues
80 $dispScriptUrlPath $dispViewPath
81 );
82
83 # Internationalisation (I18N) config from TWiki.cfg:
84 use vars qw(
85 rizwank 1.1 $useLocale $localeRegexes $siteLocale $siteCharsetOverride
86 $upperNational $lowerNational
87 );
88
89 # TWiki::Store config:
90 use vars qw(
91 $rcsDir $rcsArg $nullDev $endRcsCmd $storeTopicImpl $keywordMode
92 $storeImpl @storeSettings
93 );
94
95 # TWiki::Search config:
96 use vars qw(
97 $cmdQuote $lsCmd $egrepCmd $fgrepCmd
98 );
99
100 # ===========================
101 # Global variables
102
103 # Refactoring Note: these are split up by "site" globals and "request"
104 # globals so that the latter may latter be placed inside a Perl object
105 # instead of being globals as now.
106 rizwank 1.1
107 # ---------------------------
108 # Site-Wide Global Variables
109
110 # Misc. Globals
111 use vars qw(
112 @isoMonth @weekDay %userToWikiList %wikiToUserList $wikiversion
113 $TranslationToken %mon2num $viewScript $twikiLibDir $formatVersion
114 @publicWebList %regex
115 );
116
117 # Internationalisation (I18N) setup:
118 use vars qw(
119 $siteCharset $useUnicode $siteLang $siteFullLang $urlCharEncoding
120 );
121
122 # ---------------------------
123 # Per-Request "Global" Variables
124 use vars qw(
125 $webName $topicName $includingWebName $includingTopicName
126 $userName $wikiName $wikiUserName $urlHost
127 rizwank 1.1 $debugUserTime $debugSystemTime $script
128 $pageMode $readTopicPermissionFailed $cgiQuery $basicInitDone
129 );
130
131 # ===========================
132 # Exports
133
134 # The Render module needs to access a lot of configuration flags from
135 # TWiki.cfg, so we export them here. We also export the %regex hash
136 # and a few other useful constants.
137
138 use vars qw(@EXPORT_OK %EXPORT_TAGS @ISA);
139
140 BEGIN {
141 require Exporter;
142 @ISA = qw(Exporter);
143
144 %EXPORT_TAGS = (
145 renderflags => [qw($siteLang $securityFilter $twikiWebname $mainWebname
146 $mainTopicname $scriptSuffix $doPluralToSingular
147 $dispScriptUrlPath $dispViewPath
148 rizwank 1.1 )]
149 );
150
151 @EXPORT_OK = qw(%regex $TranslationToken);
152 Exporter::export_ok_tags('renderflags');
153 }
154
155 # ===========================
156 # TWiki version:
157 $wikiversion = '30 Oct 2004 $Rev: 1794 $';
158
159 # ===========================
160 # Key Global variables, required for writeDebug
161 # (new variables must be declared in "use vars qw(..)" above)
162 @isoMonth = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" );
163 @weekDay = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
164
165 {
166 my $count = 0;
167 %mon2num = map { $_ => $count++ } @isoMonth;
168 }
169 rizwank 1.1
170 # ===========================
171 # Read the configuration file at compile time in order to set locale
172 BEGIN {
173 do "TWiki.cfg";
174
175 # Do a dynamic 'use locale' for this module
176 if( $useLocale ) {
177 require locale;
178 import locale ();
179 }
180 }
181
182 sub writeDebug;
183 sub writeWarning;
184
185
186 # ===========================
187 # use TWiki and other modules
188 use TWiki::Prefs; # preferences
189 use TWiki::Search; # search engine
190 rizwank 1.1 use TWiki::Access; # access control
191 use TWiki::Meta; # Meta class - topic meta data
192 use TWiki::Store; # file I/O and rcs related functions
193 use TWiki::Attach; # file attachment functions
194 use TWiki::Form; # forms for topics
195 use TWiki::Func; # official TWiki functions for plugins
196 use TWiki::Plugins; # plugins handler #AS
197 use TWiki::Net; # SMTP, get URL
198 use TWiki::User;
199 use TWiki::Render;
200
201
202 # ===========================
203 # Other Global variables
204
205 # Token character that must not occur in any normal text - converted
206 # to a flag character if it ever does occur (very unlikely)
207 $TranslationToken= "\0"; # Null not allowed in charsets used with TWiki
208
209 # The following are also initialized in initialize, here for cases where
210 # initialize not called.
211 rizwank 1.1 $cgiQuery = 0;
212 @publicWebList = ();
213 $viewScript = "view";
214
215 $regex{linkProtocolPattern} = "(file|ftp|gopher|http|https|irc|news|nntp|telnet)";
216
217 # Header patterns based on '+++'. The '###' are reserved for numbered headers
218 $regex{headerPatternDa} = '^---+(\++|\#+)\s*(.+)\s*$'; # '---++ Header', '---## Header'
219 $regex{headerPatternSp} = '^\t(\++|\#+)\s*(.+)\s*$'; # ' ++ Header', ' + Header'
220 $regex{headerPatternHt} = '^<h([1-6])>\s*(.+?)\s*</h[1-6]>'; # '<h6>Header</h6>
221 $regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)'; # '---++!! Header' or '---++ Header %NOTOC% ^top'
222
223 $debugUserTime = 0;
224 $debugSystemTime = 0;
225
226 $formatVersion = "1.0";
227
228 $basicInitDone = 0; # basicInitialize not yet done
229
230 $pageMode = 'html'; # Default is to render as HTML
231
232 rizwank 1.1 =pod
233
234 ---++ writeWarning( $text )
235
236 Prints date, time, and contents $text to $warningFilename, typically
237 'warnings.txt'. Use for warnings and errors that may require admin
238 intervention. Not using Store::writeLog; log file is more of an audit/usage
239 file. Use this for defensive programming warnings (e.g. assertions).
240
241 =cut
242
243 sub writeWarning {
244 my( $text ) = @_;
245 if( $warningFilename ) {
246 my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime( time() );
247 my( $tmon) = $isoMonth[$mon];
248 $year = sprintf( "%.4u", $year + 1900 );
249 my $time = sprintf( "%.2u ${tmon} %.2u - %.2u:%.2u",
250 $mday, $year, $hour, $min );
251
252 if( open( FILE, ">>$warningFilename" ) ) {
253 rizwank 1.1 print FILE "$time $text\n";
254 close( FILE );
255 } else {
256 print STDERR "Couldn't write \"$text\" to $warningFilename: $!\n";
257 }
258 }
259 }
260
261 =pod
262
263 ---++ writeDebug( $text )
264
265 Prints date, time, and contents of $text to $debugFilename, typically
266 'debug.txt'. Use for debugging messages.
267
268 =cut
269
270 sub writeDebug {
271 my( $text ) = @_;
272
273 my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime( time() );
274 rizwank 1.1 my( $tmon) = $isoMonth[$mon];
275 $year = sprintf( "%.4u", $year + 1900 );
276 my $time = sprintf( "%.2u ${tmon} %.2u - %.2u:%.2u", $mday, $year, $hour, $min );
277
278 if( open( FILE, ">>$debugFilename" ) ) {
279 print FILE "$time $text\n";
280 close( FILE );
281 } else {
282 print STDERR "Couldn't write \"$text\" to $debugFilename: $!\n";
283 }
284 }
285
286 =pod
287
288 ---++ writeDebugTimes( $text )
289
290 Dumps user and system time spent, with deltas from last call, followed
291 by contents of $text, to debug log using writeDebug above. Use for
292 performance monitoring/debugging.
293
294 =cut
295 rizwank 1.1
296 sub writeDebugTimes
297 {
298 my( $text ) = @_;
299
300 if( ! $debugUserTime ) {
301 writeDebug( "=== sec (delta:) sec (delta:) sec function:" );
302 }
303 my( $puser, $psystem, $cuser, $csystem ) = times();
304 my $duser = $puser - $debugUserTime;
305 my $dsystem = $psystem - $debugSystemTime;
306 my $times = sprintf( "usr %1.2f (%1.2f), sys %1.2f (%1.2f), sum %1.2f",
307 $puser, $duser, $psystem, $dsystem, $puser+$psystem );
308 $debugUserTime = $puser;
309 $debugSystemTime = $psystem;
310
311 writeDebug( "==> $times, $text" );
312 }
313
314 =pod
315
316 rizwank 1.1 ---++ initialize( $pathInfo, $remoteUser, $topic, $url, $query )
317 Return value: ( $topicName, $webName, $scriptUrlPath, $userName, $dataDir )
318
319 Per-web initialization of all aspects of TWiki. Initializes the
320 Store, User, Access, and Prefs modules. Contains two plugin
321 initialization hooks: 'initialize1' to allow plugins to interact
322 for authentication, and 'initialize2' once the authenticated username
323 is available.
324
325 Also parses $theTopic to determine whether it's a URI, a "Web.Topic"
326 pair, a "Web." WebHome shorthand, or just a topic name. Note that
327 if $pathInfo is set, this overrides $theTopic.
328
329 =cut
330
331 sub initialize
332 {
333 my ( $thePathInfo, $theRemoteUser, $theTopic, $theUrl, $theQuery ) = @_;
334
335 if( not $basicInitDone ) {
336 basicInitialize();
337 rizwank 1.1 }
338
339 ##writeDebug( "\n---------------------------------" );
340
341 $cgiQuery = $theQuery;
342
343 # Initialise vars here rather than at start of module,
344 # so compatible with modPerl
345 @publicWebList = ();
346 &TWiki::Store::initialize();
347
348 &TWiki::User::initialize();
349
350 # Make %ENV safer for CGI
351 if( $safeEnvPath ) {
352 $ENV{'PATH'} = $safeEnvPath;
353 }
354 delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };
355
356 # initialize lib directory early because of later 'cd's
357 getTWikiLibDir();
358 rizwank 1.1
359 # initialize access control
360 &TWiki::Access::initializeAccess();
361 $readTopicPermissionFailed = ""; # Will be set to name(s) of topic(s) that can't be read
362
363 # initialize $webName and $topicName from URL
364 $topicName = "";
365 $webName = "";
366 if( $theTopic ) {
367 if(( $theTopic =~ /^$regex{linkProtocolPattern}\:\/\//o ) && ( $cgiQuery ) ) {
368 # redirect to URI
369 print $cgiQuery->redirect( $theTopic );
370 return; # should never return here
371 } elsif( $theTopic =~ /(.*)[\.\/](.*)/ ) {
372 # is "bin/script?topic=Webname.SomeTopic"
373 $webName = $1 || "";
374 $topicName = $2 || "";
375 # jump to WebHome if ""bin/script?topic=Webname."
376 $topicName = $mainTopicname if( $webName && ( ! $topicName ) );
377 } else {
378 # assume "bin/script/Webname?topic=SomeTopic"
379 rizwank 1.1 $topicName = $theTopic;
380 }
381 }
382
383 # Clean up PATH_INFO problems, e.g. Support.CobaltRaqInstall. A valid
384 # PATH_INFO is '/Main/WebHome', i.e. the text after the script name;
385 # invalid PATH_INFO is often a full path starting with '/cgi-bin/...'.
386 my $cgiScriptName = $ENV{'SCRIPT_NAME'} || "";
387 $thePathInfo =~ s!$cgiScriptName/!/!i;
388 ## writeDebug( "===== thePathInfo after cleanup = $thePathInfo" );
389
390 # Get the web and topic names from PATH_INFO
391 if( $thePathInfo =~ /\/(.*)[\.\/](.*)/ ) {
392 # is "bin/script/Webname/SomeTopic" or "bin/script/Webname/"
393 $webName = $1 || "" if( ! $webName );
394 $topicName = $2 || "" if( ! $topicName );
395 } elsif( $thePathInfo =~ /\/(.*)/ ) {
396 # is "bin/script/Webname" or "bin/script/"
397 $webName = $1 || "" if( ! $webName );
398 }
399 ( $topicName =~ /\.\./ ) && ( $topicName = $mainTopicname );
400 rizwank 1.1
401 # Refuse to work with character sets that allow TWiki syntax
402 # to be recognised within multi-byte characters. Only allow 'oops'
403 # page to be displayed (redirect causes this code to be re-executed).
404 if ( invalidSiteCharset() and $theUrl !~ m!$scriptUrlPath/oops! ) {
405 writeWarning "Cannot use this multi-byte encoding ('$siteCharset') as site character encoding";
406 writeWarning "Please set a different character encoding in the \$siteLocale setting in TWiki.cfg.";
407 my $url = &TWiki::getOopsUrl( $webName, $topicName, "oopsbadcharset" );
408 print $cgiQuery->redirect( $url );
409 return;
410 }
411
412 # Convert UTF-8 web and topic name from URL into site charset
413 # if necessary - no effect if URL is not in UTF-8
414 ( $webName, $topicName ) = convertUtf8URLtoSiteCharset ( $webName, $topicName );
415
416 # Filter out dangerous or unwanted characters
417 $topicName =~ s/$securityFilter//go;
418 $topicName =~ /(.*)/;
419 $topicName = $1 || $mainTopicname; # untaint variable
420 $webName =~ s/$securityFilter//go;
421 rizwank 1.1 $webName =~ /(.*)/;
422 $webName = $1 || $mainWebname; # untaint variable
423 $includingTopicName = $topicName;
424 $includingWebName = $webName;
425
426 # initialize $urlHost and $scriptUrlPath
427 if( ( $theUrl ) && ( $theUrl =~ m!^([^:]*://[^/]*)(.*)/.*$! ) && ( $2 ) ) {
428 if( $doGetScriptUrlFromCgi ) {
429 $scriptUrlPath = $2;
430 }
431 $urlHost = $1;
432 if( $doRemovePortNumber ) {
433 $urlHost =~ s/\:[0-9]+$//;
434 }
435 } else {
436 $urlHost = $defaultUrlHost;
437 }
438 # PTh 15 Jul 2001: Removed init of $scriptUrlPath based on $theUrl because
439 # $theUrl has incorrect URI after failed authentication
440
441 # initialize preferences, first part for site and web level
442 rizwank 1.1 &TWiki::Prefs::initializePrefs( $webName );
443
444 # initialize user name and user to WikiName list
445 userToWikiListInit();
446 if( !$disableAllPlugins ) {
447 # Early plugin initialization, allow plugins like SessionPlugin
448 # to set the user. This must be done before preferences are set,
449 # as we need to get user preferences
450 $userName = &TWiki::Plugins::initialize1( $topicName, $webName, $theRemoteUser, $theUrl, $thePathInfo );
451 }
452 $wikiName = userToWikiName( $userName, 1 ); # i.e. "JonDoe"
453 $wikiUserName = userToWikiName( $userName ); # i.e. "Main.JonDoe"
454
455 # initialize preferences, second part for user level
456 &TWiki::Prefs::initializeUserPrefs( $wikiUserName );
457
458 # some remaining init
459 $viewScript = "view";
460 if( ( $ENV{'SCRIPT_NAME'} ) && ( $ENV{'SCRIPT_NAME'} =~ /^.*\/viewauth$/ ) ) {
461 # Needed for TOC
462 $viewScript = "viewauth";
463 rizwank 1.1 }
464
465 TWiki::Render::initialize();
466
467 #AS
468 if( !$disableAllPlugins ) {
469 # Normal plugin initialization - userName is known and preferences available
470 &TWiki::Plugins::initialize2( $topicName, $webName, $userName );
471 }
472 #/AS
473
474 return ( $topicName, $webName, $scriptUrlPath, $userName, $dataDir );
475 }
476
477 =pod
478
479 ---++ basicInitialize()
480
481 Sets up POSIX locale and precompiled regexes - for use from scripts
482 that handle multiple webs (e.g. mailnotify) and need regexes or
483 isWebName/isWikiName to work before the per-web initialize() is called.
484 rizwank 1.1 Also called from initialize() if not necessary beforehand.
485
486 =cut
487
488 sub basicInitialize() {
489 # Set up locale for internationalisation and pre-compile regexes
490 setupLocale();
491 setupRegexes();
492
493 $basicInitDone = 1;
494 }
495
496 =pod
497
498 ---++ setupLocale()
499
500 Run-time locale setup - If $useLocale is set, this function parses $siteLocale
501 from TWiki.cfg and passes it to the POSIX::setLocale function to change TWiki's
502 operating environment.
503
504 mod_perl compatibility note: If TWiki is running under Apache, won't this play
505 rizwank 1.1 with the Apache process's locale settings too? What effects would this have?
506
507 Note that 'use locale' must be done in BEGIN block for regexes and sorting to
508 work properly, although regexes can still work without this in
509 'non-locale regexes' mode (see setupRegexes routine).
510
511 =cut
512
513 sub setupLocale {
514
515 $siteCharset = 'ISO-8859-1'; # Default values if locale mis-configured
516 $siteLang = 'en';
517 $siteFullLang = 'en-us';
518
519 if ( $useLocale ) {
520 if ( not defined $siteLocale or $siteLocale !~ /[a-z]/i ) {
521 writeWarning "Locale $siteLocale unset or has no alphabetic characters";
522 return;
523 }
524 # Extract the character set from locale and use in HTML templates
525 # and HTTP headers
526 rizwank 1.1 $siteLocale =~ m/\.([a-z0-9_-]+)$/i;
527 $siteCharset = $1 if defined $1;
528 $siteCharset =~ s/^utf8$/utf-8/i; # For convenience, avoid overrides
529 $siteCharset =~ s/^eucjp$/euc-jp/i;
530
531 # Override charset - used when locale charset not supported by Perl
532 # conversion modules
533 $siteCharset = $siteCharsetOverride || $siteCharset;
534 $siteCharset = lc $siteCharset;
535
536 # Extract the default site language - ignores '@euro' part of
537 # 'fr_BE@euro' type locales.
538 $siteLocale =~ m/^([a-z]+)_([a-z]+)/i;
539 $siteLang = (lc $1) if defined $1; # Not including country part
540 $siteFullLang = (lc "$1-$2" ) # Including country part
541 if defined $1 and defined $2;
542
543 # Set environment variables for grep
544 $ENV{'LC_CTYPE'}= $siteLocale;
545
546 # Load POSIX for I18N support
547 rizwank 1.1 require POSIX;
548 import POSIX qw( locale_h LC_CTYPE );
549
550 # Set new locale
551 my $locale = setlocale(&LC_CTYPE, $siteLocale);
552 ##writeDebug "New locale is $locale";
553 }
554 }
555
556 =pod
557
558 ---++ setupRegexes()
559
560 Set up pre-compiled regexes for use in rendering. All regexes with
561 unchanging variables in match should use the '/o' option, even if not in a
562 loop, to help mod_perl, where the same code can be executed many times
563 without recompilation.
564
565 =cut
566
567 sub setupRegexes {
568 rizwank 1.1
569 # Build up character class components for use in regexes.
570 # Depends on locale mode and Perl version, and finally on
571 # whether locale-based regexes are turned off.
572 if ( not $useLocale or $] < 5.006 or not $localeRegexes ) {
573 # No locales needed/working, or Perl 5.005_03 or lower, so just use
574 # any additional national characters defined in TWiki.cfg
575 $regex{upperAlpha} = "A-Z$upperNational";
576 $regex{lowerAlpha} = "a-z$lowerNational";
577 $regex{numeric} = '\d';
578 $regex{mixedAlpha} = "$regex{upperAlpha}$regex{lowerAlpha}";
579 } else {
580 # Perl 5.6 or higher with working locales
581 $regex{upperAlpha} = "[:upper:]";
582 $regex{lowerAlpha} = "[:lower:]";
583 $regex{numeric} = "[:digit:]";
584 $regex{mixedAlpha} = "[:alpha:]";
585 }
586 $regex{mixedAlphaNum} = "$regex{mixedAlpha}$regex{numeric}";
587 $regex{lowerAlphaNum} = "$regex{lowerAlpha}$regex{numeric}";
588
589 rizwank 1.1 # Compile regexes for efficiency and ease of use
590 # Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl
591 # book at http://regex.info/.
592
593 # TWiki concept regexes
594 $regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlpha}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/;
595 $regex{webNameRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/;
596 $regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/;
597 $regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/;
598 $regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/;
599
600 # Simplistic email regex, e.g. for WebNotify processing - no i18n
601 # characters allowed
602 $regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_]+\@[A-Za-z0-9\.\-]+)/;
603
604 # Filename regex, for attachments
605 $regex{filenameRegex} = qr/[$regex{mixedAlphaNum}\.]+/;
606
607 # Single-character alpha-based regexes
608 $regex{singleUpperAlphaRegex} = qr/[$regex{upperAlpha}]/;
609 $regex{singleLowerAlphaRegex} = qr/[$regex{lowerAlpha}]/;
610 rizwank 1.1 $regex{singleUpperAlphaNumRegex} = qr/[$regex{upperAlpha}$regex{numeric}]/;
611 $regex{singleMixedAlphaNumRegex} = qr/[$regex{upperAlpha}$regex{lowerAlpha}$regex{numeric}]/;
612
613 $regex{singleMixedNonAlphaRegex} = qr/[^$regex{upperAlpha}$regex{lowerAlpha}]/;
614 $regex{singleMixedNonAlphaNumRegex} = qr/[^$regex{upperAlpha}$regex{lowerAlpha}$regex{numeric}]/;
615
616 # Multi-character alpha-based regexes
617 $regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/;
618
619 # Character encoding regexes
620
621 # 7-bit ASCII only
622 $regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/;
623
624 # Regex to match only a valid UTF-8 character, taking care to avoid
625 # security holes due to overlong encodings by excluding the relevant
626 # gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode
627 # Encodings section. Tested against Markus Kuhn's UTF-8 test file
628 # at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
629 $regex{validUtf8CharRegex} = qr{
630 # Single byte - ASCII
631 rizwank 1.1 [\x00-\x7F]
632 |
633
634 # 2 bytes
635 [\xC2-\xDF][\x80-\xBF]
636 |
637
638 # 3 bytes
639
640 # Avoid illegal codepoints - negative lookahead
641 (?!\xEF\xBF[\xBE\xBF])
642
643 # Match valid codepoints
644 (?:
645 ([\xE0][\xA0-\xBF])|
646 ([\xE1-\xEC\xEE-\xEF][\x80-\xBF])|
647 ([\xED][\x80-\x9F])
648 )
649 [\x80-\xBF]
650 |
651
652 rizwank 1.1 # 4 bytes
653 (?:
654 ([\xF0][\x90-\xBF])|
655 ([\xF1-\xF3][\x80-\xBF])|
656 ([\xF4][\x80-\x8F])
657 )
658 [\x80-\xBF][\x80-\xBF]
659 }x;
660
661 $regex{validUtf8StringRegex} = qr/^ (?: $regex{validUtf8CharRegex} )+ $/x;
662
663 }
664
665 =pod
666
667 ---++ invalidSiteCharset()
668 Return value: boolean $isCharsetInvalid
669
670 Check for unusable multi-byte encodings as site character set
671 - anything that enables a single ASCII character such as '[' to be
672 matched within a multi-byte character cannot be used for TWiki.
673 rizwank 1.1
674 =cut
675
676 sub invalidSiteCharset {
677 # FIXME: match other problematic multi-byte character sets
678 return ( $siteCharset =~ /^(?:iso-?2022-?|hz-?|gb2312|gbk|gb18030|.*big5|.*shift_?jis|ms.kanji|johab|uhc)/i );
679 }
680
681
682 =pod
683
684 ---++ convertUtf8URLtoSiteCharset( $webName, $topicName )
685 Return value: ( string $convertedWebName, string $convertedTopicName)
686 Auto-detect UTF-8 vs. site charset in URL, and convert UTF-8 into site charset.
687
688 TODO: remove dependence on webname and topicname, i.e. generic encoding
689 subroutine.
690
691 =cut
692
693 sub convertUtf8URLtoSiteCharset {
694 rizwank 1.1 my ( $webName, $topicName ) = @_;
695
696 ##writeDebug "URL web.topic is $webName.$topicName";
697 my $fullTopicName = "$webName.$topicName";
698 my $charEncoding;
699
700 # Detect character encoding of the full topic name from URL
701 if ( $fullTopicName =~ $regex{validAsciiStringRegex} ) {
702 $urlCharEncoding = 'ASCII';
703 } elsif ( $fullTopicName =~ $regex{validUtf8StringRegex} ) {
704 $urlCharEncoding = 'UTF-8';
705
706 # Convert into ISO-8859-1 if it is the site charset
707 if ( $siteCharset =~ /^iso-?8859-?1$/i ) {
708 # ISO-8859-1 maps onto first 256 codepoints of Unicode
709 # (conversion from 'perldoc perluniintro')
710 $fullTopicName =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) /
711 chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F )
712 /egx;
713 } elsif ( $siteCharset eq "utf-8" ) {
714 # Convert into internal Unicode characters if on Perl 5.8 or higher.
715 rizwank 1.1 if( $] >= 5.008 ) {
716 require Encode; # Perl 5.8 or higher only
717 $fullTopicName = Encode::decode("utf8", $fullTopicName); # 'decode' into UTF-8
718 } else {
719 writeWarning "UTF-8 not supported on Perl $] - use Perl 5.8 or higher.";
720 }
721 writeWarning "UTF-8 not yet supported as site charset - TWiki is likely to have problems";
722 } else {
723 # Convert from UTF-8 into some other site charset
724 writeDebug "Converting from UTF-8 to $siteCharset";
725
726 # Use conversion modules depending on Perl version
727 if( $] >= 5.008 ) {
728 require Encode; # Perl 5.8 or higher only
729 import Encode qw(:fallbacks);
730 # Map $siteCharset into real encoding name
731 $charEncoding = Encode::resolve_alias( $siteCharset );
732 if( not $charEncoding ) {
733 writeWarning "Conversion to \$siteCharset '$siteCharset' not supported, or name not recognised - check 'perldoc Encode::Supported'";
734 } else {
735 ##writeDebug "Converting with Encode, valid 'to' encoding is '$charEncoding'";
736 rizwank 1.1 # Convert text using Encode:
737 # - first, convert from UTF8 bytes into internal (UTF-8) characters
738 $fullTopicName = Encode::decode("utf8", $fullTopicName);
739 # - then convert into site charset from internal UTF-8,
740 # inserting \x{NNNN} for characters that can't be converted
741 $fullTopicName = Encode::encode( $charEncoding, $fullTopicName, &FB_PERLQQ() );
742 ##writeDebug "Encode result is $fullTopicName";
743 }
744
745 } else {
746 require Unicode::MapUTF8; # Pre-5.8 Perl versions
747 $charEncoding = $siteCharset;
748 if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) {
749 writeWarning "Conversion to \$siteCharset '$siteCharset' not supported, or name not recognised - check 'perldoc Unicode::MapUTF8'";
750 } else {
751 # Convert text
752 ##writeDebug "Converting with Unicode::MapUTF8, valid encoding is '$charEncoding'";
753 $fullTopicName = Unicode::MapUTF8::from_utf8({
754 -string => $fullTopicName,
755 -charset => $charEncoding });
756 # FIXME: Check for failed conversion?
757 rizwank 1.1 }
758 }
759 }
760 ($webName, $topicName) = split /\./, $fullTopicName;
761
762 } else {
763 # Non-ASCII and non-UTF-8 - assume in site character set,
764 # no conversion required
765 $urlCharEncoding = 'Native';
766 $charEncoding = $siteCharset;
767 }
768 ##writeDebug "Final web and topic are $webName $topicName ($urlCharEncoding URL -> $siteCharset)";
769
770 return ($webName, $topicName);
771 }
772
773 =pod
774
775 ---++ writeHeader ( $query )
776
777 Simple header setup for most scripts. Calls writeHeaderFull, assuming
778 rizwank 1.1 'basic' type and 'text/html' content-type.
779
780 =cut
781
782 sub writeHeader
783 {
784 my( $query ) = @_;
785
786 # FIXME: Pass real content-length to make persistent connections work
787 # in HTTP/1.1 (performance improvement for browsers and servers).
788 # Requires significant but easy changes in various places.
789
790 # Just write a basic content-type header for text/html
791 writeHeaderFull( $query, 'basic', 'text/html', 0);
792 }
793
794
795 =pod
796
797 ---++ writeHeaderFull( $query, $pageType, $contentType, $contentLength )
798
799 rizwank 1.1 Builds and outputs HTTP headers. $pageType should (currently) be either
800 "edit" or "basic". $query is the object from the CGI module, not the actual
801 query string.
802
803 "edit" will cause headers to be generated that force caching for 24 hours, to
804 prevent Codev.BackFromPreviewLosesText bug, which caused data loss with IE5 and
805 IE6.
806
807 "basic" will cause only the Content-Type header to be set (from the
808 parameter), plus any headers set by plugins. Hopefully, further types will
809 be used to improve cacheability for other pages in future.
810
811 Implements the post-Dec2001 release plugin API, which requires the
812 writeHeaderHandler in plugin to return a string of HTTP headers, CR/LF
813 delimited. Filters out headers that the core code needs to generate for
814 whatever reason, and any illegal headers.
815
816 =cut
817
818 sub writeHeaderFull
819 {
820 rizwank 1.1 my( $query, $pageType, $contentType, $contentLength ) = @_;
821
822 # Handle Edit pages - future versions will extend to caching
823 # of other types of page, with expiry time driven by page type.
824 my( $pluginHeaders, $coreHeaders );
825
826
827 $contentType .= "; charset=$siteCharset";
828
829 if ($pageType eq 'edit') {
830 # Get time now in HTTP header format
831 my $lastModifiedString = formatTime(time, '\$http', "gmtime");
832
833 # Expiry time is set high to avoid any data loss. Each instance of
834 # Edit page has a unique URL with time-string suffix (fix for
835 # RefreshEditPage), so this long expiry time simply means that the
836 # browser Back button always works. The next Edit on this page
837 # will use another URL and therefore won't use any cached
838 # version of this Edit page.
839 my $expireHours = 24;
840 my $expireSeconds = $expireHours * 60 * 60;
841 rizwank 1.1
842 # Set content length, to enable HTTP/1.1 persistent connections
843 # (aka HTTP keepalive), and cache control headers, to ensure edit page
844 # is cached until required expiry time.
845 $coreHeaders = $query->header(
846 -content_type => $contentType,
847 -content_length => $contentLength,
848 -last_modified => $lastModifiedString,
849 -expires => "+${expireHours}h",
850 -cache_control => "max-age=$expireSeconds",
851 );
852 } elsif ($pageType eq 'basic') {
853 $coreHeaders = $query->header(
854 -content_type => $contentType,
855 );
856 } else {
857 writeWarning( "===== invalid page type in TWiki.pm, writeHeaderFull(): $pageType" );
858 }
859
860 # Delete extra CR/LF to allow suffixing more headers
861 $coreHeaders =~ s/\r\n\r\n$/\r\n/s;
862 rizwank 1.1 ##writeDebug( "===== After trim, Headers are:\n$coreHeaders" );
863
864 # Wiki Plugin Hook - get additional headers from plugin
865 $pluginHeaders = &TWiki::Plugins::writeHeaderHandler( $query ) || '';
866
867 # Delete any trailing blank line
868 $pluginHeaders =~ s/\r\n\r\n$/\r\n/s;
869
870 # Add headers supplied by plugin, omitting any already in core headers
871 my $finalHeaders = $coreHeaders;
872 if( $pluginHeaders ) {
873 # Build hash of all core header names, lower-cased
874 my ($headerLine, $headerName, %coreHeaderSeen);
875 for $headerLine (split /\r\n/, $coreHeaders) {
876 $headerLine =~ m/^([^ ]+): /i; # Get header name
877 $headerName = lc($1);
878 ##writeDebug("==== core header name $headerName");
879 $coreHeaderSeen{$headerName}++;
880 }
881 # Append plugin headers if legal and not seen in core headers
882 for $headerLine (split /\r\n/, $pluginHeaders) {
883 rizwank 1.1 $headerLine =~ m/^([^ ]+): /i; # Get header name
884 $headerName = lc($1);
885 if ( $headerName =~ m/[\-a-z]+/io ) { # Skip bad headers
886 ##writeDebug("==== plugin header name $headerName");
887 ##writeDebug("Saw $headerName already ") if $coreHeaderSeen{$headerName};
888 $finalHeaders .= $headerLine . "\r\n"
889 unless $coreHeaderSeen{$headerName};
890 }
891
892 }
893 }
894 $finalHeaders .= "\r\n" if ( $finalHeaders);
895
896 ##writeDebug( "===== Final Headers are:\n$finalHeaders" );
897 print $finalHeaders;
898
899 }
900
901 =pod
902
903 ---++ setPageMode( $mode )
904 rizwank 1.1
905 Set page rendering mode:
906 * 'rss' - encode 8-bit characters as XML entities
907 * 'html' - (default) no encoding of 8-bit characters
908
909 =cut
910
911 sub setPageMode
912 {
913 $pageMode = shift;
914 }
915
916 =pod
917
918 ---++ getPageMode()
919 Return value: string $mode
920
921 Returns current page mode, 'html' unless set via setPageMode
922 FIXME: This function is currently unused. Remove on some non
923 documentation-only commit, unless use is planned in future.
924
925 rizwank 1.1 =cut
926
927 sub getPageMode
928 {
929 return $pageMode;
930 }
931
932 =pod
933
934 ---++ getCgiQuery()
935 Retrun value: string $query
936
937 Returns the CGI query portion (i.e. the bit after the '?') of the
938 current request.
939
940 =cut
941
942 sub getCgiQuery
943 {
944 return $cgiQuery;
945 }
946 rizwank 1.1
947 =pod
948
949 ---++ redirect( $query, $url )
950
951 Redirects the request to $url, via the CGI module object $query unless
952 overridden by a plugin. Note that this is currently only called by
953 Func::redirectCgiQuery() at the request of a plugin! All of the redirects
954 done internally by TWiki are not overridable.
955
956 =cut
957
958 sub redirect
959 {
960 my( $query, $url ) = @_;
961 if( ! &TWiki::Plugins::redirectCgiQueryHandler( $query, $url ) ) {
962 print $query->redirect( $url );
963 }
964 }
965
966
967 rizwank 1.1 =pod
968
969 ---++ getEmailNotifyList( $webName, $topicName )
970 Return value: @emailNotifyList
971
972 Get email list from WebNotify page - this now handles entries of the form:
973 * Main.UserName
974 * UserName
975 * Main.GroupName
976 * GroupName
977 The 'UserName' format (i.e. no Main webname) is supported in any web, but
978 is not recommended since this may make future data conversions more
979 complicated, especially if used outside the Main web. %<nop>MAINWEB% is OK
980 instead of 'Main'. The user's email address(es) are fetched from their
981 user topic (home page) as long as they are listed in the '* Email:
982 fred@example.com' format. Nested groups are supported.
983
984 =cut
985
986 sub getEmailNotifyList
987 {
988 rizwank 1.1 my( $web, $topicname ) = @_;
989
990 $topicname = $notifyTopicname unless $topicname;
991 return() unless &TWiki::Store::topicExists( $web, $topicname );
992
993 # Allow %MAINWEB% as well as 'Main' in front of users/groups -
994 # non-capturing regex.
995 my $mainWebPattern = qr/(?:$mainWebname|%MAINWEB%)/;
996
997 my @list = ();
998 my %seen; # Incremented when email address is seen
999 foreach ( split ( /\n/, TWiki::Store::readWebTopic( $web, $topicname ) ) ) {
1000 if ( /^\s+\*\s(?:$mainWebPattern\.)?($regex{wikiWordRegex})\s+\-\s+($regex{emailAddrRegex})/o ) {
1001 # Got full form: * Main.WikiName - email@domain
1002 # (the 'Main.' part is optional, non-capturing)
1003 if ( $1 ne 'TWikiGuest' ) {
1004 # Add email address to list if non-guest and non-duplicate
1005 push (@list, $2) unless $seen{$1}++;
1006 }
1007 } elsif ( /^\s+\*\s(?:$mainWebPattern\.)?($regex{wikiWordRegex})\s*$/o ) {
1008 # Got short form: * Main.WikiName
1009 rizwank 1.1 # (the 'Main.' part is optional, non-capturing)
1010 my $userWikiName = $1;
1011 foreach ( getEmailOfUser($userWikiName) ) {
1012 # Add email address to list if it's not a duplicate
1013 push (@list, $_) unless $seen{$_}++;
1014 }
1015 }
1016 }
1017 ##writeDebug "list of emails: @list";
1018 return( @list);
1019 }
1020
1021 =pod
1022
1023 ---++ getEmailOfUser( $wikiName )
1024 Return value: ( $userEmail ) or @groupEmailList
1025
1026 Get e-mail address for a given WikiName from the user's home page, or
1027 list of e-mail addresses for a group. Nested groups are supported.
1028 $wikiName must contain _only_ the WikiName; do *not* pass names of the
1029 form "Main.JohnSmith".
1030 rizwank 1.1
1031 =cut
1032
1033 sub getEmailOfUser
1034 {
1035 my( $wikiName ) = @_; # WikiName without web prefix
1036
1037 my @list = ();
1038 # Ignore guest entry and non-existent pages
1039 if ( $wikiName ne "TWikiGuest" &&
1040 TWiki::Store::topicExists( $mainWebname, $wikiName ) ) {
1041 if ( $wikiName =~ /Group$/ ) {
1042 # Page is for a group, get all users in group
1043 ##writeDebug "using group: $mainWebname . $wikiName";
1044 my @userList = TWiki::Access::getUsersOfGroup( $wikiName );
1045 foreach my $user ( @userList ) {
1046 $user =~ s/^.*\.//; # Get rid of 'Main.' part.
1047 foreach my $email ( getEmailOfUser($user) ) {
1048 push @list, $email;
1049 }
1050 }
1051 rizwank 1.1 } else {
1052 # Page is for a user
1053 ##writeDebug "reading home page: $mainWebname . $wikiName";
1054 foreach ( split ( /\n/, &TWiki::Store::readWebTopic(
1055 $mainWebname, $wikiName ) ) ) {
1056 if (/^\s\*\sEmail:\s+([\w\-\.\+]+\@[\w\-\.\+]+)/) {
1057 # Add email address to list
1058 push @list, $1;
1059 }
1060 }
1061 }
1062 }
1063 return (@list);
1064 }
1065
1066 =pod
1067
1068 ---++ initializeRemoteUser( $remoteUser )
1069 Return value: $remoteUser
1070
1071 Acts as a filter for $remoteUser. If set, $remoteUser is filtered for
1072 rizwank 1.1 insecure characters and untainted.
1073
1074 If $doRememberRemoteUser and $remoteUser are both set, it also caches
1075 $remoteUser as belonging to the IP address of the current request.
1076
1077 If $doRememberRemoteUser is set and $remoteUser is not, then it sets
1078 $remoteUser to the last authenticated user to make a request with the
1079 current request's IP address, or $defaultUserName if no cached name
1080 is available.
1081
1082 If neither are set, then it sets $remoteUser to $defaultUserName.
1083
1084 =cut
1085
1086 sub initializeRemoteUser
1087 {
1088 my( $theRemoteUser ) = @_;
1089
1090 my $remoteUser = $theRemoteUser || $defaultUserName;
1091 $remoteUser =~ s/$securityFilter//go;
1092 $remoteUser =~ /(.*)/;
1093 rizwank 1.1 $remoteUser = $1; # untaint variable
1094
1095 my $remoteAddr = $ENV{'REMOTE_ADDR'} || "";
1096
1097 if( $ENV{'REDIRECT_STATUS'} && $ENV{'REDIRECT_STATUS'} eq '401' ) {
1098 # bail out if authentication failed
1099 $remoteAddr = "";
1100 }
1101
1102 if( ( ! $doRememberRemoteUser ) || ( ! $remoteAddr ) ) {
1103 # do not remember IP address
1104 return $remoteUser;
1105 }
1106
1107 my $text = &TWiki::Store::readFile( $remoteUserFilename );
1108 # Assume no I18N characters in userids, as for email addresses
1109 # FIXME: Needs fixing for IPv6?
1110 my %AddrToName = map { split( /\|/, $_ ) }
1111 grep { /^[0-9\.]+\|[A-Za-z0-9]+\|$/ }
1112 split( /\n/, $text );
1113
1114 rizwank 1.1 my $rememberedUser = "";
1115 if( exists( $AddrToName{ $remoteAddr } ) ) {
1116 $rememberedUser = $AddrToName{ $remoteAddr };
1117 }
1118
1119 if( $theRemoteUser ) {
1120 if( $theRemoteUser ne $rememberedUser ) {
1121 $AddrToName{ $remoteAddr } = $theRemoteUser;
1122 # create file as "$remoteAddr|$theRemoteUser|" lines
1123 $text = "# This is a generated file, do not modify.\n";
1124 foreach my $usrAddr ( sort keys %AddrToName ) {
1125 my $usrName = $AddrToName{ $usrAddr };
1126 # keep $userName unique
1127 if( ( $usrName ne $theRemoteUser )
1128 || ( $usrAddr eq $remoteAddr ) ) {
1129 $text .= "$usrAddr|$usrName|\n";
1130 }
1131 }
1132 &TWiki::Store::saveFile( $remoteUserFilename, $text );
1133 }
1134 } else {
1135 rizwank 1.1 # get user name from AddrToName table
1136 $remoteUser = $rememberedUser || $defaultUserName;
1137 }
1138
1139 return $remoteUser;
1140 }
1141
1142 =pod
1143
1144 ---++ userToWikiListInit()
1145
1146 Build hashes to translate in both directions between username (e.g. jsmith)
1147 and WikiName (e.g. JaneSmith). Only used for sites where authentication is
1148 managed by external Apache configuration, instead of via TWiki's .htpasswd
1149 mechanism.
1150
1151 =cut
1152
1153 sub userToWikiListInit
1154 {
1155 %userToWikiList = ();
1156 rizwank 1.1 %wikiToUserList = ();
1157 my @list = ();
1158 if( $doMapUserToWikiName ) {
1159 @list = split( /\n/, TWiki::Store::readFile( $userListFilename ) );
1160 } else {
1161 # fix for Codev.SecurityAlertGainAdminRightWithTWikiUsersMapping
1162 # for .htpasswd authenticated sites ignore user list, but map only guest to TWikiGuest
1163 @list = ( "\t* TWikiGuest - guest - " ); # CODE_SMELL on localization
1164 }
1165
1166 # Get all entries with two '-' characters on same line, i.e.
1167 # 'WikiName - userid - date created'
1168 @list = grep { /^\s*\* $regex{wikiWordRegex}\s*-\s*[^\-]*-/o } @list;
1169 my $wUser;
1170 my $lUser;
1171 foreach( @list ) {
1172 # Get the WikiName and userid, and build hashes in both directions
1173 if( ( /^\s*\* ($regex{wikiWordRegex})\s*\-\s*([^\s]*).*/o ) && $2 ) {
1174 $wUser = $1; # WikiName
1175 $lUser = $2; # userid
1176 $lUser =~ s/$securityFilter//go; # FIXME: Should filter in for security...
1177 rizwank 1.1 $userToWikiList{ $lUser } = $wUser;
1178 $wikiToUserList{ $wUser } = $lUser;
1179 }
1180 }
1181 }
1182
1183 =pod
1184
1185 ---++ userToWikiName( $loginUser, $dontAddWeb )
1186 Return value: $wikiName
1187
1188 Translates intranet username (e.g. jsmith) to WikiName (e.g. JaneSmith)
1189 userToWikiListInit must be called before this function is used.
1190
1191 Unless $dontAddWeb is set, "Main." is prepended to the returned WikiName.
1192
1193 if you give an invalid username, we just return that (no appending Main. blindy)
1194
1195 SMELL: the userToWikiList cache should really contain the WebName so its possible
1196 to have userTopics in more than just the MainWeb (what if you move a user topic?)
1197
1198 rizwank 1.1 =cut
1199
1200 sub userToWikiName
1201 {
1202 my( $loginUser, $dontAddWeb ) = @_;
1203
1204 if( !$loginUser ) {
1205 return "";
1206 }
1207
1208 $loginUser =~ s/$securityFilter//go;
1209 my $wUser = $userToWikiList{ $loginUser } || $loginUser;
1210 if( $dontAddWeb ) {
1211 return $wUser;
1212 }
1213 return "$mainWebname.$wUser";
1214 }
1215
1216 =pod
1217
1218 ---++ wikiToUserName( $wikiName )
1219 rizwank 1.1 Return value: $loginUser
1220
1221 Translates WikiName (e.g. JaneSmith) to an intranet username (e.g. jsmith)
1222 userToWikiListInit must be called before this function is used.
1223
1224 =cut
1225
1226 sub wikiToUserName
1227 {
1228 my( $wikiUser ) = @_;
1229 $wikiUser =~ s/^.*\.//g;
1230 my $userName = $wikiToUserList{"$wikiUser"} || $wikiUser;
1231 ##writeDebug( "TWiki::wikiToUserName: $wikiUser->$userName" );
1232 return $userName;
1233 }
1234
1235 =pod
1236
1237 ---++ isGuest()
1238
1239 Returns whether the current user is TWikiGuest or equivalent.
1240 rizwank 1.1
1241 =cut
1242
1243 sub isGuest
1244 {
1245 return ( $userName eq $defaultUserName );
1246 }
1247
1248 # =========================
1249 =pod
1250
1251 ---++ sub getWikiUserTopic ()
1252
1253 Not yet documented.
1254
1255 =cut
1256
1257 sub getWikiUserTopic
1258 {
1259 # Topic without Web name
1260 return $wikiName;
1261 rizwank 1.1 }
1262
1263 # =========================
1264 # Check for a valid WikiWord or WikiName
1265 =pod
1266
1267 ---++ sub isWikiName ( $name )
1268
1269 Not yet documented.
1270 CODE_SMELL - this should be called isWikiWord
1271
1272 =cut
1273
1274 sub isWikiName
1275 {
1276 my( $name ) = @_;
1277
1278 $name ||= ""; # Default value if undef
1279 return ( $name =~ m/^$regex{wikiWordRegex}$/o )
1280 }
1281
1282 rizwank 1.1 # =========================
1283 # Check for a valid ABBREV (acronym)
1284 =pod
1285
1286 ---++ sub isAbbrev ( $name )
1287
1288 Not yet documented.
1289
1290 =cut
1291
1292 sub isAbbrev
1293 {
1294 my( $name ) = @_;
1295
1296 $name ||= ""; # Default value if undef
1297 return ( $name =~ m/^$regex{abbrevRegex}$/o )
1298 }
1299
1300 # =========================
1301 # Check for a valid web name
1302 =pod
1303 rizwank 1.1
1304 ---++ sub isWebName ( $name )
1305
1306 Not yet documented.
1307
1308 =cut
1309
1310 sub isWebName
1311 {
1312 my( $name ) = @_;
1313
1314 $name ||= ""; # Default value if undef
1315 return ( $name =~ m/^$regex{webNameRegex}$/o )
1316 }
1317
1318 # =========================
1319 =pod
1320
1321 ---++ sub readOnlyMirrorWeb ( $theWeb )
1322
1323 Not yet documented.
1324 rizwank 1.1
1325 =cut
1326
1327 sub readOnlyMirrorWeb
1328 {
1329 my( $theWeb ) = @_;
1330
1331 my @mirrorInfo = ( "", "", "", "" );
1332 if( $siteWebTopicName ) {
1333 my $mirrorSiteName = &TWiki::Prefs::getPreferencesValue( "MIRRORSITENAME", $theWeb );
1334 if( $mirrorSiteName && $mirrorSiteName ne $siteWebTopicName ) {
1335 my $mirrorViewURL = &TWiki::Prefs::getPreferencesValue( "MIRRORVIEWURL", $theWeb );
1336 my $mirrorLink = &TWiki::Store::readTemplate( "mirrorlink" );
1337 $mirrorLink =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
1338 $mirrorLink =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
1339 $mirrorLink =~ s/\s*$//g;
1340 my $mirrorNote = &TWiki::Store::readTemplate( "mirrornote" );
1341 $mirrorNote =~ s/%MIRRORSITENAME%/$mirrorSiteName/g;
1342 $mirrorNote =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g;
1343 $mirrorNote = TWiki::Render::getRenderedVersion( $mirrorNote, $theWeb );
1344 $mirrorNote =~ s/\s*$//g;
1345 rizwank 1.1 @mirrorInfo = ( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote );
1346 }
1347 }
1348 return @mirrorInfo;
1349 }
1350
1351
1352 # =========================
1353 =pod
1354
1355 ---++ sub getDataDir ()
1356
1357 Not yet documented.
1358
1359 =cut
1360
1361 sub getDataDir
1362 {
1363 return $dataDir;
1364 }
1365
1366 rizwank 1.1 # =========================
1367 =pod
1368
1369 ---++ sub getPubDir ()
1370
1371 Not yet documented.
1372
1373 =cut
1374
1375 sub getPubDir
1376 {
1377 return $pubDir;
1378 }
1379
1380 # =========================
1381 =pod
1382
1383 ---++ sub getPubUrlPath ()
1384
1385 Not yet documented.
1386
1387 rizwank 1.1 =cut
1388
1389 sub getPubUrlPath
1390 {
1391 return $pubUrlPath;
1392 }
1393
1394 =pod
1395
1396 ---++ getTWikiLibDir()
1397
1398 If necessary, finds the full path of the directory containing TWiki.pm,
1399 and sets the variable $twikiLibDir so that this process is only performed
1400 once per invocation. (mod_perl safe: lib dir doesn't change.)
1401
1402 =cut
1403
1404 sub getTWikiLibDir
1405 {
1406 if( $twikiLibDir ) {
1407 return $twikiLibDir;
1408 rizwank 1.1 }
1409
1410 # FIXME: Should just use $INC{"TWiki.pm"} to get path used to load this
1411 # module.
1412 my $dir = "";
1413 foreach $dir ( @INC ) {
1414 if( -e "$dir/TWiki.pm" ) {
1415 $twikiLibDir = $dir;
1416 last;
1417 }
1418 }
1419
1420 # fix relative path
1421 if( $twikiLibDir =~ /^\./ ) {
1422 my $curr = cwd();
1423 $twikiLibDir = "$curr/$twikiLibDir/";
1424 # normalize "/../" and "/./"
1425 while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) {};
1426 $twikiLibDir =~ s|([\\/])\.[\\/]|$1|g;
1427 }
1428 $twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/"
1429 rizwank 1.1 $twikiLibDir =~ s|[\\/]$||; # cut trailing "/"
1430
1431 return $twikiLibDir;
1432 }
1433
1434 # =========================
1435 =pod
1436
1437 ---++ sub revDate2EpSecs ()
1438
1439 Not yet documented.
1440
1441 =cut
1442
1443 sub revDate2EpSecs
1444 # Convert RCS revision date/time to seconds since epoch, for easier sorting
1445 {
1446 my( $date ) = @_;
1447 # NOTE: This routine *will break* if input is not one of below formats!
1448
1449 # FIXME - why aren't ifs around pattern match rather than $5 etc
1450 rizwank 1.1 # try "31 Dec 2001 - 23:59" (TWiki date)
1451 if ($date =~ /([0-9]+)\s+([A-Za-z]+)\s+([0-9]+)[\s\-]+([0-9]+)\:([0-9]+)/) {
1452 my $year = $3;
1453 $year -= 1900 if( $year > 1900 );
1454 return timegm( 0, $5, $4, $1, $mon2num{$2}, $year );
1455 }
1456
1457 # try "2001/12/31 23:59:59" or "2001.12.31.23.59.59" (RCS date)
1458 if ($date =~ /([0-9]+)[\.\/\-]([0-9]+)[\.\/\-]([0-9]+)[\.\s\-]+([0-9]+)[\.\:]([0-9]+)[\.\:]([0-9]+)/) {
1459 my $year = $1;
1460 $year -= 1900 if( $year > 1900 );
1461 return timegm( $6, $5, $4, $3, $2-1, $year );
1462 }
1463
1464 # try "2001/12/31 23:59" or "2001.12.31.23.59" (RCS short date)
1465 if ($date =~ /([0-9]+)[\.\/\-]([0-9]+)[\.\/\-]([0-9]+)[\.\s\-]+([0-9]+)[\.\:]([0-9]+)/) {
1466 my $year = $1;
1467 $year -= 1900 if( $year > 1900 );
1468 return timegm( 0, $5, $4, $3, $2-1, $year );
1469 }
1470
1471 rizwank 1.1 # try "2001-12-31T23:59:59Z" or "2001-12-31T23:59:59+01:00" (ISO date)
1472 # FIXME: Calc local to zulu time "2001-12-31T23:59:59+01:00"
1473 if ($date =~ /([0-9]+)\-([0-9]+)\-([0-9]+)T([0-9]+)\:([0-9]+)\:([0-9]+)/ ) {
1474 my $year = $1;
1475 $year -= 1900 if( $year > 1900 );
1476 return timegm( $6, $5, $4, $3, $2-1, $year );
1477 }
1478
1479 # try "2001-12-31T23:59Z" or "2001-12-31T23:59+01:00" (ISO short date)
1480 # FIXME: Calc local to zulu time "2001-12-31T23:59+01:00"
1481 if ($date =~ /([0-9]+)\-([0-9]+)\-([0-9]+)T([0-9]+)\:([0-9]+)/ ) {
1482 my $year = $1;
1483 $year -= 1900 if( $year > 1900 );
1484 return timegm( 0, $5, $4, $3, $2-1, $year );
1485 }
1486
1487 # give up, return start of epoch (01 Jan 1970 GMT)
1488 return 0;
1489 }
1490
1491 # =========================
1492 rizwank 1.1 =pod
1493
1494 ---++ sub getSessionValue ()
1495
1496 Not yet documented.
1497
1498 =cut
1499
1500 sub getSessionValue
1501 {
1502 # my( $key ) = @_;
1503 return &TWiki::Plugins::getSessionValueHandler( @_ );
1504 }
1505
1506 # =========================
1507 =pod
1508
1509 ---++ sub setSessionValue ()
1510
1511 Not yet documented.
1512
1513 rizwank 1.1 =cut
1514
1515 sub setSessionValue
1516 {
1517 # my( $key, $value ) = @_;
1518 return &TWiki::Plugins::setSessionValueHandler( @_ );
1519 }
1520
1521 # =========================
1522 =pod
1523
1524 ---++ sub getSkin ()
1525
1526 Not yet documented.
1527
1528 =cut
1529
1530 sub getSkin
1531 {
1532 my $skin = "";
1533 $skin = $cgiQuery->param( 'skin' ) if( $cgiQuery );
1534 rizwank 1.1 $skin = &TWiki::Prefs::getPreferencesValue( "SKIN" ) unless( $skin );
1535 return $skin;
1536 }
1537
1538 # =========================
1539 =pod
1540
1541 ---++ sub getViewUrl ( $web, $topic )
1542
1543 Returns a fully-qualified URL to the specified topic, which must be normalized
1544 into separate specified =$web= and =$topic= parts.
1545
1546 =cut
1547
1548 sub getViewUrl
1549 {
1550 my( $theWeb, $theTopic ) = @_;
1551 # PTh 20 Jun 2000: renamed sub viewUrl to getViewUrl, added $theWeb
1552 # WM 14 Feb 2004: Removed support for old syntax not specifying $theWeb
1553
1554 $theTopic =~ s/\s*//gs; # Illegal URL, remove space
1555 rizwank 1.1
1556 # PTh 24 May 2000: added $urlHost, needed for some environments
1557 # see also Codev.PageRedirectionNotWorking
1558 return "$urlHost$dispScriptUrlPath$dispViewPath$scriptSuffix/$theWeb/$theTopic";
1559 }
1560
1561 =pod
1562
1563 ---++ getScriptURL( $web, $topic, $script )
1564 Return value: $absoluteScriptURL
1565
1566 Returns the absolute URL to a TWiki script, providing the wub and topic as
1567 "path info" parameters. The result looks something like this:
1568 "http://host/twiki/bin/$script/$web/$topic"
1569
1570 =cut
1571
1572 sub getScriptUrl
1573 {
1574 my( $theWeb, $theTopic, $theScript ) = @_;
1575
1576 rizwank 1.1 my $url = "$urlHost$dispScriptUrlPath/$theScript$scriptSuffix/$theWeb/$theTopic";
1577
1578 # FIXME consider a plugin call here - useful for certificated logon environment
1579
1580 return $url;
1581 }
1582
1583 =pod
1584
1585 ---++ getOopsUrl( $web, $topic, $template, @scriptParams )
1586 Return Value: $absoluteOopsURL
1587
1588 Composes a URL for an "oops" error page. The last parameters depend on the
1589 specific oops template in use, and are passed in the URL as 'param1..paramN'.
1590
1591 The returned URL ends up looking something like:
1592 "http://host/twiki/bin/oops/$web/$topic?template=$template¶m1=$scriptParams[0]..."
1593
1594 =cut
1595
1596 sub getOopsUrl
1597 rizwank 1.1 {
1598 my( $theWeb, $theTopic, $theTemplate,
1599 $theParam1, $theParam2, $theParam3, $theParam4 ) = @_;
1600 # PTh 20 Jun 2000: new sub
1601 my $web = $webName; # current web
1602 if( $theWeb ) {
1603 $web = $theWeb;
1604 }
1605 my $url = "";
1606 # $urlHost is needed, see Codev.PageRedirectionNotWorking
1607 $url = getScriptUrl( $web, $theTopic, "oops" );
1608 $url .= "\?template=$theTemplate";
1609 $url .= "\&param1=" . handleUrlEncode( $theParam1 ) if ( $theParam1 );
1610 $url .= "\&param2=" . handleUrlEncode( $theParam2 ) if ( $theParam2 );
1611 $url .= "\&param3=" . handleUrlEncode( $theParam3 ) if ( $theParam3 );
1612 $url .= "\&param4=" . handleUrlEncode( $theParam4 ) if ( $theParam4 );
1613
1614 return $url;
1615 }
1616
1617 # =========================
1618 rizwank 1.1 =pod
1619
1620 ---++ sub makeTopicSummary ( $theText, $theTopic, $theWeb, $theFlags )
1621
1622 Not yet documented.
1623
1624 =cut
1625
1626 sub makeTopicSummary
1627 {
1628 my( $theText, $theTopic, $theWeb, $theFlags ) = @_;
1629 # called by search, mailnotify & changes after calling readFileHead
1630
1631 my $htext = $theText;
1632 $theFlags = "" unless( $theFlags );
1633 # Format e-mail to add spam padding (HTML tags removed later)
1634 $htext =~ s/([\s\(])(?:mailto\:)*([a-zA-Z0-9\-\_\.\+]+)\@([a-zA-Z0-9\-\_\.]+)\.([a-zA-Z0-9\-\_]+)(?=[\s\.\,\;\:\!\?\)])/$1 . &TWiki::Render::mailtoLink( $2, $3, $4 )/ge;
1635 $htext =~ s/<\!\-\-.*?\-\->//gs; # remove all HTML comments
1636 $htext =~ s/<\!\-\-.*$//s; # cut HTML comment
1637 $htext =~ s/<[^>]*>//g; # remove all HTML tags
1638 $htext =~ s/\&[a-z]+;/ /g; # remove entities
1639 rizwank 1.1 $htext =~ s/%WEB%/$theWeb/g; # resolve web
1640 $htext =~ s/%TOPIC%/$theTopic/g; # resolve topic
1641 $htext =~ s/%WIKITOOLNAME%/$wikiToolName/g; # resolve TWiki tool name
1642 $htext =~ s/%META:[A-Z].*?}%//g; # remove meta data variables
1643 if( $theFlags =~ /nohead/ ) {
1644 # skip headings on top
1645 while( $htext =~ s/^\s*\-\-\-+\+[^\n\r]+// ) {}; # remove heading
1646 }
1647 unless( $theFlags =~ /showvar/ ) {
1648 # remove variables
1649 $htext =~ s/%[A-Z_]+%//g; # remove %VARS%
1650 $htext =~ s/%[A-Z_]+{.*?}%//g;# remove %VARS{}%
1651 }
1652 $htext =~ s/\[\[([^\]]*\]\[|[^\s]*\s)(.*?)\]\]/$2/g; # keep only link text of [[][]]
1653 $htext =~ s/[\%\[\]\*\|=_\&\<\>\$]/ /g; # remove Wiki formatting chars & defuse %VARS%
1654 $htext =~ s/\-\-\-+\+*\s*\!*/ /g; # remove heading formatting
1655 $htext =~ s/\s+[-\+]*/ /g; # remove newlines and special chars
1656 $htext =~ s/^\s+/ /; # remove leading spaces
1657 $htext =~ s/\s+$/ /; # remove trailing spaces
1658
1659 # FIXME I18N: Avoid splitting within multi-byte characters (e.g. EUC-JP
1660 rizwank 1.1 # encoding) by encoding bytes as Perl UTF-8 characters in Perl 5.8+.
1661 # This avoids splitting within a Unicode codepoint (or a UTF-16
1662 # surrogate pair, which is encoded as a single Perl UTF-8 character),
1663 # but we ideally need to avoid splitting closely related Unicode codepoints.
1664 # Specifically, this means Unicode combining character sequences (e.g.
1665 # letters and accents) - might be better to split on word boundary if
1666 # possible.
1667
1668 # limit to n chars
1669 my $nchar = $theFlags;
1670 unless( $nchar =~ s/^.*?([0-9]+).*$/$1/ ) {
1671 $nchar = 162;
1672 }
1673 $nchar = 16 if( $nchar < 16 );
1674 $htext =~ s/(.{$nchar})($regex{mixedAlphaNumRegex})(.*?)$/$1$2 \.\.\./;
1675
1676 # Encode special chars into XML &#nnn; entities for use in RSS feeds
1677 # - no encoding for HTML pages, to avoid breaking international
1678 # characters. FIXME: Only works for ISO-8859-1 characters, where the
1679 # Unicode encoding (&#nnn;) is identical.
1680 if( $pageMode eq 'rss' ) {
1681 rizwank 1.1 # FIXME: Issue for EBCDIC/UTF-8
1682 $htext =~ s/([\x7f-\xff])/"\&\#" . unpack( "C", $1 ) .";"/ge;
1683 }
1684
1685 # prevent text from getting rendered in inline search and link tool
1686 # tip text by escaping links (external, internal, Interwiki)
1687 $htext =~ s/([\s\(])(?=\S)/$1<nop>/g;
1688 $htext =~ s/([\-\*\s])($regex{linkProtocolPattern}\:)/$1<nop>$2/go;
1689 $htext =~ s/@([a-zA-Z0-9\-\_\.]+)/@<nop>$1/g; # email address
1690
1691 return $htext;
1692 }
1693
1694 # =========================
1695 =pod
1696
1697 ---++ sub extractParameters ( $str )
1698
1699 Extracts parameters from a variable string and returns a hash with all parameters.
1700 The nameless parameter's key is _DEFAULT.
1701
1702 rizwank 1.1 * Example variable: %TEST{ "nameless" name1="val1" name2="val2" }%
1703 * First extract text between {...} to get: "nameless" name1="val1" name2="val2"
1704 * Then call this on the text:
1705 * =my %params = TWiki::Func::extractParameters( $text );=
1706 * The hash contains now: <br />
1707 _DEFAULT => "nameless" <br />
1708 name1 => "val1" <br />
1709 name2 => "val2"
1710
1711 =cut
1712
1713 sub extractParameters
1714 {
1715 my( $str ) = @_;
1716
1717 my %params = ();
1718 return %params unless defined $str;
1719 $str =~ s/\\\"/\\$TranslationToken/g; # escape \"
1720
1721 if( $str =~ s/^\s*\"(.*?)\"\s*(\w+\s*=\s*\"|$)/$2/ ) {
1722 # is: %VAR{ "value" }%
1723 rizwank 1.1 # or: %VAR{ "value" param="etc" ... }%
1724 # Note: "value" may contain embedded double quotes
1725 $params{"_DEFAULT"} = $1 if defined $1; # distinguish between "" and "0";
1726 if( $2 ) {
1727 while( $str =~ s/^\s*(\w+)\s*=\s*\"([^\"]*)\"// ) {
1728 $params{"$1"} = $2 if defined $2;
1729 }
1730 }
1731 } elsif( ( $str =~ s/^\s*(\w+)\s*=\s*\"([^\"]*)\"// ) && ( $1 ) ) {
1732 # is: %VAR{ name = "value" }%
1733 $params{"$1"} = $2 if defined $2;
1734 while( $str =~ s/^\s*(\w+)\s*=\s*\"([^\"]*)\"// ) {
1735 $params{"$1"} = $2 if defined $2;
1736 }
1737 } elsif( $str =~ s/^\s*(.*?)\s*$// ) {
1738 # is: %VAR{ value }%
1739 $params{"_DEFAULT"} = $1 unless $1 eq "";
1740 }
1741 return map{ s/\\$TranslationToken/\"/go; $_ } %params;
1742 }
1743
1744 rizwank 1.1 # =========================
1745 =pod
1746
1747 ---++ sub extractNameValuePair ( $str, $name )
1748
1749 Not yet documented.
1750
1751 =cut
1752
1753 sub extractNameValuePair
1754 {
1755 my( $str, $name ) = @_;
1756
1757 my $value = "";
1758 return $value unless( $str );
1759 $str =~ s/\\\"/\\$TranslationToken/g; # escape \"
1760
1761 if( $name ) {
1762 # format is: %VAR{ ... name = "value" }%
1763 if( $str =~ /(^|[^\S])$name\s*=\s*\"([^\"]*)\"/ ) {
1764 $value = $2 if defined $2; # distinguish between "" and "0"
1765 rizwank 1.1 }
1766
1767 } else {
1768 # test if format: { "value" ... }
1769 if( $str =~ /(^|\=\s*\"[^\"]*\")\s*\"(.*?)\"\s*(\w+\s*=\s*\"|$)/ ) {
1770 # is: %VAR{ "value" }%
1771 # or: %VAR{ "value" param="etc" ... }%
1772 # or: %VAR{ ... = "..." "value" ... }%
1773 # Note: "value" may contain embedded double quotes
1774 $value = $2 if defined $2; # distinguish between "" and "0";
1775
1776 } elsif( ( $str =~ /^\s*\w+\s*=\s*\"([^\"]*)/ ) && ( $1 ) ) {
1777 # is: %VAR{ name = "value" }%
1778 # do nothing, is not a standalone var
1779
1780 } else {
1781 # format is: %VAR{ value }%
1782 $value = $str;
1783 }
1784 }
1785 $value =~ s/\\$TranslationToken/\"/go; # resolve \"
1786 rizwank 1.1 return $value;
1787 }
1788
1789 # =========================
1790 =pod
1791
1792 ---++ sub fixN ( $theTag )
1793
1794 Not yet documented.
1795
1796 =cut
1797
1798 sub fixN
1799 {
1800 my( $theTag ) = @_;
1801 $theTag =~ s/[\r\n]+//gs;
1802 return $theTag;
1803 }
1804
1805 # =========================
1806 =pod
1807 rizwank 1.1
1808 ---++ sub fixURL ( $theHost, $theAbsPath, $theUrl )
1809
1810 Not yet documented.
1811
1812 =cut
1813
1814 sub fixURL
1815 {
1816 my( $theHost, $theAbsPath, $theUrl ) = @_;
1817
1818 my $url = $theUrl;
1819 if( $url =~ /^\// ) {
1820 # fix absolute URL
1821 $url = "$theHost$url";
1822 } elsif( $url =~ /^\./ ) {
1823 # fix relative URL
1824 $url = "$theHost$theAbsPath/$url";
1825 } elsif( $url =~ /^$regex{linkProtocolPattern}\:/ ) {
1826 # full qualified URL, do nothing
1827 } elsif( $url ) {
1828 rizwank 1.1 # FIXME: is this test enough to detect relative URLs?
1829 $url = "$theHost$theAbsPath/$url";
1830 }
1831
1832 return $url;
1833 }
1834
1835 # =========================
1836 =pod
1837
1838 ---++ sub fixIncludeLink ( $theWeb, $theLink, $theLabel )
1839
1840 Not yet documented.
1841
1842 =cut
1843
1844 sub fixIncludeLink
1845 {
1846 my( $theWeb, $theLink, $theLabel ) = @_;
1847
1848 if( $theLabel ) {
1849 rizwank 1.1 # [[...][...]] link
1850 if( $theLink =~ /^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}\:)/ ) {
1851 return "[[$theLink][$theLabel]]"; # no change
1852 }
1853 # add 'Web.' prefix
1854 return "[[$theWeb.$theLink][$theLabel]]";
1855
1856 } else {
1857 # [[...]] link
1858 if( $theLink =~ /^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}\:)/ ) {
1859 return "[[$theLink]]"; # no change
1860 }
1861 # add 'Web.' prefix
1862 return "[[$theWeb.$theLink][$theLink]]";
1863 }
1864 }
1865
1866 # =========================
1867 =pod
1868
1869 ---++ sub cleanupIncludedHTML ( $text, $host, $path )
1870 rizwank 1.1
1871 Clean-up HTML text so that it can be shown embedded in a topic
1872
1873 =cut
1874
1875 sub cleanupIncludedHTML
1876 {
1877 my( $text, $host, $path ) = @_;
1878
1879 # FIXME: Make aware of <base> tag
1880
1881 $text =~ s/^.*?<\/head>//is; # remove all HEAD
1882 $text =~ s/<script.*?<\/script>//gis; # remove all SCRIPTs
1883 $text =~ s/^.*?<body[^>]*>//is; # remove all to <BODY>
1884 $text =~ s/(?:\n)<\/body>//is; # remove </BODY>
1885 $text =~ s/(?:\n)<\/html>//is; # remove </HTML>
1886 $text =~ s/(<[^>]*>)/&fixN($1)/ges; # join tags to one line each
1887 $text =~ s/(\s(href|src|action)\=[\"\']?)([^\"\'\>\s]*)/$1 . &fixURL( $host, $path, $3 )/geois;
1888
1889 return $text;
1890 }
1891 rizwank 1.1
1892 # =========================
1893 =pod
1894
1895 ---++ sub applyPatternToIncludedText ( $theText, $thePattern )
1896
1897 Apply a pattern on included text to extract a subset
1898
1899 =cut
1900
1901 sub applyPatternToIncludedText
1902 {
1903 my( $theText, $thePattern ) = @_;
1904 $thePattern =~ s/([^\\])([\$\@\%\&\#\'\`\/])/$1\\$2/g; # escape some special chars
1905 $thePattern =~ /(.*)/; # untaint
1906 $thePattern = $1;
1907 $theText = "" unless( $theText =~ s/$thePattern/$1/is );
1908 return $theText;
1909 }
1910
1911 # =========================
1912 rizwank 1.1 =pod
1913
1914 ---++ sub handleIncludeUrl ( $theUrl, $thePattern )
1915
1916 Not yet documented.
1917
1918 =cut
1919
1920 sub handleIncludeUrl
1921 {
1922 my( $theUrl, $thePattern, $theWeb, $theTopic ) = @_;
1923 my $text = "";
1924 my $host = "";
1925 my $port = 80;
1926 my $path = "";
1927 my $user = "";
1928 my $pass = "";
1929
1930 # For speed, read file directly if URL matches an attachment directory
1931 if( $theUrl =~ /^$urlHost$pubUrlPath\/([^\/\.]+)\/([^\/\.]+)\/([^\/]+)$/ ) {
1932 my $web = $1;
1933 rizwank 1.1 my $topic = $2;
1934 my $fileName = "$pubDir/$web/$topic/$3";
1935 if( $fileName =~ m/\.(txt|html?)$/i ) { # FIXME: Check for MIME type, not file suffix
1936 unless( -e $fileName ) {
1937 return showError( "Error: File attachment at $theUrl does not exist" );
1938 }
1939 if( "$web.$topic" ne "$theWeb.$theTopic" ) {
1940 # CODE_SMELL: Does not account for not yet authenticated user
1941 unless( TWiki::Access::checkAccessPermission( "VIEW", $wikiUserName, "", $topic, $web ) ) {
1942 return showError( "Error: No permission to view files attached to $web.$topic" );
1943 }
1944 }
1945 $text = TWiki::Store::readFile( $fileName );
1946 $text = cleanupIncludedHTML( $text, $urlHost, $pubUrlPath );
1947 $text = applyPatternToIncludedText( $text, $thePattern ) if( $thePattern );
1948 return $text;
1949 }
1950 # fall through; try to include file over http based on MIME setting
1951 }
1952
1953 # RNF 22 Jan 2002 Handle http://user:pass@host
1954 rizwank 1.1 if( $theUrl =~ /http\:\/\/(.+)\:(.+)\@([^\:]+)\:([0-9]+)(\/.*)/ ) {
1955 $user = $1;
1956 $pass = $2;
1957 $host = $3;
1958 $port = $4;
1959 $path = $5;
1960
1961 } elsif( $theUrl =~ /http\:\/\/(.+)\:(.+)\@([^\/]+)(\/.*)/ ) {
1962 $user = $1;
1963 $pass = $2;
1964 $host = $3;
1965 $path = $4;
1966
1967 } elsif( $theUrl =~ /http\:\/\/([^\:]+)\:([0-9]+)(\/.*)/ ) {
1968 $host = $1;
1969 $port = $2;
1970 $path = $3;
1971
1972 } elsif( $theUrl =~ /http\:\/\/([^\/]+)(\/.*)/ ) {
1973 $host = $1;
1974 $path = $2;
1975 rizwank 1.1
1976 } else {
1977 $text = showError( "Error: Unsupported protocol. (Must be 'http://domain/...')" );
1978 return $text;
1979 }
1980
1981 $text = &TWiki::Net::getUrl( $host, $port, $path, $user, $pass );
1982 $text =~ s/\r\n/\n/gs;
1983 $text =~ s/\r/\n/gs;
1984 $text =~ s/^(.*?\n)\n(.*)/$2/s;
1985 my $httpHeader = $1;
1986 my $contentType = "";
1987 if( $httpHeader =~ /content\-type\:\s*([^\n]*)/ois ) {
1988 $contentType = $1;
1989 }
1990 if( $contentType =~ /^text\/html/ ) {
1991 $path =~ s/(.*)\/.*/$1/; # build path for relative address
1992 $host = "http://$host"; # build host for absolute address
1993 if( $port != 80 ) {
1994 $host .= ":$port";
1995 }
1996 rizwank 1.1 $text = cleanupIncludedHTML( $text, $host, $path );
1997
1998 } elsif( $contentType =~ /^text\/(plain|css)/ ) {
1999 # do nothing
2000
2001 } else {
2002 $text = showError( "Error: Unsupported content type: $contentType."
2003 . " (Must be text/html, text/plain or text/css)" );
2004 }
2005
2006 $text = applyPatternToIncludedText( $text, $thePattern ) if( $thePattern );
2007
2008 return $text;
2009 }
2010
2011 =pod
2012
2013 ---++ handleIncludeFile( $includeCommandAttribs, $topic, $web, \@verbatimBuffer, @processedTopics )
2014 Return value: $includedText
2015
2016 Processes a specific instance %<nop>INCLUDE{...}% syntax. Returns the text to be
2017 rizwank 1.1 inserted in place of the INCLUDE command. $topic and $web should be for the
2018 immediate parent topic in the include hierarchy. @verbatimBuffer is the request-
2019 global buffer for storing removed verbatim blocks, and @processedTopics is a
2020 list of topics already %<nop>INCLUDE%'ed -- these are not allowed to be included
2021 again to prevent infinte recursive inclusion.
2022
2023 =cut
2024
2025 sub handleIncludeFile
2026 {
2027 my( $theAttributes, $theTopic, $theWeb, $verbatim, @theProcessedTopics ) = @_;
2028
2029 my %params = extractParameters( $theAttributes );
2030 my $incfile = $params{"_DEFAULT"} || "";
2031 my $pattern = $params{"pattern"} || "";
2032 my $rev = $params{"rev"} || "";
2033 my $warn = $params{"warn"} || "";
2034
2035 if( $incfile =~ /^http\:/ ) {
2036 # include web page
2037 return handleIncludeUrl( $incfile, $pattern, $theWeb, $theTopic );
2038 rizwank 1.1 }
2039
2040 # CrisBailiff, PeterThoeny 12 Jun 2000: Add security
2041 $incfile =~ s/$securityFilter//go; # zap anything suspicious
2042 if( $doSecureInclude ) {
2043 # Filter out ".." from filename, this is to
2044 # prevent includes of "../../file"
2045 $incfile =~ s/\.+/\./g;
2046 } else {
2047 # danger, could include .htpasswd with relative path
2048 $incfile =~ s/passwd//gi; # filter out passwd filename
2049 }
2050
2051 my $text = "";
2052 my $meta = "";
2053 my $isTopic = 0;
2054
2055 # test for different topic name and file name patterns
2056 my $fileName = "";
2057 TRY: {
2058 # check for topic
2059 rizwank 1.1 $fileName = "$dataDir/$theWeb/$incfile.txt"; # TopicName
2060 last TRY if( -e $fileName );
2061 my $incwebfile = $incfile;
2062 $incwebfile =~ s/\.([^\.]*)$/\/$1/;
2063 $fileName = "$dataDir/$incwebfile.txt"; # Web.TopicName
2064 last TRY if( -e $fileName );
2065 $fileName = "$dataDir/$theWeb/$incfile"; # TopicName.txt
2066 last TRY if( -e $fileName );
2067 $fileName = "$dataDir/$incfile"; # Web/TopicName.txt
2068 last TRY if( -e $fileName );
2069
2070 # give up, file not found
2071 $warn = TWiki::Prefs::getPreferencesValue( "INCLUDEWARNING" ) unless( $warn );
2072 if( $warn =~ /^on$/i ) {
2073 return showError( "Warning: Can't INCLUDE <nop>$incfile, topic not found" );
2074 } elsif( $warn && $warn !~ /^(off|no)$/i ) {
2075 $incfile =~ s/\//\./go;
2076 $warn =~ s/\$topic/$incfile/go;
2077 return $warn;
2078 } # else fail silently
2079 return "";
2080 rizwank 1.1 }
2081
2082 # prevent recursive loop
2083 # FIXME: Probably better done with a hash
2084 if( ( @theProcessedTopics ) && ( grep { /^$fileName$/ } @theProcessedTopics ) ) {
2085 # file already included
2086 if( $warn || TWiki::Prefs::getPreferencesFlag( "INCLUDEWARNING" ) ) {
2087 unless( $warn =~ /^(off|no)$/i ) {
2088 return showError( "Warning: Can't INCLUDE <nop>$incfile twice, topic is already included" );
2089 }
2090 }
2091 return "";
2092 } else {
2093 # remember for next time
2094 push( @theProcessedTopics, $fileName );
2095 }
2096
2097 # set include web/filenames and current web/filenames
2098 $includingWebName = $theWeb;
2099 $includingTopicName = $theTopic;
2100 if( $fileName =~ s/\/([^\/]*)\/([^\/]*)\.txt$/$1/ ) {
2101 rizwank 1.1 # identified "/Web/TopicName.txt" filename, e.g. a Wiki topic
2102 # so save the current web and topic name
2103 $theWeb = $1;
2104 $theTopic = $2;
2105 $isTopic = 1;
2106
2107 if( $rev ) {
2108 $rev = "1.$rev" unless( $rev =~ /^1\./ );
2109 ( $meta, $text ) = &TWiki::Store::readTopicVersion( $theWeb, $theTopic, $rev );
2110 } else {
2111 ( $meta, $text ) = &TWiki::Store::readTopic( $theWeb, $theTopic );
2112 }
2113 # remove everything before %STARTINCLUDE% and after %STOPINCLUDE%
2114 $text =~ s/.*?%STARTINCLUDE%//s;
2115 $text =~ s/%STOPINCLUDE%.*//s;
2116
2117 } # else is a file with relative path, e.g. $dataDir/../../path/to/non-twiki/file.ext
2118
2119 $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern );
2120
2121 # handle all preferences and internal tags (for speed: call by reference)
2122 rizwank 1.1 $text = takeOutVerbatim( $text, $verbatim );
2123
2124 # Escape rendering: Change " !%VARIABLE%" to " %<nop>VARIABLE%", for final " %VARIABLE%" output
2125 $text =~ s/(\s)\!\%([A-Z])/$1%<nop>$2/g;
2126
2127 # handle all preferences and internal tags
2128 &TWiki::Prefs::handlePreferencesTags( $text );
2129 handleInternalTags( $text, $theTopic, $theWeb );
2130
2131 # TWiki Plugin Hook (4th parameter tells plugin that its called from an include)
2132 &TWiki::Plugins::commonTagsHandler( $text, $theTopic, $theWeb, 1 );
2133
2134 # handle tags again because of plugin hook
2135 &TWiki::Prefs::handlePreferencesTags( $text );
2136 handleInternalTags( $text, $theTopic, $theWeb );
2137
2138 # If needed, fix all "TopicNames" to "Web.TopicNames" to get the right context
2139 if( ( $isTopic ) && ( $theWeb ne $webName ) ) {
2140 # "TopicName" to "Web.TopicName"
2141 $text =~ s/(^|[\s\(])($regex{webNameRegex}\.$regex{wikiWordRegex})/$1$TranslationToken$2/go;
2142 $text =~ s/(^|[\s\(])($regex{wikiWordRegex})/$1$theWeb\.$2/go;
2143 rizwank 1.1 $text =~ s/(^|[\s\(])$TranslationToken/$1/go;
2144 # "[[TopicName]]" to "[[Web.TopicName][TopicName]]"
2145 $text =~ s/\[\[([^\]]+)\]\]/fixIncludeLink( $theWeb, $1 )/geo;
2146 # "[[TopicName][...]]" to "[[Web.TopicName][...]]"
2147 $text =~ s/\[\[([^\]]+)\]\[([^\]]+)\]\]/fixIncludeLink( $theWeb, $1, $2 )/geo;
2148 # FIXME: Support for <noautolink>
2149 }
2150
2151 # FIXME What about attachments?
2152
2153 # recursively process multiple embedded %INCLUDE% statements and prefs
2154 $text =~ s/%INCLUDE{(.*?)}%/&handleIncludeFile($1, $theTopic, $theWeb, $verbatim, @theProcessedTopics )/ge;
2155
2156 return $text;
2157 }
2158
2159 # =========================
2160 # Only does simple search for topicmoved at present, can be expanded when required
2161 =pod
2162
2163 ---++ sub handleMetaSearch ( $attributes )
2164 rizwank 1.1
2165 Not yet documented.
2166
2167 =cut
2168
2169 sub handleMetaSearch
2170 {
2171 my( $theAttributes ) = @_;
2172
2173 my %params = extractParameters( $theAttributes );
2174 my $attrWeb = $params{"web"} || "";
2175 my $attrTopic = $params{"topic"} || "";
2176 my $attrType = $params{"type"} || "";
2177 my $attrTitle = $params{"title"} || "";
2178 my $attrDefault = $params{"default"} || "";
2179
2180 my $searchVal = "XXX";
2181
2182 if( ! $attrType ) {
2183 $attrType = "";
2184 }
2185 rizwank 1.1
2186 my $searchWeb = "all";
2187
2188 if( $attrType eq "topicmoved" ) {
2189 $searchVal = "%META:TOPICMOVED[{].*from=\\\"$attrWeb\.$attrTopic\\\".*[}]%";
2190 } elsif ( $attrType eq "parent" ) {
2191 $searchWeb = $attrWeb;
2192 $searchVal = "%META:TOPICPARENT[{].*name=\\\"($attrWeb\\.)?$attrTopic\\\".*[}]%";
2193 }
2194
2195 my $text = &TWiki::Search::searchWeb(
2196 "inline" => "1",
2197 "search" => $searchVal,
2198 "web" => $searchWeb,
2199 "type" => "regex",
2200 "nosummary" => "on",
2201 "nosearch" => "on",
2202 "noheader" => "on",
2203 "nototal" => "on",
2204 "noempty" => "on",
2205 "template" => "searchmeta",
2206 rizwank 1.1 );
2207
2208 if( $text =~ /^\s*$/ ) {
2209 $text = "$attrTitle$attrDefault";
2210 } else {
2211 $text = "$attrTitle$text";
2212 }
2213 return $text;
2214 }
2215
2216 # =========================
2217 =pod
2218
2219 ---++ sub handleSearchWeb ( $attributes, $baseWeb, $baseTopic )
2220
2221 Not yet documented.
2222
2223 =cut
2224
2225 sub handleSearchWeb
2226 {
2227 rizwank 1.1 my( $attributes, $baseWeb, $baseTopic ) = @_;
2228
2229 my %params = extractParameters( $attributes ); # pass along all attributes
2230 $params{"inline"} = 1; # and add some more
2231 $params{"baseweb"} = $baseWeb;
2232 $params{"basetopic"} = $baseTopic;
2233 $params{"search"} = $params{"_DEFAULT"} if( $params{"_DEFAULT"} );
2234 $params{"type"} = TWiki::Prefs::getPreferencesValue( "SEARCHVARDEFAULTTYPE" ) unless( $params{"type"} );
2235
2236 return TWiki::Search::searchWeb( %params );
2237 }
2238
2239 # =========================
2240 #TODO: this seems like a duplication with formatGmTime and formatLocTime
2241 #remove any 2.
2242 =pod
2243
2244 ---++ sub handleTime ( $theAttributes, $theZone )
2245
2246 Not yet documented.
2247
2248 rizwank 1.1 =cut
2249
2250 sub handleTime
2251 {
2252 my( $theAttributes, $theZone ) = @_;
2253 # format examples:
2254 # 28 Jul 2000 15:33:59 is "$day $month $year $hour:$min:$sec"
2255 # 001128 is "$ye$mo$day"
2256
2257 my $format = extractNameValuePair( $theAttributes );
2258
2259 my $value = "";
2260 my $time = time();
2261
2262 # if( $format ) {
2263 $value = formatTime($time, $format, $theZone);
2264 # } else {
2265 # if( $theZone eq "gmtime" ) {
2266 # $value = gmtime( $time );
2267 # } elsif( $theZone eq "servertime" ) {
2268 # $value = localtime( $time );
2269 rizwank 1.1 # }
2270 # }
2271
2272 # if( $theZone eq "gmtime" ) {
2273 # $value = $value." GMT";
2274 # }
2275
2276 return $value;
2277 }
2278
2279 # =========================
2280 =pod
2281 ---++ sub formatTime ($epochSeconds, $formatString, $outputTimeZone) ==> $value
2282 | $epochSeconds | epochSecs GMT |
2283 | $formatString | twiki time date format |
2284 | $outputTimeZone | timezone to display. (not sure this will work)(gmtime or servertime) |
2285
2286 =cut
2287 sub formatTime
2288 {
2289 my ($epochSeconds, $formatString, $outputTimeZone) = @_;
2290 rizwank 1.1 my $value = $epochSeconds;
2291
2292 # use default TWiki format "31 Dec 1999 - 23:59" unless specified
2293 $formatString = "\$day \$month \$year - \$hour:\$min" unless( $formatString );
2294 $outputTimeZone = $displayTimeValues unless( $outputTimeZone );
2295
2296 my( $sec, $min, $hour, $day, $mon, $year, $wday) = gmtime( $epochSeconds );
2297 ( $sec, $min, $hour, $day, $mon, $year, $wday ) = localtime( $epochSeconds ) if( $outputTimeZone eq "servertime" );
2298
2299 #standard twiki date time formats
2300 if( $formatString =~ /rcs/i ) {
2301 # RCS format, example: "2001/12/31 23:59:59"
2302 $formatString = "\$year/\$mo/\$day \$hour:\$min:\$sec";
2303 } elsif ( $formatString =~ /http|email/i ) {
2304 # HTTP header format, e.g. "Thu, 23 Jul 1998 07:21:56 EST"
2305 # - based on RFC 2616/1123 and HTTP::Date; also used
2306 # by TWiki::Net for Date header in emails.
2307 $formatString = "\$wday, \$day \$month \$year \$hour:\$min:\$sec \$tz";
2308 } elsif ( $formatString =~ /iso/i ) {
2309 # ISO Format, see spec at http://www.w3.org/TR/NOTE-datetime
2310 # e.g. "2002-12-31T19:30Z"
2311 rizwank 1.1 $formatString = "\$year-\$mo-\$dayT\$hour:\$min";
2312 if( $outputTimeZone eq "gmtime" ) {
2313 $formatString = $formatString."Z";
2314 } else {
2315 #TODO: $formatString = $formatString. # TZD = time zone designator (Z or +hh:mm or -hh:mm)
2316 }
2317 }
2318
2319 $value = $formatString;
2320 $value =~ s/\$sec[o]?[n]?[d]?[s]?/sprintf("%.2u",$sec)/geoi;
2321 $value =~ s/\$min[u]?[t]?[e]?[s]?/sprintf("%.2u",$min)/geoi;
2322 $value =~ s/\$hou[r]?[s]?/sprintf("%.2u",$hour)/geoi;
2323 $value =~ s/\$day/sprintf("%.2u",$day)/geoi;
2324 my @weekDay = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
2325 $value =~ s/\$wday/$weekDay[$wday]/geoi;
2326 $value =~ s/\$mon[t]?[h]?/$isoMonth[$mon]/goi;
2327 $value =~ s/\$mo/sprintf("%.2u",$mon+1)/geoi;
2328 $value =~ s/\$yea[r]?/sprintf("%.4u",$year+1900)/geoi;
2329 $value =~ s/\$ye/sprintf("%.2u",$year%100)/geoi;
2330
2331 #TODO: how do we get the different timezone strings (and when we add usertime, then what?)
2332 rizwank 1.1 my $tz_str = "GMT";
2333 $tz_str = "Local" if ( $outputTimeZone eq "servertime" );
2334 $value =~ s/\$tz/$tz_str/geoi;
2335
2336 return $value;
2337 }
2338
2339 # =========================
2340 =pod
2341 ---++ sub handleRevisionInfo ( $web, $topic, $formatString ) ==> $value
2342 | $web | web and |
2343 | $topic | topic to display the name for |
2344 | $formatString | twiki format string (like in search) |
2345
2346 =cut
2347 sub handleRevisionInfo
2348 {
2349 my( $theWeb, $theTopic, $theArgs ) = @_;
2350
2351 my %params = extractParameters( $theArgs );
2352
2353 rizwank 1.1 my $format = $params{"_DEFAULT"} || $params{"format"} || "r1.\$rev - \$date - \$wikiusername";
2354 my $web = $params{"web"} || $theWeb;
2355 my $topic = $params{"topic"} || $theTopic;
2356 my $cgiQuery = getCgiQuery();
2357 my $cgiRev = "";
2358 $cgiRev = $cgiQuery->param('rev') if( $cgiQuery );
2359 my $revnum = $cgiRev || $params{"rev"} || "";
2360 $revnum =~ s/r?1\.//; # cut "r" and major
2361
2362 my( $date, $user, $rev, $comment ) = TWiki::Store::getRevisionInfo( $web, $topic, $revnum );
2363 my $wikiName = userToWikiName( $user, 1 );
2364 my $wikiUserName = userToWikiName( $user );
2365
2366 my $value = $format;
2367 $value =~ s/\$web/$web/goi;
2368 $value =~ s/\$topic/$topic/goi;
2369 $value =~ s/\$rev/$rev/goi;
2370 $value =~ s/\$date/&formatTime($date)/geoi;
2371 $value =~ s/\$comment/$comment/goi;
2372 $value =~ s/\$username/$user/goi;
2373 $value =~ s/\$wikiname/$wikiName/goi;
2374 rizwank 1.1 $value =~ s/\$wikiusername/$wikiUserName/goi;
2375
2376 return $value;
2377 }
2378
2379 #AS
2380 # =========================
2381 =pod
2382
2383 ---++ sub showError ( $errormessage )
2384
2385 Not yet documented.
2386
2387 =cut
2388
2389 sub showError
2390 {
2391 my( $errormessage ) = @_;
2392 return "<font size=\"-1\" class=\"twikiAlert\" color=\"#FF0000\">$errormessage</font>" ;
2393 }
2394
2395 rizwank 1.1 =pod
2396
2397 ---++ handleToc( $text, $topic, $web, $tocAttributes )
2398 Parameters:
2399 * $text : the text of the current topic
2400 * $topic : the topic we are in
2401 * $web : the web we are in
2402 * $tocAttributes : "Topic" [web="Web"] [depth="N"]
2403 Return value: $tableOfContents
2404
2405 Andrea Sterbini 22-08-00 / PTh 28 Feb 2001
2406
2407 Handles %<nop>TOC{...}% syntax. Creates a table of contents using TWiki bulleted
2408 list markup, linked to the section headings of a topic. A section heading is
2409 entered in one of the following forms:
2410 * $headingPatternSp : \t++... spaces section heading
2411 * $headingPatternDa : ---++... dashes section heading
2412 * $headingPatternHt : <h[1-6]> HTML section heading </h[1-6]>
2413
2414 =cut
2415
2416 rizwank 1.1 sub handleToc
2417 {
2418 ## $_[0] $_[1] $_[2] $_[3]
2419 ## my( $theText, $theTopic, $theWeb, $attributes ) = @_;
2420
2421 my %params = extractParameters( $_[3] );
2422
2423 # get the topic name attribute
2424 my $topicname = $params{"_DEFAULT"} || $_[1];
2425
2426 # get the web name attribute
2427 my $web = $params{"web"} || $_[2];
2428 $web =~ s/\//\./g;
2429 my $webPath = $web;
2430 $webPath =~ s/\./\//g;
2431
2432 # get the depth limit attribute
2433 my $depth = $params{"depth"} || 6;
2434
2435 #get the title attribute
2436 my $title = $params{"title"} || "";
2437 rizwank 1.1 $title = "\n<span class=\"twikiTocTitle\">$title</span>" if( $title );
2438
2439 my $result = "";
2440 my $line = "";
2441 my $level = "";
2442 my @list = ();
2443
2444 if( "$web.$topicname" eq "$_[2].$_[1]" ) {
2445 # use text from parameter
2446 @list = split( /\n/, $_[0] );
2447
2448 } else {
2449 # read text from file
2450 if ( ! &TWiki::Store::topicExists( $web, $topicname ) ) {
2451 return showError( "TOC: Cannot find topic \"$web.$topicname\"" );
2452 }
2453 my $t = TWiki::Store::readWebTopic( $web, $topicname );
2454 $t =~ s/.*?%STARTINCLUDE%//s;
2455 $t =~ s/%STOPINCLUDE%.*//s;
2456 @list = split( /\n/, handleCommonTags( $t, $topicname, $web ) );
2457 }
2458 rizwank 1.1
2459 @list = grep { /(<\/?pre>)|($regex{headerPatternDa})|($regex{headerPatternSp})|($regex{headerPatternHt})/ } @list;
2460 my $insidePre = 0;
2461 my $i = 0;
2462 my $tabs = "";
2463 my $anchor = "";
2464 my $highest = 99;
2465 foreach $line ( @list ) {
2466 if( $line =~ /^.*<pre>.*$/io ) {
2467 $insidePre = 1;
2468 $line = "";
2469 }
2470 if( $line =~ /^.*<\/pre>.*$/io ) {
2471 $insidePre = 0;
2472 $line = "";
2473 }
2474 if (!$insidePre) {
2475 $level = $line ;
2476 if ( $line =~ /$regex{headerPatternDa}/o ) {
2477 $level =~ s/$regex{headerPatternDa}/$1/go;
2478 $level = length $level;
2479 rizwank 1.1 $line =~ s/$regex{headerPatternDa}/$2/go;
2480 } elsif
2481 ( $line =~ /$regex{headerPatternSp}/o ) {
2482 $level =~ s/$regex{headerPatternSp}/$1/go;
2483 $level = length $level;
2484 $line =~ s/$regex{headerPatternSp}/$2/go;
2485 } elsif
2486 ( $line =~ /$regex{headerPatternHt}/io ) {
2487 $level =~ s/$regex{headerPatternHt}/$1/gio;
2488 $line =~ s/$regex{headerPatternHt}/$2/gio;
2489 }
2490 my $urlPath = "";
2491 if( "$web.$topicname" ne "$webName.$topicName" ) {
2492 # not current topic, can't omit URL
2493 $urlPath = "$dispScriptUrlPath$dispViewPath$scriptSuffix/$webPath/$topicname";
2494 }
2495 if( ( $line ) && ( $level <= $depth ) ) {
2496 $anchor = TWiki::Render::makeAnchorName( $line );
2497 # cut TOC exclude '---+ heading !! exclude'
2498 $line =~ s/\s*$regex{headerPatternNoTOC}.+$//go;
2499 $line =~ s/[\n\r]//go;
2500 rizwank 1.1 next unless $line;
2501 $highest = $level if( $level < $highest );
2502 $tabs = "";
2503 for( $i=0 ; $i<$level ; $i++ ) {
2504 $tabs = "\t$tabs";
2505 }
2506 # Remove *bold*, _italic_ and =fixed= formatting
2507 $line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
2508 $line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
2509 $line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
2510 # Prevent WikiLinks
2511 $line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g; # '[[...][...]]'
2512 $line =~ s/\[\[(.*?)\]\]/$1/ge; # '[[...]]'
2513 $line =~ s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1<nop>$3/g; # 'Web.TopicName'
2514 $line =~ s/([\s\(])($regex{wikiWordRegex})/$1<nop>$2/g; # 'TopicName'
2515 $line =~ s/([\s\(])($regex{abbrevRegex})/$1<nop>$2/g; # 'TLA'
2516 # create linked bullet item, using a relative link to anchor
2517 $line = "$tabs* <a href=\"$urlPath#$anchor\">$line</a>";
2518 $result .= "\n$line";
2519 }
2520 }
2521 rizwank 1.1 }
2522 if( $result ) {
2523 if( $highest > 1 ) {
2524 # left shift TOC
2525 $highest--;
2526 $result =~ s/^\t{$highest}//gm;
2527 }
2528 $result = "<div class=\"twikiToc\">$title$result\n</div>";
2529 return $result;
2530
2531 } else {
2532 return showError("TOC: No TOC in \"$web.$topicname\"");
2533 }
2534 }
2535
2536 # =========================
2537 =pod
2538
2539 ---++ sub getPublicWebList ()
2540
2541 Not yet documented.
2542 rizwank 1.1
2543 =cut
2544
2545 sub getPublicWebList
2546 {
2547 # FIXME: Should this go elsewhere?
2548 # (Not in Store because Store should not be dependent on Prefs.)
2549
2550 if( ! @publicWebList ) {
2551 # build public web list, e.g. exclude hidden webs, but include current web
2552 my @list = &TWiki::Store::getAllWebs( "" );
2553 my $item = "";
2554 my $hidden = "";
2555 foreach $item ( @list ) {
2556 $hidden = &TWiki::Prefs::getPreferencesValue( "NOSEARCHALL", $item );
2557 # exclude topics that are hidden or start with . or _ unless current web
2558 if( ( $item eq $TWiki::webName ) || ( ( ! $hidden ) && ( $item =~ /^[^\.\_]/ ) ) ) {
2559 push( @publicWebList, $item );
2560 }
2561 }
2562 }
2563 rizwank 1.1 return @publicWebList;
2564 }
2565
2566 # =========================
2567 =pod
2568
2569 ---++ sub expandVariablesOnTopicCreation ( $theText, $theUser, $theWikiName, $theWikiUserName )
2570
2571 Expand limited set of variables with a topic during topic creation
2572
2573 =cut
2574
2575 sub expandVariablesOnTopicCreation {
2576 my ( $theText, $theUser, $theWikiName, $theWikiUserName ) = @_;
2577
2578 my $today = formatTime(time(), "\$day \$mon \$year", "gmtime");
2579 $theUser = $userName unless $theUser;
2580 $theWikiName = userToWikiName( $theUser, 1 ) unless $theWikiName;
2581 $theWikiUserName = userToWikiName( $theUser ) unless $theWikiUserName;
2582
2583 $theText =~ s/%DATE%/$today/go;
2584 rizwank 1.1 $theText =~ s/%USERNAME%/$theUser/go; # "jdoe"
2585 $theText =~ s/%WIKINAME%/$theWikiName/go; # "JonDoe"
2586 $theText =~ s/%WIKIUSERNAME%/$theWikiUserName/go; # "Main.JonDoe"
2587 $theText =~ s/%URLPARAM{(.*?)}%/&handleUrlParam($1)/geo; # expand URL parameters
2588 $theText =~ s/%NOP{.*?}%//gos; # Remove filler: Use it to remove access control at time of
2589 $theText =~ s/%NOP%//go; # topic instantiation or to prevent search from hitting a template
2590
2591 return $theText;
2592 }
2593
2594 # =========================
2595 =pod
2596
2597 ---++ sub handleWebAndTopicList ( $theAttr, $isWeb )
2598
2599 Not yet documented.
2600
2601 =cut
2602
2603 sub handleWebAndTopicList
2604 {
2605 rizwank 1.1 my( $theAttr, $isWeb ) = @_;
2606
2607 my %params = extractParameters( $theAttr );
2608
2609 my $format = $params{"_DEFAULT"} || $params{"format"} || "";
2610 $format .= '$name' unless( $format =~ /\$name/ );
2611 my $separator = $params{"separator"} || "\n";
2612 my $web = $params{"web"} || "";
2613 my $webs = $params{"webs"} || "public";
2614 my $selection = $params{"selection"} || "";
2615 $selection =~ s/\,/ /g;
2616 $selection = " $selection ";
2617 my $marker = $params{"marker"} || 'selected="selected"';
2618
2619 my @list = ();
2620 if( $isWeb ) {
2621 my @webslist = split( /,\s?/, $webs );
2622 foreach my $aweb ( @webslist ) {
2623 if( $aweb eq "public" ) {
2624 push( @list, getPublicWebList() );
2625 } elsif( $aweb eq "webtemplate" ) {
2626 rizwank 1.1 push( @list, grep { /^\_/o } &TWiki::Store::getAllWebs( "" ) );
2627 } else{
2628 push( @list, $aweb ) if( &TWiki::Store::webExists( $aweb ) );
2629 }
2630 }
2631 } else {
2632 $web = $webName if( ! $web );
2633 my $hidden = &TWiki::Prefs::getPreferencesValue( "NOSEARCHALL", $web );
2634 if( ( $web eq $TWiki::webName ) || ( ! $hidden ) ) {
2635 @list = &TWiki::Store::getTopicNames( $web );
2636 }
2637 }
2638 my $text = "";
2639 my $item = "";
2640 my $line = "";
2641 my $mark = "";
2642 foreach $item ( @list ) {
2643 $line = $format;
2644 $line =~ s/\$web/$web/goi;
2645 $line =~ s/\$name/$item/goi;
2646 $line =~ s/\$qname/"$item"/goi;
2647 rizwank 1.1 $mark = ( $selection =~ / \Q$item\E / ) ? $marker : "";
2648 $line =~ s/\$marker/$mark/goi;
2649 $text .= "$line$separator";
2650 }
2651 $text =~ s/$separator$//s; # remove last separator
2652 return $text;
2653 }
2654
2655 # =========================
2656 =pod
2657
2658 ---++ sub handleUrlParam ( $theArgs )
2659
2660 Not yet documented.
2661
2662 =cut
2663
2664 sub handleUrlParam
2665 {
2666 my( $theArgs ) = @_;
2667
2668 rizwank 1.1 my %params = extractParameters( $theArgs );
2669 my $param = $params{"_DEFAULT"} || "";
2670 my $newLine = $params{"newline"} || "";
2671 my $encode = $params{"encode"} || "";
2672 my $multiple = $params{"multiple"} || "";
2673 my $separator = $params{"separator"} || "\n";
2674
2675 my $value = "";
2676 if( $cgiQuery ) {
2677 if( $multiple ) {
2678 my @valueArray = $cgiQuery->param( $param );
2679 if( @valueArray ) {
2680 unless( $multiple =~ m/^on$/i ) {
2681 my $item = "";
2682 @valueArray = map {
2683 $item = $_;
2684 $_ = $multiple;
2685 $_ .= $item unless( s/\$item/$item/go );
2686 $_
2687 } @valueArray;
2688 }
2689 rizwank 1.1 $value = join ( $separator, @valueArray );
2690 }
2691 } else {
2692 $value = $cgiQuery->param( $param );
2693 $value = "" unless( defined $value );
2694 }
2695 }
2696 $value =~ s/\r?\n/$newLine/go if( $newLine );
2697 $value = handleUrlEncode( $value, 0, $encode ) if( $encode );
2698 unless( $value ) {
2699 $value = $params{"default"} || "";
2700 }
2701 return $value;
2702 }
2703
2704 # =========================
2705 # Encode to URL parameter or HTML entity
2706 # TODO: For non-ISO-8859-1 $siteCharset, need to convert to Unicode
2707 # for use in entity, or to UTF-8 before URL encoding.
2708
2709 =pod
2710 rizwank 1.1
2711 ---++ sub handleUrlEncode ( $theArgs, $doExtract )
2712
2713 Not yet documented.
2714
2715 =cut
2716
2717 sub handleUrlEncode
2718 {
2719 my( $theArgs, $doExtract, $theType ) = @_;
2720
2721 my $text = $theArgs;
2722 my $type = $theType || "";
2723 if( $doExtract ) {
2724 $text = extractNameValuePair( $theArgs );
2725 $type = extractNameValuePair( $theArgs, "type" ) || "";
2726 }
2727 if( $type =~ /^entit(y|ies)$/i ) {
2728 # HTML entity encoding
2729 # TODO: Encode characters > 0x7F to Unicode first
2730 $text =~ s/\"/\&\#034;/g;
2731 rizwank 1.1 $text =~ s/\%/\&\#037;/g;
2732 $text =~ s/\*/\&\#042;/g;
2733 $text =~ s/\_/\&\#095;/g;
2734 $text =~ s/\=/\&\#061;/g;
2735 $text =~ s/\[/\&\#091;/g;
2736 $text =~ s/\]/\&\#093;/g;
2737 $text =~ s/\</\&\#060;/g;
2738 $text =~ s/\>/\&\#062;/g;
2739 $text =~ s/\|/\&\#124;/g;
2740 } else {
2741 # URL encoding
2742 $text =~ s/[\n\r]/\%3Cbr\%20\%2F\%3E/g;
2743 $text =~ s/\s+/\%20/g;
2744 $text =~ s/\"/\%22/g;
2745 $text =~ s/\&/\%26/g;
2746 $text =~ s/\+/\%2B/g;
2747 $text =~ s/\</\%3C/g;
2748 $text =~ s/\>/\%3E/g;
2749 $text =~ s/\\/\%5C/g;
2750 # Encode characters > 0x7F (ASCII-derived charsets only)
2751 # TODO: Encode to UTF-8 first
2752 rizwank 1.1 $text =~ s/([\x7f-\xff])/'%' . unpack( "H*", $1 ) /ge;
2753 }
2754 return $text;
2755 }
2756
2757
2758 =pod
2759
2760 ---++ sub handleNativeUrlEncode ( $theStr, $doExtract )
2761
2762 Perform URL encoding into native charset ($siteCharset) - for use when
2763 viewing attachments via browsers that generate UTF-8 URLs, on sites running
2764 with non-UTF-8 (Native) character sets. Aim is to prevent UTF-8 URL
2765 encoding. For mainframes, we assume that UTF-8 URLs will be translated
2766 by the web server to an EBCDIC character set.
2767
2768 =cut
2769
2770 sub handleNativeUrlEncode {
2771 my( $theStr, $doExtract ) = @_;
2772
2773 rizwank 1.1 my $isEbcdic = ( 'A' eq chr(193) ); # True if Perl is using EBCDIC
2774
2775 if( $siteCharset eq "utf-8" or $isEbcdic ) {
2776 # Just strip double quotes, no URL encoding - let browser encode to
2777 # UTF-8 or EBCDIC based $siteCharset as appropriate
2778 $theStr =~ s/^"(.*)"$/$1/;
2779 return $theStr;
2780 } else {
2781 return handleUrlEncode( $theStr, $doExtract );
2782 }
2783 }
2784
2785 =pod
2786
2787 ---++ sub handleIntUrlEncode ( $theStr, $doExtract )
2788
2789 This routine was introduced to URL encode Mozilla's UTF-8 POST URLs in the
2790 TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now
2791 directly supported, but it is provided for backward compatibility with
2792 skins that may still be using the deprecated %INTURLENCODE%.
2793
2794 rizwank 1.1 =cut
2795
2796 sub handleIntUrlEncode
2797 {
2798 my( $theStr ) = @_;
2799
2800 # Just strip double quotes, no URL encoding - Mozilla UTF-8 URLs
2801 # directly supported now
2802 $theStr =~ s/^"(.*)"$/$1/;
2803 return $theStr;
2804 }
2805
2806 =pod
2807
2808 ---++ sub handleEnvVariable ( $theVar )
2809
2810 Not yet documented.
2811
2812 =cut
2813
2814 sub handleEnvVariable
2815 rizwank 1.1 {
2816 my( $theVar ) = @_;
2817 my $value = $ENV{$theVar} || "";
2818 return $value;
2819 }
2820
2821 =pod
2822
2823 ---++ sub handleTmplP ( $theParam )
2824
2825 Not yet documented.
2826
2827 =cut
2828
2829 sub handleTmplP
2830 {
2831 my( $theParam ) = @_;
2832
2833 $theParam = extractNameValuePair( $theParam );
2834 my $value = &TWiki::Store::handleTmplP( $theParam );
2835 return $value;
2836 rizwank 1.1 }
2837
2838 # =========================
2839 # Create spaced-out topic name for Ref-By search
2840 =pod
2841
2842 ---++ sub handleSpacedTopic ( $theTopic )
2843
2844 Not yet documented.
2845
2846 =cut
2847
2848 sub handleSpacedTopic
2849 {
2850 my( $theTopic ) = @_;
2851 my $spacedTopic = $theTopic;
2852 $spacedTopic =~ s/($regex{singleLowerAlphaRegex}+)($regex{singleUpperAlphaNumRegex}+)/$1%20*$2/go; # "%20*" is " *" - I18N: only in ASCII-derived charsets
2853 return $spacedTopic;
2854 }
2855
2856 # =========================
2857 rizwank 1.1 =pod
2858
2859 ---++ sub handleIcon ( $theParam )
2860
2861 Not yet documented.
2862
2863 =cut
2864
2865 sub handleIcon
2866 {
2867 my( $theParam ) = @_;
2868
2869 $theParam = extractNameValuePair( $theParam );
2870 my $value = &TWiki::Attach::filenameToIcon( "file.$theParam" );
2871 return $value;
2872 }
2873
2874 =pod
2875
2876 ---++ sub handleRelativeTopicPath ( $styleTopic, $web )
2877
2878 rizwank 1.1 Not yet documented.
2879
2880 =cut
2881
2882 sub handleRelativeTopicPath
2883 {
2884 my( $theStyleTopic, $theWeb ) = @_;
2885
2886 if ( !$theStyleTopic ) {
2887 return "";
2888 }
2889 my $theRelativePath;
2890 # if there is no dot in $theStyleTopic, no web has been specified
2891 if ( index( $theStyleTopic, "." ) == -1 ) {
2892 # add local web
2893 $theRelativePath = $theWeb . "/" . $theStyleTopic;
2894 } else {
2895 $theRelativePath = $theStyleTopic; #including dot
2896 }
2897 # replace dot by slash is not necessary; TWiki.MyTopic is a valid url
2898 # add ../ if not already present to make a relative file reference
2899 rizwank 1.1 if ( index( $theRelativePath, "../" ) == -1 ) {
2900 $theRelativePath = "../" . $theRelativePath;
2901 }
2902 return $theRelativePath;
2903 }
2904
2905 =pod
2906
2907 ---++ handleInternalTags( $text, $topic, $web )
2908
2909 Modifies $text in-place, replacing variables internal to TWiki with their
2910 values. Some example variables: %<nop>TOPIC%, %<nop>SCRIPTURL%, %<nop>WIKINAME%, etc.
2911
2912 =cut
2913
2914 sub handleInternalTags
2915 {
2916 # modify arguments directly, i.e. call by reference
2917 # $_[0] is text
2918 # $_[1] is topic
2919 # $_[2] is web
2920 rizwank 1.1
2921 # Make Edit URL unique for every edit - fix for RefreshEditPage.
2922 $_[0] =~ s!%EDITURL%!"$dispScriptUrlPath/edit$scriptSuffix/%WEB%/%TOPIC%\?t=" . time()!ge;
2923
2924 $_[0] =~ s/%NOP{(.*?)}%/$1/gs; # remove NOP tag in template topics but show content
2925 $_[0] =~ s/%NOP%/<nop>/g;
2926 $_[0] =~ s/%TMPL\:P{(.*?)}%/&handleTmplP($1)/ge;
2927 $_[0] =~ s/%SEP%/&handleTmplP('"sep"')/ge;
2928
2929 $_[0] =~ s/%HTTP_HOST%/&handleEnvVariable('HTTP_HOST')/ge;
2930 $_[0] =~ s/%REMOTE_ADDR%/&handleEnvVariable('REMOTE_ADDR')/ge;
2931 $_[0] =~ s/%REMOTE_PORT%/&handleEnvVariable('REMOTE_PORT')/ge;
2932 $_[0] =~ s/%REMOTE_USER%/&handleEnvVariable('REMOTE_USER')/ge;
2933
2934 $_[0] =~ s/%TOPIC%/$_[1]/g;
2935 $_[0] =~ s/%BASETOPIC%/$topicName/g;
2936 $_[0] =~ s/%INCLUDINGTOPIC%/$includingTopicName/g;
2937 $_[0] =~ s/%SPACEDTOPIC%/&handleSpacedTopic($_[1])/ge;
2938 $_[0] =~ s/%WEB%/$_[2]/g;
2939 $_[0] =~ s/%BASEWEB%/$webName/g;
2940 $_[0] =~ s/%INCLUDINGWEB%/$includingWebName/g;
2941 rizwank 1.1
2942 # I18N information
2943 $_[0] =~ s/%CHARSET%/$siteCharset/g;
2944 $_[0] =~ s/%SHORTLANG%/$siteLang/g;
2945 $_[0] =~ s/%LANG%/$siteFullLang/g;
2946
2947 $_[0] =~ s/%TOPICLIST{(.*?)}%/&handleWebAndTopicList($1,'0')/ge;
2948 $_[0] =~ s/%WEBLIST{(.*?)}%/&handleWebAndTopicList($1,'1')/ge;
2949
2950 # URLs and paths
2951 $_[0] =~ s/%WIKIHOMEURL%/$wikiHomeUrl/g;
2952 $_[0] =~ s/%SCRIPTURL%/$urlHost$dispScriptUrlPath/g;
2953 $_[0] =~ s/%SCRIPTURLPATH%/$dispScriptUrlPath/g;
2954 $_[0] =~ s/%SCRIPTSUFFIX%/$scriptSuffix/g;
2955 $_[0] =~ s/%PUBURL%/$urlHost$pubUrlPath/g;
2956 $_[0] =~ s/%PUBURLPATH%/$pubUrlPath/g;
2957 $_[0] =~ s/%RELATIVETOPICPATH{(.*?)}%/&handleRelativeTopicPath($1,$_[2])/ge;
2958
2959 # Attachments
2960 $_[0] =~ s!%ATTACHURL%!$urlHost%ATTACHURLPATH%!g;
2961 # I18N: URL-encode full web, topic and filename to the native
2962 rizwank 1.1 # $siteCharset for attachments viewed from browsers that use UTF-8 URL,
2963 # unless we are in UTF-8 mode or working on EBCDIC mainframe.
2964 # Include the filename suffixed to %ATTACHURLPATH% - a hack, but required
2965 # for migration purposes
2966 $_[0] =~ s!%ATTACHURLPATH%/($regex{filenameRegex})!&handleNativeUrlEncode("$pubUrlPath/$_[2]/$_[1]/$1",1)!ge;
2967 $_[0] =~ s!%ATTACHURLPATH%!&handleNativeUrlEncode("$pubUrlPath/$_[2]/$_[1]",1)!ge; # No-filename case
2968 $_[0] =~ s/%ICON{(.*?)}%/&handleIcon($1)/ge;
2969
2970 # URL encoding
2971 $_[0] =~ s/%URLPARAM{(.*?)}%/&handleUrlParam($1)/ge;
2972 $_[0] =~ s/%(URL)?ENCODE{(.*?)}%/&handleUrlEncode($2,1)/ge; # ENCODE is documented, URLENCODE is legacy
2973 $_[0] =~ s/%INTURLENCODE{(.*?)}%/&handleIntUrlEncode($1)/ge; # Deprecated - not needed with UTF-8 URL support
2974
2975 # Dates and times
2976 $_[0] =~ s/%DATE%/&formatTime(time(), "\$day \$mon \$year", "gmtime")/ge; # Deprecated, but used in signatures
2977 $_[0] =~ s/%GMTIME%/&handleTime("","gmtime")/ge;
2978 $_[0] =~ s/%GMTIME{(.*?)}%/&handleTime($1,"gmtime")/ge;
2979 $_[0] =~ s/%SERVERTIME%/&handleTime("","servertime")/ge;
2980 $_[0] =~ s/%SERVERTIME{(.*?)}%/&handleTime($1,"servertime")/ge;
2981 $_[0] =~ s/%DISPLAYTIME%/&handleTime("", $displayTimeValues)/ge;
2982 $_[0] =~ s/%DISPLAYTIME{(.*?)}%/&handleTime($1, $displayTimeValues)/ge;
2983 rizwank 1.1
2984 $_[0] =~ s/%WIKIVERSION%/$wikiversion/g;
2985 $_[0] =~ s/%PLUGINVERSION{(.*?)}%/TWiki::Plugins::getPluginVersion($1)/ge;
2986 $_[0] =~ s/%USERNAME%/$userName/g;
2987 $_[0] =~ s/%WIKINAME%/$wikiName/g;
2988 $_[0] =~ s/%WIKIUSERNAME%/$wikiUserName/g;
2989 $_[0] =~ s/%WIKITOOLNAME%/$wikiToolName/g;
2990 $_[0] =~ s/%MAINWEB%/$mainWebname/g;
2991 $_[0] =~ s/%TWIKIWEB%/$twikiWebname/g;
2992 $_[0] =~ s/%HOMETOPIC%/$mainTopicname/g;
2993 $_[0] =~ s/%WIKIUSERSTOPIC%/$wikiUsersTopicname/g;
2994 $_[0] =~ s/%WIKIPREFSTOPIC%/$wikiPrefsTopicname/g;
2995 $_[0] =~ s/%WEBPREFSTOPIC%/$webPrefsTopicname/g;
2996 $_[0] =~ s/%NOTIFYTOPIC%/$notifyTopicname/g;
2997 $_[0] =~ s/%STATISTICSTOPIC%/$statisticsTopicname/g;
2998 $_[0] =~ s/%STARTINCLUDE%//g;
2999 $_[0] =~ s/%STOPINCLUDE%//g;
3000 $_[0] =~ s/%SECTION{(.*?)}%//g;
3001 $_[0] =~ s/%ENDSECTION%//g;
3002 my $ok = 16; # SEARCH may be nested up to 16 times
3003 TRY: while( $_[0] =~ s/%SEARCH{(.*?)}%/&handleSearchWeb($1,$_[2],$_[1])/ge ) {
3004 rizwank 1.1 last TRY unless( --$ok );
3005 }
3006 $_[0] =~ s/%METASEARCH{(.*?)}%/&handleMetaSearch($1)/ge;
3007 $_[0] =~ s/%FORMFIELD{(.*?)}%/&TWiki::Render::getFormField($_[2],$_[1],$1)/ge;
3008
3009 $_[0] =~ s/%REVINFO%/handleRevisionInfo( $_[2], $_[1] )/ge;
3010 $_[0] =~ s/%REVINFO{(.*?)}%/handleRevisionInfo( $_[2], $_[1], $1 )/ge;
3011 }
3012
3013 =pod
3014
3015 ---++ takeOutVerbatim( $text, \@verbatimBuffer )
3016 Return value: $textWithoutVerbatim
3017
3018 Searches through $text and extracts <verbatim> blocks, appending each
3019 onto the end of the @verbatimBuffer array and replacing it with a token
3020 string which is not affected by TWiki rendering. The text after these
3021 substitutions is returned.
3022
3023 This function is designed to preserve the contents of verbatim blocks
3024 through some rendering operation. The general sequence of calls for
3025 rizwank 1.1 this use is something like this:
3026
3027 $textToRender = takeOutVerbatim($inputText, \@verbatimBlocks);
3028 $renderedText = performSomeRendering($textToRender);
3029 $resultText = putBackVerbatim($renderedText, "pre", @verbatimBlocks);
3030
3031 Note that some changes are made to verbatim blocks here: < and > are replaced
3032 by their HTML entities &lt; and &gt;, and the actual <verbatim>
3033 tags are replaced with <pre> tags so that the text is rendered truly
3034 "verbatim" by a browser. If this is not desired, pass "verbatim" as the
3035 second parameter of putBackVerbatim instead of "pre".
3036
3037 =cut
3038
3039 sub takeOutVerbatim
3040 {
3041 my( $intext, $verbatim ) = @_; # $verbatim is ref to array
3042
3043 if( $intext !~ /<verbatim>/oi ) {
3044 return( $intext );
3045 }
3046 rizwank 1.1
3047 # Exclude text inside verbatim from variable substitution
3048
3049 my $tmp = "";
3050 my $outtext = "";
3051 my $nesting = 0;
3052 my $verbatimCount = $#{$verbatim} + 1;
3053
3054 foreach( split( /\n/, $intext ) ) {
3055 if( /^(\s*)<verbatim>\s*$/i ) {
3056 $nesting++;
3057 if( $nesting == 1 ) {
3058 $outtext .= "$1%_VERBATIM$verbatimCount%\n";
3059 $tmp = "";
3060 next;
3061 }
3062 } elsif( m|^\s*</verbatim>\s*$|i ) {
3063 $nesting--;
3064 if( ! $nesting ) {
3065 $verbatim->[$verbatimCount++] = $tmp;
3066 next;
3067 rizwank 1.1 }
3068 }
3069
3070 if( $nesting ) {
3071 $tmp .= "$_\n";
3072 } else {
3073 $outtext .= "$_\n";
3074 }
3075 }
3076
3077 # Deal with unclosed verbatim
3078 if( $nesting ) {
3079 $verbatim->[$verbatimCount] = $tmp;
3080 }
3081
3082 return $outtext;
3083 }
3084
3085 =pod
3086
3087 ---++putBackVerbatim( $textWithoutVerbatim, $putBackType, @verbatimBuffer )
3088 rizwank 1.1 Return value: $textWithVerbatim
3089
3090 This function reverses the actions of takeOutVerbatim above. See the text for
3091 takeOutVerbatim for a more thorough description.
3092
3093 Set $putBackType to 'verbatim' to get back original text, or to 'pre' to
3094 convert to HTML readable verbatim text.
3095
3096 =cut
3097
3098 sub putBackVerbatim
3099 {
3100 my( $text, $type, @verbatim ) = @_;
3101
3102 for( my $i=0; $i<=$#verbatim; $i++ ) {
3103 my $val = $verbatim[$i];
3104 if( $type ne "verbatim" ) {
3105 $val =~ s/&/&/g;
3106 $val =~ s/</</g;
3107 $val =~ s/>/>/g;
3108 $val =~ s/\t/ /g; # A shame to do this, but been in TWiki.org have converted
3109 rizwank 1.1 # 3 spaces to tabs since day 1
3110 }
3111 $text =~ s|%_VERBATIM$i%|<$type>\n$val</$type>|;
3112 }
3113
3114 return $text;
3115 }
3116
3117 =pod
3118
3119 ---++ handleCommonTags( $text, $topic, $web, @processedTopics )
3120 Return value: $handledText
3121
3122 Processes %<nop>VARIABLE%, %<nop>TOC%, and %<nop>INCLUDE% syntax; also includes
3123 "commonTagsHandler" plugin hook. If processing an included topic,
3124 @processedTopics should be a list of topics already included, or in
3125 the process of being included.
3126
3127 Returns the text of the topic, after file inclusion, variable substitution,
3128 table-of-contents generation, and any plugin changes from commonTagsHandler.
3129
3130 rizwank 1.1 =cut
3131
3132 sub handleCommonTags
3133 {
3134 my( $text, $theTopic, $theWeb, @theProcessedTopics ) = @_;
3135
3136 # PTh 22 Jul 2000: added $theWeb for correct handling of %INCLUDE%, %SEARCH%
3137 if( !$theWeb ) {
3138 $theWeb = $webName;
3139 }
3140
3141 # TWiki Plugin Hook (for cache Plugins only)
3142 &TWiki::Plugins::beforeCommonTagsHandler( $text, $theTopic, $theWeb );
3143
3144 my @verbatim = ();
3145 $text = takeOutVerbatim( $text, \@verbatim );
3146
3147 # Escape rendering: Change " !%VARIABLE%" to " %<nop>VARIABLE%", for final " %VARIABLE%" output
3148 $text =~ s/(\s)\!\%([A-Z])/$1%<nop>$2/g;
3149
3150 # handle all preferences and internal tags (for speed: call by reference)
3151 rizwank 1.1 $includingWebName = $theWeb;
3152 $includingTopicName = $theTopic;
3153 &TWiki::Prefs::handlePreferencesTags( $text );
3154 handleInternalTags( $text, $theTopic, $theWeb );
3155
3156 # recursively process multiple embedded %INCLUDE% statements and prefs
3157 $text =~ s/%INCLUDE{(.*?)}%/&handleIncludeFile($1, $theTopic, $theWeb, \@verbatim, @theProcessedTopics )/ge;
3158
3159 # TWiki Plugin Hook
3160 &TWiki::Plugins::commonTagsHandler( $text, $theTopic, $theWeb, 0 );
3161
3162 # handle tags again because of plugin hook
3163 &TWiki::Prefs::handlePreferencesTags( $text );
3164 handleInternalTags( $text, $theTopic, $theWeb );
3165 $text =~ s/%INCLUDE{(.*?)}%/&handleIncludeFile($1, $theTopic, $theWeb, \@verbatim, @theProcessedTopics )/ge;
3166
3167 $text =~ s/%TOC{([^}]*)}%/&handleToc($text,$theTopic,$theWeb,$1)/ge;
3168 $text =~ s/%TOC%/&handleToc($text,$theTopic,$theWeb,"")/ge;
3169
3170 # Codev.FormattedSearchWithConditionalOutput: remove <nop> lines, possibly introduced by
3171 # SEARCHes with conditional CALC. This needs to be done after CALC and before table rendering
3172 rizwank 1.1 $text =~ s/^<nop>\r?\n//gm;
3173
3174 # Ideally would put back in getRenderedVersion rather than here which would save removing
3175 # it again! But this would mean altering many scripts to pass back verbatim
3176 $text = putBackVerbatim( $text, "verbatim", @verbatim );
3177
3178 # TWiki Plugin Hook (for cache Plugins only)
3179 &TWiki::Plugins::afterCommonTagsHandler( $text, $theTopic, $theWeb );
3180
3181 return $text;
3182 }
3183
3184 # =========================
3185 =pod
3186
3187 ---++ sub handleMetaTags ( $theWeb, $theTopic, $text, $meta, $isTopRev )
3188
3189 | TODO | move to Render.pm or Meta.pm of Forms.pm |
3190 | | used to render the non-active modes of META data (view, preview ...) |
3191 Not yet documented.
3192
3193 rizwank 1.1 =cut
3194
3195 sub handleMetaTags
3196 {
3197 my( $theWeb, $theTopic, $text, $meta, $isTopRev ) = @_;
3198
3199 $text =~ s/%META{\s*"form"\s*}%/&TWiki::Render::renderFormData( $theWeb, $theTopic, $meta )/ge; #this renders META:FORM and META:FIELD
3200 $text =~ s/%META{\s*"formfield"\s*(.*?)}%/&TWiki::Render::renderFormField( $meta, $1 )/ge; #TODO: what does this do? (is this the old forms system, and so can be deleted)
3201 $text =~ s/%META{\s*"attachments"\s*(.*)}%/&TWiki::Attach::renderMetaData( $theWeb,
3202 $theTopic, $meta, $1, $isTopRev )/ge; #renders attachment tables
3203 $text =~ s/%META{\s*"moved"\s*}%/&TWiki::Render::renderMoved( $theWeb, $theTopic, $meta )/ge; #render topic moved information
3204 $text =~ s/%META{\s*"parent"\s*(.*)}%/&TWiki::Render::renderParent( $theWeb, $theTopic, $meta, $1 )/ge; #render the parent information
3205
3206 $text = handleCommonTags( $text, $theTopic );
3207 $text = TWiki::Render::getRenderedVersion( $text, $theWeb );
3208
3209 return $text;
3210 }
3211
3212 =end twiki
3213
3214 rizwank 1.1 =cut
3215
3216 1;
|
Return to
TWiki.pm
CVS log
Up to [RizwankCVS] / geekymedia_web / twiki / lib