Index: tools/test/script_tests/oopsScriptTest.pm =================================================================== --- tools/test/script_tests/oopsScriptTest.pm (revision 1767) +++ tools/test/script_tests/oopsScriptTest.pm (working copy) @@ -43,13 +43,292 @@ my $web = "Sandbox"; my $topic = "AutoCreatedTopic$$"; -sub test_simple { +sub test_oopsaccesschange { my $this = shift; $this->compareOldAndNew("oops", $web, $topic, - "template=oopsrenameerr¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER"); + "template=oopsaccesschange¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); } -# Should test other parameters +sub test_oopsaccessgroup { + my $this = shift; + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsaccessgroup¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsaccessmanage { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsaccessmanage¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsaccessrename { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsaccessrename¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsaccessview { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsaccessview¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsattachnotopic { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsattachnotopic¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsauth { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsauth¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsbadcharset { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsbadcharset¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsbadpwformat { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsbadpwformat¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopschangepasswd { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopschangepasswd¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopscreatenewtopic { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopscreatenewtopic¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsempty { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsempty¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopslocked { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopslocked.pattern¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopslockedrename { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopslockedrename¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsmanage { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsmanage¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsmissing { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsmissing¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsmngcreateweb { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsmngcreateweb¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsmoveerr { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsmoveerr¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsnoformdef { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsnoformdef¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsnotwikiuser { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsnotwikiuser¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsnoweb { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsnoweb¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopspreview { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopspreview¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsregemail { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsregemail¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsregerr { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsregerr¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsregexist { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsregexist¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsregpasswd { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsregpasswd¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsregrequ { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsregrequ¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsregthanks { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsregthanks¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsregwiki { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsregwiki¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsremoveuserdone { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsremoveuserdone¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsrenameerr { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsrenameerr¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsrenamenotwikiword { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsrenamenotwikiword¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsresetpasswd { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsresetpasswd¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsrev { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsrev¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopssaveerr { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopssaveerr¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopssave { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopssave¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopssendmailerr { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopssendmailerr¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopstopicexists { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopstopicexists¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsuploadlimit { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsuploadlimit¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopsupload { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopsupload¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + +sub test_oopswrongpassword { + my $this = shift; + + $this->compareOldAndNew("oops", $web, $topic, + "template=oopswrongpassword¶m1=EINE¶m2=ZWEI¶m3=DREI¶m1=VIER", 1); +} + + 1; Index: tools/test/script_tests/ScriptTestFixture.pm =================================================================== --- tools/test/script_tests/ScriptTestFixture.pm (revision 1767) +++ tools/test/script_tests/ScriptTestFixture.pm (working copy) @@ -8,7 +8,8 @@ package ScriptTestFixture; use base qw(Test::Unit::TestCase); -use vars qw($urlroot $old $new $olddata $newdata $oldpub $newpub); +use vars qw($urlroot $old $new $olddata $newdata + $oldpub $newpub $user $pass $wget $ab); BEGIN { ############################################################## @@ -16,12 +17,16 @@ # Note that for correct operation, the runner has to be able to delete # files from the data areas belonging to the two test installations $urlroot = "http://localhost"; -$old = "twiki"; -$new = "alphaplus"; +$old = "svn"; +$new = "mine"; $olddata = "/windows/C/twiki/data"; $newdata = $olddata; $oldpub = "/windows/C/twiki/pub"; $newpub = $oldpub; +$user = "TWikiGuest"; +$pass = ""; +$wget = "/usr/bin/wget"; +$ab = "/usr/sbin/ab"; ############################################################# print STDERR "Sanitising fixtures.....\n"; @@ -46,8 +51,12 @@ $opts = ""; } #print "WGet $urlroot/$install/bin/$func/$web/$topic$opts\n"; - my $result = `wget -q -O - $urlroot/$install/bin/$func/$web/$topic$opts`; + my $result = `$wget -q -O - $urlroot/$install/bin/$func/$web/$topic$opts`; $this->assert(!$?, "WGet $urlroot/$install/bin/$func/$web/$topic$opts failed, $result"); + if ( $func ne "oops" ) { + $this->assert_does_not_match(qr/\(oops\)/, $result, "FAILED RESULT\n$result"); + } + $result =~ s/\/$install\//\/URL\//g; $result =~ s/\?t=[0-9]+\b/?t=0/go; $result =~ s/-\s+\d+:\d+\s+-/- DATE -/go; @@ -68,10 +77,10 @@ # Compare the results of the same URL in old and new sub compareOldAndNew { - my ($this, $func, $web, $topic, $opts) = @_; + my ($this, $func, $web, $topic, $opts, $ignorenl) = @_; my $old = $this->getOld($func, $web, $topic, $opts); my $new = $this->getNew($func, $web, $topic, $opts); - $this->diff($old, $new); + $this->diff($old, $new, $ignorenl); } sub oldLocked { @@ -86,11 +95,13 @@ # Diff two blocks of text sub diff { - my ($this, $old, $new) = @_; + my ($this, $old, $new, $ignorenl) = @_; open(WF,">/tmp/old") || die; + $old =~ s/\n/ /g if ( $ignorenl ); print WF $old; close(WF) || die; open(WF,">/tmp/new") || die; + $new =~ s/\n/ /g if ( $ignorenl ); print WF $new; close(WF) || die; print STDERR `diff -b -B -w -u /tmp/old /tmp/new`; Index: tools/test/script_tests/README =================================================================== --- tools/test/script_tests/README (revision 1767) +++ tools/test/script_tests/README (working copy) @@ -1,6 +1,9 @@ Script Tests ============ +- YOU MUST CONFIGURE THE PATHS IN ScriptTestFixture.pm FOR YOUR CONFIGURATION +- the command is perl TestRunner.pl CGIScriptSuite.pm + The test suite CGIScriptsSuite.pm is a Test::Unit suite designed to exercise the CGI scripts in TWiki, and is intended primarily to support refactorings. It does this by comparing script results from one server with results from the same script on another, on the assumption that the two servers are standard TWiki installations and both have identical data and pub areas (they can even share the same data and pub if necessary). The general idea is that you create two CVS checkout areas, keeping one on the latest proven code and the other on bleeding edge code. Running the suite will tell you what you have changed in the system from a user perspective. Ultimately there should be an automatic script that maintains these areas, runs the tests, and mails the results to the core team. @@ -23,15 +26,3 @@ rm -rf /Sandbox/AutoCreated*.* for both old and new installations. Please don't complain at me until you've tried this and re-run the tests. - -Test Status ------------ -The following tests are known to FAIL in some respect: - -viewfile - fails in old code as well -save - fails in old code as well -upload - fails in old code as well - -In each case these failures are due to script errors that existed before the refactorings - and therefore the tests - were done. AFAICT they are genuine errors. - -It will take time before all the tests pass reliably. Index: tools/test/script_tests/CGIScriptsSuite.pm =================================================================== --- tools/test/script_tests/CGIScriptsSuite.pm (revision 1767) +++ tools/test/script_tests/CGIScriptsSuite.pm (working copy) @@ -7,6 +7,8 @@ sub name { 'CGIScripts' }; -sub include_tests { qw(oopsScriptTest viewScriptTest editScriptTest previewScriptTest saveScriptTest renameScriptTest attachScriptTest rdiffScriptTest changesScriptTest statisticsScriptTest viewfileScriptTest uploadScriptTest manageScriptTest ) }; +sub include_tests { + qw(oopsScriptTest viewScriptTest editScriptTest previewScriptTest saveScriptTest renameScriptTest attachScriptTest rdiffScriptTest changesScriptTest statisticsScriptTest viewfileScriptTest uploadScriptTest manageScriptTest ); +}; 1; Index: tools/test/script_tests/viewScriptTest.pm =================================================================== --- tools/test/script_tests/viewScriptTest.pm (revision 1767) +++ tools/test/script_tests/viewScriptTest.pm (working copy) @@ -43,21 +43,31 @@ # $this->SUPER::tear_down(); #} -sub test_simple { +sub test_simple1 { my $this = shift; - $this->compareOldAndNew("view", "TWiki", "TextFormattingRules", undef); + $this->compareOldAndNew("view", "TWiki", "WhatIsWikiWiki", undef, 1); } -sub test_raw { +sub test_simple2 { my $this = shift; - $this->compareOldAndNew("view", "TWiki", "TextFormattingFAQ", "raw=on"); + $this->compareOldAndNew("view", "TWiki", "TextFormattingRules", undef, 1); } -sub test_skinned { +sub ntest_raw { my $this = shift; - $this->compareOldAndNew("view", "TWiki", "TextFormattingRules", "skin=print"); + $this->compareOldAndNew("view", "TWiki", "TextFormattingFAQ", "raw=on", 0); } +sub test_print_skinned { + my $this = shift; + $this->compareOldAndNew("view", "TWiki", "TextFormattingRules", "skin=print", 1); +} + +sub test_dragon_skinned { + my $this = shift; + $this->compareOldAndNew("view", "TWiki", "TextFormattingRules", "skin=dragon", 1); +} + # Should test other view parameters 1; Index: lib/TWiki.pm =================================================================== --- lib/TWiki.pm (revision 1767) +++ lib/TWiki.pm (working copy) @@ -27,15 +27,6 @@ # custom rendering rules. # - Upgrading TWiki is easy as long as you only customize DefaultPlugin.pm. # - Check web server error logs for errors, i.e. % tail /var/log/httpd/error_log -# -# 20000501 Kevin Kinnell : changed beta0404 to have many new search -# capabilities. This file had a new hash added -# for month name-to-number look-ups, a slight -# change in the parameter list for the search -# script call in &handleSearchWeb, and a new -# sub -- &revDate2EpSecs -- for calculating the -# epoch seconds from a rev date (the only way -# to sort dates.) =begin twiki @@ -45,17 +36,12 @@ =cut - package TWiki; use strict; -use Time::Local; # Added for revDate2EpSecs -use Cwd qw( cwd ); # Added for getTWikiLibDir - require 5.005; # For regex objects and internationalisation -# =========================== # TWiki config variables from TWiki.cfg: use vars qw( $defaultUserName $wikiHomeUrl $defaultUrlHost @@ -86,18 +72,17 @@ $upperNational $lowerNational ); -# TWiki::Store config: +# TWiki::Store config from TWiki.cfg use vars qw( $rcsDir $rcsArg $nullDev $endRcsCmd $storeTopicImpl $keywordMode $storeImpl @storeSettings ); -# TWiki::Search config: +# TWiki::Search config from TWiki.cfg use vars qw( $cmdQuote $lsCmd $egrepCmd $fgrepCmd ); -# =========================== # Global variables # Refactoring Note: these are split up by "site" globals and "request" @@ -109,97 +94,286 @@ # Misc. Globals use vars qw( - @isoMonth @weekDay %userToWikiList %wikiToUserList $wikiversion - $TranslationToken %mon2num $viewScript $twikiLibDir $formatVersion - @publicWebList %regex - ); + @isoMonth @weekDay $wikiversion + $TranslationToken $twikiLibDir $formatVersion + @publicWebList + %regex + %staticInternalTags + %dynamicInternalTags + ); # Internationalisation (I18N) setup: use vars qw( - $siteCharset $useUnicode $siteLang $siteFullLang $urlCharEncoding - ); + $siteCharset $useUnicode $siteLang $siteFullLang $urlCharEncoding + ); -# --------------------------- # Per-Request "Global" Variables use vars qw( - $webName $topicName $includingWebName $includingTopicName - $userName $wikiName $wikiUserName $urlHost - $debugUserTime $debugSystemTime $script - $pageMode $readTopicPermissionFailed $cgiQuery $basicInitDone - ); - -# =========================== -# Exports + $webName $topicName + $userName $wikiName $wikiUserName $urlHost + $debugUserTime $debugSystemTime $script + $readTopicPermissionFailed $cgiQuery $basicInitDone + %sessionInternalTags + %preferencesTags + ); -# The Render module needs to access a lot of configuration flags from -# TWiki.cfg, so we export them here. We also export the %regex hash -# and a few other useful constants. - -use vars qw(@EXPORT_OK %EXPORT_TAGS @ISA); - -BEGIN { - require Exporter; - @ISA = qw(Exporter); - - %EXPORT_TAGS = ( - renderflags => [qw($siteLang $securityFilter $twikiWebname $mainWebname - $mainTopicname $scriptSuffix $doPluralToSingular - $dispScriptUrlPath $dispViewPath - )] - ); - - @EXPORT_OK = qw(%regex $TranslationToken); - Exporter::export_ok_tags('renderflags'); -} - -# =========================== # TWiki version: $wikiversion = '20 Oct 2004 $Rev$'; -# =========================== -# Key Global variables, required for writeDebug +# Key Global variables # (new variables must be declared in "use vars qw(..)" above) @isoMonth = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ); @weekDay = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"); -{ - my $count = 0; - %mon2num = map { $_ => $count++ } @isoMonth; +# Run-time locale setup - If $useLocale is set, this function parses +# $siteLocale from TWiki.cfg and passes it to the POSIX::setLocale +# function to change TWiki's operating environment. +# +# SMELL: mod_perl compatibility note: If TWiki is running under Apache, +# won't this play with the Apache process's locale settings too? +# What effects would this have? +# +# Note that 'use locale' must be done in BEGIN block for regexes and sorting to +# work properly, although regexes can still work without this in +# 'non-locale regexes' mode (see _setupRegexes). + +sub _setupLocale { + $siteCharset = 'ISO-8859-1'; # Default values if locale mis-configured + $siteLang = 'en'; + $siteFullLang = 'en-us'; + + if ( $useLocale ) { + if ( not defined $siteLocale or $siteLocale !~ /[a-z]/i ) { + die "\$useLocale set but \$siteLocale $siteLocale unset or has no alphabetic characters"; + } + # Extract the character set from locale and use in HTML templates + # and HTTP headers + $siteLocale =~ m/\.([a-z0-9_-]+)$/i; + $siteCharset = $1 if defined $1; + $siteCharset =~ s/^utf8$/utf-8/i; # For convenience, avoid overrides + $siteCharset =~ s/^eucjp$/euc-jp/i; + + # Override charset - used when locale charset not supported by Perl + # conversion modules + $siteCharset = $siteCharsetOverride || $siteCharset; + $siteCharset = lc $siteCharset; + + # Extract the default site language - ignores '@euro' part of + # 'fr_BE@euro' type locales. + $siteLocale =~ m/^([a-z]+)_([a-z]+)/i; + $siteLang = (lc $1) if defined $1; # Not including country part + $siteFullLang = (lc "$1-$2" ) # Including country part + if defined $1 and defined $2; + + # Set environment variables for grep + $ENV{'LC_CTYPE'}= $siteLocale; + + # Load POSIX for I18N support. Eval because otherwise + # it gets compiled even if we don't have a locale + eval 'require POSIX; import POSIX qw( locale_h LC_CTYPE );'; + + # Set new locale + my $locale = setlocale(&LC_CTYPE, $siteLocale); + } + $staticInternalTags{CHARSET} = $siteCharset; + $staticInternalTags{SHORTLANG} = $siteLang; + $staticInternalTags{LANG} = $siteFullLang; } -# =========================== -# Read the configuration file at compile time in order to set locale +# Set up pre-compiled regexes for use in rendering. All regexes with +# unchanging variables in match should use the '/o' option, even if not in a +# loop. +sub _setupRegexes { + $regex{linkProtocolPattern} = "(file|ftp|gopher|https|http|irc|news|nntp|telnet)"; + + # Header patterns based on '+++'. The '###' are reserved for numbered + # headers + # '---++ Header', '---## Header' + $regex{headerPatternDa} = '^---+(\++|\#+)\s*(.+)\s*$'; + # ' ++ Header', ' + Header' + $regex{headerPatternSp} = '^\t(\++|\#+)\s*(.+)\s*$'; + # '
Header
+ $regex{headerPatternHt} = '^\s*(.+?)\s*'; + # '---++!! Header' or '---++ Header %NOTOC% ^top' + $regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)'; + + # Build up character class components for use in regexes. + # Depends on locale mode and Perl version, and finally on + # whether locale-based regexes are turned off. + my ( $ua, $la, $num, $ma ); + if ( not $useLocale or $] < 5.006 or not $localeRegexes ) { + # No locales needed/working, or Perl 5.005_03 or lower, so just use + # any additional national characters defined in TWiki.cfg + $ua = "A-Z$upperNational"; + $la = "a-z$lowerNational"; + $num = '\d'; + $ma = "$ua$la"; + } else { + # Perl 5.006 or higher with working locales + $ua = "[:upper:]"; + $la = "[:lower:]"; + $num = "[:digit:]"; + $ma = "[:alpha:]"; + } + $regex{upperAlpha} = $ua; + $regex{lowerAlpha} = $la; + $regex{numeric} = $num; + $regex{mixedAlpha} = $ma; + + my $man = "$ma$num"; + $regex{mixedAlphaNum} = $man; + my $lan = "$la$num"; + $regex{lowerAlphaNum} = $lan; + my $uan = "$ua$num"; + $regex{upperAlphaNum} = $uan; + + # Compile regexes for efficiency and ease of use + # Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl + # book at http://regex.info/. + + # TWiki concept regexes + $regex{wikiWordRegex} = qr/[$ua]+[$la]+[$ua]+[$man]*/o; + $regex{webNameRegex} = qr/[$ua]+[$man]*/o; + $regex{defaultWebNameRegex} = qr/_[${man}_]+/o; + $regex{anchorRegex} = qr/\#[${man}_]+/o; + $regex{abbrevRegex} = qr/[$ua]{3,}s?\b/o; + + # Simplistic email regex, e.g. for WebNotify processing - no i18n + # characters allowed + $regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_]+\@[A-Za-z0-9\.\-]+)/; + + # Filename regex, for attachments + $regex{filenameRegex} = qr/[$man\.]+/o; + + # Multi-character alpha-based regexes + $regex{mixedAlphaNumRegex} = qr/[$man]*/o; + + # Character encoding regexes + + # 7-bit ASCII only + $regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o; + + # Regex to match only a valid UTF-8 character, taking care to avoid + # security holes due to overlong encodings by excluding the relevant + # gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode + # Encodings section. Tested against Markus Kuhn's UTF-8 test file + # at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt. + $regex{validUtf8CharRegex} = qr{ + # Single byte - ASCII + [\x00-\x7F] + | + + # 2 bytes + [\xC2-\xDF][\x80-\xBF] + | + + # 3 bytes + + # Avoid illegal codepoints - negative lookahead + (?!\xEF\xBF[\xBE\xBF]) + + # Match valid codepoints + (?: + ([\xE0][\xA0-\xBF])| + ([\xE1-\xEC\xEE-\xEF][\x80-\xBF])| + ([\xED][\x80-\x9F]) + ) + [\x80-\xBF] + | + + # 4 bytes + (?: + ([\xF0][\x90-\xBF])| + ([\xF1-\xF3][\x80-\xBF])| + ([\xF4][\x80-\x8F]) + ) + [\x80-\xBF][\x80-\xBF] + }xo; + + $regex{validUtf8StringRegex} = + qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo; + +} + +sub _setupHandlerMaps { + # When processTags matches a tag it looks up the + # tag in the tables below, and either does a literal + # expansion or calls the relevant _handle method for + # the tag. + %staticInternalTags = + ( + ENDSECTION => "", + HOMETOPIC => $mainTopicname, + MAINWEB => $mainWebname, + NOTIFYTOPIC => $notifyTopicname, + PUBURLPATH => $pubUrlPath, + SCRIPTSUFFIX => $scriptSuffix, + SCRIPTURLPATH => $dispScriptUrlPath, + SECTION => "", + STARTINCLUDE => "", + STATISTICSTOPIC => $statisticsTopicname, + STOPINCLUDE => "", + TWIKIWEB => $twikiWebname, + WEBPREFSTOPIC => $webPrefsTopicname, + WIKIHOMEURL => $wikiHomeUrl, + WIKIPREFSTOPIC => $wikiPrefsTopicname, + WIKITOOLNAME => $wikiToolName, + WIKIUSERSTOPIC => $wikiUsersTopicname, + WIKIVERSION => $wikiversion, + ); + + %dynamicInternalTags = + ( + ATTACHURLPATH => \&_handleATTACHURLPATH, + DATE => \&_handleDATE, + DISPLAYTIME => \&_handleDISPLAYTIME, + ENCODE => \&_handleENCODE, + FORMFIELD => \&_handleFORMFIELD,, + GMTIME => \&_handleGMTIME, + HTTP_HOST => \&_handleHTTP_HOST, + ICON => \&_handleICON, + INCLUDE => \&_handleINCLUDE, + INTURLENCODE => \&_handleINTURLENCODE, + METASEARCH => \&_handleMETASEARCH, + PLUGINVERSION => \&_handlePLUGINVERSION, + RELATIVETOPICPATH => \&_handleRELATIVETOPICPATH, + REMOTE_ADDR => \&_handleREMOTE_ADDR, + REMOTE_PORT => \&_handleREMOTE_PORT, + REMOTE_USER => \&_handleREMOTE_USER, + REVINFO => \&_handleREVINFO, + SEARCH => \&_handleSEARCH, + SERVERTIME => \&_handleSERVERTIME, + SPACEDTOPIC => \&_handleSPACEDTOPIC, + "TMPL:P" => \&_handleTMPLP,, + TOPICLIST => \&_handleTOPICLIST, + URLENCODE => \&_handleENCODE, + URLPARAM => \&_handleURLPARAM, + VAR => \&_handleVAR, + WEBLIST => \&_handleWEBLIST, + ); +} + BEGIN { + # Read the configuration file at compile time in order to set locale do "TWiki.cfg"; - # Do a dynamic 'use locale' for this module if( $useLocale ) { - require locale; - import locale (); + eval 'require locale; import locale ();'; } + + _setupHandlerMaps(); + _setupLocale(); + _setupRegexes(); } -sub writeDebug; -sub writeWarning; - - -# =========================== -# use TWiki and other modules use TWiki::Prefs; # preferences -use TWiki::Search; # search engine use TWiki::Access; # access control -use TWiki::Meta; # Meta class - topic meta data use TWiki::Store; # file I/O and rcs related functions -use TWiki::Attach; # file attachment functions -use TWiki::Form; # forms for topics -use TWiki::Func; # official TWiki functions for plugins -use TWiki::Plugins; # plugins handler #AS -use TWiki::Net; # SMTP, get URL +use TWiki::Plugins; # plugins handler use TWiki::User; -use TWiki::Render; +use TWiki::Render; # HTML generation +use TWiki::Templates; # TWiki template language - -# =========================== # Other Global variables # Token character that must not occur in any normal text - converted @@ -210,16 +384,7 @@ # initialize not called. $cgiQuery = 0; @publicWebList = (); -$viewScript = "view"; -$regex{linkProtocolPattern} = "(file|ftp|gopher|http|https|irc|news|nntp|telnet)"; - -# Header patterns based on '+++'. The '###' are reserved for numbered headers -$regex{headerPatternDa} = '^---+(\++|\#+)\s*(.+)\s*$'; # '---++ Header', '---## Header' -$regex{headerPatternSp} = '^\t(\++|\#+)\s*(.+)\s*$'; # ' ++ Header', ' + Header' -$regex{headerPatternHt} = '^\s*(.+?)\s*'; # '
Header
-$regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)'; # '---++!! Header' or '---++ Header %NOTOC% ^top' - $debugUserTime = 0; $debugSystemTime = 0; @@ -227,88 +392,78 @@ $basicInitDone = 0; # basicInitialize not yet done -$pageMode = 'html'; # Default is to render as HTML +# Concatenates date, time, and $text to a log file. +# The logfilename can optionally use a %DATE% variable to support +# logs that are rotated once a month. +# | =$log= | Base filename for log file | +# | =$message= | Message to print | +sub _writeReport { + my ( $log, $message ) = @_; -=pod - ----++ writeWarning( $text ) - -Prints date, time, and contents $text to $warningFilename, typically -'warnings.txt'. Use for warnings and errors that may require admin -intervention. Not using Store::writeLog; log file is more of an audit/usage -file. Use this for defensive programming warnings (e.g. assertions). - -=cut - -sub writeWarning { - my( $text ) = @_; - if( $warningFilename ) { + if ( $log ) { my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime( time() ); - my( $tmon) = $isoMonth[$mon]; + my $yearmonth = sprintf( "%.4u%.2u", $year, $mon+1 ); + $log =~ s/%DATE%/$yearmonth/go; + + my( $tmon) = $isoMonth[$mon]; $year = sprintf( "%.4u", $year + 1900 ); my $time = sprintf( "%.2u ${tmon} %.2u - %.2u:%.2u", - $mday, $year, $hour, $min ); + $mday, $year, $hour, $min ); - if( open( FILE, ">>$warningFilename" ) ) { - print FILE "$time $text\n"; + if( open( FILE, ">>$log" ) ) { + print FILE "| $time | $message\n"; close( FILE ); } else { - print STDERR "Couldn't write \"$text\" to $warningFilename: $!\n"; + print STDERR "Couldn't write \"$message\" to $log: $!\n"; } } } =pod ----++ writeDebug( $text ) +---++ sub writeLog ( $action, $webTopic, $extra, $user ) -Prints date, time, and contents of $text to $debugFilename, typically -'debug.txt'. Use for debugging messages. +Write the log for an event to the logfile =cut -sub writeDebug { - my( $text ) = @_; - - my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime( time() ); - my( $tmon) = $isoMonth[$mon]; - $year = sprintf( "%.4u", $year + 1900 ); - my $time = sprintf( "%.2u ${tmon} %.2u - %.2u:%.2u", $mday, $year, $hour, $min ); +sub writeLog +{ + my( $action, $webTopic, $extra, $user ) = @_; - if( open( FILE, ">>$debugFilename" ) ) { - print FILE "$time $text\n"; - close( FILE ); - } else { - print STDERR "Couldn't write \"$text\" to $debugFilename: $!\n"; - } + my $wuserName = $user || $userName; + $wuserName = TWiki::User::userToWikiName( $wuserName ); + my $remoteAddr = $ENV{'REMOTE_ADDR'} || ""; + my $text = "$wuserName | $action | $webTopic | $extra | $remoteAddr |"; + + _writeReport( $logFilename, $text ); } =pod ----++ writeDebugTimes( $text ) +---++ writeWarning( $text ) -Dumps user and system time spent, with deltas from last call, followed -by contents of $text, to debug log using writeDebug above. Use for -performance monitoring/debugging. +Prints date, time, and contents $text to $warningFilename, typically +'warnings.txt'. Use for warnings and errors that may require admin +intervention. Use this for defensive programming warnings (e.g. assertions). =cut -sub writeDebugTimes -{ - my( $text ) = @_; +sub writeWarning { + _writeReport( $warningFilename, @_ ); +} - if( ! $debugUserTime ) { - writeDebug( "=== sec (delta:) sec (delta:) sec function:" ); - } - my( $puser, $psystem, $cuser, $csystem ) = times(); - my $duser = $puser - $debugUserTime; - my $dsystem = $psystem - $debugSystemTime; - my $times = sprintf( "usr %1.2f (%1.2f), sys %1.2f (%1.2f), sum %1.2f", - $puser, $duser, $psystem, $dsystem, $puser+$psystem ); - $debugUserTime = $puser; - $debugSystemTime = $psystem; +=pod - writeDebug( "==> $times, $text" ); +---++ writeDebug( $text ) + +Prints date, time, and contents of $text to $debugFilename, typically +'debug.txt'. Use for debugging messages. + +=cut + +sub writeDebug { + _writeReport( $debugFilename, @_ ); } =pod @@ -328,26 +483,20 @@ =cut -sub initialize -{ +sub initialize { my ( $thePathInfo, $theRemoteUser, $theTopic, $theUrl, $theQuery ) = @_; - - if( not $basicInitDone ) { - basicInitialize(); - } - ##writeDebug( "\n---------------------------------" ); + basicInitialize() unless( $basicInitDone ); $cgiQuery = $theQuery; - - # Initialise vars here rather than at start of module, + + # Initialise per-session vars here rather than at start of module, # so compatible with modPerl @publicWebList = (); - &TWiki::Store::initialize(); + TWiki::Store::initialize(); + TWiki::User::initialize(); - &TWiki::User::initialize(); - - # Make %ENV safer for CGI + # Make %ENV safer, preventing hijack of the search path if( $safeEnvPath ) { $ENV{'PATH'} = $safeEnvPath; } @@ -357,7 +506,7 @@ getTWikiLibDir(); # initialize access control - &TWiki::Access::initializeAccess(); + TWiki::Access::initializeAccess(); $readTopicPermissionFailed = ""; # Will be set to name(s) of topic(s) that can't be read # initialize $webName and $topicName from URL @@ -385,7 +534,6 @@ # invalid PATH_INFO is often a full path starting with '/cgi-bin/...'. my $cgiScriptName = $ENV{'SCRIPT_NAME'} || ""; $thePathInfo =~ s!$cgiScriptName/!/!i; - ## writeDebug( "===== thePathInfo after cleanup = $thePathInfo" ); # Get the web and topic names from PATH_INFO if( $thePathInfo =~ /\/(.*)[\.\/](.*)/ ) { @@ -401,11 +549,11 @@ # Refuse to work with character sets that allow TWiki syntax # to be recognised within multi-byte characters. Only allow 'oops' # page to be displayed (redirect causes this code to be re-executed). - if ( invalidSiteCharset() and $theUrl !~ m!$scriptUrlPath/oops! ) { - writeWarning "Cannot use this multi-byte encoding ('$siteCharset') as site character encoding"; - writeWarning "Please set a different character encoding in the \$siteLocale setting in TWiki.cfg."; - my $url = &TWiki::getOopsUrl( $webName, $topicName, "oopsbadcharset" ); - print $cgiQuery->redirect( $url ); + if ( _invalidSiteCharset() and $theUrl !~ m!$scriptUrlPath/oops! ) { + writeWarning( "Cannot use this multi-byte encoding ('$siteCharset') as site character encoding" ); + writeWarning( "Please set a different character encoding in the \$siteLocale setting in TWiki.cfg." ); + my $url = TWiki::getOopsUrl( $webName, $topicName, "oopsbadcharset" ); + print $cgiQuery->redirect( $url ); return; } @@ -420,8 +568,6 @@ $webName =~ s/$securityFilter//go; $webName =~ /(.*)/; $webName = $1 || $mainWebname; # untaint variable - $includingTopicName = $topicName; - $includingWebName = $webName; # initialize $urlHost and $scriptUrlPath if( ( $theUrl ) && ( $theUrl =~ m!^([^:]*://[^/]*)(.*)/.*$! ) && ( $2 ) ) { @@ -435,42 +581,45 @@ } else { $urlHost = $defaultUrlHost; } - # PTh 15 Jul 2001: Removed init of $scriptUrlPath based on $theUrl because - # $theUrl has incorrect URI after failed authentication # initialize preferences, first part for site and web level - &TWiki::Prefs::initializePrefs( $webName ); + TWiki::Prefs::initializePrefs( $webName ); - # initialize user name and user to WikiName list - userToWikiListInit(); if( !$disableAllPlugins ) { - # Early plugin initialization, allow plugins like SessionPlugin + # Early plugin initialization, allow plugins like SessionPlugin # to set the user. This must be done before preferences are set, # as we need to get user preferences - $userName = &TWiki::Plugins::initialize1( $topicName, $webName, $theRemoteUser, $theUrl, $thePathInfo ); + $userName = TWiki::Plugins::initialize1( $topicName, $webName, $theRemoteUser, $theUrl, $thePathInfo ); } - $wikiName = userToWikiName( $userName, 1 ); # i.e. "JonDoe" - $wikiUserName = userToWikiName( $userName ); # i.e. "Main.JonDoe" + $wikiName = TWiki::User::userToWikiName( $userName, 1 ); # i.e. "JonDoe" + $wikiUserName = TWiki::User::userToWikiName( $userName ); # i.e. "Main.JonDoe" + $sessionInternalTags{USERNAME} = $userName; + $sessionInternalTags{WIKINAME} = $wikiName; + $sessionInternalTags{WIKIUSERNAME} = $wikiUserName; + $sessionInternalTags{BASEWEB} = $webName; + $sessionInternalTags{BASETOPIC} = $topicName; + $sessionInternalTags{INCLUDINGTOPIC} = $topicName; + $sessionInternalTags{INCLUDINGWEB} = $webName; + $sessionInternalTags{ATTACHURL} = "$urlHost%ATTACHURLPATH%"; + $sessionInternalTags{PUBURL} = "$urlHost$pubUrlPath"; + $sessionInternalTags{SCRIPTURL} = "$urlHost$dispScriptUrlPath"; + # initialize preferences, second part for user level - &TWiki::Prefs::initializeUserPrefs( $wikiUserName ); + TWiki::Prefs::initializeUserPrefs( $wikiUserName ); - # some remaining init - $viewScript = "view"; - if( ( $ENV{'SCRIPT_NAME'} ) && ( $ENV{'SCRIPT_NAME'} =~ /^.*\/viewauth$/ ) ) { - # Needed for TOC - $viewScript = "viewauth"; - } - TWiki::Render::initialize(); -#AS if( !$disableAllPlugins ) { # Normal plugin initialization - userName is known and preferences available - &TWiki::Plugins::initialize2( $topicName, $webName, $userName ); + TWiki::Plugins::initialize2( $topicName, $webName, $userName ); } -#/AS + # Assumes all preferences values are set by now, which may well be false! + # It would be better to get the Prefs module to maintain this + # hash. + TWiki::Prefs::loadHash( \%preferencesTags ); + return ( $topicName, $webName, $scriptUrlPath, $userName, $dataDir ); } @@ -478,292 +627,108 @@ ---++ basicInitialize() -Sets up POSIX locale and precompiled regexes - for use from scripts -that handle multiple webs (e.g. mailnotify) and need regexes or -isWebName/isWikiName to work before the per-web initialize() is called. +Sets up basic stuff - for use from scripts +that require the BEGIN block of this class to be +executed e.g. mailnotify and need regexes or +isWebName/isWikiWord to work before the per-web initialize() is called. Also called from initialize() if not necessary beforehand. =cut sub basicInitialize() { - # Set up locale for internationalisation and pre-compile regexes - setupLocale(); - setupRegexes(); - $basicInitDone = 1; } -=pod - ----++ setupLocale() - -Run-time locale setup - If $useLocale is set, this function parses $siteLocale -from TWiki.cfg and passes it to the POSIX::setLocale function to change TWiki's -operating environment. - -mod_perl compatibility note: If TWiki is running under Apache, won't this play -with the Apache process's locale settings too? What effects would this have? - -Note that 'use locale' must be done in BEGIN block for regexes and sorting to -work properly, although regexes can still work without this in -'non-locale regexes' mode (see setupRegexes routine). - -=cut - -sub setupLocale { - - $siteCharset = 'ISO-8859-1'; # Default values if locale mis-configured - $siteLang = 'en'; - $siteFullLang = 'en-us'; - - if ( $useLocale ) { - if ( not defined $siteLocale or $siteLocale !~ /[a-z]/i ) { - writeWarning "Locale $siteLocale unset or has no alphabetic characters"; - return; - } - # Extract the character set from locale and use in HTML templates - # and HTTP headers - $siteLocale =~ m/\.([a-z0-9_-]+)$/i; - $siteCharset = $1 if defined $1; - $siteCharset =~ s/^utf8$/utf-8/i; # For convenience, avoid overrides - $siteCharset =~ s/^eucjp$/euc-jp/i; - - # Override charset - used when locale charset not supported by Perl - # conversion modules - $siteCharset = $siteCharsetOverride || $siteCharset; - $siteCharset = lc $siteCharset; - - # Extract the default site language - ignores '@euro' part of - # 'fr_BE@euro' type locales. - $siteLocale =~ m/^([a-z]+)_([a-z]+)/i; - $siteLang = (lc $1) if defined $1; # Not including country part - $siteFullLang = (lc "$1-$2" ) # Including country part - if defined $1 and defined $2; - - # Set environment variables for grep - $ENV{'LC_CTYPE'}= $siteLocale; - - # Load POSIX for I18N support - require POSIX; - import POSIX qw( locale_h LC_CTYPE ); - - # Set new locale - my $locale = setlocale(&LC_CTYPE, $siteLocale); - ##writeDebug "New locale is $locale"; - } -} - -=pod - ----++ setupRegexes() - -Set up pre-compiled regexes for use in rendering. All regexes with -unchanging variables in match should use the '/o' option, even if not in a -loop, to help mod_perl, where the same code can be executed many times -without recompilation. - -=cut - -sub setupRegexes { - - # Build up character class components for use in regexes. - # Depends on locale mode and Perl version, and finally on - # whether locale-based regexes are turned off. - if ( not $useLocale or $] < 5.006 or not $localeRegexes ) { - # No locales needed/working, or Perl 5.005_03 or lower, so just use - # any additional national characters defined in TWiki.cfg - $regex{upperAlpha} = "A-Z$upperNational"; - $regex{lowerAlpha} = "a-z$lowerNational"; - $regex{numeric} = '\d'; - $regex{mixedAlpha} = "$regex{upperAlpha}$regex{lowerAlpha}"; - } else { - # Perl 5.6 or higher with working locales - $regex{upperAlpha} = "[:upper:]"; - $regex{lowerAlpha} = "[:lower:]"; - $regex{numeric} = "[:digit:]"; - $regex{mixedAlpha} = "[:alpha:]"; - } - $regex{mixedAlphaNum} = "$regex{mixedAlpha}$regex{numeric}"; - $regex{lowerAlphaNum} = "$regex{lowerAlpha}$regex{numeric}"; - - # Compile regexes for efficiency and ease of use - # Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl - # book at http://regex.info/. - - # TWiki concept regexes - $regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlpha}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/; - $regex{webNameRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/; - $regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/; - $regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/; - $regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/; - - # Simplistic email regex, e.g. for WebNotify processing - no i18n - # characters allowed - $regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_]+\@[A-Za-z0-9\.\-]+)/; - - # Filename regex, for attachments - $regex{filenameRegex} = qr/[$regex{mixedAlphaNum}\.]+/; - - # Single-character alpha-based regexes - $regex{singleUpperAlphaRegex} = qr/[$regex{upperAlpha}]/; - $regex{singleLowerAlphaRegex} = qr/[$regex{lowerAlpha}]/; - $regex{singleUpperAlphaNumRegex} = qr/[$regex{upperAlpha}$regex{numeric}]/; - $regex{singleMixedAlphaNumRegex} = qr/[$regex{upperAlpha}$regex{lowerAlpha}$regex{numeric}]/; - - $regex{singleMixedNonAlphaRegex} = qr/[^$regex{upperAlpha}$regex{lowerAlpha}]/; - $regex{singleMixedNonAlphaNumRegex} = qr/[^$regex{upperAlpha}$regex{lowerAlpha}$regex{numeric}]/; - - # Multi-character alpha-based regexes - $regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/; - - # Character encoding regexes - - # 7-bit ASCII only - $regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/; - - # Regex to match only a valid UTF-8 character, taking care to avoid - # security holes due to overlong encodings by excluding the relevant - # gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode - # Encodings section. Tested against Markus Kuhn's UTF-8 test file - # at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt. - $regex{validUtf8CharRegex} = qr{ - # Single byte - ASCII - [\x00-\x7F] - | - - # 2 bytes - [\xC2-\xDF][\x80-\xBF] - | - - # 3 bytes - - # Avoid illegal codepoints - negative lookahead - (?!\xEF\xBF[\xBE\xBF]) - - # Match valid codepoints - (?: - ([\xE0][\xA0-\xBF])| - ([\xE1-\xEC\xEE-\xEF][\x80-\xBF])| - ([\xED][\x80-\x9F]) - ) - [\x80-\xBF] - | - - # 4 bytes - (?: - ([\xF0][\x90-\xBF])| - ([\xF1-\xF3][\x80-\xBF])| - ([\xF4][\x80-\x8F]) - ) - [\x80-\xBF][\x80-\xBF] - }x; - - $regex{validUtf8StringRegex} = qr/^ (?: $regex{validUtf8CharRegex} )+ $/x; - -} - -=pod - ----++ invalidSiteCharset() -Return value: boolean $isCharsetInvalid - -Check for unusable multi-byte encodings as site character set -- anything that enables a single ASCII character such as '[' to be -matched within a multi-byte character cannot be used for TWiki. - -=cut - -sub invalidSiteCharset { +# Return value: boolean $isCharsetInvalid +# Check for unusable multi-byte encodings as site character set +# - anything that enables a single ASCII character such as '[' to be +# matched within a multi-byte character cannot be used for TWiki. +sub _invalidSiteCharset { # FIXME: match other problematic multi-byte character sets return ( $siteCharset =~ /^(?:iso-2022-?|hz-?|.*big5|.*shift_?jis|ms.kanji)/i ); } - =pod ---++ convertUtf8URLtoSiteCharset( $webName, $topicName ) Return value: ( string $convertedWebName, string $convertedTopicName) Auto-detect UTF-8 vs. site charset in URL, and convert UTF-8 into site charset. -TODO: remove dependence on webname and topicname, i.e. generic encoding -subroutine. +TODO: remove dependence on webname and topicname. =cut sub convertUtf8URLtoSiteCharset { my ( $webName, $topicName ) = @_; - ##writeDebug "URL web.topic is $webName.$topicName"; my $fullTopicName = "$webName.$topicName"; my $charEncoding; # Detect character encoding of the full topic name from URL if ( $fullTopicName =~ $regex{validAsciiStringRegex} ) { - $urlCharEncoding = 'ASCII'; + $urlCharEncoding = 'ASCII'; } elsif ( $fullTopicName =~ $regex{validUtf8StringRegex} ) { - $urlCharEncoding = 'UTF-8'; + $urlCharEncoding = 'UTF-8'; - # Convert into ISO-8859-1 if it is the site charset - if ( $siteCharset =~ /^iso-?8859-?1$/i ) { - # ISO-8859-1 maps onto first 256 codepoints of Unicode - # (conversion from 'perldoc perluniintro') - $fullTopicName =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) / - chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F ) - /egx; - } elsif ( $siteCharset eq "utf-8" ) { - # Convert into internal Unicode characters if on Perl 5.8 or higher. - if( $] >= 5.008 ) { - require Encode; # Perl 5.8 or higher only - $fullTopicName = Encode::decode("utf8", $fullTopicName); # 'decode' into UTF-8 - } else { - writeWarning "UTF-8 not supported on Perl $] - use Perl 5.8 or higher."; - } - writeWarning "UTF-8 not yet supported as site charset - TWiki is likely to have problems"; - } else { - # Convert from UTF-8 into some other site charset - writeDebug "Converting from UTF-8 to $siteCharset"; + # Convert into ISO-8859-1 if it is the site charset + if ( $siteCharset =~ /^iso-?8859-?1$/i ) { + # ISO-8859-1 maps onto first 256 codepoints of Unicode + # (conversion from 'perldoc perluniintro') + $fullTopicName =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) / + chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F ) + /egx; + } elsif ( $siteCharset eq "utf-8" ) { + # Convert into internal Unicode characters if on Perl 5.8 or higher. + if( $] >= 5.008 ) { + require Encode; # Perl 5.8 or higher only + $fullTopicName = Encode::decode("utf8", $fullTopicName); # 'decode' into UTF-8 + } else { + writeWarning( "UTF-8 not supported on Perl $] - use Perl 5.8 or higher." ); + } + writeWarning( "UTF-8 not yet supported as site charset - TWiki is likely to have problems" ); + } else { + # Convert from UTF-8 into some other site charset + writeDebug( "Converting from UTF-8 to $siteCharset" ); - # Use conversion modules depending on Perl version - if( $] >= 5.008 ) { - require Encode; # Perl 5.8 or higher only + # Use conversion modules depending on Perl version + if( $] >= 5.008 ) { + require Encode; # Perl 5.8 or higher only import Encode qw(:fallbacks); - # Map $siteCharset into real encoding name - $charEncoding = Encode::resolve_alias( $siteCharset ); - if( not $charEncoding ) { - writeWarning "Conversion to \$siteCharset '$siteCharset' not supported, or name not recognised - check 'perldoc Encode::Supported'"; - } else { - ##writeDebug "Converting with Encode, valid 'to' encoding is '$charEncoding'"; - # Convert text using Encode: - # - first, convert from UTF8 bytes into internal (UTF-8) characters - $fullTopicName = Encode::decode("utf8", $fullTopicName); - # - then convert into site charset from internal UTF-8, - # inserting \x{NNNN} for characters that can't be converted + # Map $siteCharset into real encoding name + $charEncoding = Encode::resolve_alias( $siteCharset ); + if( not $charEncoding ) { + writeWarning( "Conversion to \$siteCharset '$siteCharset' not supported, or name not recognised - check 'perldoc Encode::Supported'" ); + } else { + ##writeDebug "Converting with Encode, valid 'to' encoding is '$charEncoding'"; + # Convert text using Encode: + # - first, convert from UTF8 bytes into internal (UTF-8) characters + $fullTopicName = Encode::decode("utf8", $fullTopicName); + # - then convert into site charset from internal UTF-8, + # inserting \x{NNNN} for characters that can't be converted $fullTopicName = Encode::encode( $charEncoding, $fullTopicName, &FB_PERLQQ() ); - ##writeDebug "Encode result is $fullTopicName"; - } - - } else { - require Unicode::MapUTF8; # Pre-5.8 Perl versions - $charEncoding = $siteCharset; - if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) { - writeWarning "Conversion to \$siteCharset '$siteCharset' not supported, or name not recognised - check 'perldoc Unicode::MapUTF8'"; - } else { - # Convert text - ##writeDebug "Converting with Unicode::MapUTF8, valid encoding is '$charEncoding'"; - $fullTopicName = Unicode::MapUTF8::from_utf8({ - -string => $fullTopicName, - -charset => $charEncoding }); - # FIXME: Check for failed conversion? - } - } - } - ($webName, $topicName) = split /\./, $fullTopicName; - + ##writeDebug "Encode result is $fullTopicName"; + } + } else { + require Unicode::MapUTF8; # Pre-5.8 Perl versions + $charEncoding = $siteCharset; + if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) { + writeWarning( "Conversion to \$siteCharset '$siteCharset' not supported, or name not recognised - check 'perldoc Unicode::MapUTF8'" ); + } else { + # Convert text + ##writeDebug "Converting with Unicode::MapUTF8, valid encoding is '$charEncoding'"; + $fullTopicName = Unicode::MapUTF8::from_utf8({ + -string => $fullTopicName, + -charset => $charEncoding }); + # FIXME: Check for failed conversion? + } + } + } + ($webName, $topicName) = split /\./, $fullTopicName; } else { - # Non-ASCII and non-UTF-8 - assume in site character set, - # no conversion required - $urlCharEncoding = 'Native'; - $charEncoding = $siteCharset; + # Non-ASCII and non-UTF-8 - assume in site character set, + # no conversion required + $urlCharEncoding = 'Native'; + $charEncoding = $siteCharset; } ##writeDebug "Final web and topic are $webName $topicName ($urlCharEncoding URL -> $siteCharset)"; @@ -779,19 +744,17 @@ =cut -sub writeHeader -{ - my( $query ) = @_; +sub writeHeader { + my( $query, $contentLength ) = @_; - # FIXME: Pass real content-length to make persistent connections work - # in HTTP/1.1 (performance improvement for browsers and servers). - # Requires significant but easy changes in various places. + # Pass real content-length to make persistent connections work + # in HTTP/1.1 (performance improvement for browsers and servers) + $contentLength = 0 unless defined( $contentLength ); # Just write a basic content-type header for text/html - writeHeaderFull( $query, 'basic', 'text/html', 0); + writeHeaderFull( $query, 'basic', 'text/html', $contentLength); } - =pod ---++ writeHeaderFull( $query, $pageType, $contentType, $contentLength ) @@ -815,8 +778,7 @@ =cut -sub writeHeaderFull -{ +sub writeHeaderFull { my( $query, $pageType, $contentType, $contentLength ) = @_; # Handle Edit pages - future versions will extend to caching @@ -842,7 +804,7 @@ # Set content length, to enable HTTP/1.1 persistent connections # (aka HTTP keepalive), and cache control headers, to ensure edit page # is cached until required expiry time. - $coreHeaders = $query->header( + $coreHeaders = $query->header( -content_type => $contentType, -content_length => $contentLength, -last_modified => $lastModifiedString, @@ -854,15 +816,14 @@ -content_type => $contentType, ); } else { - writeWarning( "===== invalid page type in TWiki.pm, writeHeaderFull(): $pageType" ); + writeWarning( "Invalid page type in TWiki.pm, writeHeaderFull(): $pageType" ); } # Delete extra CR/LF to allow suffixing more headers $coreHeaders =~ s/\r\n\r\n$/\r\n/s; - ##writeDebug( "===== After trim, Headers are:\n$coreHeaders" ); # Wiki Plugin Hook - get additional headers from plugin - $pluginHeaders = &TWiki::Plugins::writeHeaderHandler( $query ) || ''; + $pluginHeaders = TWiki::Plugins::writeHeaderHandler( $query ) || ''; # Delete any trailing blank line $pluginHeaders =~ s/\r\n\r\n$/\r\n/s; @@ -875,7 +836,6 @@ for $headerLine (split /\r\n/, $coreHeaders) { $headerLine =~ m/^([^ ]+): /i; # Get header name $headerName = lc($1); - ##writeDebug("==== core header name $headerName"); $coreHeaderSeen{$headerName}++; } # Append plugin headers if legal and not seen in core headers @@ -883,8 +843,6 @@ $headerLine =~ m/^([^ ]+): /i; # Get header name $headerName = lc($1); if ( $headerName =~ m/[\-a-z]+/io ) { # Skip bad headers - ##writeDebug("==== plugin header name $headerName"); - ##writeDebug("Saw $headerName already ") if $coreHeaderSeen{$headerName}; $finalHeaders .= $headerLine . "\r\n" unless $coreHeaderSeen{$headerName}; } @@ -893,54 +851,19 @@ } $finalHeaders .= "\r\n" if ( $finalHeaders); - ##writeDebug( "===== Final Headers are:\n$finalHeaders" ); print $finalHeaders; - } =pod ----++ setPageMode( $mode ) - -Set page rendering mode: - * 'rss' - encode 8-bit characters as XML entities - * 'html' - (default) no encoding of 8-bit characters - -=cut - -sub setPageMode -{ - $pageMode = shift; -} - -=pod - ----++ getPageMode() -Return value: string $mode - -Returns current page mode, 'html' unless set via setPageMode -FIXME: This function is currently unused. Remove on some non -documentation-only commit, unless use is planned in future. - -=cut - -sub getPageMode -{ - return $pageMode; -} - -=pod - ---++ getCgiQuery() -Retrun value: string $query +Return value: string $query -Returns the CGI query portion (i.e. the bit after the '?') of the -current request. +Returns the CGI query object for the current request. See =perldoc CGI= =cut -sub getCgiQuery -{ +sub getCgiQuery { return $cgiQuery; } @@ -949,395 +872,96 @@ ---++ redirect( $query, $url ) Redirects the request to $url, via the CGI module object $query unless -overridden by a plugin. Note that this is currently only called by -Func::redirectCgiQuery() at the request of a plugin! All of the redirects -done internally by TWiki are not overridable. +overridden by a plugin declaring a =redirectCgiQueryHandler=. =cut -sub redirect -{ +sub redirect { my( $query, $url ) = @_; - if( ! &TWiki::Plugins::redirectCgiQueryHandler( $query, $url ) ) { + if( ! TWiki::Plugins::redirectCgiQueryHandler( $query, $url ) ) { print $query->redirect( $url ); } } - =pod ----++ getEmailNotifyList( $webName, $topicName ) -Return value: @emailNotifyList +---++ isValidWikiWord ( $name ) +Check for a valid WikiWord or WikiName -Get email list from WebNotify page - this now handles entries of the form: - * Main.UserName - * UserName - * Main.GroupName - * GroupName -The 'UserName' format (i.e. no Main webname) is supported in any web, but -is not recommended since this may make future data conversions more -complicated, especially if used outside the Main web. %MAINWEB% is OK -instead of 'Main'. The user's email address(es) are fetched from their -user topic (home page) as long as they are listed in the '* Email: -fred@example.com' format. Nested groups are supported. - =cut -sub getEmailNotifyList -{ - my( $web, $topicname ) = @_; +sub isValidWikiWord { + my( $name ) = @_; - $topicname = $notifyTopicname unless $topicname; - return() unless &TWiki::Store::topicExists( $web, $topicname ); - - # Allow %MAINWEB% as well as 'Main' in front of users/groups - - # non-capturing regex. - my $mainWebPattern = qr/(?:$mainWebname|%MAINWEB%)/; - - my @list = (); - my %seen; # Incremented when email address is seen - foreach ( split ( /\n/, TWiki::Store::readWebTopic( $web, $topicname ) ) ) { - if ( /^\s+\*\s(?:$mainWebPattern\.)?($regex{wikiWordRegex})\s+\-\s+($regex{emailAddrRegex})/o ) { - # Got full form: * Main.WikiName - email@domain - # (the 'Main.' part is optional, non-capturing) - if ( $1 ne 'TWikiGuest' ) { - # Add email address to list if non-guest and non-duplicate - push (@list, $2) unless $seen{$1}++; - } - } elsif ( /^\s+\*\s(?:$mainWebPattern\.)?($regex{wikiWordRegex})\s*$/o ) { - # Got short form: * Main.WikiName - # (the 'Main.' part is optional, non-capturing) - my $userWikiName = $1; - foreach ( getEmailOfUser($userWikiName) ) { - # Add email address to list if it's not a duplicate - push (@list, $_) unless $seen{$_}++; - } - } - } - ##writeDebug "list of emails: @list"; - return( @list); + $name ||= ""; # Default value if undef + return ( $name =~ m/^$regex{wikiWordRegex}$/o ) } =pod ----++ getEmailOfUser( $wikiName ) -Return value: ( $userEmail ) or @groupEmailList +---++ isValidTopicName ( $name ) +Check for a valid topic name -Get e-mail address for a given WikiName from the user's home page, or -list of e-mail addresses for a group. Nested groups are supported. -$wikiName must contain _only_ the WikiName; do *not* pass names of the -form "Main.JohnSmith". - =cut -sub getEmailOfUser -{ - my( $wikiName ) = @_; # WikiName without web prefix - - my @list = (); - # Ignore guest entry and non-existent pages - if ( $wikiName ne "TWikiGuest" && - TWiki::Store::topicExists( $mainWebname, $wikiName ) ) { - if ( $wikiName =~ /Group$/ ) { - # Page is for a group, get all users in group - ##writeDebug "using group: $mainWebname . $wikiName"; - my @userList = TWiki::Access::getUsersOfGroup( $wikiName ); - foreach my $user ( @userList ) { - $user =~ s/^.*\.//; # Get rid of 'Main.' part. - foreach my $email ( getEmailOfUser($user) ) { - push @list, $email; - } - } - } else { - # Page is for a user - ##writeDebug "reading home page: $mainWebname . $wikiName"; - foreach ( split ( /\n/, &TWiki::Store::readWebTopic( - $mainWebname, $wikiName ) ) ) { - if (/^\s\*\sEmail:\s+([\w\-\.\+]+\@[\w\-\.\+]+)/) { - # Add email address to list - push @list, $1; - } - } - } - } - return (@list); -} - -=pod - ----++ initializeRemoteUser( $remoteUser ) -Return value: $remoteUser - -Acts as a filter for $remoteUser. If set, $remoteUser is filtered for -insecure characters and untainted. - -If $doRememberRemoteUser and $remoteUser are both set, it also caches -$remoteUser as belonging to the IP address of the current request. - -If $doRememberRemoteUser is set and $remoteUser is not, then it sets -$remoteUser to the last authenticated user to make a request with the -current request's IP address, or $defaultUserName if no cached name -is available. - -If neither are set, then it sets $remoteUser to $defaultUserName. - -=cut - -sub initializeRemoteUser -{ - my( $theRemoteUser ) = @_; - - my $remoteUser = $theRemoteUser || $defaultUserName; - $remoteUser =~ s/$securityFilter//go; - $remoteUser =~ /(.*)/; - $remoteUser = $1; # untaint variable - - my $remoteAddr = $ENV{'REMOTE_ADDR'} || ""; - - if( $ENV{'REDIRECT_STATUS'} && $ENV{'REDIRECT_STATUS'} eq '401' ) { - # bail out if authentication failed - $remoteAddr = ""; - } - - if( ( ! $doRememberRemoteUser ) || ( ! $remoteAddr ) ) { - # do not remember IP address - return $remoteUser; - } - - my $text = &TWiki::Store::readFile( $remoteUserFilename ); - # Assume no I18N characters in userids, as for email addresses - # FIXME: Needs fixing for IPv6? - my %AddrToName = map { split( /\|/, $_ ) } - grep { /^[0-9\.]+\|[A-Za-z0-9]+\|$/ } - split( /\n/, $text ); - - my $rememberedUser = ""; - if( exists( $AddrToName{ $remoteAddr } ) ) { - $rememberedUser = $AddrToName{ $remoteAddr }; - } - - if( $theRemoteUser ) { - if( $theRemoteUser ne $rememberedUser ) { - $AddrToName{ $remoteAddr } = $theRemoteUser; - # create file as "$remoteAddr|$theRemoteUser|" lines - $text = "# This is a generated file, do not modify.\n"; - foreach my $usrAddr ( sort keys %AddrToName ) { - my $usrName = $AddrToName{ $usrAddr }; - # keep $userName unique - if( ( $usrName ne $theRemoteUser ) - || ( $usrAddr eq $remoteAddr ) ) { - $text .= "$usrAddr|$usrName|\n"; - } - } - &TWiki::Store::saveFile( $remoteUserFilename, $text ); - } - } else { - # get user name from AddrToName table - $remoteUser = $rememberedUser || $defaultUserName; - } - - return $remoteUser; -} - -=pod - ----++ userToWikiListInit() - -Build hashes to translate in both directions between username (e.g. jsmith) -and WikiName (e.g. JaneSmith). Only used for sites where authentication is -managed by external Apache configuration, instead of via TWiki's .htpasswd -mechanism. - -=cut - -sub userToWikiListInit -{ - %userToWikiList = (); - %wikiToUserList = (); - my @list = (); - if( $doMapUserToWikiName ) { - @list = split( /\n/, TWiki::Store::readFile( $userListFilename ) ); - } else { - # fix for Codev.SecurityAlertGainAdminRightWithTWikiUsersMapping - # for .htpasswd authenticated sites ignore user list, but map only guest to TWikiGuest - @list = ( "\t* TWikiGuest - guest - " ); # CODE_SMELL on localization - } - - # Get all entries with two '-' characters on same line, i.e. - # 'WikiName - userid - date created' - @list = grep { /^\s*\* $regex{wikiWordRegex}\s*-\s*[^\-]*-/o } @list; - my $wUser; - my $lUser; - foreach( @list ) { - # Get the WikiName and userid, and build hashes in both directions - if( ( /^\s*\* ($regex{wikiWordRegex})\s*\-\s*([^\s]*).*/o ) && $2 ) { - $wUser = $1; # WikiName - $lUser = $2; # userid - $lUser =~ s/$securityFilter//go; # FIXME: Should filter in for security... - $userToWikiList{ $lUser } = $wUser; - $wikiToUserList{ $wUser } = $lUser; - } - } -} - -=pod - ----++ userToWikiName( $loginUser, $dontAddWeb ) -Return value: $wikiName - -Translates intranet username (e.g. jsmith) to WikiName (e.g. JaneSmith) -userToWikiListInit must be called before this function is used. - -Unless $dontAddWeb is set, "Main." is prepended to the returned WikiName. - -if you give an invalid username, we just return that (no appending Main. blindy) - -SMELL: the userToWikiList cache should really contain the WebName so its possible - to have userTopics in more than just the MainWeb (what if you move a user topic?) - -=cut - -sub userToWikiName -{ - my( $loginUser, $dontAddWeb ) = @_; - - if( !$loginUser ) { - return ""; - } - - $loginUser =~ s/$securityFilter//go; - my $wUser = $userToWikiList{ $loginUser } || $loginUser; - if( $dontAddWeb ) { - return $wUser; - } - return "$mainWebname.$wUser"; -} - -=pod - ----++ wikiToUserName( $wikiName ) -Return value: $loginUser - -Translates WikiName (e.g. JaneSmith) to an intranet username (e.g. jsmith) -userToWikiListInit must be called before this function is used. - -=cut - -sub wikiToUserName -{ - my( $wikiUser ) = @_; - $wikiUser =~ s/^.*\.//g; - my $userName = $wikiToUserList{"$wikiUser"} || $wikiUser; - ##writeDebug( "TWiki::wikiToUserName: $wikiUser->$userName" ); - return $userName; -} - -=pod - ----++ isGuest() - -Returns whether the current user is TWikiGuest or equivalent. - -=cut - -sub isGuest -{ - return ( $userName eq $defaultUserName ); -} - -# ========================= -=pod - ----++ sub getWikiUserTopic () - -Not yet documented. - -=cut - -sub getWikiUserTopic -{ - # Topic without Web name - return $wikiName; -} - -# ========================= -# Check for a valid WikiWord or WikiName -=pod - ----++ sub isWikiName ( $name ) - -Not yet documented. -CODE_SMELL - this should be called isWikiWord - -=cut - -sub isWikiName -{ +sub isValidTopicName { my( $name ) = @_; - $name ||= ""; # Default value if undef - return ( $name =~ m/^$regex{wikiWordRegex}$/o ) + return isValidWikiWord( @_ ) || isValidAbbrev( @_ ); } -# ========================= -# Check for a valid ABBREV (acronym) =pod ----++ sub isAbbrev ( $name ) +---++ isValidAbbrev ( $name ) +Check for a valid ABBREV (acronym) -Not yet documented. - =cut -sub isAbbrev -{ +sub isValidAbbrev { my( $name ) = @_; $name ||= ""; # Default value if undef return ( $name =~ m/^$regex{abbrevRegex}$/o ) } -# ========================= -# Check for a valid web name =pod ----++ sub isWebName ( $name ) +---++ isValidWebName ( $name ) -Not yet documented. +Check for a valid web name =cut -sub isWebName -{ +sub isValidWebName { my( $name ) = @_; $name ||= ""; # Default value if undef return ( $name =~ m/^$regex{webNameRegex}$/o ) } -# ========================= =pod ----++ sub readOnlyMirrorWeb ( $theWeb ) +---++ readOnlyMirrorWeb ( $theWeb ) -Not yet documented. +If this is a mirrored web, return information about the mirror. The info +is returned in a quadruple: +| site name | URL | link | note | =cut -sub readOnlyMirrorWeb -{ +sub readOnlyMirrorWeb { my( $theWeb ) = @_; my @mirrorInfo = ( "", "", "", "" ); if( $siteWebTopicName ) { - my $mirrorSiteName = &TWiki::Prefs::getPreferencesValue( "MIRRORSITENAME", $theWeb ); + my $mirrorSiteName = TWiki::Prefs::getPreferencesValue( "MIRRORSITENAME", $theWeb ); if( $mirrorSiteName && $mirrorSiteName ne $siteWebTopicName ) { - my $mirrorViewURL = &TWiki::Prefs::getPreferencesValue( "MIRRORVIEWURL", $theWeb ); - my $mirrorLink = &TWiki::Store::readTemplate( "mirrorlink" ); + my $mirrorViewURL = TWiki::Prefs::getPreferencesValue( "MIRRORVIEWURL", $theWeb ); + my $mirrorLink = TWiki::Store::readTemplate( "mirrorlink" ); $mirrorLink =~ s/%MIRRORSITENAME%/$mirrorSiteName/g; $mirrorLink =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g; $mirrorLink =~ s/\s*$//g; - my $mirrorNote = &TWiki::Store::readTemplate( "mirrornote" ); + my $mirrorNote = TWiki::Store::readTemplate( "mirrornote" ); $mirrorNote =~ s/%MIRRORSITENAME%/$mirrorSiteName/g; $mirrorNote =~ s/%MIRRORVIEWURL%/$mirrorViewURL/g; $mirrorNote = TWiki::Render::getRenderedVersion( $mirrorNote, $theWeb ); @@ -1348,51 +972,8 @@ return @mirrorInfo; } - -# ========================= =pod ----++ sub getDataDir () - -Not yet documented. - -=cut - -sub getDataDir -{ - return $dataDir; -} - -# ========================= -=pod - ----++ sub getPubDir () - -Not yet documented. - -=cut - -sub getPubDir -{ - return $pubDir; -} - -# ========================= -=pod - ----++ sub getPubUrlPath () - -Not yet documented. - -=cut - -sub getPubUrlPath -{ - return $pubUrlPath; -} - -=pod - ---++ getTWikiLibDir() If necessary, finds the full path of the directory containing TWiki.pm, @@ -1401,8 +982,7 @@ =cut -sub getTWikiLibDir -{ +sub getTWikiLibDir { if( $twikiLibDir ) { return $twikiLibDir; } @@ -1417,12 +997,25 @@ } } - # fix relative path + # fix path relative to location of called script if( $twikiLibDir =~ /^\./ ) { - my $curr = cwd(); - $twikiLibDir = "$curr/$twikiLibDir/"; + writeWarning( "TWiki lib path is relative; you should make it absolute, otherwise some scripts may not run from the command line." ); + my $bin; + if( $ENV{"SCRIPT_FILENAME"} && + $ENV{"SCRIPT_FILENAME"} =~ /^(.+)\/[^\/]+$/ ) { + # CGI script name + $bin = $1; + } elsif ( $0 =~ /^(.*)\/.*?$/ ) { + # program name + $bin = $1; + } else { + # last ditch; relative to current directory. + eval 'use Cwd qw( cwd ); $bin = cwd();'; + } + $twikiLibDir = "$bin/$twikiLibDir/"; # normalize "/../" and "/./" - while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) {}; + while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) { + }; $twikiLibDir =~ s|([\\/])\.[\\/]|$1|g; } $twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/" @@ -1431,130 +1024,34 @@ return $twikiLibDir; } -# ========================= =pod ----++ sub revDate2EpSecs () +---++ getSkin () -Not yet documented. +Get the name of the currently requested skin =cut -sub revDate2EpSecs -# Convert RCS revision date/time to seconds since epoch, for easier sorting -{ - my( $date ) = @_; - # NOTE: This routine *will break* if input is not one of below formats! - - # FIXME - why aren't ifs around pattern match rather than $5 etc - # try "31 Dec 2001 - 23:59" (TWiki date) - if ($date =~ /([0-9]+)\s+([A-Za-z]+)\s+([0-9]+)[\s\-]+([0-9]+)\:([0-9]+)/) { - my $year = $3; - $year -= 1900 if( $year > 1900 ); - return timegm( 0, $5, $4, $1, $mon2num{$2}, $year ); - } - - # try "2001/12/31 23:59:59" or "2001.12.31.23.59.59" (RCS date) - if ($date =~ /([0-9]+)[\.\/\-]([0-9]+)[\.\/\-]([0-9]+)[\.\s\-]+([0-9]+)[\.\:]([0-9]+)[\.\:]([0-9]+)/) { - my $year = $1; - $year -= 1900 if( $year > 1900 ); - return timegm( $6, $5, $4, $3, $2-1, $year ); - } - - # try "2001/12/31 23:59" or "2001.12.31.23.59" (RCS short date) - if ($date =~ /([0-9]+)[\.\/\-]([0-9]+)[\.\/\-]([0-9]+)[\.\s\-]+([0-9]+)[\.\:]([0-9]+)/) { - my $year = $1; - $year -= 1900 if( $year > 1900 ); - return timegm( 0, $5, $4, $3, $2-1, $year ); - } - - # try "2001-12-31T23:59:59Z" or "2001-12-31T23:59:59+01:00" (ISO date) - # FIXME: Calc local to zulu time "2001-12-31T23:59:59+01:00" - if ($date =~ /([0-9]+)\-([0-9]+)\-([0-9]+)T([0-9]+)\:([0-9]+)\:([0-9]+)/ ) { - my $year = $1; - $year -= 1900 if( $year > 1900 ); - return timegm( $6, $5, $4, $3, $2-1, $year ); - } - - # try "2001-12-31T23:59Z" or "2001-12-31T23:59+01:00" (ISO short date) - # FIXME: Calc local to zulu time "2001-12-31T23:59+01:00" - if ($date =~ /([0-9]+)\-([0-9]+)\-([0-9]+)T([0-9]+)\:([0-9]+)/ ) { - my $year = $1; - $year -= 1900 if( $year > 1900 ); - return timegm( 0, $5, $4, $3, $2-1, $year ); - } - - # give up, return start of epoch (01 Jan 1970 GMT) - return 0; -} - -# ========================= -=pod - ----++ sub getSessionValue () - -Not yet documented. - -=cut - -sub getSessionValue -{ -# my( $key ) = @_; - return &TWiki::Plugins::getSessionValueHandler( @_ ); -} - -# ========================= -=pod - ----++ sub setSessionValue () - -Not yet documented. - -=cut - -sub setSessionValue -{ -# my( $key, $value ) = @_; - return &TWiki::Plugins::setSessionValueHandler( @_ ); -} - -# ========================= -=pod - ----++ sub getSkin () - -Not yet documented. - -=cut - -sub getSkin -{ +sub getSkin { my $skin = ""; $skin = $cgiQuery->param( 'skin' ) if( $cgiQuery ); - $skin = &TWiki::Prefs::getPreferencesValue( "SKIN" ) unless( $skin ); + $skin = TWiki::Prefs::getPreferencesValue( "SKIN" ) unless( $skin ); return $skin; } -# ========================= =pod ----++ sub getViewUrl ( $web, $topic ) +---++ getViewUrl ( $web, $topic ) -Returns a fully-qualified URL to the specified topic, which must be normalized -into separate specified =$web= and =$topic= parts. +Returns a fully-qualified URL to the specified topic. =cut -sub getViewUrl -{ +sub getViewUrl { my( $theWeb, $theTopic ) = @_; - # PTh 20 Jun 2000: renamed sub viewUrl to getViewUrl, added $theWeb - # WM 14 Feb 2004: Removed support for old syntax not specifying $theWeb $theTopic =~ s/\s*//gs; # Illegal URL, remove space - # PTh 24 May 2000: added $urlHost, needed for some environments - # see also Codev.PageRedirectionNotWorking return "$urlHost$dispScriptUrlPath$dispViewPath$scriptSuffix/$theWeb/$theTopic"; } @@ -1569,8 +1066,7 @@ =cut -sub getScriptUrl -{ +sub getScriptUrl { my( $theWeb, $theTopic, $theScript ) = @_; my $url = "$urlHost$dispScriptUrlPath/$theScript$scriptSuffix/$theWeb/$theTopic"; @@ -1593,11 +1089,9 @@ =cut -sub getOopsUrl -{ +sub getOopsUrl { my( $theWeb, $theTopic, $theTemplate, $theParam1, $theParam2, $theParam3, $theParam4 ) = @_; - # PTh 20 Jun 2000: new sub my $web = $webName; # current web if( $theWeb ) { $web = $theWeb; @@ -1606,98 +1100,51 @@ # $urlHost is needed, see Codev.PageRedirectionNotWorking $url = getScriptUrl( $web, $theTopic, "oops" ); $url .= "\?template=$theTemplate"; - $url .= "\&param1=" . handleUrlEncode( $theParam1 ) if ( $theParam1 ); - $url .= "\&param2=" . handleUrlEncode( $theParam2 ) if ( $theParam2 ); - $url .= "\&param3=" . handleUrlEncode( $theParam3 ) if ( $theParam3 ); - $url .= "\&param4=" . handleUrlEncode( $theParam4 ) if ( $theParam4 ); + $url .= "\&param1=" . _urlEncode( $theParam1 ) if ( $theParam1 ); + $url .= "\&param2=" . _urlEncode( $theParam2 ) if ( $theParam2 ); + $url .= "\&param3=" . _urlEncode( $theParam3 ) if ( $theParam3 ); + $url .= "\&param4=" . _urlEncode( $theParam4 ) if ( $theParam4 ); return $url; } -# ========================= =pod ----++ sub makeTopicSummary ( $theText, $theTopic, $theWeb, $theFlags ) +---++ normalizeWebTopicName ( $theWeb, $theTopic ) -Not yet documented. +Normalize a Web.TopicName +
+Input:                      Return:
+  ( "Web",  "Topic" )         ( "Web",  "Topic" )
+  ( "",     "Topic" )         ( "Main", "Topic" )
+  ( "",     "" )              ( "Main", "WebHome" )
+  ( "",     "Web/Topic" )     ( "Web",  "Topic" )
+  ( "",     "Web.Topic" )     ( "Web",  "Topic" )
+  ( "Web1", "Web2.Topic" )    ( "Web2", "Topic" )
+
+Note: Function renamed from getWebTopic =cut -sub makeTopicSummary -{ - my( $theText, $theTopic, $theWeb, $theFlags ) = @_; - # called by search, mailnotify & changes after calling readFileHead +sub normalizeWebTopicName { + my( $theWeb, $theTopic ) = @_; - my $htext = $theText; - $theFlags = "" unless( $theFlags ); - # Format e-mail to add spam padding (HTML tags removed later) - $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; - $htext =~ s/<\!\-\-.*?\-\->//gs; # remove all HTML comments - $htext =~ s/<\!\-\-.*$//s; # cut HTML comment - $htext =~ s/<[^>]*>//g; # remove all HTML tags - $htext =~ s/\&[a-z]+;/ /g; # remove entities - $htext =~ s/%WEB%/$theWeb/g; # resolve web - $htext =~ s/%TOPIC%/$theTopic/g; # resolve topic - $htext =~ s/%WIKITOOLNAME%/$wikiToolName/g; # resolve TWiki tool name - $htext =~ s/%META:[A-Z].*?}%//g; # remove meta data variables - if( $theFlags =~ /nohead/ ) { - # skip headings on top - while( $htext =~ s/^\s*\-\-\-+\+[^\n\r]+// ) {}; # remove heading - } - unless( $theFlags =~ /showvar/ ) { - # remove variables - $htext =~ s/%[A-Z_]+%//g; # remove %VARS% - $htext =~ s/%[A-Z_]+{.*?}%//g;# remove %VARS{}% - } - $htext =~ s/\[\[([^\]]*\]\[|[^\s]*\s)(.*?)\]\]/$2/g; # keep only link text of [[][]] - $htext =~ s/[\%\[\]\*\|=_\&\<\>\$]/ /g; # remove Wiki formatting chars & defuse %VARS% - $htext =~ s/\-\-\-+\+*\s*\!*/ /g; # remove heading formatting - $htext =~ s/\s+[-\+]*/ /g; # remove newlines and special chars - $htext =~ s/^\s+/ /; # remove leading spaces - $htext =~ s/\s+$/ /; # remove trailing spaces + if( $theTopic =~ m|^([^.]+)[\.\/](.*)$| ) { + $theWeb = $1; + $theTopic = $2; + } + $theWeb = $TWiki::webName unless( $theWeb ); + $theTopic = $TWiki::topicName unless( $theTopic ); - # FIXME I18N: Avoid splitting within multi-byte characters (e.g. EUC-JP - # encoding) by encoding bytes as Perl UTF-8 characters in Perl 5.8+. - # This avoids splitting within a Unicode codepoint (or a UTF-16 - # surrogate pair, which is encoded as a single Perl UTF-8 character), - # but we ideally need to avoid splitting closely related Unicode codepoints. - # Specifically, this means Unicode combining character sequences (e.g. - # letters and accents) - might be better to split on word boundary if - # possible. - - # limit to n chars - my $nchar = $theFlags; - unless( $nchar =~ s/^.*?([0-9]+).*$/$1/ ) { - $nchar = 162; - } - $nchar = 16 if( $nchar < 16 ); - $htext =~ s/(.{$nchar})($regex{mixedAlphaNumRegex})(.*?)$/$1$2 \.\.\./; - - # Encode special chars into XML &#nnn; entities for use in RSS feeds - # - no encoding for HTML pages, to avoid breaking international - # characters. FIXME: Only works for ISO-8859-1 characters, where the - # Unicode encoding (&#nnn;) is identical. - if( $pageMode eq 'rss' ) { - # FIXME: Issue for EBCDIC/UTF-8 - $htext =~ s/([\x7f-\xff])/"\&\#" . unpack( "C", $1 ) .";"/ge; - } - - # prevent text from getting rendered in inline search and link tool - # tip text by escaping links (external, internal, Interwiki) - $htext =~ s/([\s\(])(?=\S)/$1/g; - $htext =~ s/([\-\*\s])($regex{linkProtocolPattern}\:)/$1$2/go; - $htext =~ s/@([a-zA-Z0-9\-\_\.]+)/@$1/g; # email address - - return $htext; + return( $theWeb, $theTopic ); } -# ========================= =pod ----++ sub extractParameters ( $str ) +---++ extractParameters ( $str ) Extracts parameters from a variable string and returns a hash with all parameters. -The nameless parameter's key is _DEFAULT. +The nameless parameter key is _DEFAULT. * Example variable: %TEST{ "nameless" name1="val1" name2="val2" }% * First extract text between {...} to get: "nameless" name1="val1" name2="val2" @@ -1710,8 +1157,7 @@ =cut -sub extractParameters -{ +sub extractParameters { my( $str ) = @_; my %params = (); @@ -1741,17 +1187,19 @@ return map{ s/\\$TranslationToken/\"/go; $_ } %params; } -# ========================= =pod ----++ sub extractNameValuePair ( $str, $name ) +---++ extractNameValuePair ( $str, $name ) -Not yet documented. +Extract a named or unnamed value from a variable parameter string +Function extractParameters is more efficient for extracting several parameters +| =$attr= | Attribute string | +| =$name= | Name, optional | +| Return: =$value= | Extracted value | =cut -sub extractNameValuePair -{ +sub extractNameValuePair { my( $str, $name ) = @_; my $value = ""; @@ -1786,33 +1234,14 @@ return $value; } -# ========================= -=pod - ----++ sub fixN ( $theTag ) - -Not yet documented. - -=cut - -sub fixN -{ +sub _fixN { my( $theTag ) = @_; $theTag =~ s/[\r\n]+//gs; return $theTag; } -# ========================= -=pod - ----++ sub fixURL ( $theHost, $theAbsPath, $theUrl ) - -Not yet documented. - -=cut - -sub fixURL -{ +# Convert relative URLs to absolute URIs +sub __fixURL { my( $theHost, $theAbsPath, $theUrl ) = @_; my $url = $theUrl; @@ -1822,7 +1251,7 @@ } elsif( $url =~ /^\./ ) { # fix relative URL $url = "$theHost$theAbsPath/$url"; - } elsif( $url =~ /^$regex{linkProtocolPattern}\:/ ) { + } elsif( $url =~ /^$regex{linkProtocolPattern}\:/o ) { # full qualified URL, do nothing } elsif( $url ) { # FIXME: is this test enough to detect relative URLs? @@ -1832,48 +1261,25 @@ return $url; } -# ========================= -=pod - ----++ sub fixIncludeLink ( $theWeb, $theLink, $theLabel ) - -Not yet documented. - -=cut - -sub fixIncludeLink -{ +sub _fixIncludeLink { my( $theWeb, $theLink, $theLabel ) = @_; - if( $theLabel ) { - # [[...][...]] link - if( $theLink =~ /^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}\:)/ ) { - return "[[$theLink][$theLabel]]"; # no change + # [[...][...]] link + if( $theLink =~ /^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}\:)/o ) { + if ( $theLabel ) { + return "[[$theLink][$theLabel]]"; + } else { + return "[[$theLink]]"; } - # add 'Web.' prefix + } elsif ( $theLabel ) { return "[[$theWeb.$theLink][$theLabel]]"; - } else { - # [[...]] link - if( $theLink =~ /^($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}\:)/ ) { - return "[[$theLink]]"; # no change - } - # add 'Web.' prefix return "[[$theWeb.$theLink][$theLink]]"; } } -# ========================= -=pod - ----++ sub cleanupIncludedHTML ( $text, $host, $path ) - -Clean-up HTML text so that it can be shown embedded in a topic - -=cut - -sub cleanupIncludedHTML -{ +# Clean-up HTML text so that it can be shown embedded in a topic +sub _cleanupIncludedHTML { my( $text, $host, $path ) = @_; # FIXME: Make aware of tag @@ -1883,23 +1289,21 @@ $text =~ s/^.*?]*>//is; # remove all to $text =~ s/(?:\n)<\/body>//is; # remove $text =~ s/(?:\n)<\/html>//is; # remove - $text =~ s/(<[^>]*>)/&fixN($1)/ges; # join tags to one line each - $text =~ s/(\s(href|src|action)\=[\"\']?)([^\"\'\>\s]*)/$1 . &fixURL( $host, $path, $3 )/geois; + $text =~ s/(<[^>]*>)/&_fixN($1)/ges; # join tags to one line each + $text =~ s/(\s(href|src|action)\=[\"\']?)([^\"\'\>\s]*)/$1 . &_fixURL( $host, $path, $3 )/geois; return $text; } -# ========================= =pod ----++ sub applyPatternToIncludedText ( $theText, $thePattern ) +---++ applyPatternToIncludedText ( $theText, $thePattern ) Apply a pattern on included text to extract a subset =cut -sub applyPatternToIncludedText -{ +sub applyPatternToIncludedText { my( $theText, $thePattern ) = @_; $thePattern =~ s/([^\\])([\$\@\%\&\#\'\`\/])/$1\\$2/g; # escape some special chars $thePattern =~ /(.*)/; # untaint @@ -1908,17 +1312,27 @@ return $theText; } -# ========================= -=pod +sub _handleFORMFIELD { + return TWiki::Render::renderFormField( @_ ); +} ----++ sub handleIncludeUrl ( $theUrl, $thePattern ) +sub _handleTMPLP { + my $params = shift; + return TWiki::Templates::expandTemplate( $params->{_DEFAULT} ); +} -Not yet documented. +sub _handleVAR { + my $params = shift; + return TWiki::Prefs::getWebVariable( $params->{_DEFAULT} ); +} -=cut +sub _handlePLUGINVERSION { + my $params = shift; + TWiki::Plugins::getPluginVersion( $params->{_DEFAULT} ); +} -sub handleIncludeUrl -{ +# Fetch content from a URL for includion by an INCLUDE +sub _includeUrl { my( $theUrl, $thePattern, $theWeb, $theTopic ) = @_; my $text = ""; my $host = ""; @@ -1934,51 +1348,38 @@ my $fileName = "$pubDir/$web/$topic/$3"; if( $fileName =~ m/\.(txt|html?)$/i ) { # FIXME: Check for MIME type, not file suffix unless( -e $fileName ) { - return showError( "Error: File attachment at $theUrl does not exist" ); + return _inlineError( "Error: File attachment at $theUrl does not exist" ); } if( "$web.$topic" ne "$theWeb.$theTopic" ) { # CODE_SMELL: Does not account for not yet authenticated user unless( TWiki::Access::checkAccessPermission( "VIEW", $wikiUserName, "", $topic, $web ) ) { - return showError( "Error: No permission to view files attached to $web.$topic" ); + return _inlineError( "Error: No permission to view files attached to $web.$topic" ); } } $text = TWiki::Store::readFile( $fileName ); - $text = cleanupIncludedHTML( $text, $urlHost, $pubUrlPath ); + $text = _cleanupIncludedHTML( $text, $urlHost, $pubUrlPath ); $text = applyPatternToIncludedText( $text, $thePattern ) if( $thePattern ); return $text; } # fall through; try to include file over http based on MIME setting } - # RNF 22 Jan 2002 Handle http://user:pass@host if( $theUrl =~ /http\:\/\/(.+)\:(.+)\@([^\:]+)\:([0-9]+)(\/.*)/ ) { - $user = $1; - $pass = $2; - $host = $3; - $port = $4; - $path = $5; - + ( $user, $pass, $host, $port, $path ) = ( $1, $2, $3, $4, $5 ); } elsif( $theUrl =~ /http\:\/\/(.+)\:(.+)\@([^\/]+)(\/.*)/ ) { - $user = $1; - $pass = $2; - $host = $3; - $path = $4; - + ( $user, $pass, $host, $path ) = ( $1, $2, $3, $4 ); } elsif( $theUrl =~ /http\:\/\/([^\:]+)\:([0-9]+)(\/.*)/ ) { - $host = $1; - $port = $2; - $path = $3; - + ( $host, $port, $path ) = ( $1, $2, $3 ); } elsif( $theUrl =~ /http\:\/\/([^\/]+)(\/.*)/ ) { - $host = $1; - $path = $2; - + ( $host, $path ) = ( $1, $2 ); } else { - $text = showError( "Error: Unsupported protocol. (Must be 'http://domain/...')" ); + $text = _inlineError( "Error: Unsupported protocol. (Must be 'http://domain/...')" ); return $text; } - $text = &TWiki::Net::getUrl( $host, $port, $path, $user, $pass ); + use TWiki::Net; # SMTP, get URL + + $text = TWiki::Net::getUrl( $host, $port, $path, $user, $pass ); $text =~ s/\r\n/\n/gs; $text =~ s/\r/\n/gs; $text =~ s/^(.*?\n)\n(.*)/$2/s; @@ -1993,13 +1394,13 @@ if( $port != 80 ) { $host .= ":$port"; } - $text = cleanupIncludedHTML( $text, $host, $path ); + $text = _cleanupIncludedHTML( $text, $host, $path ); } elsif( $contentType =~ /^text\/(plain|css)/ ) { # do nothing } else { - $text = showError( "Error: Unsupported content type: $contentType." + $text = _inlineError( "Error: Unsupported content type: $contentType." . " (Must be text/html, text/plain or text/css)" ); } @@ -2008,36 +1409,32 @@ return $text; } -=pod +# Processes a specific instance %INCLUDE{...}% syntax. +# Returns the text to be inserted in place of the INCLUDE command. +# $topic and $web should be for the immediate parent topic in the +# include hierarchy. Works for both URLs and absolute server paths. +# +# \@verbatim is a buffer for storing removed verbatim blocks. +# It is optional. +# +# \%theProcessedTopics is a hash of topics already %INCLUDE%'ed. +# These are not allowed to be included again to prevent infinte recursive +# inclusion. It is optional (will be created on demand). +sub _handleINCLUDE { + my ( $params, $theTopic, $theWeb, $verbatim, $theProcessedTopics ) = @_; ----++ handleIncludeFile( $includeCommandAttribs, $topic, $web, \@verbatimBuffer, @processedTopics ) -Return value: $includedText + my $incfile = $params->{_DEFAULT}; + my $pattern = $params->{pattern}; + my $rev = $params->{rev}; + my $warn = $params->{warn}; -Processes a specific instance %INCLUDE{...}% syntax. Returns the text to be -inserted in place of the INCLUDE command. $topic and $web should be for the -immediate parent topic in the include hierarchy. @verbatimBuffer is the request- -global buffer for storing removed verbatim blocks, and @processedTopics is a -list of topics already %INCLUDE%'ed -- these are not allowed to be included -again to prevent infinte recursive inclusion. - -=cut - -sub handleIncludeFile -{ - my( $theAttributes, $theTopic, $theWeb, $verbatim, @theProcessedTopics ) = @_; - - my %params = extractParameters( $theAttributes ); - my $incfile = $params{"_DEFAULT"} || ""; - my $pattern = $params{"pattern"} || ""; - my $rev = $params{"rev"} || ""; - my $warn = $params{"warn"} || ""; - if( $incfile =~ /^http\:/ ) { # include web page - return handleIncludeUrl( $incfile, $pattern, $theWeb, $theTopic ); + return _includeUrl( $incfile, $pattern, $theWeb, $theTopic ); } - # CrisBailiff, PeterThoeny 12 Jun 2000: Add security + $theProcessedTopics = {} unless $theProcessedTopics; + $incfile =~ s/$securityFilter//go; # zap anything suspicious if( $doSecureInclude ) { # Filter out ".." from filename, this is to @@ -2070,7 +1467,7 @@ # give up, file not found $warn = TWiki::Prefs::getPreferencesValue( "INCLUDEWARNING" ) unless( $warn ); if( $warn =~ /^on$/i ) { - return showError( "Warning: Can't INCLUDE $incfile, topic not found" ); + return _inlineError( "Warning: Can't INCLUDE $incfile, topic not found" ); } elsif( $warn && $warn !~ /^(off|no)$/i ) { $incfile =~ s/\//\./go; $warn =~ s/\$topic/$incfile/go; @@ -2080,22 +1477,22 @@ } # prevent recursive loop - if( ( @theProcessedTopics ) && ( grep { /^$fileName$/ } @theProcessedTopics ) ) { + if( $theProcessedTopics->{$fileName} ) { # file already included if( $warn || TWiki::Prefs::getPreferencesFlag( "INCLUDEWARNING" ) ) { unless( $warn =~ /^(off|no)$/i ) { - return showError( "Warning: Can't INCLUDE $incfile twice, topic is already included" ); + return _inlineError( "Warning: Can't INCLUDE $incfile twice, topic is already included" ); } } return ""; } else { # remember for next time - push( @theProcessedTopics, $fileName ); + $theProcessedTopics->{$fileName} = 1; } # set include web/filenames and current web/filenames - $includingWebName = $theWeb; - $includingTopicName = $theTopic; + $sessionInternalTags{INCLUDINGWEB} = $theWeb; + $sessionInternalTags{INCLUDINGTOPIC} = $theTopic; if( $fileName =~ s/\/([^\/]*)\/([^\/]*)\.txt$/$1/ ) { # identified "/Web/TopicName.txt" filename, e.g. a Wiki topic # so save the current web and topic name @@ -2105,9 +1502,9 @@ if( $rev ) { $rev = "1.$rev" unless( $rev =~ /^1\./ ); - ( $meta, $text ) = &TWiki::Store::readTopicVersion( $theWeb, $theTopic, $rev ); + ( $meta, $text ) = TWiki::Store::readTopicVersion( $theWeb, $theTopic, $rev ); } else { - ( $meta, $text ) = &TWiki::Store::readTopic( $theWeb, $theTopic ); + ( $meta, $text ) = TWiki::Store::readTopic( $theWeb, $theTopic ); } # remove everything before %STARTINCLUDE% and after %STOPINCLUDE% $text =~ s/.*?%STARTINCLUDE%//s; @@ -2117,73 +1514,81 @@ $text = applyPatternToIncludedText( $text, $pattern ) if( $pattern ); - # handle all preferences and internal tags (for speed: call by reference) - $text = takeOutVerbatim( $text, $verbatim ); + # handle all preferences and internal tags + $text = TWiki::Render::takeOutBlocks( $text, "verbatim", $verbatim ); # Escape rendering: Change " !%VARIABLE%" to " %VARIABLE%", for final " %VARIABLE%" output $text =~ s/(\s)\!\%([A-Z])/$1%$2/g; - # handle all preferences and internal tags - &TWiki::Prefs::handlePreferencesTags( $text ); - handleInternalTags( $text, $theTopic, $theWeb ); + processTags( \$text, $theTopic, $theWeb, + $verbatim, $theProcessedTopics ); - # TWiki Plugin Hook (4th parameter tells plugin that its called from an include) - &TWiki::Plugins::commonTagsHandler( $text, $theTopic, $theWeb, 1 ); + # 4th parameter tells plugin that its called from an include + TWiki::Plugins::commonTagsHandler( $text, $theTopic, $theWeb, 1 ); - # handle tags again because of plugin hook - &TWiki::Prefs::handlePreferencesTags( $text ); - handleInternalTags( $text, $theTopic, $theWeb ); - - # If needed, fix all "TopicNames" to "Web.TopicNames" to get the right context + # If needed, fix all "TopicNames" to "Web.TopicNames" to get the + # right context + # SMELL: This is a hack. if( ( $isTopic ) && ( $theWeb ne $webName ) ) { # "TopicName" to "Web.TopicName" $text =~ s/(^|[\s\(])($regex{webNameRegex}\.$regex{wikiWordRegex})/$1$TranslationToken$2/go; $text =~ s/(^|[\s\(])($regex{wikiWordRegex})/$1$theWeb\.$2/go; $text =~ s/(^|[\s\(])$TranslationToken/$1/go; # "[[TopicName]]" to "[[Web.TopicName][TopicName]]" - $text =~ s/\[\[([^\]]+)\]\]/fixIncludeLink( $theWeb, $1 )/geo; + $text =~ s/\[\[([^\]]+)\]\]/&_fixIncludeLink( $theWeb, $1 )/geo; # "[[TopicName][...]]" to "[[Web.TopicName][...]]" - $text =~ s/\[\[([^\]]+)\]\[([^\]]+)\]\]/fixIncludeLink( $theWeb, $1, $2 )/geo; + $text =~ s/\[\[([^\]]+)\]\[([^\]]+)\]\]/&_fixIncludeLink( $theWeb, $1, $2 )/geo; # FIXME: Support for } - - # FIXME What about attachments? - # recursively process multiple embedded %INCLUDE% statements and prefs - $text =~ s/%INCLUDE{(.*?)}%/&handleIncludeFile($1, $theTopic, $theWeb, $verbatim, @theProcessedTopics )/ge; + # handle tags again because of plugin hook + processTags( \$text, $theTopic, $theWeb, + $verbatim, $theProcessedTopics ); + $text =~ s/^\n+/\n/; + $text =~ s/\n+$/\n/; + + # FIXME What about attachments? + return $text; } -# ========================= -# Only does simple search for topicmoved at present, can be expanded when required -=pod +sub _handleHTTP_HOST { + return $ENV{HTTP_HOST}; +} ----++ sub handleMetaSearch ( $attributes ) +sub _handleREMOTE_ADDR { + return $ENV{REMOTE_ADDR}; +} -Not yet documented. +sub _handleREMOTE_PORT { + return $ENV{REMOTE_PORT}; +} -=cut +sub _handleREMOTE_USER { + return $ENV{REMOTE_USER}; +} -sub handleMetaSearch -{ - my( $theAttributes ) = @_; +# Only does simple search for topicmoved at present, can be expanded when required +# SMELL: this violates encapsulation of Store and Meta, by exporting +# the assumption that meta-data is stored embedded inside topic +# text. +sub _handleMETASEARCH { + my $params = shift; + my $attrWeb = $params->{web}; + my $attrTopic = $params->{topic}; + my $attrType = $params->{type}; + my $attrTitle = $params->{title}; + my $attrDefault = $params->{default}; - my %params = extractParameters( $theAttributes ); - my $attrWeb = $params{"web"} || ""; - my $attrTopic = $params{"topic"} || ""; - my $attrType = $params{"type"} || ""; - my $attrTitle = $params{"title"} || ""; - my $attrDefault = $params{"default"} || ""; - my $searchVal = "XXX"; - + if( ! $attrType ) { $attrType = ""; } my $searchWeb = "all"; - + if( $attrType eq "topicmoved" ) { $searchVal = "%META:TOPICMOVED[{].*from=\\\"$attrWeb\.$attrTopic\\\".*[}]%"; } elsif ( $attrType eq "parent" ) { @@ -2191,8 +1596,10 @@ $searchVal = "%META:TOPICPARENT[{].*name=\\\"($attrWeb\\.)?$attrTopic\\\".*[}]%"; } - my $text = &TWiki::Search::searchWeb( - "inline" => "1", + use TWiki::Search; # search engine + + my $text = TWiki::Search::searchWeb( + #"_callback" => undef, "search" => $searchVal, "web" => $searchWeb, "type" => "regex", @@ -2212,79 +1619,35 @@ return $text; } -# ========================= -=pod +# Deprecated, but used in signatures +sub _handleDATE { + return formatTime(time(), "\$day \$mon \$year", "gmtime"); +} ----++ sub handleSearchWeb ( $attributes, $baseWeb, $baseTopic ) +sub _handleGMTIME { + my $params = shift; + return formatTime( time(), $params->{_DEFAULT}, "gmtime" ); +} -Not yet documented. - -=cut - -sub handleSearchWeb -{ - my( $attributes, $baseWeb, $baseTopic ) = @_; - - my %params = extractParameters( $attributes ); # pass along all attributes - $params{"inline"} = 1; # and add some more - $params{"baseweb"} = $baseWeb; - $params{"basetopic"} = $baseTopic; - $params{"search"} = $params{"_DEFAULT"} if( $params{"_DEFAULT"} ); - $params{"type"} = TWiki::Prefs::getPreferencesValue( "SEARCHVARDEFAULTTYPE" ) unless( $params{"type"} ); - - return TWiki::Search::searchWeb( %params ); +sub _handleSERVERTIME { + my $params = shift; + return formatTime( time(), $params->{_DEFAULT}, "servertime" ); } -# ========================= -#TODO: this seems like a duplication with formatGmTime and formatLocTime -#remove any 2. -=pod - ----++ sub handleTime ( $theAttributes, $theZone ) - -Not yet documented. - -=cut - -sub handleTime -{ - my( $theAttributes, $theZone ) = @_; - # format examples: - # 28 Jul 2000 15:33:59 is "$day $month $year $hour:$min:$sec" - # 001128 is "$ye$mo$day" - - my $format = extractNameValuePair( $theAttributes ); - - my $value = ""; - my $time = time(); - -# if( $format ) { - $value = formatTime($time, $format, $theZone); - # } else { - # if( $theZone eq "gmtime" ) { - # $value = gmtime( $time ); - # } elsif( $theZone eq "servertime" ) { - # $value = localtime( $time ); - # } - # } - -# if( $theZone eq "gmtime" ) { -# $value = $value." GMT"; -# } - - return $value; +sub _handleDISPLAYTIME { + my $params = shift; + return formatTime( time(), $params->{_DEFAULT}, $displayTimeValues ); } -# ========================= =pod ----++ sub formatTime ($epochSeconds, $formatString, $outputTimeZone) ==> $value + +---++ formatTime ($epochSeconds, $formatString, $outputTimeZone) ==> $value | $epochSeconds | epochSecs GMT | | $formatString | twiki time date format | | $outputTimeZone | timezone to display. (not sure this will work)(gmtime or servertime) | =cut -sub formatTime -{ +sub formatTime { my ($epochSeconds, $formatString, $outputTimeZone) = @_; my $value = $epochSeconds; @@ -2313,8 +1676,8 @@ } else { #TODO: $formatString = $formatString. # TZD = time zone designator (Z or +hh:mm or -hh:mm) } - } - + } + $value = $formatString; $value =~ s/\$sec[o]?[n]?[d]?[s]?/sprintf("%.2u",$sec)/geoi; $value =~ s/\$min[u]?[t]?[e]?[s]?/sprintf("%.2u",$min)/geoi; @@ -2326,41 +1689,36 @@ $value =~ s/\$mo/sprintf("%.2u",$mon+1)/geoi; $value =~ s/\$yea[r]?/sprintf("%.4u",$year+1900)/geoi; $value =~ s/\$ye/sprintf("%.2u",$year%100)/geoi; - -#TODO: how do we get the different timezone strings (and when we add usertime, then what?) + +#TODO: how do we get the different timezone strings (and when we add usertime, then what?) my $tz_str = "GMT"; $tz_str = "Local" if ( $outputTimeZone eq "servertime" ); $value =~ s/\$tz/$tz_str/geoi; - - return $value; + + return $value; } -# ========================= -=pod ----++ sub handleRevisionInfo ( $web, $topic, $formatString ) ==> $value -| $web | web and | -| $topic | topic to display the name for | -| $formatString | twiki format string (like in search) | +#| $web | web and | +#| $topic | topic to display the name for | +#| $formatString | twiki format string (like in search) | +sub _handleREVINFO { + my ( $params, $theTopic, $theWeb ) = @_; -=cut -sub handleRevisionInfo -{ - my( $theWeb, $theTopic, $theArgs ) = @_; - - my %params = extractParameters( $theArgs ); - - my $format = $params{"_DEFAULT"} || $params{"format"} || "r1.\$rev - \$date - \$wikiusername"; - my $web = $params{"web"} || $theWeb; - my $topic = $params{"topic"} || $theTopic; + my $format = $params->{_DEFAULT} || $params->{format} + || "r1.\$rev - \$date - \$wikiusername"; + my $web = $params->{web} || $theWeb; + my $topic = $params->{topic} || $theTopic; my $cgiQuery = getCgiQuery(); my $cgiRev = ""; $cgiRev = $cgiQuery->param('rev') if( $cgiQuery ); - my $revnum = $cgiRev || $params{"rev"} || ""; + my $revnum = $cgiRev || $params->{rev} || ""; + $revnum =~ s/r?1\.//; # cut "r" and major - my( $date, $user, $rev, $comment ) = TWiki::Store::getRevisionInfo( $web, $topic, $revnum ); - my $wikiName = userToWikiName( $user, 1 ); - my $wikiUserName = userToWikiName( $user ); + my( $date, $user, $rev, $comment ) = + TWiki::Store::getRevisionInfo( $web, $topic, $revnum ); + my $wikiName = TWiki::User::userToWikiName( $user, 1 ); + my $wikiUserName = TWiki::User::userToWikiName( $user ); my $value = $format; $value =~ s/\$web/$web/goi; @@ -2371,189 +1729,58 @@ $value =~ s/\$username/$user/goi; $value =~ s/\$wikiname/$wikiName/goi; $value =~ s/\$wikiusername/$wikiUserName/goi; - - return $value; + + return $value; } -#AS -# ========================= -=pod +sub _handleENCODE { + my $params = shift; ----++ sub showError ( $errormessage ) - -Not yet documented. - -=cut - -sub showError -{ - my( $errormessage ) = @_; - return "$errormessage" ; + my $type = $params->{type}; + my $text = $params->{_DEFAULT}; + if ( $type && $type =~ /^entit(y|ies)$/i ) { + return entityEncode( $text ); + } else { + return _urlEncode( $text ); + } } -=pod +sub _handleSEARCH { + my ( $params, $theTopic, $theWeb ) = @_; ----++ handleToc( $text, $topic, $web, $tocAttributes ) -Parameters: - * $text : the text of the current topic - * $topic : the topic we are in - * $web : the web we are in - * $tocAttributes : "Topic" [web="Web"] [depth="N"] -Return value: $tableOfContents + # pass on all attrs, and add some more + #$params->{_callback} = undef; + $params->{inline} = 1; + $params->{baseweb} = $theTopic; + $params->{basetopic} = $theWeb; + $params->{search} = $params->{_DEFAULT} if( $params->{_DEFAULT} ); + $params->{type} = TWiki::Prefs::getPreferencesValue( "SEARCHVARDEFAULTTYPE" ) unless( $params->{type} ); -Andrea Sterbini 22-08-00 / PTh 28 Feb 2001 + use TWiki::Search; # search engine -Handles %TOC{...}% syntax. Creates a table of contents using TWiki bulleted -list markup, linked to the section headings of a topic. A section heading is -entered in one of the following forms: - * $headingPatternSp : \t++... spaces section heading - * $headingPatternDa : ---++... dashes section heading - * $headingPatternHt : <h[1-6]> HTML section heading </h[1-6]> + return TWiki::Search::searchWeb( %$params ); +} -=cut - -sub handleToc -{ - ## $_[0] $_[1] $_[2] $_[3] - ## my( $theText, $theTopic, $theWeb, $attributes ) = @_; - - my %params = extractParameters( $_[3] ); - - # get the topic name attribute - my $topicname = $params{"_DEFAULT"} || $_[1]; - - # get the web name attribute - my $web = $params{"web"} || $_[2]; - $web =~ s/\//\./g; - my $webPath = $web; - $webPath =~ s/\./\//g; - - # get the depth limit attribute - my $depth = $params{"depth"} || 6; - - #get the title attribute - my $title = $params{"title"} || ""; - $title = "\n$title" if( $title ); - - my $result = ""; - my $line = ""; - my $level = ""; - my @list = (); - - if( "$web.$topicname" eq "$_[2].$_[1]" ) { - # use text from parameter - @list = split( /\n/, $_[0] ); - - } else { - # read text from file - if ( ! &TWiki::Store::topicExists( $web, $topicname ) ) { - return showError( "TOC: Cannot find topic \"$web.$topicname\"" ); - } - my $t = TWiki::Store::readWebTopic( $web, $topicname ); - $t =~ s/.*?%STARTINCLUDE%//s; - $t =~ s/%STOPINCLUDE%.*//s; - @list = split( /\n/, handleCommonTags( $t, $topicname, $web ) ); - } - - @list = grep { /(<\/?pre>)|($regex{headerPatternDa})|($regex{headerPatternSp})|($regex{headerPatternHt})/ } @list; - my $insidePre = 0; - my $i = 0; - my $tabs = ""; - my $anchor = ""; - my $highest = 99; - foreach $line ( @list ) { - if( $line =~ /^.*
.*$/io ) {
-            $insidePre = 1;
-            $line = "";
-        }
-        if( $line =~ /^.*<\/pre>.*$/io ) {
-            $insidePre = 0;
-            $line = "";
-        }
-        if (!$insidePre) {
-            $level = $line ;
-            if ( $line =~  /$regex{headerPatternDa}/o ) {
-                $level =~ s/$regex{headerPatternDa}/$1/go;
-                $level = length $level;
-                $line  =~ s/$regex{headerPatternDa}/$2/go;
-            } elsif
-               ( $line =~  /$regex{headerPatternSp}/o ) {
-                $level =~ s/$regex{headerPatternSp}/$1/go;
-                $level = length $level;
-                $line  =~ s/$regex{headerPatternSp}/$2/go;
-            } elsif
-               ( $line =~  /$regex{headerPatternHt}/io ) {
-                $level =~ s/$regex{headerPatternHt}/$1/gio;
-                $line  =~ s/$regex{headerPatternHt}/$2/gio;
-            }
-            my $urlPath = "";
-            if( "$web.$topicname" ne "$webName.$topicName" ) {
-                # not current topic, can't omit URL
-                $urlPath = "$dispScriptUrlPath$dispViewPath$scriptSuffix/$webPath/$topicname";
-            }
-            if( ( $line ) && ( $level <= $depth ) ) {
-                $anchor = TWiki::Render::makeAnchorName( $line );
-                # cut TOC exclude '---+ heading !! exclude'
-                $line  =~ s/\s*$regex{headerPatternNoTOC}.+$//go;
-                $line  =~ s/[\n\r]//go;
-                next unless $line;
-                $highest = $level if( $level < $highest );
-                $tabs = "";
-                for( $i=0 ; $i<$level ; $i++ ) {
-                    $tabs = "\t$tabs";
-                }
-                # Remove *bold*, _italic_ and =fixed= formatting
-                $line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
-                $line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
-                $line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
-                # Prevent WikiLinks
-                $line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g;  # '[[...][...]]'
-                $line =~ s/\[\[(.*?)\]\]/$1/ge;        # '[[...]]'
-                $line =~ s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1$3/g;  # 'Web.TopicName'
-                $line =~ s/([\s\(])($regex{wikiWordRegex})/$1$2/g;  # 'TopicName'
-                $line =~ s/([\s\(])($regex{abbrevRegex})/$1$2/g;    # 'TLA'
-                # create linked bullet item, using a relative link to anchor
-                $line = "$tabs* $line";
-                $result .= "\n$line";
-            }
-        }
-    }
-    if( $result ) {
-        if( $highest > 1 ) {
-            # left shift TOC
-            $highest--;
-            $result =~ s/^\t{$highest}//gm;
-        }
-        $result = "
$title$result\n
"; - return $result; - - } else { - return showError("TOC: No TOC in \"$web.$topicname\""); - } +# Format an error for inline inclusion in HTML +sub _inlineError { + my( $errormessage ) = @_; + return "$errormessage" ; } -# ========================= =pod ----++ sub getPublicWebList () +---++ getPublicWebList () +Return public web list, i.e. exclude hidden webs, but include current web -Not yet documented. - =cut -sub getPublicWebList -{ - # FIXME: Should this go elsewhere? - # (Not in Store because Store should not be dependent on Prefs.) - +sub getPublicWebList { if( ! @publicWebList ) { - # build public web list, e.g. exclude hidden webs, but include current web - my @list = &TWiki::Store::getAllWebs( "" ); + my @list = TWiki::Store::getAllWebs(); my $item = ""; my $hidden = ""; foreach $item ( @list ) { - $hidden = &TWiki::Prefs::getPreferencesValue( "NOSEARCHALL", $item ); - # exclude topics that are hidden or start with . or _ unless current web + $hidden = TWiki::Prefs::getPreferencesValue( "NOSEARCHALL", $item ); if( ( $item eq $TWiki::webName ) || ( ( ! $hidden ) && ( $item =~ /^[^\.\_]/ ) ) ) { push( @publicWebList, $item ); } @@ -2562,58 +1789,66 @@ return @publicWebList; } -# ========================= =pod ----++ sub expandVariablesOnTopicCreation ( $theText, $theUser, $theWikiName, $theWikiUserName ) +---++ expandVariablesOnTopicCreation ( $theText, $theUser, $theWikiName, $theWikiUserName ) +Expand limited set of variables during topic creation. These are variables +expected in templates that must be statically expanded in new content. -Expand limited set of variables with a topic during topic creation +The expanded variables are: +| =%DATE%= | Signature-format date | +| =%USERNAME%= | Base login name | +| =%WIKINAME%= | Wiki name | +| =%WIKIUSERNAME%= | Wiki name with prepended web | +| =%URLPARAM%= | Parameters to the current CGI query | +| =%NOP%= | No-op | =cut sub expandVariablesOnTopicCreation { my ( $theText, $theUser, $theWikiName, $theWikiUserName ) = @_; - my $today = formatTime(time(), "\$day \$mon \$year", "gmtime"); - $theUser = $userName unless $theUser; - $theWikiName = userToWikiName( $theUser, 1 ) unless $theWikiName; - $theWikiUserName = userToWikiName( $theUser ) unless $theWikiUserName; + $theUser = $userName unless $theUser; + $theWikiName = TWiki::User::userToWikiName( $theUser, 1 ) + unless $theWikiName; + $theWikiUserName = TWiki::User::userToWikiName( $theUser ) + unless $theWikiUserName; - $theText =~ s/%DATE%/$today/go; - $theText =~ s/%USERNAME%/$theUser/go; # "jdoe" - $theText =~ s/%WIKINAME%/$theWikiName/go; # "JonDoe" - $theText =~ s/%WIKIUSERNAME%/$theWikiUserName/go; # "Main.JonDoe" - $theText =~ s/%URLPARAM{(.*?)}%/&handleUrlParam($1)/geo; # expand URL parameters - $theText =~ s/%NOP{.*?}%//gos; # Remove filler: Use it to remove access control at time of - $theText =~ s/%NOP%//go; # topic instantiation or to prevent search from hitting a template + $theText =~ s/%DATE%/&_handleDATE()/ge; + $theText =~ s/%USERNAME%/$theUser/go; # "jdoe" + $theText =~ s/%WIKINAME%/$theWikiName/go; # "JonDoe" + $theText =~ s/%WIKIUSERNAME%/$theWikiUserName/go; # "Main.JonDoe" + $theText =~ s/%URLPARAM{(.*?)}%/&_handleURLPARAM(\%{extractParameters($1)})/geo; + # Remove filler: Use it to remove access control at time of + # topic instantiation or to prevent search from hitting a template + # SMELL: this expansion of %NOP{}% is different to the default + # which retains content..... + $theText =~ s/%NOP{.*?}%//gos; + $theText =~ s/%NOP%//go; return $theText; } -# ========================= -=pod +sub _handleWEBLIST { + return _webOrTopicList( 1, @_ ); +} ----++ sub handleWebAndTopicList ( $theAttr, $isWeb ) +sub _handleTOPICLIST { + return _webOrTopicList( 0, @_ ); +} -Not yet documented. +sub _webOrTopicList { + my( $isWeb, $params ) = @_; -=cut - -sub handleWebAndTopicList -{ - my( $theAttr, $isWeb ) = @_; - - my %params = extractParameters( $theAttr ); - - my $format = $params{"_DEFAULT"} || $params{"format"} || ""; + my $format = $params->{_DEFAULT} || $params->{format}; $format .= '$name' unless( $format =~ /\$name/ ); - my $separator = $params{"separator"} || "\n"; - my $web = $params{"web"} || ""; - my $webs = $params{"webs"} || "public"; - my $selection = $params{"selection"} || ""; + my $separator = $params->{separator} || "\n"; + my $web = $params->{web} || ""; + my $webs = $params->{webs} || "public"; + my $selection = $params->{selection} || ""; $selection =~ s/\,/ /g; $selection = " $selection "; - my $marker = $params{"marker"} || 'selected="selected"'; + my $marker = $params->{marker} || 'selected="selected"'; my @list = (); if( $isWeb ) { @@ -2622,16 +1857,16 @@ if( $aweb eq "public" ) { push( @list, getPublicWebList() ); } elsif( $aweb eq "webtemplate" ) { - push( @list, grep { /^\_/o } &TWiki::Store::getAllWebs( "" ) ); + push( @list, grep { /^\_/o } TWiki::Store::getAllWebs() ); } else{ - push( @list, $aweb ) if( &TWiki::Store::webExists( $aweb ) ); + push( @list, $aweb ) if( TWiki::Store::webExists( $aweb ) ); } } } else { $web = $webName if( ! $web ); - my $hidden = &TWiki::Prefs::getPreferencesValue( "NOSEARCHALL", $web ); + my $hidden = TWiki::Prefs::getPreferencesValue( "NOSEARCHALL", $web ); if( ( $web eq $TWiki::webName ) || ( ! $hidden ) ) { - @list = &TWiki::Store::getTopicNames( $web ); + @list = TWiki::Store::getTopicNames( $web ); } } my $text = ""; @@ -2651,26 +1886,15 @@ return $text; } -# ========================= -=pod +sub _handleURLPARAM { + my $params = shift; ----++ sub handleUrlParam ( $theArgs ) + my $param = $params->{_DEFAULT}; + my $newLine = $params->{newline}; + my $encode = $params->{encode}; + my $multiple = $params->{multiple}; + my $separator = $params->{separator} || "\n"; -Not yet documented. - -=cut - -sub handleUrlParam -{ - my( $theArgs ) = @_; - - my %params = extractParameters( $theArgs ); - my $param = $params{"_DEFAULT"} || ""; - my $newLine = $params{"newline"} || ""; - my $encode = $params{"encode"} || ""; - my $multiple = $params{"multiple"} || ""; - my $separator = $params{"separator"} || "\n"; - my $value = ""; if( $cgiQuery ) { if( $multiple ) { @@ -2693,521 +1917,407 @@ } } $value =~ s/\r?\n/$newLine/go if( $newLine ); - $value = handleUrlEncode( $value, 0, $encode ) if( $encode ); + if ( $encode && $encode =~ /^entit(y|ies)$/ ) { + $value = entityEncode( $value ); + } else { + $value = _urlEncode( $value ); + } unless( $value ) { - $value = $params{"default"} || ""; + $value = $params->{default} || ""; } return $value; } -# ========================= -# Encode to URL parameter or HTML entity -# TODO: For non-ISO-8859-1 $siteCharset, need to convert to Unicode -# for use in entity, or to UTF-8 before URL encoding. - =pod ----++ sub handleUrlEncode ( $theArgs, $doExtract ) +---++ entityEncode (text ) +| =$text= | Text to encode | +Escape certain characters to HTML entities -Not yet documented. - =cut -sub handleUrlEncode -{ - my( $theArgs, $doExtract, $theType ) = @_; +sub entityEncode { + my $text = shift; - my $text = $theArgs; - my $type = $theType || ""; - if( $doExtract ) { - $text = extractNameValuePair( $theArgs ); - $type = extractNameValuePair( $theArgs, "type" ) || ""; - } - if( $type =~ /^entit(y|ies)$/i ) { - # HTML entity encoding - # TODO: Encode characters > 0x7F to Unicode first - $text =~ s/\"/\&\#034;/g; - $text =~ s/\%/\&\#037;/g; - $text =~ s/\*/\&\#042;/g; - $text =~ s/\_/\&\#095;/g; - $text =~ s/\=/\&\#061;/g; - $text =~ s/\[/\&\#091;/g; - $text =~ s/\]/\&\#093;/g; - $text =~ s/\/\&\#062;/g; - $text =~ s/\|/\&\#124;/g; - } else { - # URL encoding - $text =~ s/[\n\r]/\%3Cbr\%20\%2F\%3E/g; - $text =~ s/\s+/\%20/g; - $text =~ s/\"/\%22/g; - $text =~ s/\&/\%26/g; - $text =~ s/\+/\%2B/g; - $text =~ s/\/\%3E/g; - $text =~ s/\\/\%5C/g; - # Encode characters > 0x7F (ASCII-derived charsets only) - # TODO: Encode to UTF-8 first - $text =~ s/([\x7f-\xff])/'%' . unpack( "H*", $1 ) /ge; - } + # HTML entity encoding + $text =~ s/([\"\%\*\_\=\[\]\<\>\|])/"\&\#".ord( $1 ).";"/ge; return $text; } +# Generate a $w-char hexidecimal number representing $n. +# Default $w is 2 (one byte) +sub _hexchar { + my( $n, $w ) = @_; + $w = 2 unless $w; + return sprintf( "%0${w}x", ord( $n )); +} -=pod +# Encode to URL parameter +# TODO: For non-ISO-8859-1 $siteCharset, need to convert to +# UTF-8 before URL encoding. +# | =$text= | Text to encode | +# SMELL: what is the relationship to nativeUrlEncode?? +sub _urlEncode { + my $text = shift; ----++ sub handleNativeUrlEncode ( $theStr, $doExtract ) + # URL encoding + $text =~ s/[\n\r]/\%3Cbr\%20\%2F\%3E/g; + $text =~ s/\s/\%20/g; + $text =~ s/(["&+<>\\])/"%"._hexchar($1,2)/ge; + # Encode characters > 0x7F (ASCII-derived charsets only) + # TODO: Encode to UTF-8 first + $text =~ s/([\x7f-\xff])/'%' . unpack( "H*", $1 ) /ge; + return $text; +} + +=pod + +---++ nativeUrlEncode ( $theStr, $doExtract ) Perform URL encoding into native charset ($siteCharset) - for use when viewing attachments via browsers that generate UTF-8 URLs, on sites running with non-UTF-8 (Native) character sets. Aim is to prevent UTF-8 URL encoding. For mainframes, we assume that UTF-8 URLs will be translated by the web server to an EBCDIC character set. +SMELL: why is this different to _urlEncode? + =cut -sub handleNativeUrlEncode { - my( $theStr, $doExtract ) = @_; +sub nativeUrlEncode { + my $theStr = shift; my $isEbcdic = ( 'A' eq chr(193) ); # True if Perl is using EBCDIC if( $siteCharset eq "utf-8" or $isEbcdic ) { - # Just strip double quotes, no URL encoding - let browser encode to - # UTF-8 or EBCDIC based $siteCharset as appropriate - $theStr =~ s/^"(.*)"$/$1/; - return $theStr; + # Just strip double quotes, no URL encoding - let browser encode to + # UTF-8 or EBCDIC based $siteCharset as appropriate + $theStr =~ s/^"(.*)"$/$1/; + return $theStr; } else { - return handleUrlEncode( $theStr, $doExtract ); + return _urlEncode( $theStr ); } } -=pod - ----++ sub handleIntUrlEncode ( $theStr, $doExtract ) - -This routine was introduced to URL encode Mozilla's UTF-8 POST URLs in the -TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now -directly supported, but it is provided for backward compatibility with -skins that may still be using the deprecated %INTURLENCODE%. - -=cut - -sub handleIntUrlEncode -{ - my( $theStr ) = @_; - +# This routine was introduced to URL encode Mozilla UTF-8 POST URLs in the +# TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now +# directly supported, but it is provided for backward compatibility with +# skins that may still be using the deprecated %INTURLENCODE%. +sub _handleINTURLENCODE { + my $params = shift; # Just strip double quotes, no URL encoding - Mozilla UTF-8 URLs # directly supported now - $theStr =~ s/^"(.*)"$/$1/; - return $theStr; + return $params->{_DEFAULT}; } =pod ----++ sub handleEnvVariable ( $theVar ) +---++ sub searchableTopic ( $topic ) -Not yet documented. +Space out the topic name for a search, by inserting " *" at +the start of each component word. =cut -sub handleEnvVariable +sub searchableTopic { - my( $theVar ) = @_; - my $value = $ENV{$theVar} || ""; - return $value; + my( $topic ) = @_; + # FindMe -> Find\s*Me + $topic =~ s/([$regex{lowerAlpha}]+)([$regex{upperAlpha}$regex{numeric}]+)/$1%20*$2/go; # "%20*" is " *" - I18N: only in ASCII-derived charsets + return $topic; } -=pod +sub _handleSPACEDTOPIC { + my ( $params, $theTopic ) = @_; ----++ sub handleTmplP ( $theParam ) + return _urlEncode( searchableTopic( $theTopic )); +} -Not yet documented. +sub _handleICON { + my $params = shift; -=cut + my $theParam = $params->{_DEFAULT}; -sub handleTmplP -{ - my( $theParam ) = @_; - - $theParam = extractNameValuePair( $theParam ); - my $value = &TWiki::Store::handleTmplP( $theParam ); + my $value = TWiki::Render::filenameToIcon( "file.$theParam" ); return $value; } -# ========================= -# Create spaced-out topic name for Ref-By search -=pod +sub _handleRELATIVETOPICPATH { + my ( $params, $theTopic, $theWeb ) = @_; ----++ sub handleSpacedTopic ( $theTopic ) + my $theStyleTopic = $params->{_DEFAULT}; -Not yet documented. + return "" unless $theStyleTopic; -=cut - -sub handleSpacedTopic -{ - my( $theTopic ) = @_; - my $spacedTopic = $theTopic; - $spacedTopic =~ s/($regex{singleLowerAlphaRegex}+)($regex{singleUpperAlphaNumRegex}+)/$1%20*$2/go; # "%20*" is " *" - I18N: only in ASCII-derived charsets - return $spacedTopic; + my $theRelativePath; + # if there is no dot in $theStyleTopic, no web has been specified + if ( index( $theStyleTopic, "." ) == -1 ) { + # add local web + $theRelativePath = $theWeb . "/" . $theStyleTopic; + } else { + $theRelativePath = $theStyleTopic; #including dot + } + # replace dot by slash is not necessary; TWiki.MyTopic is a valid url + # add ../ if not already present to make a relative file reference + if ( index( $theRelativePath, "../" ) == -1 ) { + $theRelativePath = "../" . $theRelativePath; + } + return $theRelativePath; } -# ========================= -=pod +sub _handleATTACHURLPATH { + my ( $params, $theTopic, $theWeb ) = @_; ----++ sub handleIcon ( $theParam ) - -Not yet documented. - -=cut - -sub handleIcon -{ - my( $theParam ) = @_; - - $theParam = extractNameValuePair( $theParam ); - my $value = &TWiki::Attach::filenameToIcon( "file.$theParam" ); - return $value; + return nativeUrlEncode( "$pubUrlPath/$theWeb/$theTopic" ); } =pod ----++ sub handleRelativeTopicPath ( $styleTopic, $web ) +---++ processTags( \$text, $topic, $web, $verb, $incs ) +Expands variables by replacing the variables with their +values. Some example variables: %TOPIC%, %SCRIPTURL%, +%WIKINAME%, etc. -Not yet documented. +$web and $incs are passed in for recursive include expansion. They can +safely be undef. -=cut +The rules for tag expansion are: + 1 Tags are expanded left to right, in the order they are encountered. + 1 Tags are recursively expanded as soon as they are encountered - the algorithm is inherently single-pass + 1 A tag is not ""encountered" until the matching }% has been seen, by which time all tags in parameters will have been expanded + 1 Tag expansions that create new tags recursively are limited to a set number of hierarchical levels of expansion -sub handleRelativeTopicPath -{ - my( $theStyleTopic, $theWeb ) = @_; +Formerly known as handleInternalTags, but renamed when it was rewritten +because the old name clashes with the namespace of handlers. - if ( !$theStyleTopic ) { - return ""; - } - my $theRelativePath; - # if there is no dot in $theStyleTopic, no web has been specified - if ( index( $theStyleTopic, "." ) == -1 ) { - # add local web - $theRelativePath = $theWeb . "/" . $theStyleTopic; - } else { - $theRelativePath = $theStyleTopic; #including dot - } - # replace dot by slash is not necessary; TWiki.MyTopic is a valid url - # add ../ if not already present to make a relative file reference - if ( index( $theRelativePath, "../" ) == -1 ) { - $theRelativePath = "../" . $theRelativePath; - } - return $theRelativePath; -} - -=pod - ----++ handleInternalTags( $text, $topic, $web ) - -Modifies $text in-place, replacing variables internal to TWiki with their -values. Some example variables: %TOPIC%, %SCRIPTURL%, %WIKINAME%, etc. - =cut -sub handleInternalTags -{ - # modify arguments directly, i.e. call by reference - # $_[0] is text - # $_[1] is topic - # $_[2] is web +sub processTags { + my $text = shift; # reference + my ( $topic, $web ) = @_; - # Make Edit URL unique for every edit - fix for RefreshEditPage. - $_[0] =~ s!%EDITURL%!"$dispScriptUrlPath/edit$scriptSuffix/%WEB%/%TOPIC%\?t=" . time()!ge; + my $memTopic = $sessionInternalTags{TOPIC}; + my $memWeb = $sessionInternalTags{WEB}; + my $memEurl = $sessionInternalTags{EDITURL}; - $_[0] =~ s/%NOP{(.*?)}%/$1/gs; # remove NOP tag in template topics but show content - $_[0] =~ s/%NOP%//g; - $_[0] =~ s/%TMPL\:P{(.*?)}%/&handleTmplP($1)/ge; - $_[0] =~ s/%SEP%/&handleTmplP('"sep"')/ge; + $sessionInternalTags{TOPIC} = $topic; + $sessionInternalTags{WEB} = $web; + # Make Edit URL unique - fix for RefreshEditPage. + $sessionInternalTags{EDITURL} = + "$dispScriptUrlPath/edit$scriptSuffix/$web/$topic\?t=" . time(); - $_[0] =~ s/%HTTP_HOST%/&handleEnvVariable('HTTP_HOST')/ge; - $_[0] =~ s/%REMOTE_ADDR%/&handleEnvVariable('REMOTE_ADDR')/ge; - $_[0] =~ s/%REMOTE_PORT%/&handleEnvVariable('REMOTE_PORT')/ge; - $_[0] =~ s/%REMOTE_USER%/&handleEnvVariable('REMOTE_USER')/ge; + # SMELL: why is this done every time, and not statically during + # template loading? + $$text =~ s/%NOP{(.*?)}%/$1/gs; # remove NOP tag in template topics but show content + $$text =~ s/%NOP%//g; + my $sep = TWiki::Templates::expandTemplate('"sep"'); + $$text =~ s/%SEP%/$sep/g; - $_[0] =~ s/%TOPIC%/$_[1]/g; - $_[0] =~ s/%BASETOPIC%/$topicName/g; - $_[0] =~ s/%INCLUDINGTOPIC%/$includingTopicName/g; - $_[0] =~ s/%SPACEDTOPIC%/&handleSpacedTopic($_[1])/ge; - $_[0] =~ s/%WEB%/$_[2]/g; - $_[0] =~ s/%BASEWEB%/$webName/g; - $_[0] =~ s/%INCLUDINGWEB%/$includingWebName/g; + # NOTE TO DEBUGGERS + # The depth parameter in the following call controls the maximum number + # of levels of expansion. If it is set to 1 then only tags in the + # topic will be expanded; tags that they in turn generate will be + # left unexpanded. If it is set to 2 then the expansion will stop after + # the first recursive inclusion, and so on. This is incredible useful + # when debugging The default is set to 16 + # to match the original limit on search expansion, though this of + # course applies to _all_ tags and not just search. + $$text = _processTags( $$text, 16, "", @_ ); - # I18N information - $_[0] =~ s/%CHARSET%/$siteCharset/g; - $_[0] =~ s/%SHORTLANG%/$siteLang/g; - $_[0] =~ s/%LANG%/$siteFullLang/g; + $sessionInternalTags{TOPIC} = $memTopic; + $sessionInternalTags{WEB} = $memWeb; + $sessionInternalTags{EDITURL} = $memEurl; +} - $_[0] =~ s/%TOPICLIST{(.*?)}%/&handleWebAndTopicList($1,'0')/ge; - $_[0] =~ s/%WEBLIST{(.*?)}%/&handleWebAndTopicList($1,'1')/ge; +# Process TWiki %TAGS{}% by parsing the input tokenised into +# % separated sections. The parser is a simple stack-based parse, +# sufficient to ensure nesting of tags is correct, but no more +# than that. +# $depth limits the number of recursive expansion steps that +# can be performed on expanded tags. +sub _processTags { + my $text = shift; - # URLs and paths - $_[0] =~ s/%WIKIHOMEURL%/$wikiHomeUrl/g; - $_[0] =~ s/%SCRIPTURL%/$urlHost$dispScriptUrlPath/g; - $_[0] =~ s/%SCRIPTURLPATH%/$dispScriptUrlPath/g; - $_[0] =~ s/%SCRIPTSUFFIX%/$scriptSuffix/g; - $_[0] =~ s/%PUBURL%/$urlHost$pubUrlPath/g; - $_[0] =~ s/%PUBURLPATH%/$pubUrlPath/g; - $_[0] =~ s/%RELATIVETOPICPATH{(.*?)}%/&handleRelativeTopicPath($1,$_[2])/ge; + return "" unless defined( $text ); - # Attachments - $_[0] =~ s!%ATTACHURL%!$urlHost%ATTACHURLPATH%!g; - # I18N: URL-encode full web, topic and filename to the native - # $siteCharset for attachments viewed from browsers that use UTF-8 URL, - # unless we are in UTF-8 mode or working on EBCDIC mainframe. - # Include the filename suffixed to %ATTACHURLPATH% - a hack, but required - # for migration purposes - $_[0] =~ s!%ATTACHURLPATH%/($regex{filenameRegex})!&handleNativeUrlEncode("$pubUrlPath/$_[2]/$_[1]/$1",1)!ge; - $_[0] =~ s!%ATTACHURLPATH%!&handleNativeUrlEncode("$pubUrlPath/$_[2]/$_[1]",1)!ge; # No-filename case - $_[0] =~ s/%ICON{(.*?)}%/&handleIcon($1)/ge; + my $depth = shift; + my $expanding = shift; - # URL encoding - $_[0] =~ s/%URLPARAM{(.*?)}%/&handleUrlParam($1)/ge; - $_[0] =~ s/%(URL)?ENCODE{(.*?)}%/&handleUrlEncode($2,1)/ge; # ENCODE is documented, URLENCODE is legacy - $_[0] =~ s/%INTURLENCODE{(.*?)}%/&handleIntUrlEncode($1)/ge; # Deprecated - not needed with UTF-8 URL support - - # Dates and times - $_[0] =~ s/%DATE%/&formatTime(time(), "\$day \$mon \$year", "gmtime")/ge; # Deprecated, but used in signatures - $_[0] =~ s/%GMTIME%/&handleTime("","gmtime")/ge; - $_[0] =~ s/%GMTIME{(.*?)}%/&handleTime($1,"gmtime")/ge; - $_[0] =~ s/%SERVERTIME%/&handleTime("","servertime")/ge; - $_[0] =~ s/%SERVERTIME{(.*?)}%/&handleTime($1,"servertime")/ge; - $_[0] =~ s/%DISPLAYTIME%/&handleTime("", $displayTimeValues)/ge; - $_[0] =~ s/%DISPLAYTIME{(.*?)}%/&handleTime($1, $displayTimeValues)/ge; + # my( $topic, $web, $verbatim, $processedTopics ) = @_; - $_[0] =~ s/%WIKIVERSION%/$wikiversion/g; - $_[0] =~ s/%PLUGINVERSION{(.*?)}%/TWiki::Plugins::getPluginVersion($1)/ge; - $_[0] =~ s/%USERNAME%/$userName/g; - $_[0] =~ s/%WIKINAME%/$wikiName/g; - $_[0] =~ s/%WIKIUSERNAME%/$wikiUserName/g; - $_[0] =~ s/%WIKITOOLNAME%/$wikiToolName/g; - $_[0] =~ s/%MAINWEB%/$mainWebname/g; - $_[0] =~ s/%TWIKIWEB%/$twikiWebname/g; - $_[0] =~ s/%HOMETOPIC%/$mainTopicname/g; - $_[0] =~ s/%WIKIUSERSTOPIC%/$wikiUsersTopicname/g; - $_[0] =~ s/%WIKIPREFSTOPIC%/$wikiPrefsTopicname/g; - $_[0] =~ s/%WEBPREFSTOPIC%/$webPrefsTopicname/g; - $_[0] =~ s/%NOTIFYTOPIC%/$notifyTopicname/g; - $_[0] =~ s/%STATISTICSTOPIC%/$statisticsTopicname/g; - $_[0] =~ s/%STARTINCLUDE%//g; - $_[0] =~ s/%STOPINCLUDE%//g; - $_[0] =~ s/%SECTION{(.*?)}%//g; - $_[0] =~ s/%ENDSECTION%//g; - my $ok = 16; # SEARCH may be nested up to 16 times - TRY: while( $_[0] =~ s/%SEARCH{(.*?)}%/&handleSearchWeb($1,$_[2],$_[1])/ge ) { - last TRY unless( --$ok ); + unless ( $depth ) { + my $mess = "Max recursive depth reached: $expanding"; + writeWarning( $mess ); + return $text; + #return _inlineError( $mess ); } - $_[0] =~ s/%METASEARCH{(.*?)}%/&handleMetaSearch($1)/ge; - $_[0] =~ s/%FORMFIELD{(.*?)}%/&TWiki::Render::getFormField($_[2],$_[1],$1)/ge; - $_[0] =~ s/%REVINFO%/handleRevisionInfo( $_[2], $_[1] )/ge; - $_[0] =~ s/%REVINFO{(.*?)}%/handleRevisionInfo( $_[2], $_[1], $1 )/ge; -} + my @queue = split( /%/, $text ); -=pod + my $sep = ""; + $sep = "%" if ( $text =~ /^%/ ); + my @stack; + my $cycle = 0; + #my $tell = 1; + push( @stack, "" ); + while ( scalar( @queue )) { + my $token = shift( @queue ); + #print STDERR "PROCESSING $token \n" if $tell; + my $simple = 0; ----++ takeOutVerbatim( $text, \@verbatimBuffer ) -Return value: $textWithoutVerbatim + $cycle++; -Searches through $text and extracts <verbatim> blocks, appending each -onto the end of the @verbatimBuffer array and replacing it with a token -string which is not affected by TWiki rendering. The text after these -substitutions is returned. + if ( $sep && $token =~ /^[A-Z][A-Z0-9_:]*{/ ) { + # a parameterised tag; push a new context + push( @stack, $token ); + $simple = $token =~ /}$/; + $token = ""; + # fall through to handle close }% + } elsif ( $sep && $token =~ /^[A-Z][A-Z0-9_:]*$/ ) { + #print STDERR "PUSHING $token ",$stack[$#stack],"\n" if $tell; + push( @stack, "" ); # push a context + $simple = 1; + # fall through to handle close }% + } -This function is designed to preserve the contents of verbatim blocks -through some rendering operation. The general sequence of calls for -this use is something like this: - - $textToRender = takeOutVerbatim($inputText, \@verbatimBlocks); - $renderedText = performSomeRendering($textToRender); - $resultText = putBackVerbatim($renderedText, "pre", @verbatimBlocks); - -Note that some changes are made to verbatim blocks here: < and > are replaced -by their HTML entities &lt; and &gt;, and the actual <verbatim> -tags are replaced with <pre> tags so that the text is rendered truly -"verbatim" by a browser. If this is not desired, pass "verbatim" as the -second parameter of putBackVerbatim instead of "pre". - -=cut - -sub takeOutVerbatim -{ - my( $intext, $verbatim ) = @_; # $verbatim is ref to array - - if( $intext !~ //oi ) { - return( $intext ); - } - - # Exclude text inside verbatim from variable substitution - - my $tmp = ""; - my $outtext = ""; - my $nesting = 0; - my $verbatimCount = $#{$verbatim} + 1; - - foreach( split( /\n/, $intext ) ) { - if( /^(\s*)\s*$/i ) { - $nesting++; - if( $nesting == 1 ) { - $outtext .= "$1%_VERBATIM$verbatimCount%\n"; - $tmp = ""; - next; + if ( $#stack && ( $simple || $token =~ /}$/ )) { + # close of a tag. Pop the context. + my $expr = pop( @stack ) . $token; + my ( $tag, $args ); + if( $expr =~ /^(.*?)\{(.*)\}$/s ) { + ( $tag, $args) = ( $1, $2 ); + } else { + ( $tag, $args ) = ( $expr, undef ); } - } elsif( m|^\s*\s*$|i ) { - $nesting--; - if( ! $nesting ) { - $verbatim->[$verbatimCount++] = $tmp; - next; + #print STDERR "expand $expr ",$stack[$#stack],"\n" if $tell; + my ( $r, $e ) = _handleTag( $expr, $tag, $args, @_ ); + if ( $r ) { + # recursively expand what we just got + $e = _processTags( $e, $depth - 1, + "$expanding:$depth/$tag", @_ ); + if ( defined( $e ) && $e !~ /\n/ ) { + #print STDERR "EXPANDED $tag -> $e\n" if $tell; + #print STDERR "Added to ",$stack[$#stack],"\n" if $tell; + } + $sep = ""; + } else { + #print STDERR "EXPANSION OF $tag ( $expr )failed\n" if $tell; + $e = "%$expr"; } + $stack[$#stack] .= $e; + next; } - if( $nesting ) { - $tmp .= "$_\n"; - } else { - $outtext .= "$_\n"; - } + $sep = "" if $cycle == 1; + # something else separated by % signs + #print STDERR "ADDED $sep$token ".ord($token),"\n" if $tell; + $stack[$#stack] .= "$sep$token"; + $sep = "%"; } - - # Deal with unclosed verbatim - if( $nesting ) { - $verbatim->[$verbatimCount] = $tmp; + + # Run out of input. Close open tags. + while ( $#stack ) { + my $expr = pop( @stack ); + writeWarning( "Unclosed tag $expr..."); + $stack[$#stack] .= $expr; } - - return $outtext; + + return pop( @stack ); } -=pod +# Handle expansion of 'constant' tags (as against preference tags) +# $eref is a reference to the flag that records the number of +# successful expansions on a single pass through the text +# $result is (initially) the whole tag expression +# $tag is the tag part +# $args is the bit in the {} (if there are any) +sub _handleTag { + my $result = shift; # whole expression + my $tag = shift; # tag subexpression + my $args = shift; + # my( $topic, $web, $verbatim, $processedTopics ) = @_; ----++putBackVerbatim( $textWithoutVerbatim, $putBackType, @verbatimBuffer ) -Return value: $textWithVerbatim + my $res; -This function reverses the actions of takeOutVerbatim above. See the text for -takeOutVerbatim for a more thorough description. + if ( defined( $preferencesTags{$tag} )) { + $res = $preferencesTags{$tag}; + } elsif ( defined( $sessionInternalTags{$tag} )) { + $res = $sessionInternalTags{$tag}; + } elsif ( defined( $staticInternalTags{$tag} )) { + $res = $staticInternalTags{$tag}; + } elsif ( defined( $dynamicInternalTags{$tag} )) { + my %params = extractParameters( $args ); -Set $putBackType to 'verbatim' to get back original text, or to 'pre' to -convert to HTML readable verbatim text. - -=cut - -sub putBackVerbatim -{ - my( $text, $type, @verbatim ) = @_; - - for( my $i=0; $i<=$#verbatim; $i++ ) { - my $val = $verbatim[$i]; - if( $type ne "verbatim" ) { - $val =~ s/&/&/g; - $val =~ s//>/g; - $val =~ s/\t/ /g; # A shame to do this, but been in TWiki.org have converted - # 3 spaces to tabs since day 1 - } - $text =~ s|%_VERBATIM$i%|<$type>\n$val|; + $res = &{$dynamicInternalTags{$tag}}( \%params, @_ ); } - return $text; + #if ( defined( $res )) { + # print STDERR "EXPAND $tag -> $res\n"; + #} + return ( defined( $res ), $res ); } =pod ----++ handleCommonTags( $text, $topic, $web, @processedTopics ) -Return value: $handledText +---++ handleCommonTags( $text, $topic, $web ) => processed $text +Processes %VARIABLE%, and %TOC% syntax; also includes +"commonTagsHandler" plugin hook. -Processes %VARIABLE%, %TOC%, and %INCLUDE% syntax; also includes -"commonTagsHandler" plugin hook. If processing an included topic, -@processedTopics should be a list of topics already included, or in -the process of being included. - Returns the text of the topic, after file inclusion, variable substitution, table-of-contents generation, and any plugin changes from commonTagsHandler. =cut -sub handleCommonTags -{ - my( $text, $theTopic, $theWeb, @theProcessedTopics ) = @_; +sub handleCommonTags { + my( $text, $theTopic, $theWeb ) = @_; - # PTh 22 Jul 2000: added $theWeb for correct handling of %INCLUDE%, %SEARCH% if( !$theWeb ) { $theWeb = $webName; } - # TWiki Plugin Hook (for cache Plugins only) - &TWiki::Plugins::beforeCommonTagsHandler( $text, $theTopic, $theWeb ); - my @verbatim = (); - $text = takeOutVerbatim( $text, \@verbatim ); + my $theProcessedTopics = {}; + # Plugin Hook (for cache Plugins only) + TWiki::Plugins::beforeCommonTagsHandler( $text, $theTopic, $theWeb ); + + $text = TWiki::Render::takeOutBlocks( $text, "verbatim", \@verbatim ); + # Escape rendering: Change " !%VARIABLE%" to " %VARIABLE%", for final " %VARIABLE%" output $text =~ s/(\s)\!\%([A-Z])/$1%$2/g; - # handle all preferences and internal tags (for speed: call by reference) - $includingWebName = $theWeb; - $includingTopicName = $theTopic; - &TWiki::Prefs::handlePreferencesTags( $text ); - handleInternalTags( $text, $theTopic, $theWeb ); + my $memW = $sessionInternalTags{INCLUDINGWEB}; + my $memT = $sessionInternalTags{INCLUDINGTOPIC}; + $sessionInternalTags{INCLUDINGWEB} = $theWeb; + $sessionInternalTags{INCLUDINGTOPIC} = $theTopic; - # recursively process multiple embedded %INCLUDE% statements and prefs - $text =~ s/%INCLUDE{(.*?)}%/&handleIncludeFile($1, $theTopic, $theWeb, \@verbatim, @theProcessedTopics )/ge; + processTags( \$text, $theTopic, $theWeb, + \@verbatim, $theProcessedTopics ); - # TWiki Plugin Hook - &TWiki::Plugins::commonTagsHandler( $text, $theTopic, $theWeb, 0 ); + # Plugin Hook + TWiki::Plugins::commonTagsHandler( $text, $theTopic, $theWeb, 0 ); - # handle tags again because of plugin hook - &TWiki::Prefs::handlePreferencesTags( $text ); - handleInternalTags( $text, $theTopic, $theWeb ); - $text =~ s/%INCLUDE{(.*?)}%/&handleIncludeFile($1, $theTopic, $theWeb, \@verbatim, @theProcessedTopics )/ge; + # process tags again because plugin hook may have added more in + processTags( \$text, $theTopic, $theWeb, + \@verbatim, $theProcessedTopics ); - $text =~ s/%TOC{([^}]*)}%/&handleToc($text,$theTopic,$theWeb,$1)/ge; - $text =~ s/%TOC%/&handleToc($text,$theTopic,$theWeb,"")/ge; + $sessionInternalTags{INCLUDINGWEB} = $memW; + $sessionInternalTags{INCLUDINGTOPIC} = $memT; - # Codev.FormattedSearchWithConditionalOutput: remove lines, possibly introduced by - # SEARCHes with conditional CALC. This needs to be done after CALC and before table rendering + # Codev.FormattedSearchWithConditionalOutput: remove lines, + # possibly introduced by SEARCHes with conditional CALC. This needs + # to be done after CALC and before table rendering + # SMELL: is this a hack? Looks like it.... $text =~ s/^\r?\n//gm; - # Ideally would put back in getRenderedVersion rather than here which would save removing - # it again! But this would mean altering many scripts to pass back verbatim - $text = putBackVerbatim( $text, "verbatim", @verbatim ); + $text = TWiki::Render::putBackBlocks( $text, \@verbatim, "verbatim" ); # TWiki Plugin Hook (for cache Plugins only) - &TWiki::Plugins::afterCommonTagsHandler( $text, $theTopic, $theWeb ); + TWiki::Plugins::afterCommonTagsHandler( $text, $theTopic, $theWeb ); return $text; } -# ========================= -=pod - ----++ sub handleMetaTags ( $theWeb, $theTopic, $text, $meta, $isTopRev ) - -| TODO | move to Render.pm or Meta.pm of Forms.pm | -| | used to render the non-active modes of META data (view, preview ...) | -Not yet documented. - -=cut - -sub handleMetaTags -{ - my( $theWeb, $theTopic, $text, $meta, $isTopRev ) = @_; - - $text =~ s/%META{\s*"form"\s*}%/&TWiki::Render::renderFormData( $theWeb, $theTopic, $meta )/ge; #this renders META:FORM and META:FIELD - $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) - $text =~ s/%META{\s*"attachments"\s*(.*)}%/&TWiki::Attach::renderMetaData( $theWeb, - $theTopic, $meta, $1, $isTopRev )/ge; #renders attachment tables - $text =~ s/%META{\s*"moved"\s*}%/&TWiki::Render::renderMoved( $theWeb, $theTopic, $meta )/ge; #render topic moved information - $text =~ s/%META{\s*"parent"\s*(.*)}%/&TWiki::Render::renderParent( $theWeb, $theTopic, $meta, $1 )/ge; #render the parent information - - $text = handleCommonTags( $text, $theTopic ); - $text = TWiki::Render::getRenderedVersion( $text, $theWeb ); - - return $text; -} - =end twiki =cut Index: lib/TWiki/Attach.pm =================================================================== --- lib/TWiki/Attach.pm (revision 1767) +++ lib/TWiki/Attach.pm (working copy) @@ -21,6 +21,14 @@ use strict; +use TWiki; +use TWiki::Templates; +use TWiki::Store; +use TWiki::Render; +use TWiki::User; +use TWiki::Prefs; +use TWiki::Meta; + =begin twiki ---+ TWiki::Attach Module @@ -31,8 +39,6 @@ package TWiki::Attach; -use vars qw( %templateVars ); - # ====================== =pod @@ -64,15 +70,9 @@ my $attrAttr = $attachment->{attr}; if( ! $attrAttr || ( $showAttr && $attrAttr =~ /^[$showAttr]*$/ )) { - $rows .= _formatRow( $web, - $topic, - $attachment->{name}, - $attachment->{version}, + $rows .= _formatRow( $web, $topic, + $attachment, $isTopTopicRev, - $attachment->{date}, - $attachment->{user}, - $attachment->{comment}, - $attachment, $row ); } } @@ -93,30 +93,29 @@ sub _getTemplate { my $template = shift; - if ( ! defined( $templateVars{$template} )) { - TWiki::Store::readTemplate("attachtables"); - } + TWiki::Templates::readTemplate("attachtables") unless + TWiki::Templates::haveTemplate( $template ); - return TWiki::Store::handleTmplP($template); + return TWiki::Templates::expandTemplate( $template ); } #========================= =pod ----++ sub formatVersions ( $theWeb, $theTopic, $attachment, $attrs ) +---++ sub formatVersions ( $theWeb, $theTopic, $attrs ) Generate a version history table for a single attachment | =$web= | the web | | =$topic= | the topic | -| =$attachment= | basename of attachment | | =$attrs= | Hash of meta-data attributes | =cut sub formatVersions { - my( $web, $topic, $attachment, $attrs ) = @_; + my( $web, $topic, %attrs ) = @_; - my $latestRev = TWiki::Store::getRevisionNumber( $web, $topic, $attachment ); + my $latestRev = + TWiki::Store::getRevisionNumber( $web, $topic, $attrs{name} ); $latestRev =~ m/\.(.*)/o; my $maxRevNum = $1; @@ -130,15 +129,18 @@ my $rev = "1.$version"; my( $date, $userName, $minorRev, $comment ) = - TWiki::Store::getRevisionInfo( $web, $topic, $rev, $attachment ); + TWiki::Store::getRevisionInfo( $web, $topic, $rev, $attrs{name} ); $rows .= _formatRow( $web, $topic, - $attachment, - $rev, + { + name => $attrs{name}, + version => $rev, + date => $date, + user => $userName, + comment => $comment, + attr => $attrs{attr}, + size => $attrs{size} + }, ( $rev eq $latestRev), - $date, - $userName, - $comment, - $attrs, $row ); } @@ -148,137 +150,116 @@ #========================= =pod ----++ sub _formatRow ( $web, $topic, $file, $rev, $topRev, $date, $userName, $comment, $attrs, $tmpl ) +---++ sub _formatRow ( $web, $topic, $info, $topRev, $attrs, $tmpl ) Format a single row in an attachment table by expanding a template. | =$web= | the web | | =$topic= | the topic | -| =$file= | the attachment file name | -| =$rev= | the required revision; required to be a full (major.minor) revision number | +| =$info= | hash containing fields name, user (user (not wikiname) who uploaded this revision), date (date of _this revision_ of the attachment), command and version (the required revision; required to be a full (major.minor) revision number) | | =$topRev= | boolean indicating if this revision is the most recent revision | -| =$date= | date of _this revision_ of the attachment | -| =$userName= | user (not wikiname) who uploaded this revision | -| =$comment= | comment against this revision | -| =$attrs= | reference to a hash of other meta-data attributes for the attachment | +| =$tmpl= | The template of a row | =cut sub _formatRow { - my ( $web, $topic, $file, $rev, $topRev, - $date, $userName, $comment, $attrs, $tmpl ) = @_; + my ( $web, $topic, $info, $topRev, $tmpl ) = @_; my $row = $tmpl; - $row =~ s/%A_REV%/$rev/go; + $row =~ s/%A_(\w+)%/&_expandAttrs($1,$web,$topic,$info,$topRev)/ge; + $row =~ s/\0/%/g; - if ( $row =~ /%A_ICON%/o ) { - my $fileIcon = filenameToIcon( $file ); - $row =~ s/%A_ICON%/$fileIcon/go; - } - - if ( $row =~ /%A_URL%/o ) { - my $url; - - if ( $topRev ) { - # I18N: To support attachments via UTF-8 URLs to attachment - # directories/files that use non-UTF-8 character sets, go through viewfile. - # If using %PUBURL%, must URL-encode explicitly to site character set. - $url = TWiki::handleNativeUrlEncode( "%PUBURLPATH%/$web/$topic/$file" ); - } else { - $url = "%SCRIPTURLPATH%/viewfile%SCRIPTSUFFIX%/". - "$web/$topic?rev=$rev&filename=$file"; - } - $row =~ s/%A_URL%/$url/go; - } - - if ( $row =~ /%A_SIZE%/o && $attrs ) { - my $attrSize = $attrs->{size}; - $attrSize = 100 if( $attrSize < 100 ); - $attrSize = sprintf( "%1.1f K", $attrSize / 1024 ); - $row =~ s/%A_SIZE%/$attrSize/go; - } - - $comment =~ s/\|/|/g; - $comment = " " unless ( $comment ); - $row =~ s/%A_COMMENT%/$comment/go; - - if ( $row =~ /%A_ATTRS%/o && $attrs ) { - my $attrAttr = $attrs->{attr}; - $attrAttr = $attrAttr || " "; - $row =~ s/%A_ATTRS%/$attrAttr/go; - } - - $row =~ s/%A_FILE%/$file/go; - - $date = TWiki::formatTime( $date ); - $row =~ s/%A_DATE%/$date/go; - - my $wikiUserName = TWiki::userToWikiName( $userName ); - $row =~ s/%A_USER%/$wikiUserName/go; - return $row; } -# ========================= -=pod +sub _expandAttrs { + my ( $attr, $web, $topic, $info, $topRev ) = @_; + my $file = $info->{name}; ----++ sub filenameToIcon ( $fileName ) + if ( $attr eq "REV" ) { + return $info->{version}; + } + elsif ( $attr eq "ICON" ) { + my $fileIcon = TWiki::Render::filenameToIcon( $file ); + return $fileIcon; + } + elsif ( $attr eq "URL" ) { + my $url; -Produce an image tailored to the type of the file, guessed from -it's extension. - -used in TWiki::handleIcon - -=cut - -sub filenameToIcon -{ - my( $fileName ) = @_; - - my @bits = ( split( /\./, $fileName ) ); - my $fileExt = lc $bits[$#bits]; - - my $tmp = &TWiki::getPubDir(); - my $iconDir = "$tmp/icn"; - my $iconUrl = "$TWiki::pubUrlPath/icn"; - my $iconList = &TWiki::Store::readFile( "$iconDir/_filetypes.txt" ); - foreach( split( /\n/, $iconList ) ) { - @bits = ( split( / / ) ); - if( $bits[0] eq $fileExt ) { - return "\"\""; + if ( $topRev ) { + # I18N: To support attachments via UTF-8 URLs to attachment + # directories/files that use non-UTF-8 character sets, go + # through viewfile. + # If using %PUBURL%, must URL-encode explicitly to site + # character set. + $url = TWiki::nativeUrlEncode( "%PUBURLPATH%/$web/$topic/$file" ); + } else { + $url = "%SCRIPTURLPATH%/viewfile%SCRIPTSUFFIX%/". + "$web/$topic?rev=$info->{version}&filename=$file"; } + return $url; } - return "\"\""; + elsif ( $attr eq "SIZE" ) { + my $attrSize = $info->{size}; + $attrSize = 100 if( $attrSize < 100 ); + return sprintf( "%1.1f K", $attrSize / 1024 ); + } + elsif ( $attr eq "COMMENT" ) { + my $comment = $info->{comment}; + if ( $comment) { + $comment =~ s/\|/|/g; + } else { + $comment = " "; + } + return $comment; + } + elsif ( $attr eq "ATTRS" ) { + return $info->{attr} or " "; + } + elsif ( $attr eq "FILE" ) { + return $file; + } + elsif ( $attr eq "DATE" ) { + return TWiki::formatTime( $info->{date} ); + } + elsif ( $attr eq "USER" ) { + return TWiki::User::userToWikiName( $info->{user} ); + } + else { + return "\0A_$attr\0"; + } } + # ========================= -=pod +#=pod +# +#---++ sub removeFile () +# +#Remove attachment macro for specified file from topic +#return "", or error string +# +#=cut +# +#sub removeFile +#{ +# my $theFile = $_[1]; +# my $error = ""; +# +# # %FILEATTACHMENT{[\s]*"$theFile"[^}]*}% +# if( ! ( $_[0] =~ s/%FILEATTACHMENT{[\s]*"$theFile"[^}]*}%//) ) { +# $error = "Failed to remove attachment $theFile"; +# } +# return $error; +#} ----++ sub removeFile () - -Remove attachment macro for specified file from topic -return "", or error string - -=cut - -sub removeFile -{ - my $theFile = $_[1]; - my $error = ""; - - # %FILEATTACHMENT{[\s]*"$theFile"[^}]*}% - if( ! ( $_[0] =~ s/%FILEATTACHMENT{[\s]*"$theFile"[^}]*}%//) ) { - $error = "Failed to remove attachment $theFile"; - } - return $error; -} - # ========================= =pod ---++ sub updateProperties ( $fileName, $hideFile, $fileComment, $meta ) -Not yet documented. +Update the properties for the given attachment in the given +meta object. =cut @@ -326,12 +307,297 @@ $meta->put( "FILEATTACHMENT", @attrs ); } +# ========================= + +=pod + +---++ sub getAttachmentLink( $web, $topic, $name, $meta ) +| =$web= | Name of the web | +| =$topic= | Name of the topic | +| =$name= | Name of the attachment | +| =$meta= | Meta object that contains the meta info | +Build a link to the attachment, suitable for insertion in the topic. + +=cut + +sub getAttachmentLink +{ + my ( $web, $topic, $attName, $meta ) = @_; + + my %att = $meta->findOne( "FILEATTACHMENT", $attName ); + my $fileComment = $att{comment}; + $fileComment = $attName unless ( $fileComment ); + + my $fileLink = ""; + my $imgSize = ""; + + if( $attName =~ /\.(gif|jpg|jpeg|png)$/i ) { + # inline image + + # The pixel size calculation is done for performance reasons + # Some browsers wait with rendering a page until the size of + # embedded images is known, e.g. after all images of a page are + # downloaded. When you upload an image to TWiki and checkmark + # the link checkbox, TWiki will generate the width and height + # img parameters, speeding up the page rendering. + my $stream = TWiki::Store::getAttachmentStream( $web, $topic, $attName ); + my( $nx, $ny ) = &_imgsize( $stream, $attName ); + + if( ( $nx > 0 ) && ( $ny > 0 ) ) { + $imgSize = "width=\"$nx\" height=\"$ny\" "; + } + $fileLink = TWiki::Prefs::getPreferencesValue( "ATTACHEDIMAGEFORMAT" ) + || ' * $comment:
' + . ' $name'; + } else { + # normal attached file + $fileLink = TWiki::Prefs::getPreferencesValue( "ATTACHEDFILELINKFORMAT" ) + || ' * [[%ATTACHURL%/$name][$name]]: $comment'; + } + + $fileLink =~ s/^ /\t\t/go; + $fileLink =~ s/^ /\t/go; + $fileLink =~ s/\$name/$attName/g; + $fileLink =~ s/\$comment/$fileComment/g; + $fileLink =~ s/\$size/$imgSize/g; + $fileLink =~ s/\\t/\t/go; + $fileLink =~ s/\\n/\n/go; + $fileLink =~ s/([^\n])$/$1\n/; + + return $fileLink; +} + +# ========================= +# code fragment to extract pixel size from images +# taken from http://www.tardis.ed.ac.uk/~ark/wwwis/ +# subroutines: _imgsize, _gifsize, _OLDgifsize, _gif_blockskip, +# _NEWgifsize, _jpegsize +# + +# ========================= +sub _imgsize { + my( $file, $att ) = @_; + my( $x, $y) = ( 0, 0 ); + + if( defined( $file ) ) { + binmode( $file ); # for crappy MS OSes - Win/Dos/NT use is NOT SUPPORTED + my $s; + return ( 0, 0 ) unless ( read( $file, $s, 4 ) == 4 ); + seek( $file, 0, 0 ); + if ( $s eq "GIF8" ) { + # GIF 47 49 46 38 + ( $x, $y ) = _gifsize( $file ); + } else { + my ( $a, $b, $c, $d ) = unpack( 'C4', $s ); + if ( $a == 0x89 && $b == 0x50 && + $c == 0x4E && $d == 0x47 ) { + # PNG 89 50 4e 47 + ( $x, $y ) = _pngsize( $file ); + } elsif ( $a == 0xFF && $b == 0xD8 && + $c == 0xFF && $d == 0xE0 ) { + # JPG ff d8 ff e0 + ( $x, $y ) = _jpegsize( $file ); + } + } + close( $file ); + } + return( $x, $y ); +} + + +# ========================= +sub _gifsize +{ + my( $GIF ) = @_; + if( 0 ) { + return &_NEWgifsize( $GIF ); + } else { + return &_OLDgifsize( $GIF ); + } +} + + +# ========================= +sub _OLDgifsize { + my( $GIF ) = @_; + my( $type, $a, $b, $c, $d, $s ) = ( 0, 0, 0, 0, 0, 0 ); + + if( defined( $GIF ) && + read( $GIF, $type, 6 ) && + $type =~ /GIF8[7,9]a/ && + read( $GIF, $s, 4 ) == 4 ) { + ( $a, $b, $c, $d ) = unpack( "C"x4, $s ); + return( $b<<8|$a, $d<<8|$c ); + } + return( 0, 0 ); +} + + +# ========================= +# part of _NEWgifsize +sub _gif_blockskip { + my ( $GIF, $skip, $type ) = @_; + my ( $s ) = 0; + my ( $dummy ) = ''; + + read( $GIF, $dummy, $skip ); # Skip header (if any) + while( 1 ) { + if( eof( $GIF ) ) { + #warn "Invalid/Corrupted GIF (at EOF in GIF $type)\n"; + return ""; + } + read( $GIF, $s, 1 ); # Block size + last if ord( $s ) == 0; # Block terminator + read( $GIF, $dummy, ord( $s ) ); # Skip data + } +} + + +# ========================= +# this code by "Daniel V. Klein" +sub _NEWgifsize { + my( $GIF ) = @_; + my( $cmapsize, $a, $b, $c, $d, $e ) = 0; + my( $type, $s ) = ( 0, 0 ); + my( $x, $y ) = ( 0, 0 ); + my( $dummy ) = ''; + + return( $x,$y ) if( !defined $GIF ); + + read( $GIF, $type, 6 ); + if( $type !~ /GIF8[7,9]a/ || read( $GIF, $s, 7 ) != 7 ) { + #warn "Invalid/Corrupted GIF (bad header)\n"; + return( $x, $y ); + } + ( $e ) = unpack( "x4 C", $s ); + if( $e & 0x80 ) { + $cmapsize = 3 * 2**(($e & 0x07) + 1); + if( !read( $GIF, $dummy, $cmapsize ) ) { + #warn "Invalid/Corrupted GIF (global color map too small?)\n"; + return( $x, $y ); + } + } + FINDIMAGE: + while( 1 ) { + if( eof( $GIF ) ) { + #warn "Invalid/Corrupted GIF (at EOF w/o Image Descriptors)\n"; + return( $x, $y ); + } + read( $GIF, $s, 1 ); + ( $e ) = unpack( "C", $s ); + if( $e == 0x2c ) { # Image Descriptor (GIF87a, GIF89a 20.c.i) + if( read( $GIF, $s, 8 ) != 8 ) { + #warn "Invalid/Corrupted GIF (missing image header?)\n"; + return( $x, $y ); + } + ( $a, $b, $c, $d ) = unpack( "x4 C4", $s ); + $x = $b<<8|$a; + $y = $d<<8|$c; + return( $x, $y ); + } + if( $type eq "GIF89a" ) { + if( $e == 0x21 ) { # Extension Introducer (GIF89a 23.c.i) + read( $GIF, $s, 1 ); + ( $e ) = unpack( "C", $s ); + if( $e == 0xF9 ) { # Graphic Control Extension (GIF89a 23.c.ii) + read( $GIF, $dummy, 6 ); # Skip it + next FINDIMAGE; # Look again for Image Descriptor + } elsif( $e == 0xFE ) { # Comment Extension (GIF89a 24.c.ii) + &_gif_blockskip( $GIF, 0, "Comment" ); + next FINDIMAGE; # Look again for Image Descriptor + } elsif( $e == 0x01 ) { # Plain Text Label (GIF89a 25.c.ii) + &_gif_blockskip( $GIF, 12, "text data" ); + next FINDIMAGE; # Look again for Image Descriptor + } elsif( $e == 0xFF ) { # Application Extension Label (GIF89a 26.c.ii) + &_gif_blockskip( $GIF, 11, "application data" ); + next FINDIMAGE; # Look again for Image Descriptor + } else { + #printf STDERR "Invalid/Corrupted GIF (Unknown extension %#x)\n", $e; + return( $x, $y ); + } + } else { + #printf STDERR "Invalid/Corrupted GIF (Unknown code %#x)\n", $e; + return( $x, $y ); + } + } else { + #warn "Invalid/Corrupted GIF (missing GIF87a Image Descriptor)\n"; + return( $x, $y ); + } + } +} + +# ========================= +# _jpegsize : gets the width and height (in pixels) of a jpeg file +# Andrew Tong, werdna@ugcs.caltech.edu February 14, 1995 +# modified slightly by alex@ed.ac.uk +sub _jpegsize { + my( $JPEG ) = @_; + my( $done ) = 0; + my( $c1, $c2, $ch, $s, $length, $dummy ) = ( 0, 0, 0, 0, 0, 0 ); + my( $a, $b, $c, $d ); + + if( defined( $JPEG ) && + read( $JPEG, $c1, 1 ) && + read( $JPEG, $c2, 1 ) && + ord( $c1 ) == 0xFF && + ord( $c2 ) == 0xD8 ) { + while ( ord( $ch ) != 0xDA && !$done ) { + # Find next marker (JPEG markers begin with 0xFF) + # This can hang the program!! + while( ord( $ch ) != 0xFF ) { + return( 0, 0 ) unless read( $JPEG, $ch, 1 ); + } + # JPEG markers can be padded with unlimited 0xFF's + while( ord( $ch ) == 0xFF ) { + return( 0, 0 ) unless read( $JPEG, $ch, 1 ); + } + # Now, $ch contains the value of the marker. + if( ( ord( $ch ) >= 0xC0 ) && ( ord( $ch ) <= 0xC3 ) ) { + return( 0, 0 ) unless read( $JPEG, $dummy, 3 ); + return( 0, 0 ) unless read( $JPEG, $s, 4 ); + ( $a, $b, $c, $d ) = unpack( "C"x4, $s ); + return( $c<<8|$d, $a<<8|$b ); + } else { + # We **MUST** skip variables, since FF's within variable names are + # NOT valid JPEG markers + return( 0, 0 ) unless read( $JPEG, $s, 2 ); + ( $c1, $c2 ) = unpack( "C"x2, $s ); + $length = $c1<<8|$c2; + last if( !defined( $length ) || $length < 2 ); + read( $JPEG, $dummy, $length-2 ); + } + } + } + return( 0, 0 ); +} + +# ========================= +# _pngsize : gets the width & height (in pixels) of a png file +# cor this program is on the cutting edge of technology! (pity it's blunt!) +# GRR 970619: fixed bytesex assumption +# source: http://www.la-grange.net/2000/05/04-png.html +sub _pngsize { + my ($PNG) = @_; + my ($head) = ""; + my($a, $b, $c, $d, $e, $f, $g, $h)=0; + if(defined($PNG) && + read( $PNG, $head, 8 ) == 8 && + $head eq "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a" && + read($PNG, $head, 4) == 4 && + read($PNG, $head, 4) == 4 && + $head eq "IHDR" && + read($PNG, $head, 8) == 8 ){ + ($a,$b,$c,$d,$e,$f,$g,$h)=unpack("C"x8,$head); + return ($a<<24|$b<<16|$c<<8|$d, $e<<24|$f<<16|$g<<8|$h); + } + return (0,0); +} + #========================= =pod ---++ sub migrateFormatForTopic ( $theWeb, $theTopic, $doLogToStdOut ) -Not yet documented. CODE_SMELL: Is this really necessary? migrateFormatForTopic? =cut @@ -351,7 +617,8 @@ $text = "$before$newtext"; my ( $dontLogSave, $doUnlock, $dontNotify ) = ( "", "1", "1" ); - my $error = TWiki::Store::save( $theWeb, $theTopic, $text, "", $dontLogSave, $doUnlock, $dontNotify, "upgraded attachment format" ); + my $meta = TWiki::Meta->new(); + my $error = TWiki::Store::noHandlersSave( $theWeb, $theTopic, $text, $meta, "", $dontLogSave, $doUnlock, $dontNotify, "upgraded attachment format" ); if ( $error ) { print "Attach: error from save: $error\n"; } @@ -399,14 +666,16 @@ if( ! $fileDate ) { $fileDate = ""; } else { + # SMELL: violates Store encapsulation! + eval 'use TWiki::Store::RcsFile;'; $fileDate =~ s/ / /go; - $fileDate = &TWiki::revDate2EpSecs( $fileDate ); + $fileDate = TWiki::Store::RcsFile::revDate2EpSecs( $fileDate ); } ( $before, $fileUser, $after ) = split( /<(?:\/)*TwkFileUser>/, $atext ); if( ! $fileUser ) { $fileUser = ""; } else { - $fileUser = &TWiki::wikiToUserName( $fileUser ); + $fileUser = TWiki::User::wikiToUserName( $fileUser ); } $fileUser =~ s/ //go; ( $before, $fileComment, $after ) = split( /<(?:\/)*TwkFileComment>/, $atext ); @@ -416,6 +685,22 @@ return ( $fileName, $filePath, $fileSize, $fileDate, $fileUser, $fileComment ); } +# Convert a key=value list to a list of key,value,key,value..... +sub _keyValue2list +{ + my( $args ) = @_; + + my @res = (); + + # Format of data is name="value" name1="value1" [...] + while( $args =~ s/\s*([^=]+)=\"([^"]*)\"//o ) { #" avoid confusing syntax highlighters + push @res, $1; + push @res, $2; + } + + return @res; +} + # ========================= =pod @@ -465,7 +750,7 @@ my $name = $1; my $rest = $2; $rest =~ s/^\s*//; - my @values = TWiki::Store::keyValue2list( $rest ); + my @values = _keyValue2list( $rest ); unshift @values, $name; unshift @values, "name"; $meta->put( "FILEATTACHMENT", @values ); @@ -494,11 +779,12 @@ foreach my $att ( @attach ) { my $date = $att->{"date"}; if( $date =~ /-/ ) { + use TWiki::Store::RcsFile; $date =~ s/ / /go; - $date = TWiki::revDate2EpSecs( $date ); + $date = TWiki::Store::RcsFile::revDate2EpSecs( $date ); } $att->{"date"} = $date; - $att->{"user"} = &TWiki::wikiToUserName( $att->{"user"} ); + $att->{"user"} = TWiki::User::wikiToUserName( $att->{"user"} ); } } Index: lib/TWiki/Search.pm =================================================================== --- lib/TWiki/Search.pm (revision 1767) +++ lib/TWiki/Search.pm (working copy) @@ -52,8 +52,7 @@ BEGIN { # Do a dynamic 'use locale' for this module if( $TWiki::useLocale ) { - require locale; - import locale (); + eval 'require locale; import locale ();'; } $cacheRev1webTopic = ""; } @@ -157,7 +156,7 @@ $topics =~ s/\)\$//o; # @topicList = split( /\|/, $topics ); # build list from topic pattern } else { # topic list with wildcards - @topicList = _getTopicList( $theWeb ); # get all topics in web + @topicList = TWiki::Store::getTopicNames( $theWeb ); # get all topics in web if( $caseSensitive ) { @topicList = grep( /$theTopic/, @topicList ); # limit by topic name, } else { # Codev.SearchTopicNameAndTopicText @@ -165,7 +164,7 @@ } } } else { - @topicList = _getTopicList( $theWeb ); # get all topics in web + @topicList = TWiki::Store::getTopicNames( $theWeb ); # get all topics in web } my $sDir = "$TWiki::dataDir/$theWeb"; @@ -259,24 +258,6 @@ # ========================= =pod ----++ sub _getTopicList ( $web ) - -Not yet documented. - -=cut - -sub _getTopicList -{ - my( $web ) = @_ ; - opendir DIR, "$TWiki::dataDir/$web" ; - my @topicList = sort map { s/\.txt$//o; $_ } grep { /\.txt$/ } readdir( DIR ); - closedir( DIR ); - return @topicList; -} - -# ========================= -=pod - ---++ sub _makeTopicPattern ( $theTopic ) Not yet documented. @@ -306,23 +287,34 @@ sub revDate2ISO { - my $epochSec = &TWiki::revDate2EpSecs( $_[0] ); + my $epochSec = TWiki::Store::RcsFile::revDate2EpSecs( $_[0] ); return &TWiki::formatTime( $epochSec, "\$iso", "gmtime"); } # ========================= =pod ----++ sub searchWeb () +---++ sub searchWeb (...) -Not yet documented. +Search according to the parameters. +If =_callback= is set, that means the caller wants results as +soon as they are ready. =_callback_ should be set to a reference +to a function which takes identical parameters to "print". + +If =_callback= is set, the result is always undef. Otherwise the +result is a string containing the rendered search results. + +If =inline= is set, then the results are *not* decorated with +the search template head and tail blocks. + =cut sub searchWeb { my %params = @_; - my $doInline = $params{"inline"} || 0; + my $callback = $params{_callback}; + my $inline = $params{inline}; my $baseWeb = $params{"baseweb"} || $TWiki::webName; my $baseTopic = $params{"basetopic"} || $TWiki::topicName; my $emptySearch = "something.Very/unLikelyTo+search-for;-)"; @@ -355,16 +347,6 @@ ##TWiki::writeDebug "Search locale is $TWiki::siteLocale"; - ## 0501 kk : vvv new option to limit results - # process the result limit here, this is the 'global' limit for - # all webs in a multi-web search - - ## ############# - ## 0605 kk : vvv This code broke due to changes in the wiki.pm - ## file; it used to rely on the value of $1 being - ## a null string if there was no match. What a pity - ## Perl doesn't do The Right Thing, but whatever--it's - ## fixed now. if ($theLimit =~ /(^\d+$)/o) { # only digits, all else is the same as $theLimit = $1; # an empty string. "+10" won't work. } else { @@ -388,7 +370,7 @@ $newLine =~ s/\$n([^$mixedAlpha]|$)/\n$1/gos; } - my $searchResult = ""; + my $searchResult = ""; my $topic = $TWiki::mainTopicname; my @webList = (); @@ -399,7 +381,6 @@ # Search what webs? "" current web, list gets the list, all gets # all (unless marked in WebPrefs as NOSEARCHALL) - if( $theWebName ) { foreach my $web ( split( /[\,\s]+/, $theWebName ) ) { # the web processing loop filters for valid web names, so don't do it here. @@ -449,13 +430,13 @@ $theTemplate = "searchformat" if( $theFormat ); if( $theTemplate ) { - $tmpl = &TWiki::Store::readTemplate( "$theTemplate" ); + $tmpl = TWiki::Templates::readTemplate( "$theTemplate" ); # FIXME replace following with this @@@ } elsif( $doBookView ) { - $tmpl = &TWiki::Store::readTemplate( "searchbookview" ); + $tmpl = &TWiki::Templates::readTemplate( "searchbookview" ); } elsif ($doRenameView ) { # Rename view, showing where topics refer to topic being renamed. - $tmpl = &TWiki::Store::readTemplate( "searchrenameview" ); # JohnTalintyre + $tmpl = &TWiki::Templates::readTemplate( "searchrenameview" ); # JohnTalintyre # Create full search string from topic name that is passed in $renameTopic = $theSearchVal; @@ -463,7 +444,7 @@ $renameWeb = $1; $renameTopic = $2; } - $spacedTopic = spacedTopic( $renameTopic ); + $spacedTopic = TWiki::searchableTopic( $renameTopic ); $spacedTopic = $renameWeb . '\.' . $spacedTopic if( $renameWeb ); # I18N: match non-alpha before and after topic name in renameview searches @@ -474,36 +455,48 @@ "([^${alphaNum}_]" . '|$)|' . '(\[\[' . $spacedTopic . '\]\])'; } else { - $tmpl = &TWiki::Store::readTemplate( "search" ); + $tmpl = &TWiki::Templates::readTemplate( "search" ); } $tmpl =~ s/\%META{.*?}\%//go; # remove %META{"parent"}% - my( $tmplHead, $tmplSearch, - $tmplTable, $tmplNumber, $tmplTail ) = split( /%SPLIT%/, $tmpl ); - $tmplHead = &TWiki::handleCommonTags( $tmplHead, $topic ); - $tmplSearch = &TWiki::handleCommonTags( $tmplSearch, $topic ); - $tmplNumber = &TWiki::handleCommonTags( $tmplNumber, $topic ); - $tmplTail = &TWiki::handleCommonTags( $tmplTail, $topic ); + my( $tmplHead, $tmplSearch, $tmplTable, $tmplNumber, $tmplTail ) = + split( /%SPLIT%/, $tmpl ); if( ! $tmplTail ) { - print ""; - print "

TWiki Installation Error

"; - # Might not be search.tmpl FIXME - print "Incorrect format of search.tmpl (missing %SPLIT% parts)"; - print ""; - return; + my $mess = "" . + "

TWiki Installation Error

" . + # Might not be search.tmpl FIXME + "Incorrect format of search.tmpl (missing sections? There should be 4 %SPLIT% tags.)" . + ""; + if ( $callback ) { + &$callback( $mess ); + return undef; + } else { + return $mess; + } } - if( ! $doInline ) { - # print first part of full HTML page - $tmplHead = &TWiki::Render::getRenderedVersion( $tmplHead ); - $tmplHead =~ s|||goi; # remove tags (PTh 06 Nov 2000) - print $tmplHead; + $tmplSearch = TWiki::handleCommonTags( $tmplSearch, $topic ); + $tmplNumber = TWiki::handleCommonTags( $tmplNumber, $topic ); + + unless( $inline ) { + # head and tail only required if _not_ inline + $tmplHead = TWiki::handleCommonTags( $tmplHead, $topic ); + + if( $callback) { + $tmplHead = TWiki::Render::getRenderedVersion( $tmplHead ); + $tmplHead =~ s|||goi; # remove tags + &$callback( $tmplHead ); + } else { + # don't getRenderedVersion; this will be done by a single + # call at the end. + $searchResult .= $tmplHead; + } } - if( ! $noSearch ) { - # print "Search:" part + unless( $noSearch ) { + # generate "Search:" part my $searchStr = $theSearchVal; $searchStr = "" if( $theSearchVal eq $emptySearch ); $searchStr =~ s/&/&/go; @@ -511,12 +504,13 @@ $searchStr =~ s/>/>/go; $searchStr =~ s/^\.\*$/Index/go; $tmplSearch =~ s/%SEARCHSTRING%/$searchStr/go; - if( $doInline ) { - $searchResult .= $tmplSearch; - } else { - $tmplSearch = &TWiki::Render::getRenderedVersion( $tmplSearch ); + if( $callback) { + $tmplSearch = TWiki::Render::getRenderedVersion( $tmplSearch ); $tmplSearch =~ s|||goi; # remove tag - print $tmplSearch; + &$callback( $tmplSearch ); + } else { + # don't getRenderedVersion; will be done later + $searchResult .= $tmplSearch; } } @@ -524,19 +518,13 @@ # write log entry # FIXME: Move log entry further down to log actual webs searched - if( ( $TWiki::doLogTopicSearch ) && ( ! $doInline ) ) { - # 0501 kk : vvv Moved from search - # PTh 17 May 2000: reverted to old behaviour, - # e.g. do not log inline search - # PTh 03 Nov 2000: Moved out of the 'foreach $thisWebName' loop + if( ( $TWiki::doLogTopicSearch ) && ( ! $inline ) ) { $tempVal = join( ' ', @webList ); - &TWiki::Store::writeLog( "search", $tempVal, $theSearchVal ); + TWiki::writeLog( "search", $tempVal, $theSearchVal ); } # loop through webs foreach my $thisWebName ( @webList ) { - - # PTh 03 Nov 2000: Add security check $thisWebName =~ s/$TWiki::securityFilter//go; $thisWebName =~ /(.*)/; $thisWebName = $1; # untaint variable @@ -611,8 +599,8 @@ $tempVal = $_; # Permission check done below, so force this read to succeed with "internal" parameter my( $meta, $text ) = &TWiki::Store::readTopic( $thisWebName, $tempVal, "", "internal" ); - my ( $revdate, $revuser, $revnum ) = &TWiki::Store::getRevisionInfoFromMeta( $thisWebName, $tempVal, $meta ); - $topicRevUser{ $tempVal } = &TWiki::userToWikiName( $revuser ); + my ( $revdate, $revuser, $revnum ) = $meta->getRevisionInfo( $thisWebName, $tempVal ); + $topicRevUser{ $tempVal } = TWiki::User::userToWikiName( $revuser ); $topicRevDate{ $tempVal } = $revdate; # keep epoc sec for sorting $topicRevNum{ $tempVal } = $revnum; $topicAllowView{ $tempVal } = &TWiki::Access::checkAccessPermission( "view", $TWiki::wikiUserName, @@ -642,8 +630,8 @@ $tempVal = $_; # Permission check done below, so force this read to succeed with "internal" parameter my( $meta, $text ) = &TWiki::Store::readTopic( $thisWebName, $tempVal, "", "internal" ); - my( $revdate, $revuser, $revnum ) = &TWiki::Store::getRevisionInfoFromMeta( $thisWebName, $tempVal, $meta ); - $topicRevUser{ $tempVal } = &TWiki::userToWikiName( $revuser ); + my( $revdate, $revuser, $revnum ) = $meta->getRevisionInfo( $thisWebName, $tempVal ); + $topicRevUser{ $tempVal } = TWiki::User::userToWikiName( $revuser ); $topicRevDate{ $tempVal } = &TWiki::formatTime( $revdate ); $topicRevNum{ $tempVal } = $revnum; $topicAllowView{ $tempVal } = &TWiki::Access::checkAccessPermission( "view", $TWiki::wikiUserName, @@ -673,8 +661,8 @@ $tempVal = $_; # Permission check done below, so force this read to succeed with "internal" parameter my( $meta, $text ) = &TWiki::Store::readTopic( $thisWebName, $tempVal, "", "internal" ); - my( $revdate, $revuser, $revnum ) = &TWiki::Store::getRevisionInfoFromMeta( $thisWebName, $tempVal, $meta ); - $topicRevUser{ $tempVal } = &TWiki::userToWikiName( $revuser ); + my( $revdate, $revuser, $revnum ) = $meta->getRevisionInfo( $thisWebName, $tempVal ); + $topicRevUser{ $tempVal } = TWiki::User::userToWikiName( $revuser ); $topicRevDate{ $tempVal } = &TWiki::formatTime( $revdate ); $topicRevNum{ $tempVal } = $revnum; $topicAllowView{ $tempVal } = &TWiki::Access::checkAccessPermission( "view", $TWiki::wikiUserName, @@ -703,8 +691,8 @@ $tempVal = $_; # Permission check done below, so force this read to succeed with "internal" parameter my( $meta, $text ) = &TWiki::Store::readTopic( $thisWebName, $tempVal, "", "internal" ); - my( $revdate, $revuser, $revnum ) = &TWiki::Store::getRevisionInfoFromMeta( $thisWebName, $tempVal, $meta ); - $topicRevUser{ $tempVal } = &TWiki::userToWikiName( $revuser ); + my( $revdate, $revuser, $revnum ) = $meta->getRevisionInfo( $thisWebName, $tempVal ); + $topicRevUser{ $tempVal } = TWiki::User::userToWikiName( $revuser ); $topicRevDate{ $tempVal } = &TWiki::formatTime( $revdate ); $topicRevNum{ $tempVal } = $revnum; $topicAllowView{ $tempVal } = &TWiki::Access::checkAccessPermission( "view", $TWiki::wikiUserName, @@ -780,16 +768,16 @@ $text =~ s/%WEB%/$thisWebName/gos; $text =~ s/%TOPIC%/$topic/gos; $allowView = &TWiki::Access::checkAccessPermission( "view", $TWiki::wikiUserName, $text, $topic, $thisWebName ); - ( $revDate, $revUser, $revNum ) = &TWiki::Store::getRevisionInfoFromMeta( $thisWebName, $topic, $meta ); + ( $revDate, $revUser, $revNum ) = $meta->getRevisionInfo( $thisWebName, $topic ); $revDate = &TWiki::formatTime( $revDate ); - $revUser = &TWiki::userToWikiName( $revUser ); + $revUser = TWiki::User::userToWikiName( $revUser ); } $locked = ""; if( $doShowLock ) { ( $tempVal ) = &TWiki::Store::topicIsLockedBy( $thisWebName, $topic ); if( $tempVal ) { - $revUser = &TWiki::userToWikiName( $tempVal ); + $revUser = TWiki::User::userToWikiName( $tempVal ); $locked = "(LOCKED)"; } } @@ -844,7 +832,7 @@ $tempVal =~ s/\$rev/1.$revNum/gos; $tempVal =~ s/\$wikiusername/$revUser/gos; $tempVal =~ s/\$wikiname/wikiName($revUser)/geos; - $tempVal =~ s/\$username/&TWiki::wikiToUserName($revUser)/geos; + $tempVal =~ s/\$username/&TWiki::User::wikiToUserName($revUser)/geos; $tempVal =~ s/\$createdate/_getRev1Info( $thisWebName, $topic, "date" )/geos; $tempVal =~ s/\$createusername/_getRev1Info( $thisWebName, $topic, "username" )/geos; $tempVal =~ s/\$createwikiname/_getRev1Info( $thisWebName, $topic, "wikiname" )/geos; @@ -874,12 +862,13 @@ $tempVal =~ s/%REVISION%/$revNumText/o; $tempVal =~ s/%AUTHOR%/$revUser/o; - if( ( $doInline || $theFormat ) && ( ! ( $forceRendering ) ) ) { - # print at the end if formatted search because of table rendering + if( ( $inline || $theFormat ) && ( ! ( $forceRendering ) ) ) { # do nothing } else { - $tempVal = &TWiki::handleCommonTags( $tempVal, $topic ); - $tempVal = &TWiki::Render::getRenderedVersion( $tempVal ); + # don't callback yet because of table + # rendering + $tempVal = TWiki::handleCommonTags( $tempVal, $topic ); + $tempVal = TWiki::Render::getRenderedVersion( $tempVal ); } if( $doRenameView ) { # added JET 19 Feb 2000 @@ -958,8 +947,8 @@ } elsif( $theFormat ) { # free format, added PTh 10 Oct 2001 - $tempVal =~ s/\$summary\(([^\)]*)\)/&TWiki::makeTopicSummary( $text, $topic, $thisWebName, $1 )/geos; - $tempVal =~ s/\$summary/&TWiki::makeTopicSummary( $text, $topic, $thisWebName )/geos; + $tempVal =~ s/\$summary\(([^\)]*)\)/&TWiki::Render::makeTopicSummary( $text, $topic, $thisWebName, $1 )/geos; + $tempVal =~ s/\$summary/&TWiki::Render::makeTopicSummary( $text, $topic, $thisWebName )/geos; $tempVal =~ s/\$parent\(([^\)]*)\)/breakName( getMetaParent( $meta ), $1 )/geos; $tempVal =~ s/\$parent/getMetaParent( $meta )/geos; $tempVal =~ s/\$formfield\(\s*([^\)]*)\s*\)/getMetaFormField( $meta, $1 )/geos; @@ -989,7 +978,7 @@ } else { $head = &TWiki::Store::readFileHead( "$TWiki::dataDir\/$thisWebName\/$topic.txt", 16 ); } - $head = &TWiki::makeTopicSummary( $head, $topic, $thisWebName ); + $head = &TWiki::Render::makeTopicSummary( $head, $topic, $thisWebName ); $tempVal =~ s/%TEXTHEAD%/$head/go; } @@ -998,27 +987,32 @@ $headerDone = 1; $beforeText =~ s/%WEBBGCOLOR%/$thisWebBGColor/go; $beforeText =~ s/%WEB%/$thisWebName/go; - $beforeText = &TWiki::handleCommonTags( $beforeText, $topic ); - if( $doInline || $theFormat ) { - # print at the end if formatted search because of table rendering - $searchResult .= $beforeText; - } else { - $beforeText = &TWiki::Render::getRenderedVersion( $beforeText, $thisWebName ); + $beforeText = TWiki::handleCommonTags( $beforeText, + $topic ); + if ( $callback) { + $beforeText = + TWiki::Render::getRenderedVersion( $beforeText, + $thisWebName ); $beforeText =~ s|||goi; # remove tag - print $beforeText; + &$callback( $beforeText ); + } else { + $searchResult .= $beforeText; } } # output topic (or line if multiple=on) - if( $doInline || $theFormat ) { - # print at the end if formatted search because of table rendering - $searchResult .= $tempVal; - } else { - $tempVal = &TWiki::Render::getRenderedVersion( $tempVal, $thisWebName ); + if( !( $inline || $theFormat )) { + $tempVal = + TWiki::Render::getRenderedVersion( $tempVal, $thisWebName ); $tempVal =~ s|||goi; # remove tag - print $tempVal; } + if ( $callback) { + &$callback( $tempVal ); + } else { + $searchResult .= $tempVal; + } + } while( @multipleHitLines ); # multiple=on loop $ntopics += 1; @@ -1028,15 +1022,19 @@ # output footer only if hits in web if( $ntopics ) { # output footer of $thisWebName - $afterText = &TWiki::handleCommonTags( $afterText, $topic ); - if( $doInline || $theFormat ) { - # print at the end if formatted search because of table rendering + $afterText = TWiki::handleCommonTags( $afterText, $topic ); + if( $inline || $theFormat ) { $afterText =~ s/\n$//os; # remove trailing new line - $searchResult .= $afterText; - } else { - $afterText = &TWiki::Render::getRenderedVersion( $afterText, $thisWebName ); + } + + if ( $callback) { + $afterText = + TWiki::Render::getRenderedVersion( $afterText, + $thisWebName ); $afterText =~ s|||goi; # remove tag - print $afterText; + &$callback( $afterText ); + } else { + $searchResult .= $afterText; } } @@ -1045,13 +1043,14 @@ unless( $noTotal ) { my $thisNumber = $tmplNumber; $thisNumber =~ s/%NTOPICS%/$ntopics/go; - if( $doInline || $theFormat ) { - # print at the end if formatted search because of table rendering - $searchResult .= $thisNumber; - } else { - $thisNumber = &TWiki::Render::getRenderedVersion( $thisNumber, $thisWebName ); + if ( $callback) { + $thisNumber = + TWiki::Render::getRenderedVersion( $thisNumber, + $thisWebName ); $thisNumber =~ s|||goi; # remove tag - print $thisNumber; + &$callback( $thisNumber ); + } else { + $searchResult .= $thisNumber; } } } @@ -1064,21 +1063,23 @@ $searchResult =~ s/\n$//os; # remove trailing new line } } - if( $doInline ) { - # return formatted search result - return $searchResult; - } else { - if( $theFormat ) { - # finally print $searchResult which got delayed because of formatted search - $tmplTail = "$searchResult$tmplTail"; - } + unless( $inline ) { + $tmplTail = TWiki::handleCommonTags( $tmplTail, $topic ); - # print last part of full HTML page - $tmplTail = &TWiki::Render::getRenderedVersion( $tmplTail ); - $tmplTail =~ s|||goi; # remove tag - print $tmplTail; + if( $callback ) { + $tmplTail = TWiki::Render::getRenderedVersion( $tmplTail ); + $tmplTail =~ s|||goi; # remove tag + &$callback( $tmplTail ); + } else { + $searchResult .= $tmplTail; + } } + + return undef if ( $callback ); + + $searchResult = TWiki::Render::getRenderedVersion( $searchResult ); + $searchResult =~ s|||goi; # remove tag return $searchResult; } @@ -1105,10 +1106,10 @@ return $cacheRev1user; } if( $theAttr eq "wikiname" ) { - return &TWiki::userToWikiName( $cacheRev1user, 1 ); + return TWiki::User::userToWikiName( $cacheRev1user, 1 ); } if( $theAttr eq "wikiusername" ) { - return &TWiki::userToWikiName( $cacheRev1user ); + return TWiki::User::userToWikiName( $cacheRev1user ); } if( $theAttr eq "date" ) { return &TWiki::formatTime( $cacheRev1date ); @@ -1264,29 +1265,7 @@ } #========================= -# Turn a topic into a spaced-out topic, with space before each part of -# the WikiWord. -=pod ----++ sub spacedTopic ( $topic ) - -Not yet documented. - -=cut - -sub spacedTopic -{ - my( $topic ) = @_; - # FindMe -> Find\s*Me - # I18N fix - my $upperAlpha = $TWiki::regex{singleUpperAlphaRegex}; - my $lowerAlpha = $TWiki::regex{singleLowerAlphaRegex}; - $topic =~ s/($lowerAlpha)($upperAlpha)/$1 *$2/go; - return $topic; -} - -#========================= - 1; # EOF Index: lib/TWiki/Plugins/DefaultPlugin.pm =================================================================== --- lib/TWiki/Plugins/DefaultPlugin.pm (revision 1767) +++ lib/TWiki/Plugins/DefaultPlugin.pm (working copy) @@ -55,16 +55,19 @@ # ========================= package TWiki::Plugins::DefaultPlugin; +use TWiki::Func; + +use strict; + # ========================= use vars qw( $web $topic $user $installWeb $VERSION $pluginName $debug $doOldInclude $renderingWeb ); -$VERSION = '1.021'; +$VERSION = '1.030'; $pluginName = 'DefaultPlugin'; # Name of this Plugin -# ========================= sub initPlugin { ( $topic, $web, $user, $installWeb ) = @_; @@ -88,85 +91,37 @@ return 1; } -# ========================= -sub DISABLE_earlyInitPlugin -{ -### Remove DISABLE_ for a plugin that requires early initialization, that is expects to have -### initializeUserHandler called before initPlugin, giving the plugin a chance to set the user -### See SessionPlugin for an example of this. - return 1; -} - - -# ========================= -sub DISABLE_initializeUserHandler -{ -### my ( $loginName, $url, $pathInfo ) = @_; # do not uncomment, use $_[0], $_[1]... instead - - TWiki::Func::writeDebug( "- ${pluginName}::initializeUserHandler( $_[0], $_[1] )" ) if $debug; - - # Allows a plugin to set the username based on cookies. Called by TWiki::initialize. - # Return the user name, or "guest" if not logged in. - # New hook in TWiki::Plugins $VERSION = '1.010' - -} - -# ========================= -sub DISABLE_registrationHandler -{ -### my ( $web, $wikiName, $loginName ) = @_; # do not uncomment, use $_[0], $_[1]... instead - - TWiki::Func::writeDebug( "- ${pluginName}::registrationHandler( $_[0], $_[1] )" ) if $debug; - - # Allows a plugin to set a cookie at time of user registration. - # Called by the register script. - # New hook in TWiki::Plugins $VERSION = '1.010' - -} - -# ========================= -sub DISABLE_beforeCommonTagsHandler -{ -### my ( $text, $topic, $web ) = @_; # do not uncomment, use $_[0], $_[1]... instead - - TWiki::Func::writeDebug( "- ${pluginName}::beforeCommonTagsHandler( $_[2].$_[1] )" ) if $debug; - - # Called at the beginning of TWiki::handleCommonTags (for cache Plugins use only) -} - -# ========================= sub commonTagsHandler { ### my ( $text, $topic, $web ) = @_; # do not uncomment, use $_[0], $_[1]... instead TWiki::Func::writeDebug( "- ${pluginName}::commonTagsHandler( $_[2].$_[1] )" ) if $debug; - # This is the place to define customized tags and variables - # Called by TWiki::handleCommonTags, after %INCLUDE:"..."% - # for compatibility for earlier TWiki versions: + + ###################### + # Old INCLUDE syntax if( $doOldInclude ) { # allow two level includes - $_[0] =~ s/%INCLUDE:"([^%\"]*?)"%/TWiki::handleIncludeFile( $1, $_[1], $_[2], "" )/geo; - $_[0] =~ s/%INCLUDE:"([^%\"]*?)"%/TWiki::handleIncludeFile( $1, $_[1], $_[2], "" )/geo; + $_[0] =~ s/%INCLUDE:"([^%\"]*?)"%/TWiki::_handleINCLUDE( TWiki::extractParameters( $1 ), $_[1], $_[2], "" )/geo; + $_[0] =~ s/%INCLUDE:"([^%\"]*?)"%/TWiki::_handleINCLUDE( TWiki::extractParameters( $1 ), $_[1], $_[2], "" )/geo; } - # do custom extension rule, like for example: - # $_[0] =~ s/%XYZ%/&handleXyz()/ge; - # $_[0] =~ s/%XYZ{(.*?)}%/&handleXyz($1)/ge; -} + ###################### + # Full attachment filename + # Process the filename suffixed to %ATTACHURLPATH% + # Required for migration purposes + my $pubUrlPath = TWiki::Func::getPubUrlPath(); + my $attfexpr = TWiki::nativeUrlEncode( "$pubUrlPath/$_[2]/$_[1]" ); + my $fnRE = TWiki::Func::getRegularExpression( "filenameRegex" ); + $_[0] =~ s!$attfexpr/($fnRE)!"$attfexpr/".&TWiki::nativeUrlEncode($1)!ge; -# ========================= -sub DISABLE_afterCommonTagsHandler -{ -### my ( $text, $topic, $web ) = @_; # do not uncomment, use $_[0], $_[1]... instead - - TWiki::Func::writeDebug( "- ${pluginName}::afterCommonTagsHandler( $_[2].$_[1] )" ) if $debug; - - # Called at the end of TWiki::handleCommonTags (for cache Plugins use only) + ###################### + # TOC handling + # SMELL: this should be in its own plugin + $_[0] =~ s/%TOC({([^}]*)})?%/&_handleTOC($2, @_)/ge; } -# ========================= sub startRenderingHandler { ### my ( $text, $web ) = @_; # do not uncomment, use $_[0], $_[1] instead @@ -178,7 +133,6 @@ $renderingWeb = $_[1]; } -# ========================= sub outsidePREHandler { ### my ( $text ) = @_; # do not uncomment, use $_[0] instead @@ -213,152 +167,154 @@ # $_[0] =~ s/(.*?)<\/link>/&TWiki::internalLink("",$web,$1,$1,"",1)/geo; } -# ========================= -sub DISABLE_insidePREHandler -{ -### my ( $text ) = @_; # do not uncomment, use $_[0] instead +# Parameters: +# * $text : the text of the current topic +# * $topic : the topic we are in +# * $web : the web we are in +# * $tocAttributes : "Topic" [web="Web"] [depth="N"] +# Return value: $tableOfContents +# Andrea Sterbini 22-08-00 / PTh 28 Feb 2001 +# Handles %TOC{...}% syntax. Creates a table of contents using TWiki bulleted +# list markup, linked to the section headings of a topic. A section heading is +# entered in one of the following forms: +# * $headingPatternSp : \t++... spaces section heading +# * $headingPatternDa : ---++... dashes section heading +# * $headingPatternHt : <h[1-6]> HTML section heading </h[1-6]> +sub _handleTOC { + my $args = shift; + my %params = TWiki::Func::extractParameters( $args ); - ##TWiki::Func::writeDebug( "- ${pluginName}::insidePREHandler( $web.$topic )" ) if $debug; + ## $_[0] $_[1] $_[2] $_[3] + ## my( $theText, $theTopic, $theWeb, $attributes ) = @_; + my $topicName = $_[1]; + my $webName = $_[2]; - # This handler is called by getRenderedVersion, once per line, before any changes, - # for lines inside
 and  tags. 
-    # Use it to define customized rendering rules
+    # get the topic name attribute
+    my $topicname = $params{_DEFAULT}  || $_[1];
 
-    # do custom extension rule, like for example:
-    # $_[0] =~ s/old/new/go;
-}
+    # get the web name attribute
+    my $web = $params{web} || $_[2];
+    $web =~ s/\//\./g;
+    my $webPath = $web;
+    $webPath =~ s/\./\//g;
 
-# =========================
-sub DISABLE_endRenderingHandler
-{
-### my ( $text ) = @_;   # do not uncomment, use $_[0] instead
+    # get the depth limit attribute
+    my $depth = $params{depth} || 6;
 
-    TWiki::Func::writeDebug( "- ${pluginName}::endRenderingHandler( $web.$topic )" ) if $debug;
+    #get the title attribute
+    my $title = $params{title} || "";
+    $title = "\n$title" if( $title );
 
-    # This handler is called by getRenderedVersion just after the line loop, that is,
-    # after almost all XHTML rendering of a topic.  tags are removed after this.
+    my $result  = "";
+    my $line  = "";
+    my $level = "";
+    my @list  = ();
+my $debug = "";
+    if( "$web.$topicname" eq "$_[2].$_[1]" ) {
+        # use text from parameter
+        @list = split( /\n/, $_[0] );
 
-}
+    } else {
+        # read text from file
+        if ( ! TWiki::Func::topicExists( $web, $topicname ) ) {
+            return _inlineError( "TOC: Cannot find topic \"$web.$topicname\"" );
+        }
+        my $t = TWiki::Func::readWebTopic( $web, $topicname );
+        $t =~ s/.*?%STARTINCLUDE%//s;
+        $t =~ s/%STOPINCLUDE%.*//s;
+        @list = split( /\n/, TWiki::Func::expandCommonVariables( $t, $topicname, $web ) );
+    }
 
-# =========================
-sub DISABLE_beforeEditHandler
-{
-### my ( $text, $topic, $web ) = @_;   # do not uncomment, use $_[0], $_[1]... instead
+    my $headerDaRE =  TWiki::Func::getRegularExpression( "headerPatternDa" );
+    my $headerSpRE =  TWiki::Func::getRegularExpression( "headerPatternSp" );
+    my $headerHtRE =  TWiki::Func::getRegularExpression( "headerPatternHt" );
+    my $webnameRE =   TWiki::Func::getRegularExpression( "webNameRegex" );
+    my $wikiwordRE =  TWiki::Func::getRegularExpression( "wikiWordRegex" );
+    my $abbrevRE =    TWiki::Func::getRegularExpression( "abbrevRegex" );
+    my $headerNoTOC = TWiki::Func::getRegularExpression( "headerPatternNoTOC" );
+    @list = grep { /(<\/?pre>)|($headerDaRE)|($headerSpRE)|($headerHtRE)/o } @list;
+    my $insidePre = 0;
+    my $i = 0;
+    my $tabs = "";
+    my $anchor = "";
+    my $highest = 99;
+    # SMELL: this handling of 
 is archaic. Surely this should be
+    # done using the outsidePreHandler?
+    foreach $line ( @list ) {
+        if( $line =~ /^.*
.*$/io ) {
+            $insidePre = 1;
+            $line = "";
+        }
+        if( $line =~ /^.*<\/pre>.*$/io ) {
+            $insidePre = 0;
+            $line = "";
+        }
+        if (!$insidePre) {
+            $level = $line ;
+            if ( $line =~  /$headerDaRE/o ) {
+                $level =~ s/$headerDaRE/$1/go;
+                $level = length $level;
+                $line  =~ s/$headerDaRE/$2/go;
+            } elsif
+               ( $line =~  /$headerSpRE/o ) {
+                $level =~ s/$headerSpRE/$1/go;
+                $level = length $level;
+                $line  =~ s/$headerSpRE/$2/go;
+            } elsif
+               ( $line =~  /$headerHtRE/io ) {
+                $level =~ s/$headerHtRE/$1/gio;
+                $line  =~ s/$headerHtRE/$2/gio;
+            }
+            my $urlPath = "";
+            if( "$web.$topicname" ne "$webName.$topicName" ) {
+                # not current topic, can't omit URL
+                $urlPath = "$TWiki::dispScriptUrlPath$TWiki::dispViewPath$TWiki::scriptSuffix/$webPath/$topicname";
+            }
+            if( ( $line ) && ( $level <= $depth ) ) {
+                $anchor = TWiki::Render::makeAnchorName( $line );
+                # cut TOC exclude '---+ heading !! exclude'
+                $line  =~ s/\s*$headerNoTOC.+$//go;
+                $line  =~ s/[\n\r]//go;
+                next unless $line;
+                $highest = $level if( $level < $highest );
+                $tabs = "";
+                for( $i=0 ; $i<$level ; $i++ ) {
+                    $tabs = "\t$tabs";
+                }
+                # Remove *bold*, _italic_ and =fixed= formatting
+                $line =~ s/(^|[\s\(])\*([^\s]+?|[^\s].*?[^\s])\*($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
+                $line =~ s/(^|[\s\(])_+([^\s]+?|[^\s].*?[^\s])_+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
+                $line =~ s/(^|[\s\(])=+([^\s]+?|[^\s].*?[^\s])=+($|[\s\,\.\;\:\!\?\)])/$1$2$3/g;
+                # Prevent WikiLinks
+                $line =~ s/\[\[.*?\]\[(.*?)\]\]/$1/g;  # '[[...][...]]'
+                $line =~ s/\[\[(.*?)\]\]/$1/ge;        # '[[...]]'
+                $line =~ s/([\s\(])($webnameRE)\.($wikiwordRE)/$1$3/g;  # 'Web.TopicName'
+                $line =~ s/([\s\(])($wikiwordRE)/$1$2/g;  # 'TopicName'
+                $line =~ s/([\s\(])($abbrevRE)/$1$2/g;    # 'TLA'
+                # create linked bullet item, using a relative link to anchor
+                $line = "$tabs* $line";
+                $result .= "\n$line";
+            }
+        }
+    }
+    if( $result ) {
+        if( $highest > 1 ) {
+            # left shift TOC
+            $highest--;
+            $result =~ s/^\t{$highest}//gm;
+        }
+        $result = "
$title$result\n
"; + return $result; - TWiki::Func::writeDebug( "- ${pluginName}::beforeEditHandler( $_[2].$_[1] )" ) if $debug; - - # This handler is called by the edit script just before presenting the edit text - # in the edit box. Use it to process the text before editing. - # New hook in TWiki::Plugins $VERSION = '1.010' - + } else { + return _inlineError("TOC: No TOC in \"$web.$topicname\" $debug"); + } } -# ========================= -sub DISABLE_afterEditHandler -{ -### my ( $text, $topic, $web ) = @_; # do not uncomment, use $_[0], $_[1]... instead - - TWiki::Func::writeDebug( "- ${pluginName}::afterEditHandler( $_[2].$_[1] )" ) if $debug; - - # This handler is called by the preview script just before presenting the text. - # New hook in TWiki::Plugins $VERSION = '1.010' - +# Format an error for inline inclusion in HTML +sub _inlineError { + my( $errormessage ) = @_; + return "$errormessage" ; } -# ========================= -sub DISABLE_beforeSaveHandler -{ -### my ( $text, $topic, $web ) = @_; # do not uncomment, use $_[0], $_[1]... instead - - TWiki::Func::writeDebug( "- ${pluginName}::beforeSaveHandler( $_[2].$_[1] )" ) if $debug; - - # This handler is called by TWiki::Store::saveTopic just before the save action. - # New hook in TWiki::Plugins $VERSION = '1.010' - -} - -# ========================= -sub DISABLE_afterSaveHandler -{ -### my ( $text, $topic, $web, $error ) = @_; # do not uncomment, use $_[0], $_[1]... instead - - TWiki::Func::writeDebug( "- ${pluginName}::afterSaveHandler( $_[2].$_[1] )" ) if $debug; - - # This handler is called by TWiki::Store::saveTopic just after the save action. - # New hook in TWiki::Plugins $VERSION = '1.020' - -} - -# ========================= -sub DISABLE_writeHeaderHandler -{ -### my ( $query ) = @_; # do not uncomment, use $_[0] instead - - TWiki::Func::writeDebug( "- ${pluginName}::writeHeaderHandler( query )" ) if $debug; - - # This handler is called by TWiki::writeHeader, just prior to writing header. - # Return a single result: A string containing HTTP headers, delimited by CR/LF - # and with no blank lines. Plugin generated headers may be modified by core - # code before they are output, to fix bugs or manage caching. Plugins should no - # longer write headers to standard output. - # Use only in one Plugin. - # New hook in TWiki::Plugins $VERSION = '1.010' - -} - -# ========================= -sub DISABLE_redirectCgiQueryHandler -{ -### my ( $query, $url ) = @_; # do not uncomment, use $_[0], $_[1] instead - - TWiki::Func::writeDebug( "- ${pluginName}::redirectCgiQueryHandler( query, $_[1] )" ) if $debug; - - # This handler is called by TWiki::redirect. Use it to overload TWiki's internal redirect. - # Use only in one Plugin. - # New hook in TWiki::Plugins $VERSION = '1.010' - -} - -# ========================= -sub DISABLE_getSessionValueHandler -{ -### my ( $key ) = @_; # do not uncomment, use $_[0] instead - - TWiki::Func::writeDebug( "- ${pluginName}::getSessionValueHandler( $_[0] )" ) if $debug; - - # This handler is called by TWiki::getSessionValue. Return the value of a key. - # Use only in one Plugin. - # New hook in TWiki::Plugins $VERSION = '1.010' - -} - -# ========================= -sub DISABLE_setSessionValueHandler -{ -### my ( $key, $value ) = @_; # do not uncomment, use $_[0], $_[1] instead - - TWiki::Func::writeDebug( "- ${pluginName}::setSessionValueHandler( $_[0], $_[1] )" ) if $debug; - - # This handler is called by TWiki::setSessionValue. - # Use only in one Plugin. - # New hook in TWiki::Plugins $VERSION = '1.010' - -} - -# ========================= -sub DISABLE_renderFormFieldForEditHandler -{ - my ( $name, $type, $size, $value, $attributes, $possibleValues ) = @_; - - TWiki::Func::writeDebug( "- ${pluginName}::renderFormFieldForEditHandler( $web.$topic )" ) if $debug; - - # This handler is called by Form.renderForEdit, before built in types are considered - - my $ret = ""; - # Set ret to html, leave empty if plugin doesn't want to render this field - return $ret; -} - -# ========================= - 1; Index: lib/TWiki/UI.pm =================================================================== --- lib/TWiki/UI.pm (revision 1767) +++ lib/TWiki/UI.pm (working copy) @@ -54,13 +54,12 @@ my $query = TWiki::getCgiQuery(); if ( $query && $query->param( 'noredirect' )) { - TWiki::writeHeader( $query ); + my $content = join(" ", @_) . " \n"; + TWiki::writeHeader( $query, length( $content ) ); + print $content; } elsif ( $query ) { TWiki::redirect( $query, $url ); - return; # no print to STDOUT } - - print join(" ", @_) . " \n"; } =pod twiki @@ -83,7 +82,7 @@ =pod twiki ----+++ webExists( $web, $topic, $fn ) => boolean +---+++ topicExists( $web, $topic, $fn ) => boolean Check if the given topic exists, returning 1 if it does, or invoking TWiki::UI::oops and returning 0 if it doesn't. $fn is the name of the command invoked, and will be used in composing @@ -93,7 +92,7 @@ sub topicExists { my ( $webName, $topic, $fn ) = @_; - +die "ARGH ", join(",",caller); return 1 if TWiki::Store::topicExists( $webName, $topic ); oops( $webName, $topic, "${fn}notopic", "ERROR $webName.$topic Missing topic" ); @@ -126,8 +125,6 @@ return 1; } -=cut - =pod twiki ---+++ isAccessPermitted( $web, $topic, $mode, $user ) => boolean @@ -168,17 +165,28 @@ return 0; } -=pod twiki +=pod ----+++ writeDebugTimes( $message ) -Write a debugging message indicating the time at which this function -was called. Used for benchmarking. +---++ sub readTemplateTopic ( $theTopicName ) +Read a topic from the TWiki web, or if that fails from the current +web. + =cut -sub writeDebugTimes { - my $mess = shift; - # TWiki::writeDebug(); +sub readTemplateTopic +{ + my( $theTopicName ) = @_; + + $theTopicName =~ s/$TWiki::securityFilter//go; # zap anything suspicious + + # try to read in current web, if not read from TWiki web + + my $web = $TWiki::twikiWebname; + if( TWiki::Store::topicExists( $TWiki::webName, $theTopicName ) ) { + $web = $TWiki::webName; + } + return TWiki::Store::readTopic( $web, $theTopicName ); } 1; Index: lib/TWiki/User.pm =================================================================== --- lib/TWiki/User.pm (revision 1767) +++ lib/TWiki/User.pm (working copy) @@ -33,17 +33,8 @@ package TWiki::User; -#use File::Copy; -#use Time::Local; +use TWiki::Templates; -#if( $TWiki::OS eq "WINDOWS" ) { -# require MIME::Base64; -# import MIME::Base64 qw( encode_base64 ); -# require Digest::SHA1; -# import Digest::SHA1 qw( sha1 ); -#} - - use strict; # 'Use locale' for internationalisation of Perl sorting in getTopicNames @@ -51,27 +42,26 @@ BEGIN { # Do a dynamic 'use locale' for this module if( $TWiki::useLocale ) { - require locale; - import locale (); + eval 'require locale; import locale ();'; } } -# FIXME: Move elsewhere? -# template variable hash: (built from %TMPL:DEF{"key"}% ... %TMPL:END%) -use vars qw( %templateVars $UserImpl ); # init in TWiki.pm so okay for modPerl +use vars qw( + $UserImpl + %userToWikiList %wikiToUserList + $wikiNamesMapped + ); $UserImpl = ""; -# =========================== =pod ---+++ initialize () | Description: | loads the selected User Implementation | =cut -sub initialize -{ - %templateVars = (); + +sub initialize { if ( # (-e $TWiki::htpasswdFilename ) && #<<< maybe ( $TWiki::htpasswdFormatFamily eq "htpasswd" ) ) { $UserImpl = "TWiki::User::HtPasswdUser"; @@ -83,17 +73,7 @@ eval "use ".$UserImpl; } -# =========================== -=pod - ----++ sub _getUserHandler ( $web, $topic, $attachment ) - -Not yet documented. - -=cut - -sub _getUserHandler -{ +sub _getUserHandler { my( $web, $topic, $attachment ) = @_; $attachment = "" if( ! $attachment ); @@ -101,30 +81,29 @@ my $handlerName = $UserImpl; my $handler = $handlerName->new( ); + $wikiNamesMapped = 0; + return $handler; } -#========================= =pod ---++ UserPasswordExists( $user ) ==> $passwordExists | Description: | checks to see if there is a $user in the password system | | Parameter: =$user= | the username we are looking for | | Return: =$passwordExists= | "1" if true, "" if not | -| TODO: | what if the login name is not the same as the twikiname?? (I think we don't have TWikiName to username mapping fully worked out| +| TODO: | what if the login name is not the same as the twikiname?? (I think we dont have TWikiName to username mapping fully worked out| =cut -sub UserPasswordExists -{ +sub UserPasswordExists { my ( $user ) = @_; my $handler = _getUserHandler(); return $handler->UserPasswordExists($user); } - -#========================= + =pod ---++ UpdateUserPassword( $user, $oldUserPassword, $newUserPassword ) ==> $success @@ -139,8 +118,7 @@ =cut -sub UpdateUserPassword -{ +sub UpdateUserPassword { my ( $user, $oldUserPassword, $newUserPassword ) = @_; if ( $user =~ /AnonymousContributor/ ) { @@ -151,7 +129,6 @@ return $handler->UpdateUserPassword($user, $oldUserPassword, $newUserPassword); } -#========================= =pod ---++ AddUserPassword( $user, $newUserPassword ) ==> $success @@ -165,8 +142,7 @@ =cut -sub AddUserPassword -{ +sub AddUserPassword { my ( $user, $newUserPassword ) = @_; if ( $user =~ /AnonymousContributor/ ) { @@ -177,7 +153,6 @@ return $handler->AddUserPassword($user, $newUserPassword); } -#========================= =pod ---++ RemoveUser( $user ) ==> $success @@ -188,15 +163,13 @@ =cut -sub RemoveUser -{ +sub RemoveUser { my ( $user ) = @_; my $handler = _getUserHandler(); return $handler->RemoveUser($user); } -# ========================= =pod ---++ CheckUserPasswd( $user, $password ) ==> $success @@ -208,28 +181,25 @@ =cut -sub CheckUserPasswd -{ +sub CheckUserPasswd { my ( $user, $password ) = @_; my $handler = _getUserHandler(); return $handler->CheckUserPasswd($user, $password); } - -# ========================= + =pod ---++ addUserToTWikiUsersTopic( $wikiName, $remoteUser ) ==> $topicName -| Description: | create the User's TWikiTopic | -| Parameter: =$wikiName= | the user's TWikiName | +| Description: | create the Users TWikiTopic | +| Parameter: =$wikiName= | the users TWikiName | | Parameter: =$remoteUser= | the remote username (is this used in the password file at any time?) | | Return: =$topicName= | the name of the TWikiTopic created | | TODO: | does this really belong here? | =cut -sub addUserToTWikiUsersTopic -{ +sub addUserToTWikiUsersTopic { my ( $wikiName, $remoteUser ) = @_; my $today = &TWiki::formatTime(time(), "\$day \$mon \$year", "gmtime"); my $topicName = $TWiki::wikiUsersTopicname; @@ -277,12 +247,191 @@ $result .= "$line\n"; } - &TWiki::Store::saveTopic( $TWiki::mainWebname, $topicName, $result, $meta, "", 1 ); + TWiki::Store::saveTopic( $TWiki::mainWebname, $topicName, $result, $meta, "", 1 ); return $topicName; } +=pod +---++ initializeRemoteUser( $remoteUser ) +Return value: $remoteUser +Acts as a filter for $remoteUser. If set, $remoteUser is filtered for +insecure characters and untainted. + +If $doRememberRemoteUser and $remoteUser are both set in TWiki.cfg, it +also caches $remoteUser as belonging to the IP address of the current request. + +If $doRememberRemoteUser is set and $remoteUser is not, then it sets +$remoteUser to the last authenticated user to make a request with the +current request's IP address, or $defaultUserName if no cached name +is available. + +If neither are set, then it sets $remoteUser to $defaultUserName. + +SMELL: the association of a user with an IP address is a high +risk strategy that can fail in the following environments: + 1 Multiple users at the same IP address + 1 Short-lease DHCP environments +This is documented sufficiently for a risk assessment to be made +by the installer. However it would be much safer (and more user +friendly) to use cookies. + +SMELL: this should be done in User.pm + +=cut + +sub initializeRemoteUser { + my( $theRemoteUser ) = @_; + + my $remoteUser = $theRemoteUser || $TWiki::defaultUserName; + $remoteUser =~ s/$TWiki::securityFilter//go; + $remoteUser =~ /(.*)/; + $remoteUser = $1; # untaint variable + + my $remoteAddr = $ENV{'REMOTE_ADDR'} || ""; + + if( $ENV{'REDIRECT_STATUS'} && $ENV{'REDIRECT_STATUS'} eq '401' ) { + # bail out if authentication failed + $remoteAddr = ""; + } + + if( ( ! $TWiki::doRememberRemoteUser ) || ( ! $remoteAddr ) ) { + # do not remember IP address + return $remoteUser; + } + + my $text = TWiki::Store::readFile( $TWiki::remoteUserFilename ); + # Assume no I18N characters in userids, as for email addresses + # FIXME: Needs fixing for IPv6? + my %AddrToName = map { split( /\|/, $_ ) } + grep { /^[0-9\.]+\|[A-Za-z0-9]+\|$/ } + split( /\n/, $text ); + + my $rememberedUser = ""; + if( exists( $AddrToName{ $remoteAddr } ) ) { + $rememberedUser = $AddrToName{ $remoteAddr }; + } + + if( $theRemoteUser ) { + if( $theRemoteUser ne $rememberedUser ) { + $AddrToName{ $remoteAddr } = $theRemoteUser; + # create file as "$remoteAddr|$theRemoteUser|" lines + $text = "# This is a generated file, do not modify.\n"; + foreach my $usrAddr ( sort keys %AddrToName ) { + my $usrName = $AddrToName{ $usrAddr }; + # keep $userName unique + if( ( $usrName ne $theRemoteUser ) + || ( $usrAddr eq $remoteAddr ) ) { + $text .= "$usrAddr|$usrName|\n"; + } + } + TWiki::Store::saveFile( $TWiki::remoteUserFilename, $text ); + } + } else { + # get user name from AddrToName table + $remoteUser = $rememberedUser || $TWiki::defaultUserName; + } + + return $remoteUser; +} + +=pod + +---++ _cacheUserToWikiTranslations() +Build hashes to translate in both directions between username (e.g. jsmith) +and WikiName (e.g. JaneSmith). Only used for sites where authentication is +managed by external Apache configuration, instead of via TWiki's .htpasswd +mechanism. + +Should only be called once per request. + +SMELL: this should be done in User.pm + +=cut + +sub _cacheUserToWikiTranslations { + return if $wikiNamesMapped; + $wikiNamesMapped = 1; + + %userToWikiList = (); + %wikiToUserList = (); + my @list = (); + if( $TWiki::doMapUserToWikiName ) { + @list = split( /\n/, TWiki::Store::readFile( $TWiki::userListFilename ) ); + } else { + # fix for Codev.SecurityAlertGainAdminRightWithTWikiUsersMapping + # for .htpasswd authenticated sites ignore user list, but map only guest to TWikiGuest + @list = ( "\t* TWikiGuest - guest - " ); # CODE_SMELL on localization + } + + # Get all entries with two '-' characters on same line, i.e. + # 'WikiName - userid - date created' + @list = grep { /^\s*\* $TWiki::regex{wikiWordRegex}\s*-\s*[^\-]*-/o } @list; + my $wUser; + my $lUser; + foreach( @list ) { + # Get the WikiName and userid, and build hashes in both directions + if( ( /^\s*\* ($TWiki::regex{wikiWordRegex})\s*\-\s*([^\s]*).*/o ) && $2 ) { + $wUser = $1; # WikiName + $lUser = $2; # userid + $lUser =~ s/$TWiki::securityFilter//go; # FIXME: Should filter in for security... + $userToWikiList{ $lUser } = $wUser; + $wikiToUserList{ $wUser } = $lUser; + } + } +} + +=pod + +---++ userToWikiName( $loginUser, $dontAddWeb ) +Return value: $wikiName + +Translates intranet username (e.g. jsmith) to WikiName (e.g. JaneSmith) + +Unless $dontAddWeb is set, "Main." is prepended to the returned WikiName. + +If you give an invalid username, we just return that (no appending Main. blindy) + +SMELL: the userToWikiList cache should really contain the WebName so its possible + to have userTopics in more than just the MainWeb (what if you move a user topic?) + +=cut + +sub userToWikiName { + my( $loginUser, $dontAddWeb ) = @_; + + if( !$loginUser ) { + return ""; + } + + _cacheUserToWikiTranslations(); + + $loginUser =~ s/$TWiki::securityFilter//go; + my $wUser = $userToWikiList{ $loginUser } || $loginUser; + if( $dontAddWeb ) { + return $wUser; + } + return "$TWiki::mainWebname.$wUser"; +} + +=pod + +---++ wikiToUserName( $wikiName ) +Return value: $loginUser + +Translates WikiName (e.g. JaneSmith) to an intranet username (e.g. jsmith) + +=cut + +sub wikiToUserName { + my( $wikiUser ) = @_; + $wikiUser =~ s/^.*\.//g; + _cacheUserToWikiTranslations(); + my $userName = $wikiToUserList{"$wikiUser"} || $wikiUser; + return $userName; +} + 1; # EOF Index: lib/TWiki/Prefs.pm =================================================================== --- lib/TWiki/Prefs.pm (revision 1767) +++ lib/TWiki/Prefs.pm (working copy) @@ -31,6 +31,11 @@ This module reads TWiki preferences of site-level, web-level and user-level topics and implements routines to access those preferences. +SMELL: This implementation does far to much copying around of prefs +values. Inheritance should be handled by stacking the prefs object, +which will slow down accessing prefs values but that is a relatively +small part of the rendering process. + =cut $TWiki::Prefs::finalPrefsName = "FINALPREFERENCES"; @@ -53,24 +58,31 @@ Returns a new TopicParser object. +=cut + +sub new { + return bless {}, $_[0]; +} + + +=pod + ---+++ sub parseText( $text, $prefs ) Parse settings from text and add them to the preferences in $prefs =cut -sub new { return bless {}, $_[0]; } - sub parseText { my( $self, $text, $prefs ) = @_; - $text =~ s/\r/\n/g; - $text =~ s/\n+/\n/g; + #$text =~ s/\r/\n/g; + #$text =~ s/\n+/\n/g; my $key = ""; my $value =""; my $isKey = 0; - foreach( split( /\n/, $text ) ) { + foreach( split( /\r?\n/, $text ) ) { if( /^\t+\*\sSet\s(\w+)\s\=\s*(.*)/ ) { if( $isKey ) { $prefs->_insertPrefsValue( $key, $value ); @@ -170,9 +182,9 @@ $self->{prefs} = {}; - my $parser = TWiki::Prefs::Parser->new(); my( $meta, $text ) = TWiki::Store::readTopic( $theWeb, $theTopic, 1 ); + my $parser = new TWiki::Prefs::Parser(); $parser->parseText( $text, $self ); $parser->parseMeta( $meta, $self ); } @@ -325,8 +337,11 @@ } elsif( $self->{type} eq "request" ) { # request prefs - read topic and user my $parent = $self->{parent}; - my $topicPrefsSetting = $parent->getPreferenceFlag("READTOPICPREFS"); - my $topicPrefsOverride = $parent->getPreferenceFlag("TOPICOVERRIDESUSER"); + my $topicPrefsSetting = + TWiki::Prefs::formatAsFlag( $parent->{prefs}{READTOPICPREFS} ); + my $topicPrefsOverride = + TWiki::Prefs::formatAsFlag( $parent->{prefs}{TOPICOVERRIDESUSER} ); + if( $topicPrefsSetting && !$topicPrefsOverride ) { # topic prefs overridden by user prefs $self->loadPrefsFromTopic( $parent->{web}, @@ -409,14 +424,14 @@ sub inheritPrefs { my( $self, $otherPrefsObject ) = @_; - foreach my $key( %{$otherPrefsObject->{prefs}} ) { + foreach my $key( keys %{$otherPrefsObject->{prefs}} ) { $self->{prefs}{$key} = $otherPrefsObject->{prefs}{$key}; } } =pod ----+++ sub replacePreferencesTags( $text ) +---+++ sub replacePreferencesTags( \$text ) Substitutes preferences values for =%PREF%= tags in =$text=, modifying that parameter in-place. @@ -424,47 +439,24 @@ =cut sub replacePreferencesTags { - #my( $self, $text ) = @_; - $_[1] =~ s/%(\w+)%/&_exvar( $1, @_ )/ge; + my( $self, $text ) = @_; + $$text =~ s/(%([A-Z0-9_]+)%)/$self->_exvar($1,$2)/ge; } sub _exvar { - #my( $vbl,$self ) = @_ - my $v = $_[1]->{prefs}{$_[0]}; + #my( $self, $all, $vbl ) = @_ + my $v = $_[0]->{prefs}{$_[2]}; return $v if( defined( $v )); - return "%$_[0]%"; + return $_[1]; } -=pod - ----+++ sub getPreferenceValue( $key ) - -Returns the stored preference with key =$key=, or "" if no such preference -exists. - -=cut - -sub getPreferenceValue { - return $_[0]->{prefs}{$_[1]} or ""; +sub loadHash { + my( $self, $hash ) = @_; + foreach my $var ( keys %{$self->{prefs}} ) { + $hash->{$var} = $self->{prefs}{$var}; + } } -=pod - ----+++ sub getPreferenceFlag( $key ) - -Returns a preference as a flag. See -=[[#sub_formatAsFlag_prefValue][Prefs::formatAsFlag]]= for details on how -preference values are converted to flags. - -=cut - -sub getPreferenceFlag { - my( $self, $theKey ) = @_; - - my $value = $self->getPreferenceValue( $theKey ); - return TWiki::Prefs::formatAsFlag( $value ); -} - # ============================================================================= package TWiki::Prefs; @@ -496,8 +488,10 @@ $requestWeb = $theWebName; $globalPrefs = TWiki::Prefs::PrefsCache->new("global"); - $webPrefs{$requestWeb} = TWiki::Prefs::PrefsCache->new("web", $globalPrefs, $requestWeb); - $requestPrefs = TWiki::Prefs::PrefsCache->new("copy", $webPrefs{$requestWeb}); + $webPrefs{$requestWeb} = + new TWiki::Prefs::PrefsCache("web", $globalPrefs, $requestWeb); + $requestPrefs = + new TWiki::Prefs::PrefsCache("copy", $webPrefs{$requestWeb}); return; } @@ -583,36 +577,35 @@ =pod ----+++ sub handlePreferencesTags( $text ) +---+++ sub expandPreferencesTags( \$text ) -Replaces %PREF% and %VAR{"pref"}% syntax in $text, modifying that parameter in-place. +Replaces %PREF% and %VAR{"pref"}% syntax in $text =cut -sub handlePreferencesTags { - my $textRef = \$_[0]; +sub expandPreferencesTags { + $requestPrefs->replacePreferencesTags( @_ ); +} - $requestPrefs->replacePreferencesTags( $$textRef ); - - # handle web specific variables - $$textRef =~ s/\%VAR{(.*?)}\%/prvGetWebVariable( $1 )/ge; +sub loadHash { + $requestPrefs->loadHash( @_ ); } =pod ----+++ sub prvGetWebVariable( $attributeString ) +---+++ sub getWebVariable( $attributeString ) Returns the value for a %VAR{"foo" web="bar"}% syntax, given the stuff inside the {}'s. =cut -sub prvGetWebVariable { +sub getWebVariable { my( $attributeString ) = @_; my $key = &TWiki::extractNameValuePair( $attributeString ); - my $attrWeb = &TWiki::extractNameValuePair( $attributeString, "web" ); + my $attrWeb = TWiki::extractNameValuePair( $attributeString, "web" ); if( $attrWeb =~ /%[A-Z]+%/ ) { # handle %MAINWEB%-type cases - &TWiki::handleInternalTags( $attrWeb, $requestWeb, "dummy" ); + TWiki::handleInternalTags( $attrWeb, $requestWeb, "dummy" ); } return getPreferencesValue( $key, $attrWeb); @@ -633,14 +626,12 @@ sub formatAsFlag { my( $value ) = @_; - $value =~ s/^\s*(.*?)\s*$/$1/gi; - $value =~ s/off//gi; - $value =~ s/no//gi; - if( $value ) { - return 1; - } else { - return 0; - } + return 0 unless ( defined( $value )); + return 1 if ( $value =~ m/^\s*(on|1|true|yes)\s*$/i ); + return 0 if ( $value =~ m/^\s*(off|0|false|no)\s*$/i ); + + $value =~ s/^\s*(.*?)\s*$/$1/i; + return ( $value ? 1 : 0 ); } =pod @@ -691,22 +682,30 @@ sub getPreferencesValue { my( $theKey, $theWeb ) = @_; - my $sessionValue = &TWiki::getSessionValue( $theKey ); + my $sessionValue = + TWiki::Plugins::getSessionValueHandler( $theKey ); + if( defined( $sessionValue ) ) { return $sessionValue; } + my $val; if( $theWeb ) { if (!exists $webPrefs{$theWeb}) { - $webPrefs{$theWeb} = TWiki::Prefs::PrefsCache->new("web", $globalPrefs, $theWeb); + $webPrefs{$theWeb} = + new TWiki::Prefs::PrefsCache("web", $globalPrefs, $theWeb); } - return $webPrefs{$theWeb}->getPreferenceValue( $theKey ); + $val = $webPrefs{$theWeb}->{prefs}{$theKey}; } else { - return $requestPrefs->getPreferenceValue( $theKey ) if defined $requestPrefs; - if (exists $webPrefs{$requestWeb}) { - return $webPrefs{$requestWeb}->getPreferenceValue( $theKey ); # user/topic prefs not yet init'd + if( defined( $requestPrefs )) { + $val = $requestPrefs->{prefs}{$theKey}; + } elsif (exists( $webPrefs{$requestWeb} )) { + # user/topic prefs not yet init'd + $val = $webPrefs{$requestWeb}->{prefs}{$theKey}; } } + $val = "" unless( defined( $val )); + return $val; } # ========================= Index: lib/TWiki/Render.pm =================================================================== --- lib/TWiki/Render.pm (revision 1767) +++ lib/TWiki/Render.pm (working copy) @@ -36,30 +36,24 @@ use strict; -use TWiki qw(:renderflags %regex $TranslationToken); +use TWiki; +use TWiki::Attach; -# =========================== -# Read the configuration file at compile time in order to set locale BEGIN { - do "TWiki.cfg"; - # Do a dynamic 'use locale' for this module if( $TWiki::useLocale ) { - require locale; - import locale (); + eval 'require locale; import locale ();'; } } # Globals used in rendering use vars qw( - $isList @listTypes @listElements - $newTopicFontColor $newTopicBgColor $linkToolTipInfo $noAutoLink - $newLinkSymbol %ffCache - - ); - + $newTopicFontColor $newTopicBgColor $linkToolTipInfo $noAutoLink + $newLinkSymbol %ffCache $renderMode + ); $noAutoLink = 0; +$renderMode = 'html'; # Default is to render as HTML =pod @@ -85,46 +79,29 @@ # Prevent autolink of WikiWords $noAutoLink = TWiki::Prefs::getPreferencesValue("NOAUTOLINK") || 0; - undef %ffCache; + undef %ffCache; } -=pod - ----++ sub renderParent ( $web, $topic, $meta, $args ) - -Not yet documented. - -=cut - -sub renderParent +sub _renderParent { my( $web, $topic, $meta, $args ) = @_; - - my $text = ""; + my %ah; - my $dontRecurse = 0; - my $noWebHome = 0; - my $prefix = ""; - my $suffix = ""; - my $usesep = ""; - if( $args ) { - $dontRecurse = TWiki::extractNameValuePair( $args, "dontrecurse" ); - $noWebHome = TWiki::extractNameValuePair( $args, "nowebhome" ); - $prefix = TWiki::extractNameValuePair( $args, "prefix" ); - $suffix = TWiki::extractNameValuePair( $args, "suffix" ); - $usesep = TWiki::extractNameValuePair( $args, "separator" ); + %ah = TWiki::extractParameters( $args ); } + my $dontRecurse = $ah{dontrecurse} || 0; + my $noWebHome = $ah{nowebhome} || 0; + my $prefix = $ah{prefix} || ""; + my $suffix = $ah{suffix} || ""; + my $usesep = $ah{separator} || " > "; - if( ! $usesep ) { - $usesep = " > "; - } - - my %visited = (); + my %visited; $visited{"$web.$topic"} = 1; my $sep = ""; my $cWeb = $web; + my $text = ""; while( 1 ) { my %parent = $meta->findOne( "TOPICPARENT" ); @@ -136,7 +113,7 @@ $pWeb = $1; $pTopic = $2; } - if( $noWebHome && ( $pTopic eq $mainTopicname ) ) { + if( $noWebHome && ( $pTopic eq $TWiki::mainTopicname ) ) { last; # exclude "WebHome" } $text = "[[$pWeb.$pTopic][$pTopic]]$sep$text"; @@ -144,14 +121,13 @@ if( $dontRecurse || ! $name ) { last; } else { - my $dummy; if( $visited{"$pWeb.$pTopic"} ) { last; } else { $visited{"$pWeb.$pTopic"} = 1; } if( TWiki::Store::topicExists( $pWeb, $pTopic ) ) { - ( $meta, $dummy ) = TWiki::Store::readTopMeta( $pWeb, $pTopic ); + $meta = TWiki::Store::getMinimalMeta( $pWeb, $pTopic ); } else { last; } @@ -173,23 +149,12 @@ return $text; } -# ======================== -=pod - ----++ sub renderMoved ( $web, $topic, $meta ) - -Not yet documented. - -=cut - -sub renderMoved +sub _renderMoved { my( $web, $topic, $meta ) = @_; - my $text = ""; - my %moved = $meta->findOne( "TOPICMOVED" ); - + if( %moved ) { my $from = $moved{"from"}; $from =~ /(.*)\.(.*)/; @@ -200,34 +165,24 @@ my $toWeb = $1; my $toTopic = $2; my $by = $moved{"by"}; - $by = TWiki::userToWikiName( $by ); + $by = TWiki::User::userToWikiName( $by ); my $date = $moved{"date"}; $date = TWiki::formatTime( $date, "", "gmtime" ); - + # Only allow put back if current web and topic match stored information my $putBack = ""; if( $web eq $toWeb && $topic eq $toTopic ) { $putBack = " - put it back"; } $text = "$to moved from $from on $date by $by $putBack"; } - return $text; } -# ======================== -=pod - ----++ sub renderFormField ( $meta, $args ) - -Not yet documented. - -=cut - -sub renderFormField +sub _renderFormField { my( $meta, $args ) = @_; my $text = ""; @@ -238,22 +193,12 @@ return $text; } -# ========================= -=pod - ----++ sub renderFormData ( $web, $topic, $meta ) - -Not yet documented. - -=cut - -sub renderFormData +sub _renderFormData { my( $web, $topic, $meta ) = @_; - my $metaText = ""; - my %form = $meta->findOne( "FORM" ); + if( %form ) { my $name = $form{"name"}; $metaText = "
\n"; @@ -278,10 +223,12 @@ ---++ sub encodeSpecialChars ( $text ) -Not yet documented. +Escape out the chars &, ", >, < and whitespace with replaceable tokens. +Presumably this is used to avoid browser interpretation =cut +# " sub encodeSpecialChars { my( $text ) = @_; @@ -300,14 +247,14 @@ ---++ sub decodeSpecialChars ( $text ) -Not yet documented. +Reverse the encoding of encodeSpecialChars =cut sub decodeSpecialChars { my( $text ) = @_; - + $text =~ s/%_N_%/\r\n/g; $text =~ s/%_L_%//g; @@ -318,75 +265,57 @@ } -# ========================= # Render bulleted and numbered lists, including nesting. # Called from several places. Accumulates @listTypes and @listElements # to track nested lists. -=pod +sub _emitList { + my( $listTypes, $listElements, $result, + $theType, $theElement, $theIndent, $theOlType, + ) = @_; ----++ sub emitList ( $theType, $theElement, $theDepth, $theOlType ) + $theIndent =~ s/ /\t/g; + my $depth = length( $theIndent ); -Not yet documented. - -=cut - -sub emitList { - my( $theType, $theElement, $theDepth, $theOlType ) = @_; - - my $result = ""; - $isList = 1; - # Ordered list type $theOlType = "" unless( $theOlType ); $theOlType =~ s/^(.).*/$1/; $theOlType = "" if( $theOlType eq "1" ); - if( @listTypes < $theDepth ) { + if( @$listTypes < $depth ) { my $firstTime = 1; - while( @listTypes < $theDepth ) { - push( @listTypes, $theType ); - push( @listElements, $theElement ); - $result .= "<$theElement>\n" unless( $firstTime ); + while( @$listTypes < $depth ) { + push( @$listTypes, $theType ); + push( @$listElements, $theElement ); + push( @$result, "<$theElement>\n" ) unless( $firstTime ); if( $theOlType ) { - $result .= "<$theType type=\"$theOlType\">\n"; + push( @$result, "<$theType type=\"$theOlType\">\n" ); } else { - $result .= "<$theType>\n"; + push( @$result, "<$theType>\n" ); } $firstTime = 0; } - } elsif( @listTypes > $theDepth ) { - while( @listTypes > $theDepth ) { - local($_) = pop @listElements; - $result .= "\n"; - local($_) = pop @listTypes; - $result .= "\n"; + } elsif( @$listTypes > $depth ) { + while( @$listTypes > $depth ) { + local($_) = pop @$listElements; + push( @$result, "\n" ); + local($_) = pop @$listTypes; + push( @$result, "\n" ); } - $result .= "\n" if( @listElements ); + push( @$result, "[$#$listElements]>\n") if( @$listElements ); - } elsif( @listElements ) { - $result = "\n"; + } elsif( @$listElements ) { + push ( @$result, "[$#$listElements]>\n" ); } - if( ( @listTypes ) && ( $listTypes[$#listTypes] ne $theType ) ) { - $result .= "\n<$theType>\n"; - $listTypes[$#listTypes] = $theType; - $listElements[$#listElements] = $theElement; + if( ( @$listTypes ) && ( $listTypes->[$#$listTypes] ne $theType ) ) { + push( @$result, "[$#$listTypes]><$theType>\n" ); + $listTypes->[$#$listTypes] = $theType; + $listElements->[$#$listElements] = $theElement; } - - return $result; } -# ======================== -=pod - ----++ sub emitTR ( $thePre, $theRow, $insideTABLE ) - -Not yet documented. - -=cut - -sub emitTR { +sub _emitTR { my ( $thePre, $theRow, $insideTABLE ) = @_; my $text = ""; @@ -400,12 +329,12 @@ } $theRow =~ s/\t/ /g; # change tabs to space $theRow =~ s/\s*$//; # remove trailing spaces - $theRow =~ s/(\|\|+)/$TranslationToken . length($1) . "\|"/ge; # calc COLSPAN + $theRow =~ s/(\|\|+)/$TWiki::TranslationToken . length($1) . "\|"/ge; # calc COLSPAN foreach( split( /\|/, $theRow ) ) { $attr = ""; #AS 25-5-01 Fix to avoid matching also single columns - if ( s/$TranslationToken([0-9]+)//o ) { + if ( s/$TWiki::TranslationToken([0-9]+)//o ) { $attr = " colspan=\"$1\"" ; } s/^\s+$/   /; @@ -429,16 +358,7 @@ return $text; } -# ========================= -=pod - ----++ sub fixedFontText ( $theText, $theDoBold ) - -Not yet documented. - -=cut - -sub fixedFontText +sub _fixedFontText { my( $theText, $theDoBold ) = @_; # preserve white space, so replace it by "  " patterns @@ -451,28 +371,20 @@ } } -# ========================= # Build an HTML <Hn> element with suitable anchor for linking from %TOC% -=pod - ----++ sub makeAnchorHeading ( $theText, $theLevel ) - -Not yet documented. - -=cut - -sub makeAnchorHeading +sub _makeAnchorHeading { my( $theHeading, $theLevel ) = @_; # - Build '

heading

' markup # - Initial '' is needed to prevent subsequent matches. - # - filter out $regex{headerPatternNoTOC} ( '!!' and '%NOTOC%' ) + # - filter out $TWiki::regex{headerPatternNoTOC} ( '!!' and '%NOTOC%' ) # CODE_SMELL: Empty anchor tags seem not to be allowed, but validators and browsers tolerate them my $anchorName = makeAnchorName( $theHeading, 0 ); my $compatAnchorName = makeAnchorName( $theHeading, 1 ); - $theHeading =~ s/$regex{headerPatternNoTOC}//o; # filter '!!', '%NOTOC%' + # filter '!!', '%NOTOC%' + $theHeading =~ s/$TWiki::regex{headerPatternNoTOC}//o; my $text = ""; $text .= " "; $text .= " " if( $compatAnchorName ne $anchorName ); @@ -481,13 +393,13 @@ return $text; } -# ========================= -# Build a valid HTML anchor name =pod ----++ sub makeAnchorName ( $anchorName, $compatibilityMode ) +---++ sub makeAnchorName($anchorName, $compatibilityMode) +| =$anchorName= | | +| =$compatibilityMode= | | -Not yet documented. +Build a valid HTML anchor name =cut @@ -495,7 +407,7 @@ { my( $anchorName, $compatibilityMode ) = @_; - if ( ! $compatibilityMode && $anchorName =~ /^$regex{anchorRegex}$/ ) { + if ( ! $compatibilityMode && $anchorName =~ /^$TWiki::regex{anchorRegex}$/ ) { # accept, already valid -- just remove leading # return substr($anchorName, 1); } @@ -509,10 +421,10 @@ $anchorName =~ s/<\w[^>]*>//gi; # remove HTML tags $anchorName =~ s/\&\#?[a-zA-Z0-9]*;//g; # remove HTML entities $anchorName =~ s/\&//g; # remove & - $anchorName =~ s/^(.+?)\s*$regex{headerPatternNoTOC}.*/$1/o; # filter TOC excludes if not at beginning - $anchorName =~ s/$regex{headerPatternNoTOC}//o; # filter '!!', '%NOTOC%' + $anchorName =~ s/^(.+?)\s*$TWiki::regex{headerPatternNoTOC}.*/$1/o; # filter TOC excludes if not at beginning + $anchorName =~ s/$TWiki::regex{headerPatternNoTOC}//o; # filter '!!', '%NOTOC%' # FIXME: More efficient to match with '+' on next line: - $anchorName =~ s/$regex{singleMixedNonAlphaNumRegex}/_/g; # only allowed chars + $anchorName =~ s/[^$TWiki::regex{mixedAlphaNum}]/_/g; # only allowed chars $anchorName =~ s/__+/_/g; # remove excessive '_' if ( !$compatibilityMode ) { $anchorName =~ s/^[\s\#\_]*//; # no leading space nor '#', '_' @@ -527,17 +439,9 @@ return $anchorName; } -# ========================= -=pod - ----++ sub linkToolTipInfo ( $theWeb, $theTopic ) - -Returns =title="..."= tooltip info in case LINKTOOLTIPINFO perferences variable is set. -Warning: Slower performance if enabled. - -=cut - -sub linkToolTipInfo +# Returns =title="..."= tooltip info in case LINKTOOLTIPINFO perferences variable is set. +# Warning: Slower performance if enabled. +sub _linkToolTipInfo { my( $theWeb, $theTopic ) = @_; return "" unless( $linkToolTipInfo ); @@ -551,31 +455,34 @@ $text =~ s/\$rev/1.$rev/g; $text =~ s/\$date/&TWiki::formatTime( $date )/ge; $text =~ s/\$username/$user/g; # "jsmith" - $text =~ s/\$wikiname/"" . &TWiki::userToWikiName( $user, 1 )/ge; # "JohnSmith" - $text =~ s/\$wikiusername/"" . &TWiki::userToWikiName( $user )/ge; # "Main.JohnSmith" + $text =~ s/\$wikiname/"" . &TWiki::User::userToWikiName( $user, 1 )/ge; # "JohnSmith" + $text =~ s/\$wikiusername/"" . &TWiki::User::userToWikiName( $user )/ge; # "Main.JohnSmith" if( $text =~ /\$summary/ ) { my $summary = &TWiki::Store::readFileHead( "$TWiki::dataDir/$theWeb/$theTopic.txt", 16 ); - $summary = &TWiki::makeTopicSummary( $summary, $theTopic, $theWeb ); + $summary = makeTopicSummary( $summary, $theTopic, $theWeb ); $summary =~ s/[\"\']//g; # remove quotes (not allowed in title attribute) $text =~ s/\$summary/$summary/g; } return " title=\"$text\""; } -# ========================= =pod ----++ sub internalLink ( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink, $doKeepWeb ) +---++ sub internalLink ( $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink, $doKeepWeb ) -Not yet documented. +Generate a link. +| =$theWeb= | the web containing the topic | +| =$theTopic= | the topic to be lunk | +| =$theLinkText= | text to use for the link | +| =$theAnchor= | the link anchor, if any | +| =$doLink= | boolean: false means suppress link for non-existing pages | +| =$doKeepWeb= | boolean: true to keep web prefix (for non existing Web.TOPIC) | + =cut sub internalLink { - my( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink, $doKeepWeb ) = @_; - # $thePreamble is text used before the TWiki link syntax - # $doLink is boolean: false means suppress link for non-existing pages - # $doKeepWeb is boolean: true to keep web prefix (for non existing Web.TOPIC) + my( $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink, $doKeepWeb ) = @_; # Get rid of leading/trailing spaces in topic name $theTopic =~ s/^\s*//; @@ -585,24 +492,25 @@ # whole link, and first of each word. TODO: Try to turn this off, # avoiding spaces being stripped elsewhere - e.g. $doPreserveSpacedOutWords $theTopic =~ s/^(.)/\U$1/; - $theTopic =~ s/\s($regex{singleMixedAlphaNumRegex})/\U$1/go; + $theTopic =~ s/\s([$TWiki::regex{mixedAlphaNum}])/\U$1/go; # Add before WikiWord inside link text to prevent double links - $theLinkText =~ s/([\s\(])($regex{singleUpperAlphaRegex})/$1$2/go; + $theLinkText =~ s/([\s\(])([$TWiki::regex{upperAlpha}])/$1$2/go; # Allow spacing out, etc - if (TWiki::isWikiName($theLinkText)) { + if (TWiki::isValidWikiWord($theLinkText)) { $theLinkText = TWiki::Plugins::renderWikiWordHandler( $theLinkText ) || $theLinkText; } my $exist = &TWiki::Store::topicExists( $theWeb, $theTopic ); + # I18N - Only apply plural processing if site language is English, or # if a built-in English-language web (Main, TWiki or Plugins). Plurals # apply to names ending in 's', where topic doesn't exist with plural # name. - if( ( $doPluralToSingular ) and ( $siteLang eq 'en' - or $theWeb eq $mainWebname - or $theWeb eq $twikiWebname + if( ( $TWiki::doPluralToSingular ) and ( $TWiki::siteLang eq 'en' + or $theWeb eq $TWiki::mainWebname + or $theWeb eq $TWiki::twikiWebname or $theWeb eq 'Plugins' ) and ( $theTopic =~ /s$/ ) and not ( $exist ) ) { @@ -618,19 +526,19 @@ } } - my $text = $thePreamble; + my $text = ""; if( $exist) { if( $theAnchor ) { my $anchor = makeAnchorName( $theAnchor ); - $text .= "$theLinkText"; return $text; } else { - $text .= "$theLinkText"; return $text; } @@ -638,7 +546,7 @@ } elsif( $doLink ) { $text .= "" . "$theLinkText" - . "$newLinkSymbol"; + . "$newLinkSymbol"; return $text; } elsif( $doKeepWeb ) { @@ -651,93 +559,62 @@ } } -# ========================= -=pod - ----++ sub internalCrosswebLink ( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink ) - -Not yet documented. - -=cut - -sub internalCrosswebLink +# Handle specific links of the form: +# format: [[$theText]] +# format: [[$theLink][$theText]] +sub _specificLink { - my( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink ) = @_; - if ( $theTopic eq $TWiki::mainTopicname && $theWeb ne $TWiki::webName ) { - return internalLink( $thePreamble, $theWeb, $theTopic, $theWeb, $theAnchor, $doLink ); - } else { - return internalLink( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink ); - } -} + my( $theWeb, $theTopic, $theText, $theLink ) = @_; -# ========================= -# Handle most internal and external links -=pod + $theText = $theLink unless defined( $theText ); ----++ sub specificLink ( $thePreamble, $theWeb, $theTopic, $theText, $theLink ) - -Not yet documented. - -=cut - -sub specificLink -{ - my( $thePreamble, $theWeb, $theTopic, $theText, $theLink ) = @_; - - # format: $thePreamble[[$theText]] - # format: $thePreamble[[$theLink][$theText]] - # # Current page's $theWeb and $theTopic are also used # Strip leading/trailing spaces $theLink =~ s/^\s*//; $theLink =~ s/\s*$//; - if( $theLink =~ /^$regex{linkProtocolPattern}\:/ ) { + if( $theLink =~ /^$TWiki::regex{linkProtocolPattern}\:/ ) { + if ( $theLink =~ /^(\S+)\s+(.*)$/ ) { + # '[[URL#anchor display text]]' link: + $theLink = $1; + $theText = $2; + } else { + # '[[Web.odd wiki word#anchor][display text]]' link: + # '[[Web.odd wiki word#anchor]]' link: - # External link: add before WikiWord and ABBREV - # inside link text, to prevent double links - $theText =~ s/([\s\(])($regex{singleUpperAlphaRegex})/$1$2/go; - return "$thePreamble$theText"; + # External link: add before WikiWord and ABBREV + # inside link text, to prevent double links + $theText =~ s/([\s\(])([$TWiki::regex{upperAlpha}])/$1$2/go; + } + return "$theText"; + } - } else { + # Internal link: get any 'Web.' prefix, or use current web + $theLink =~ s/^($TWiki::regex{webNameRegex}|$TWiki::regex{defaultWebNameRegex})\.//; + my $web = $1 || $theWeb; + (my $baz = "foo") =~ s/foo//; # reset $1, defensive coding - # Internal link: get any 'Web.' prefix, or use current web - $theLink =~ s/^($regex{webNameRegex}|$regex{defaultWebNameRegex})\.//; - my $web = $1 || $theWeb; - (my $baz = "foo") =~ s/foo//; # reset $1, defensive coding + # Extract '#anchor' + # FIXME and NOTE: Had '-' as valid anchor character, removed + # $theLink =~ s/(\#[a-zA-Z_0-9\-]*$)//; + $theLink =~ s/($TWiki::regex{anchorRegex}$)//; + my $anchor = $1 || ""; - # Extract '#anchor' - # FIXME and NOTE: Had '-' as valid anchor character, removed - # $theLink =~ s/(\#[a-zA-Z_0-9\-]*$)//; - $theLink =~ s/($regex{anchorRegex}$)//; - my $anchor = $1 || ""; - - # Get the topic name - my $topic = $theLink || $theTopic; # remaining is topic - $topic =~ s/\&[a-z]+\;//gi; # filter out &any; entities - $topic =~ s/\&\#[0-9]+\;//g; # filter out { entities - $topic =~ s/[\\\/\#\&\(\)\{\}\[\]\<\>\!\=\:\,\.]//g; - $topic =~ s/$securityFilter//go; # filter out suspicious chars - if( ! $topic ) { - return "$thePreamble$theText"; # no link if no topic - } - - return internalLink( $thePreamble, $web, $topic, $theText, $anchor, 1 ); + # Get the topic name + my $topic = $theLink || $theTopic; # remaining is topic + $topic =~ s/\&[a-z]+\;//gi; # filter out &any; entities + $topic =~ s/\&\#[0-9]+\;//g; # filter out { entities + $topic =~ s/[\\\/\#\&\(\)\{\}\[\]\<\>\!\=\:\,\.]//g; + $topic =~ s/$TWiki::securityFilter//go; # filter out suspicious chars + if( ! $topic ) { + return $theText; # no link if no topic } + return internalLink( $web, $topic, $theText, $anchor, 1 ); } -# ========================= -=pod - ----++ sub externalLink ( $pre, $url ) - -Not yet documented. - -=cut - -sub externalLink +sub _externalLink { my( $pre, $url ) = @_; if( $url =~ /\.(gif|jpg|jpeg|png)$/i ) { @@ -749,16 +626,7 @@ return "$pre$url"; } -# ========================= -=pod - ----++ sub mailtoLink ( $theAccount, $theSubDomain, $theTopDomain ) - -Not yet documented. - -=cut - -sub mailtoLink +sub _mailtoLink { my( $theAccount, $theSubDomain, $theTopDomain ) = @_; @@ -766,16 +634,7 @@ return "$addr"; } -# ========================= -=pod - ----++ sub mailtoLinkFull ( $theAccount, $theSubDomain, $theTopDomain, $theLinkText ) - -Not yet documented. - -=cut - -sub mailtoLinkFull +sub _mailtoLinkFull { my( $theAccount, $theSubDomain, $theTopDomain, $theLinkText ) = @_; @@ -783,16 +642,7 @@ return "$theLinkText"; } -# ========================= -=pod - ----++ sub mailtoLinkSimple ( $theMailtoString, $theLinkText ) - -Not yet documented. - -=cut - -sub mailtoLinkSimple +sub _mailtoLinkSimple { # Does not do any anti-spam padding, because address will not include '@' my( $theMailtoString, $theLinkText ) = @_; @@ -806,86 +656,122 @@ =pod ----++ sub getFormField ( $web, $topic, $args ) +---++ sub filenameToIcon ( $fileName ) -+Returns the expansion of a %FORMFIELD{}% tag. +Produce an image tailored to the type of the file, guessed from +its extension. +used in TWiki::handleIcon + =cut -sub getFormField +sub filenameToIcon { - my( $web, $topic, $args ) = @_; + my( $fileName ) = @_; - my $formField = TWiki::extractNameValuePair( $args ); - my $formTopic = TWiki::extractNameValuePair( $args, "topic" ); - my $altText = TWiki::extractNameValuePair( $args, "alttext" ); - my $default = TWiki::extractNameValuePair( $args, "default" ) || undef; - my $format = TWiki::extractNameValuePair( $args, "format" ); + my @bits = ( split( /\./, $fileName ) ); + my $fileExt = lc $bits[$#bits]; - unless ( $format ) { - # if null format explicitly set, return empty - return "" if ( $args =~ m/format\s*=/o); - # Otherwise default to value - $format = "\$value"; - } + my $iconDir = "$TWiki::pubDir/icn"; + my $iconUrl = "$TWiki::pubUrlPath/icn"; + my $iconList = &TWiki::Store::readFile( "$iconDir/_filetypes.txt" ); + foreach( split( /\n/, $iconList ) ) { + @bits = ( split( / / ) ); + if( $bits[0] eq $fileExt ) { + return "\"\""; + } + } + return "\"\""; +} - my $formWeb; - if ( $formTopic ) { - if ($topic =~ /^([^.]+)\.([^.]+)/o) { - ( $formWeb, $topic ) = ( $1, $2 ); - } else { - # SMELL: Undocumented feature, "web" parameter - $formWeb = TWiki::extractNameValuePair( $args, "web" ); - } - $formWeb = $web unless $formWeb; - } else { - $formWeb = $web; - $formTopic = $topic; - } +=pod - my $meta = $ffCache{"$formWeb.$formTopic"}; - unless ( $meta ) { - my $dummyText; - ( $meta, $dummyText ) = - TWiki::Store::readTopic( $formWeb, $formTopic ); - $ffCache{"$formWeb.$formTopic"} = $meta; - } +---++ sub renderFormField ( %params, $topic, $web ) - my $text = ""; - my $found = 0; - if ( $meta ) { - my @fields = $meta->find( "FIELD" ); - foreach my $field ( @fields ) { - my $title = $field->{"title"}; - my $name = $field->{"name"}; - if( $title eq $formField || $name eq $formField ) { - $found = 1; - my $value = $field->{"value"}; - if (length $value) { - $text = $format; - $text =~ s/\$value/$value/go; - } elsif ( defined $default ) { - $text = $default; - } - last; #one hit suffices - } - } - } +Returns the fully rendered expansion of a %FORMFIELD{}% tag. - unless ( $found ) { - $text = $altText; - } +=cut - return "" unless $text; +sub renderFormField +{ + my %params = shift; - return getRenderedVersion( $text, $web ); + my $topic = $params{_theTopic}; + my $web = $params{_theWeb}; + + my $formField = $params{_DEFAULT}; + my $formTopic = $params{ "topic" }; + my $altText = $params{ "alttext" }; + my $default = $params{ "default" }; + my $format = $params{ "format" }; + + unless ( $format ) { + # if null format explicitly set, return empty + # SMELL: it's not clear what this does; the implication + # is that it does something that violates TWiki tag syntax, + # so I've had to comment it out.... + # return "" if ( $args =~ m/format\s*=/o); + # Otherwise default to value + $format = "\$value"; + } + + my $formWeb; + if ( $formTopic ) { + if ($topic =~ /^([^.]+)\.([^.]+)/o) { + ( $formWeb, $topic ) = ( $1, $2 ); + } else { + # SMELL: Undocumented feature, "web" parameter + $formWeb = $params{"web"}; + } + $formWeb = $web unless $formWeb; + } else { + $formWeb = $web; + $formTopic = $topic; + } + + my $meta = $ffCache{"$formWeb.$formTopic"}; + unless ( $meta ) { + my $dummyText; + ( $meta, $dummyText ) = + TWiki::Store::readTopic( $formWeb, $formTopic ); + $ffCache{"$formWeb.$formTopic"} = $meta; + } + + my $text = ""; + my $found = 0; + if ( $meta ) { + my @fields = $meta->find( "FIELD" ); + foreach my $field ( @fields ) { + my $title = $field->{"title"}; + my $name = $field->{"name"}; + if( $title eq $formField || $name eq $formField ) { + $found = 1; + my $value = $field->{"value"}; + if (length $value) { + $text = $format; + $text =~ s/\$value/$value/go; + } elsif ( defined $default ) { + $text = $default; + } + last; #one hit suffices + } + } + } + + unless ( $found ) { + $text = $altText; + } + + return "" unless $text; + + return getRenderedVersion( $text, $web ); } =pod ---++ sub getRenderedVersion ( $text, $theWeb, $meta ) -Not yet documented. +The main rendering function. =cut @@ -900,7 +786,6 @@ # (fails in %INCLUDE%, %SEARCH%) my $theTopic = $TWiki::topicName; - # PTh 22 Jul 2000: added $theWeb for correct handling of %INCLUDE%, %SEARCH% if( !$theWeb ) { $theWeb = $TWiki::webName; } @@ -909,233 +794,557 @@ $result = ""; $insidePRE = 0; $insideTABLE = 0; - $insideNoAutoLink = 0; # PTh 02 Feb 2001: Added Codev.DisableWikiWordLinks - $isList = 0; - @listTypes = (); - @listElements = (); + $insideNoAutoLink = 0; + my @listTypes = (); + my @listElements = (); + # Initial cleanup $text =~ s/\r//g; - $text =~ s/(\n?)$/\n\n/s; # clutch to enforce correct rendering at end of doc + # clutch to enforce correct rendering at end of doc + $text =~ s/(\n?)$/\n\n/s; # Convert any occurrences of token (very unlikely - details in # Codev.NationalCharTokenClash) - $text =~ s/$TranslationToken/!/go; + $text =~ s/$TWiki::TranslationToken/!/go; my @verbatim = (); - $text = TWiki::takeOutVerbatim( $text, \@verbatim ); - $text =~ s/\\\n//g; # Join lines ending in "\" + $text = takeOutBlocks( $text, "verbatim", \@verbatim ); + $text =~ s/\\\n//gs; # Join lines ending in "\" + # do not render HTML head, style sheets and scripts + # SMELL: this is easily defeated by ]/i ) { my $bodyTag = ""; my $bodyText = ""; ( $head, $bodyTag, $bodyText ) = split( /(|i && ( $insidePRE = 1 ); - m|
|i && ( $insidePRE = 0 ); - m||i && ( $insideNoAutoLink = 1 ); - m||i && ( $insideNoAutoLink = 0 ); + if ( m/
/i ) {
+            $insidePRE = 1;
+        }
+        if ( m/<\/pre>/i ) {
+            $insidePRE = 0;
+        }
+        if ( m//i ) {
+            $insideNoAutoLink = 1;
+        }
+        if ( m/<\/noautolink>/i ) {
+            $insideNoAutoLink = 0;
+        }
 
         if( $insidePRE ) {
             # inside 
 
             # close list tags if any
             if( @listTypes ) {
-                $result .= &emitList( "", "", 0 );
+                _emitList( \@listTypes, \@listElements, \@result, "", "", "" );
                 $isList = 0;
             }
 
-# Wiki Plugin Hook
-            &TWiki::Plugins::insidePREHandler( $_ );
+            # Wiki Plugin Hook
+            TWiki::Plugins::insidePREHandler( $_ );
 
-            s/(.*)/$1\n/;
-            s/\t/   /g;		# Three spaces
-            $result .= $_;
+            push( @result, "$_\n" );
 
-        } else {
-          # normal state, do Wiki rendering
+            next;
+        }
 
-# Wiki Plugin Hook
-          &TWiki::Plugins::outsidePREHandler( $_ );
-          $extraLines = undef;   # Plugins might introduce extra lines
-          do {                   # Loop over extra lines added by plugins
-            $_ = $extraLines if( defined $extraLines );
-            s/^(.*?)\n(.*)$/$1/s;
-            $extraLines = $2;    # Save extra lines, need to parse each separately
+        # normal state, do Wiki rendering
 
-# Escape rendering: Change " !AnyWord" to " AnyWord", for final " AnyWord" output
-            s/(^|[\s\(])\!(?=[\w\*\=])/$1/g;
+        # Wiki Plugin Hook
+        TWiki::Plugins::outsidePREHandler( $_ );
+        # insert any extra lines generated by the plugin
+        if ( $_ =~ /\n/ ) {
+            foreach my $xtra ( split( /\n/, $_ )) {
+                unshift( @lines, $xtra );
+            }
+            $_ = pop( @lines);
+        }
 
-# Blockquoted email (indented with '> ')
-            s/^>(.*?)$/>  $1 <\/cite>
/g; + # Escape rendering: Change " !AnyWord" to " AnyWord", + # for final " AnyWord" output + s/(^|[\s\(])\!(?=[\w\*\=])/$1/g; -# Embedded HTML - s/\<(\!\-\-)/$TranslationToken$1/g; # Allow standalone "" - # FIXME: next 2 lines are redundant since s///g's below do same - # thing - s/(\<\<+)/"<\;" x length($1)/ge; - s/(\>\>+)/">\;" x length($1)/ge; - s/\/nopTOKEN/g; # defuse inside HTML tags - s/\<(\S.*?)\>/$TranslationToken$1$TranslationToken/g; - s//>\;/g; - s/$TranslationToken(\S.*?)$TranslationToken/\<$1\>/go; - s/nopTOKEN/\/g; - s/(\-\-)$TranslationToken/$1\>/go; - s/$TranslationToken(\!\-\-)/\<$1/go; + # Blockquoted email (indented with '> ') + s/^>(.*?)$/> $1 <\/cite>
/g; -# Handle embedded URLs - s!(^|[\-\*\s\(])($regex{linkProtocolPattern}\:([^\s\<\>\"]+[^\s\.\,\!\?\;\:\)\<]))!&externalLink($1,$2)!geo; + # locate isolated < and > and translate to entities + s/ + s/-->/--$TWiki::TranslationToken/g; + # escape out matched <> pairs + s/<(\S.*?)>/$TWiki::TranslationToken$1$TWiki::TranslationToken/go; + # entitify lone < and > + s//>\;/g; + s/$TWiki::TranslationToken(\S.*?)$TWiki::TranslationToken/<$1>/go; + s/--$TWiki::TranslationToken/-->/go; + s/$TWiki::TranslationToken!--// ) { - $text = TWiki::Attach::migrateToFileAttachmentMacro( $meta, $text ); - } - - if ( $text =~ // ) { - $text = TWiki::Form::upgradeCategoryTable( $web, $topic, $meta, $text ); - } - - return( $meta, $text ); -} - -=pod - ----++ sub _extractMetaData ( $web, $topic, $fulltext ) - -Expect meta data at top of file, but willing to accept it anywhere. -If we have an old file format without meta data, then convert. - -=cut - +# Expect meta data at top of file, but willing to accept it anywhere. +# If we have an old file format without meta data, then convert. +# +# *WARNING: SIDE-EFFECTING FUNCTION* meta-data is stripped from the $text sub _extractMetaData { - my( $web, $topic, $fulltext ) = @_; - - my $meta = TWiki::Meta->new(); - my $text = $meta->read( $fulltext ); + #my( $web, $topic, $text ) = @_; - - # If there is no meta data then convert + my $meta = TWiki::Meta->new( $_[0], $_[1] ); + $_[2] =~ s/^%META:([^{]+){(.*)}%\r?\n/&_addMetaDatum($meta,$1,$2)/gem; + + # If there is no meta data then convert from old format if( ! $meta->count( "TOPICINFO" ) ) { - ( $meta, $text ) = convert2metaFormat( $web, $topic, $text ); + if ( $_[2] =~ // ) { + $_[2] = TWiki::Attach::migrateToFileAttachmentMacro( $meta, + $_[2] ); + } + + if ( $_[2] =~ // ) { + $_[2] = TWiki::Form::upgradeCategoryTable( $_[0], $_[1], + $meta, $_[2] ); + } } else { my %topicinfo = $meta->findOne( "TOPICINFO" ); if( $topicinfo{"format"} eq "1.0beta" ) { # This format used live at DrKW for a few months - if( $text =~ // ) { - $text = TWiki::Form::upgradeCategoryTable( $web, $topic, $meta, $text ); + if( $_[2] =~ // ) { + $_[2] = TWiki::Form::upgradeCategoryTable( $_[0], + $_[1], + $meta, + $_[2] ); } - TWiki::Attach::upgradeFrom1v0beta( $meta ); - if( $meta->count( "TOPICMOVED" ) ) { my %moved = $meta->findOne( "TOPICMOVED" ); - $moved{"by"} = TWiki::wikiToUserName( $moved{"by"} ); + $moved{"by"} = TWiki::User::wikiToUserName( $moved{"by"} ); $meta->put( "TOPICMOVED", %moved ); } } } - - return( $meta, $text ); -} -=pod - ----++ sub getFileName ( $theWeb, $theTopic, $theAttachment ) - -Not yet documented.
-*FIXME - get rid of this because uses private part of handler* - -=cut - -sub getFileName -{ - my( $theWeb, $theTopic, $theAttachment ) = @_; - - my $topicHandler = _getTopicHandler( $theWeb, $theTopic, $theAttachment ); - return $topicHandler->{file}; + return $meta; } =pod ----++ sub readTopMeta ( $theWeb, $theTopic ) +---++ sub getMinimalMeta ( $theWeb, $theTopic ) -> $meta -Just read the meta data at the top of the topic.
-Generalise for Codev.DataFramework, but needs to be fast because -of use by view script. +Get the minimum amount of meta-data necessary to find the +topic parent. +Generalised for Codev.DataFramework. Needs to be fast because +of use by Render.pm. =cut -sub readTopMeta +sub getMinimalMeta { my( $theWeb, $theTopic ) = @_; - + my $topicHandler = _getTopicHandler( $theWeb, $theTopic ); - my $filename = getFileName( $theWeb, $theTopic ); - + my $filename = $topicHandler->{file}; + my $data = ""; my $line; $/ = "\n"; # read line by line @@ -1249,12 +1031,9 @@ $data .= $line; } } - - my( $meta, $text ) = _extractMetaData( $theWeb, $theTopic, $data ); - close( IN_FILE ); - return $meta; + return _extractMetaData( $theWeb, $theTopic, $data ); } =pod @@ -1274,11 +1053,10 @@ sub readTopic { my( $theWeb, $theTopic, $internal ) = @_; - - my $fullText = readTopicRaw( $theWeb, $theTopic, "", $internal ); - - my ( $meta, $text ) = _extractMetaData( $theWeb, $theTopic, $fullText ); - + + my $text = readTopicRaw( $theWeb, $theTopic, "", $internal ); + my $meta = _extractMetaData( $theWeb, $theTopic, $text ); + die "Internal error |$theWeb|$theTopic|" unless $meta; return( $meta, $text ); } @@ -1286,14 +1064,16 @@ ---++ sub readWebTopic ( $theWeb, $theName ) -Not yet documented. +Reads and returns the raw text of a topic. +SMELL: since the text returned contains META this method breaks the encapsulation of the Store. The only argument for this method is that it skips the extraction of meta-data from topics, which may be fractionally faster. I _believe_ it can be safely implemented to just return the topic text with no META. + =cut sub readWebTopic { my( $theWeb, $theName ) = @_; - my $text = &readFile( "$TWiki::dataDir/$theWeb/$theName.txt" ); + my $text = readFile( "$TWiki::dataDir/$theWeb/$theName.txt" ); return $text; } @@ -1308,6 +1088,8 @@ is not granted, then an error message will be returned in $text, and set in $TWiki::readTopicPermissionFailed. +SMELL: breaks encapsulation of the store, as it assumes meta is stored embedded in the text, and clients use this. Other implementors of store will be forced to insert meta-data to ensure correct operation of View raw=debug and the "repRev" mode of Edit. + =cut sub readTopicRaw @@ -1315,18 +1097,18 @@ my( $theWeb, $theTopic, $theVersion, $internal ) = @_; #SVEN - test if theTopic contains a webName to override $theWeb - ( $theWeb, $theTopic ) = normalizeWebTopicName( $theWeb, $theTopic ); + ( $theWeb, $theTopic ) = TWiki::normalizeWebTopicName( $theWeb, $theTopic ); my $text = ""; if( ! $theVersion ) { - $text = &readFile( "$TWiki::dataDir/$theWeb/$theTopic.txt" ); + $text = readFile( "$TWiki::dataDir/$theWeb/$theTopic.txt" ); } else { $text = _readVersionNoMeta( $theWeb, $theTopic, $theVersion); } my $viewAccessOK = 1; unless( $internal ) { - $viewAccessOK = &TWiki::Access::checkAccessPermission( "view", $TWiki::wikiUserName, $text, $theTopic, $theWeb ); + $viewAccessOK = TWiki::Access::checkAccessPermission( "view", $TWiki::wikiUserName, $text, $theTopic, $theWeb ); # TWiki::writeDebug( "readTopicRaw $viewAccessOK $TWiki::wikiUserName $theWeb $theTopic" ); } @@ -1343,238 +1125,6 @@ =pod ----++ sub readTemplateTopic ( $theTopicName ) - -Not yet documented. - -=cut - -sub readTemplateTopic -{ - my( $theTopicName ) = @_; - - $theTopicName =~ s/$TWiki::securityFilter//go; # zap anything suspicious - - # try to read in current web, if not read from TWiki web - - my $web = $TWiki::twikiWebname; - if( topicExists( $TWiki::webName, $theTopicName ) ) { - $web = $TWiki::webName; - } - return readTopic( $web, $theTopicName ); -} - -=pod - ----++ _readTemplateFile ( $theName, $theSkin ) -Return value: raw template text, or "" if read fails - -WARNING! THIS FUNCTION DEPENDS ON GLOBAL VARIABLES - -PRIVATE Reads a template, constructing a candidate name for the template thus: $name.$skin.tmpl, -and looking for a file of that name first in templates/$web and then if that fails in templates/. -If a template is not found, tries to parse $name into a web name and a topic name, and -read topic $Web.${Skin}Skin${Topic}Template. If $name does not contain a web specifier, -$Web defaults to TWiki::twikiWebname. If no skin is specified, topic is ${Topic}Template. -If the topic exists, checks access permissions and reads the topic -without meta-data. In the event that the read fails (template not found, access permissions fail) -returns the empty string "". skin, web and topic names are forced to an upper-case first character -when composing user topic names. - -=cut - -sub _readTemplateFile -{ - my( $theName, $theSkin, $theWeb ) = @_; - $theSkin = "" unless $theSkin; # prevent 'uninitialized value' warnings - - # CrisBailiff, PeterThoeny 13 Jun 2000: Add security - $theName =~ s/$TWiki::securityFilter//go; # zap anything suspicious - $theName =~ s/\.+/\./g; # Filter out ".." from filename - $theSkin =~ s/$TWiki::securityFilter//go; # zap anything suspicious - $theSkin =~ s/\.+/\./g; # Filter out ".." from filename - - my $tmplFile = ""; - - # search first in twiki/templates/Web dir - # for file script(.skin).tmpl - my $tmplDir = "$TWiki::templateDir/$theWeb"; - if( opendir( DIR, $tmplDir ) ) { - # for performance use readdir, not a row of ( -e file ) - my @filelist = grep /^$theName\..*tmpl$/, readdir DIR; - closedir DIR; - $tmplFile = "$theName.$theSkin.tmpl"; - if( ! grep { /^$tmplFile$/ } @filelist ) { - $tmplFile = "$theName.tmpl"; - if( ! grep { /^$tmplFile$/ } @filelist ) { - $tmplFile = ""; - } - } - if( $tmplFile ) { - $tmplFile = "$tmplDir/$tmplFile"; - } - } - - # if not found, search in twiki/templates dir - $tmplDir = $TWiki::templateDir; - if( ( ! $tmplFile ) && ( opendir( DIR, $tmplDir ) ) ) { - my @filelist = grep /^$theName\..*tmpl$/, readdir DIR; - closedir DIR; - $tmplFile = "$theName.$theSkin.tmpl"; - if( ! grep { /^$tmplFile$/ } @filelist ) { - $tmplFile = "$theName.tmpl"; - if( ! grep { /^$tmplFile$/ } @filelist ) { - $tmplFile = ""; - } - } - if( $tmplFile ) { - $tmplFile = "$tmplDir/$tmplFile"; - } - } - - # See if it is a user topic. Search first in current web - # twiki web. Note that neither web nor topic may be variables when used in a template. - if ( ! $tmplFile ) { - if ( $theSkin ne "" ) { - $theSkin = ucfirst( $theSkin ) . "Skin"; - } - - my $theTopic; - my $theWeb; - - if ( $theName =~ /^(\w+)\.(\w+)$/ ) { - $theWeb = ucfirst( $1 ); - $theTopic = ucfirst( $2 ); - } else { - $theWeb = $TWiki::webName; - $theTopic = $theSkin . ucfirst( $theName ) . "Template"; - if ( !TWiki::Store::topicExists( $theWeb, $theTopic )) { - $theWeb = $TWiki::twikiWebname; - } - } - - if ( TWiki::Store::topicExists( $theWeb, $theTopic ) && - TWiki::Access::checkAccessPermission( "view", - $TWiki::wikiUserName, "", $theTopic, $theWeb )) { - my ( $meta, $text ) = TWiki::Store::readTopic( $theWeb, $theTopic, 1 ); - return $text; - } - } - - # read the template file - if( -e $tmplFile ) { - return &readFile( $tmplFile ); - } - return ""; -} - -=pod - ----++ sub handleTmplP ( $theVar ) -Return value: expanded text of the named template, as found from looking in the global register of template definitions. - -WARNING! THIS FUNCTION DEPENDS ON GLOBAL VARIABLES - -If $theVar is the name of a previously defined template, returns the text of -that template after recursive expansion of any TMPL:P tags it contains. - -=cut - -sub handleTmplP -{ - # Print template variable, called by %TMPL:P{"$theVar"}% - my( $theVar ) = @_; - - my $val = ""; - if( ( %templateVars ) && ( exists $templateVars{ $theVar } ) ) { - $val = $templateVars{ $theVar }; - $val =~ s/%TMPL\:P{[\s\"]*(.*?)[\"\s]*}%/&handleTmplP($1)/geo; # recursion - } - if( ( $theVar eq "sep" ) && ( ! $val ) ) { - # set separator explicitely if not set - $val = " | "; - } - return $val; -} - -=pod - ----++ sub readTemplate ( $theName, $theSkin, $theWeb ) -Return value: expanded template text - -WARNING! THIS IS A SIDE-EFFECTING FUNCTION - -PUBLIC Reads a template, constructing a candidate name for the template as described in -_readTemplateFile. - -If template text is found, extracts include statements and fully expands them. -Also extracts template definitions and adds them to the -global templateVars hash, overwriting any previous definition. - -=cut - -sub readTemplate -{ - my( $theName, $theSkin, $theWeb ) = @_; - - if( ! defined($theSkin) ) { - $theSkin = &TWiki::getSkin(); - } - - if( ! defined( $theWeb ) ) { - $theWeb = $TWiki::webName; - } - - # recursively read template file(s) - my $text = _readTemplateFile( $theName, $theSkin, $theWeb ); - while( $text =~ /%TMPL\:INCLUDE{[\s\"]*(.*?)[\"\s]*}%/s ) { - $text =~ s/%TMPL\:INCLUDE{[\s\"]*(.*?)[\"\s]*}%/&_readTemplateFile( $1, $theSkin, $theWeb )/geo; - } - - if( ! ( $text =~ /%TMPL\:/s ) ) { - # no template processing - $text =~ s|^(( {3})+)|"\t" x (length($1)/3)|geom; # leading spaces to tabs - return $text; - } - - my $result = ""; - my $key = ""; - my $val = ""; - my $delim = ""; - foreach( split( /(%TMPL\:)/, $text ) ) { - if( /^(%TMPL\:)$/ ) { - $delim = $1; - } elsif( ( /^DEF{[\s\"]*(.*?)[\"\s]*}%[\n\r]*(.*)/s ) && ( $1 ) ) { - # handle %TMPL:DEF{"key"}% - if( $key ) { - $templateVars{ $key } = $val; - } - $key = $1; - $val = $2 || ""; - - } elsif( /^END%[\n\r]*(.*)/s ) { - # handle %TMPL:END% - $templateVars{ $key } = $val; - $key = ""; - $val = ""; - $result .= $1 || ""; - - } elsif( $key ) { - $val .= "$delim$_"; - - } else { - $result .= "$delim$_"; - } - } - - # handle %TMPL:P{"..."}% recursively - $result =~ s/%TMPL\:P{[\s\"]*(.*?)[\"\s]*}%/&handleTmplP($1)/geo; - $result =~ s|^(( {3})+)|"\t" x (length($1)/3)|geom; # leading spaces to tabs - return $result; -} - -=pod - ---++ readFile( $filename ) Return value: $fileContents @@ -1583,6 +1133,10 @@ any $filename coming from a user is stripped of special characters that might change Perl's open() semantics. +Used for reading side-files of meta-data, such as fileTypes, changes, etc. + +SMELL: Breaks Store encapsulation, if it is used to read files other than the standard meta-files (e.g. if it is used to read topic files) + =cut sub readFile @@ -1603,8 +1157,10 @@ ---++ sub readFileHead ( $name, $maxLines ) -Not yet documented. +Returns $maxLines of content from the head of the given file-system file. +SMELL: breaks Store encapsulation, if it is used to access topics or attachments under the control of Store. + =cut sub readFileHead @@ -1623,9 +1179,6 @@ return $data; } - -#AS 5 Dec 2000 collect all Web's topic names - =pod ---+++ getTopicNames( $web ) ==> @topics @@ -1651,24 +1204,24 @@ closedir( DIR ); return @topicList ; } -#/AS - -#AS 5 Dec 2000 collect immediate subWeb names - =pod ---++ sub getSubWebs ( $web ) -Not yet documented. +gets a list of sub-webs contained in the given named web. If the +web is null, it gets a list of all top-level webs. $web may +be a pathname at any level of the hierarchy; for example, it may be +Dadweb/Kidweb/Petweb. Includes hidden webs (those starting with +non-alphanumeric characters). =cut sub getSubWebs { my( $web ) = @_ ; - + if( !defined $web ) { - $web=""; + $web=""; } #FIXME untaint web name? @@ -1680,52 +1233,53 @@ # this is not magic, it just looks like it. my @webList = sort - grep { s#^.+/([^/]+)$#$1# } - grep { -d } - map { "$TWiki::dataDir/$web/$_" } - grep { ! /^\.\.?$/ } @tmpList; + grep { !/^\.\.?$/ && -d "$TWiki::dataDir/$web/$_" } + @tmpList; return @webList ; } -#/AS # ========================= -#AS 26 Dec 2000 recursively collects all Web names -#FIXME: move var to TWiki.cfg ? -use vars qw ($subWebsAllowedP); +# CC: removed - useless. +#use vars qw ($subWebsAllowedP); -$subWebsAllowedP = 0; # 1 = subwebs allowed, 0 = flat webs +#$subWebsAllowedP = 0; # 1 = subwebs allowed, 0 = flat webs =pod ----++ sub getAllWebs ( $web ) +---++ sub getAllWebs() -> list of web names -Not yet documented. +Gets a list of webnames, of webs contained within the given +web. Potentially able to expand recursively, but this is +commented out as support is lacking for subwebs almost everywhere +else. =cut sub getAllWebs { # returns a list of subweb names my( $web ) = @_ ; - + if( !defined $web ) { - $web=""; + $web=""; } - my @webList = map { s/^\///o; $_ } - map { "$web/$_" } - &getSubWebs( $web ); - my $subWeb = ""; - if( $subWebsAllowedP ) { - my @subWebs = @webList; - foreach $subWeb ( @webList ) { - push @subWebs, &getAllWebs( $subWeb ); - } - return @subWebs; - } + + my @webList = + map { s/^\///o; $_ } # remove leading / + map { "$web/$_" } + &getSubWebs( $web ); + +#cc my $subWeb = ""; +#cc if( $subWebsAllowedP ) { +#cc my @subWebs = @webList; +#cc foreach $subWeb ( @webList ) { +#cc push @subWebs, &getAllWebs( $subWeb ); +#cc } +#cc return @subWebs; +#cc } return @webList ; } -#/AS =pod @@ -1751,10 +1305,114 @@ return $topicHandler->setTopicRevisionTag( $web, $topic, $rev, $tag ); } +# Write a meta-data key=value pair +sub _writeKeyValue { + my( $key, $value ) = @_; + $value =~ s/\r\r\n/%_N_%/go; + $value =~ s/\r\n/%_N_%/go; + $value =~ s/\n\r/%_N_%/go; + $value =~ s/\r\n/%_N_%/go; # Deal with doubles or \n\r + $value =~ s/\r/\n/go; + $value =~ s/\n/%_N_%/go; + $value =~ s/"/%_Q_%/go; + return "$key=\"$value\""; +} + +# Write all the key=value pairs for the types listed +sub _writeTypes { + my( $meta, @types ) = @_; + + my $text = ""; + + if( $types[0] eq "not" ) { + # write all types that are not in the list + my %seen; + @seen{ @types } = (); + @types = (); # empty "not in list" + foreach my $key ( keys %$meta ) { + push( @types, $key ) unless + (exists $seen{ $key } || $key =~ /^_/); + } + } + + foreach my $type ( @types ) { + my $data = $meta->{$type}; + foreach my $item ( @$data ) { + my $sep = ""; + $text .= "%META:$type\{"; + my $name = $item->{"name"}; + if( $name ) { + # If there's a name field, put first to make regexp based searching easier + $text .= _writeKeyValue( "name", $item->{"name"} ); + $sep = " "; + } + foreach my $key ( sort keys %$item ) { + if( $key ne "name" ) { + $text .= $sep; + $text .= _writeKeyValue( $key, $item->{$key} ); + $sep = " "; + } + } + $text .= "\}%\n"; + } + } + + return $text; +} + +# Meta data for start of topic +sub _writeStart +{ + my( $meta ) = @_; + + return _writeTypes( $meta, qw/TOPICINFO TOPICPARENT/ ); +} + +# Meta data for end of topic +sub _writeEnd +{ + my( $meta ) = @_; + + my $text = _writeTypes($meta, qw/FORM FIELD FILEATTACHMENT TOPICMOVED/ ); + # append remaining meta data + $text .= _writeTypes( $meta, qw/not TOPICINFO TOPICPARENT FORM FIELD FILEATTACHMENT TOPICMOVED/ ); + return $text; +} + +# =========================== +# Prepend/append meta data to topic +sub _writeMeta +{ + my( $meta, $text ) = @_; + + my $start = _writeStart( $meta ); + my $end = _writeEnd( $meta ); + $text = $start . "$text"; + $text =~ s/([^\n\r])$/$1\n/; # new line is required at end + $text .= $end; + + return $text; +} + +=pod + +---++ sub getDebugText($meta, $text) -> $text +Generate a debug text form of the text/meta, for use in debug displays, +by annotating the text with meta informtion. + +=cut + +sub getDebugText { + my ( $meta, $text ) = @_; + + return _writeMeta( $meta, $text ); +} + # ========================= 1; # EOF + Index: lib/TWiki/Access.pm =================================================================== --- lib/TWiki/Access.pm (revision 1767) +++ lib/TWiki/Access.pm (working copy) @@ -35,44 +35,39 @@ use strict; -use vars qw( - %allGroups @processedGroups -); +# hash (indexed on group name) of hashes (indexed on users) +use vars qw( %allGroups ); -# ========================= =pod ---++ initializeAccess() -| Description: | Basic module initialization, called from TWiki::initialize | +Basic module initialization, called from TWiki::initialize =cut sub initializeAccess { %allGroups = (); - @processedGroups = (); } -# ========================= -# Are there any security restrictions for this Web -# (ignoring settings on individual pages). =pod ---++ sub permissionsSet ( $web ) -Not yet documented. +Are there any security restrictions for this Web +(ignoring settings on individual pages). =cut sub permissionsSet { my( $web ) = @_; - + my $permSet = 0; - + my @types = qw/ALLOW DENY/; my @actions = qw/CHANGE VIEW RENAME/; - + OUT: foreach my $type ( @types ) { foreach my $action ( @actions ) { my $pref = $type . "WEB" . $action; @@ -83,11 +78,10 @@ } } } - + return $permSet; } -# ========================= =pod ---++ checkAccessPermission( $action, $user, $text, $topic, $web ) ==> $ok @@ -106,14 +100,12 @@ my( $theAccessType, $theUserName, $theTopicText, $theTopicName, $theWebName ) = @_; -#AS 2001-11-04 see Codev.UnchangeableTopicBug if ( $TWiki::doSuperAdminGroup && - $TWiki::superAdminGroup ) { - if ( &userIsInGroup( $theUserName, $TWiki::superAdminGroup ) ) { - return 1; - } + $TWiki::superAdminGroup ) { + if ( userIsInGroup( $theUserName, $TWiki::superAdminGroup )) { + return 1; + } } -#/AS $theAccessType = uc( $theAccessType ); # upper case if( ! $theWebName ) { @@ -121,67 +113,46 @@ } if( ! $theTopicText ) { # text not supplied as parameter, so read topic - $theTopicText = &TWiki::Store::readWebTopic( $theWebName, $theTopicName ); + $theTopicText = TWiki::Store::readWebTopic( $theWebName, $theTopicName ); } - ##&TWiki::writeDebug( "checkAccessPermission: Type $theAccessType, user $theUserName, topic $theTopicName" ); # parse the " * Set (ALLOWTOPIC|DENYTOPIC)$theAccessType = " in body text - my @denyList = (); - my @allowList = (); + my %deny; + my %allow; foreach( split( /\n/, $theTopicText ) ) { if( /^\s+\*\sSet\s(ALLOWTOPIC|DENYTOPIC)$theAccessType\s*\=\s*(.*)/ ) { if( $2 ) { my $allowOrDeny = $1; # "ALLOWTOPIC" or "DENYTOPIC" - my @tmpList = map { getUsersOfGroup( $_ ) } - prvGetUserList( $2 ); - ##my $tmp = join( ', ', @tmpList ); - ##&TWiki::writeDebug( " Topic $allowOrDeny$theAccessType: {$tmp}" ); + my %tmp = _parseUserList( $2, 1 ); if( $allowOrDeny eq "DENYTOPIC" ) { - @denyList = @tmpList; + %deny = %tmp; } else { - @allowList = @tmpList; + %allow = %tmp; } } } } - + # if empty, get access permissions from preferences - if( ! @denyList ) { - my $tmpVal = &TWiki::Prefs::getPreferencesValue( "DENYWEB$theAccessType", $theWebName ); - @denyList = map { getUsersOfGroup( $_ ) } - prvGetUserList( $tmpVal ); - ##my $tmp = join( ', ', @denyList ); - ##&TWiki::writeDebug( " Prefs DENYWEB$theAccessType: {$tmp}" ); + unless( %deny ) { + my $tmpVal = + TWiki::Prefs::getPreferencesValue( "DENYWEB$theAccessType", + $theWebName ); + %deny = _parseUserList( $tmpVal, 1 ); } - if( ! @allowList ) { - my $tmpVal = &TWiki::Prefs::getPreferencesValue( "ALLOWWEB$theAccessType", $theWebName ); - @allowList = map { getUsersOfGroup( $_ ) } - prvGetUserList( $tmpVal ); - ##my $tmp = join( ', ', @allowList ); - ##&TWiki::writeDebug( " Prefs ALLOWWEB$theAccessType: {$tmp}" ); - } - # access permission logic - if( @denyList ) { - if( grep { /^$theUserName$/ } @denyList ) { - # user is on deny list - ##&TWiki::writeDebug( " return 0, user is on deny list" ); - return 0; - } + unless( %allow ) { + my $tmpVal = + TWiki::Prefs::getPreferencesValue( "ALLOWWEB$theAccessType", + $theWebName ); + %allow = _parseUserList( $tmpVal, 1 ); } - if( @allowList ) { - if( grep { /^$theUserName$/ } @allowList ) { - # user is on allow list - ##&TWiki::writeDebug( " return 1, user is on allow list" ); - return 1; - } else { - # user is not on allow list - ##&TWiki::writeDebug( " return 0, user is not on allow list" ); - return 0; - } - } + + return 0 if( %deny && $deny{$theUserName} ); + + return $allow{$theUserName} if ( %allow ); + # allow is undefined, so grant access - ##&TWiki::writeDebug( " return 1, allow is undefined" ); return 1; } @@ -196,19 +167,22 @@ sub getListOfGroups { - my $text = &TWiki::Search::searchWeb( - "inline" => "1", - "search" => "Set GROUP =", - "web" => "all", - "topic" => "*Group", - "type" => "regex", - "nosummary" => "on", - "nosearch" => "on", - "noheader" => "on", - "nototal" => "on", - "noempty" => "on", - "format" => "\$web.\$topic", - ); + my $text = + TWiki::Search::searchWeb + ( + #_callback => undef, + inline => 1, + "search" => "Set GROUP =", + "web" => "all", + "topic" => "*Group", + "type" => "regex", + "nosummary" => "on", + "nosearch" => "on", + "noheader" => "on", + "nototal" => "on", + "noempty" => "on", + "format" => "\$web.\$topic", + ); my ( @list ) = split ( /\n/, $text ); return @list; @@ -228,12 +202,11 @@ { my( $theUserName ) = @_; - my $userTopic = prvGetWebTopicName( $TWiki::mainWebname, $theUserName ); + my $userTopic = _getWebTopicName( $TWiki::mainWebname, $theUserName ); my @grpMembers = (); my @listOfGroups = getListOfGroups(); my $group; - &TWiki::writeDebug("Checking [$userTopic]"); foreach $group ( @listOfGroups) { if ( userIsInGroup ( $userTopic, $group )) { push ( @grpMembers, $group ); @@ -247,12 +220,11 @@ =pod ---++ userIsInGroup( $user, $group ) ==> $ok -| Description: | Check if user is a member of a group | +Check if user is a member of a group. If a topic which is +not a group is specified, checks if it is the users topic. | Parameter: =$user= | Remote WikiName, e.g. "Main.PeterThoeny" | | Parameter: =$group= | Group name, e.g. "Main.EngineeringGroup" | | Return: =$ok= | 1 user is in group, 0 if not | -| TODO: | what are we checking if we are not specifying a Group? | -| | more detailed documentation@! | =cut @@ -260,54 +232,37 @@ { my( $theUserName, $theGroupTopicName ) = @_; - my $usrTopic = prvGetWebTopicName( $TWiki::mainWebname, $theUserName ); - my $grpTopic = prvGetWebTopicName( $TWiki::mainWebname, $theGroupTopicName ); + my $usrTopic = _getWebTopicName( $TWiki::mainWebname, $theUserName ); + my $grpTopic = _getWebTopicName( $TWiki::mainWebname, $theGroupTopicName ); my @grpMembers = (); if( $grpTopic !~ /.*Group$/ ) { # not a group, so compare user to user - push( @grpMembers, $grpTopic ); - } elsif( ( %allGroups ) && ( exists $allGroups{ $grpTopic } ) ) { - # group is allready known - @grpMembers = @{ $allGroups{ $grpTopic } }; - } else { - @grpMembers = prvGetUsersOfGroup( $grpTopic, 1 ); + return ( $grpTopic eq $usrTopic ); } + unless ( exists $allGroups{$grpTopic} ) { + getUsersOfGroup( $grpTopic ); + } - my $isInGroup = grep { /^$usrTopic$/ } @grpMembers; - return $isInGroup; + return 0 unless exists( $allGroups{$grpTopic} ); + + return $allGroups{$grpTopic}{$usrTopic}; } -# ========================= =pod ---++ getUsersOfGroup( $group ) ==> @users -| Description: | Get all members of a group; groups are expanded recursively | -| Parameter: =$group= | Group topic name, e.g. "Main.EngineeringGroup" | -| Return: =@users= | List of users, e.g. ( "Main.JohnSmith", "Main.JaneMiller" ) | +Get all members of a group; groups are expanded recursively +Return list of users, e.g. ( "Main.JohnSmith", "Main.JaneMiller" ) +| =$group= | Group topic name, e.g. "Main.EngineeringGroup" | +| =$processedGroups= | Internal use only; pass undef | =cut sub getUsersOfGroup { - my( $theGroupTopicName ) = @_; - ##TWiki::writeDebug( "group is $theGroupTopicName" ); - return prvGetUsersOfGroup( $theGroupTopicName, 1 ); -} + my( $theGroupTopicName, $processedGroups ) = @_; -# ========================= -=pod - ----++ sub prvGetUsersOfGroup ( $theGroupTopicName, $theFirstCall ) - -Not yet documented. - -=cut - -sub prvGetUsersOfGroup -{ - my( $theGroupTopicName, $theFirstCall ) = @_; - my @resultList = (); # extract web and topic name my $topic = $theGroupTopicName; @@ -317,7 +272,6 @@ $web = $1; $topic = $2; } - ##TWiki::writeDebug( "Web is $web, topic is $topic" ); if( $topic !~ /.*Group$/ ) { # return user, is not a group @@ -325,66 +279,56 @@ } # check if group topic is already processed - if( $theFirstCall ) { - # FIXME: Get rid of this global variable - @processedGroups = (); - } elsif( grep { /^$web\.$topic$/ } @processedGroups ) { - # do nothing, already processed + if( !defined( $processedGroups )) { + $processedGroups = {}; + } elsif( $processedGroups->{"$web.$topic"} ) { return (); } - push( @processedGroups, "$web\.$topic" ); + $processedGroups->{"$web.$topic"} = 1; # read topic - my $text = &TWiki::Store::readWebTopic( $web, $topic ); + my $text = TWiki::Store::readWebTopic( $web, $topic ); + # SMELL: what the blazes is this? Comment it out, and + # see what breaks.... DFP rules. # reset variables, defensive coding needed for recursion - (my $baz = "foo") =~ s/foo//; + #(my $baz = "foo") =~ s/foo//; # extract users my $user = ""; - my @glist = (); + my %glist; foreach( split( /\n/, $text ) ) { - if( /^\s+\*\sSet\sGROUP\s*\=\s*(.*)/ ) { - if( $1 ) { - @glist = prvGetUserList( $1 ); - } + if( /^\s+\*\sSet\sGROUP\s*\=\s*(.+)$/ ) { + # Note: if there are multiple GROUP assignments in the + # topic, the last will be taken. + %glist = _parseUserList( $1, 0 ); } } - foreach( @glist ) { + foreach ( keys %glist ) { if( /.*Group$/ ) { # $user is actually a group my $group = $_; if( ( %allGroups ) && ( exists $allGroups{ $group } ) ) { - # allready known, so add to list - push( @resultList, @{ $allGroups{ $group } } ); + # already known, so add to list + push( @resultList, keys %{$allGroups{$group}} ); } else { # call recursively - my @userList = prvGetUsersOfGroup( $group, 0 ); - # add group to allGroups hash - $allGroups{ $group } = [ @userList ]; - push( @resultList, @userList ); + push( @resultList, + map { $allGroups{$group}{$_} = 1; } + getUsersOfGroup( $group, $processedGroups )); } } else { # add user to list push( @resultList, $_ ); } } - ##TWiki::writeDebug( "Returning group member list of @resultList" ); return @resultList; } -# ========================= -=pod - ----++ sub prvGetWebTopicName ( $theWebName, $theTopicName ) - -Not yet documented. - -=cut - -sub prvGetWebTopicName +sub _getWebTopicName { my( $theWebName, $theTopicName ) = @_; + # SMELL: this is a hack, isn't it? What should really be going on here? $theTopicName =~ s/%MAINWEB%/$theWebName/go; $theTopicName =~ s/%TWIKIWEB%/$theWebName/go; if( $theTopicName =~ /[\.]/ ) { @@ -395,26 +339,27 @@ return $theTopicName; } -# ========================= -=pod - ----++ sub prvGetUserList ( $theItems ) - -Not yet documented. - -=cut - -sub prvGetUserList +# Get a hash indexed by the users in a list. If expand is +# true, recursively expand groups defined in the list to create +# a flat has of users. +sub _parseUserList { - my( $theItems ) = @_; + my( $theItems, $expand ) = @_; # comma delimited list of users or groups # i.e.: "%MAINWEB%.UserA, UserB, Main.UserC # something else" $theItems =~ s/(<[^>]*>)//go; # Remove HTML tags # TODO: i18n fix for user name $theItems =~ s/\s*([a-zA-Z0-9_\.\,\s\%]*)\s*(.*)/$1/go; # Limit list - my @list = map { prvGetWebTopicName( $TWiki::mainWebname, $_ ) } - split( /[\,\s]+/, $theItems ); - return @list; + my %list; + foreach( split( /[\,\s]+/, $theItems )) { + my $e = _getWebTopicName( $TWiki::mainWebname, $_ ); + if ( $expand ) { + map { $list{$_} = 1; } getUsersOfGroup( $e ); + } else { + $list{$e} = 1; + } + } + return %list; } # ========================= Index: lib/TWiki/UI/Upload.pm =================================================================== --- lib/TWiki/UI/Upload.pm (revision 1767) +++ lib/TWiki/UI/Upload.pm (working copy) @@ -38,7 +38,7 @@ my ( $webName, $topic, $userName, $query ) = @_; my $fileName = $query->param( 'filename' ) || ""; - my $skin = $query->param( "skin" ); + my $skin = TWiki::getSkin(); return unless TWiki::UI::webExists( $webName, $topic ); @@ -52,7 +52,7 @@ return if TWiki::UI::isMirror( $webName, $topic ); - my $wikiUserName = &TWiki::userToWikiName( $userName ); + my $wikiUserName = &TWiki::User::userToWikiName( $userName ); return unless TWiki::UI::isAccessPermitted( $webName, $topic, "change", $wikiUserName ); @@ -60,303 +60,52 @@ ( $meta, $text ) = &TWiki::Store::readTopic( $webName, $topic ); my %args = $meta->findOne( "FILEATTACHMENT", $fileName ); - %args = ( "attr" => "", "path" => "", "comment" => "" ) if( ! % args ); + %args = ( + name => $fileName, + attr => "", + path => "", + comment => "" + ) if( ! % args ); - if ( $args{"attr"} =~ /h/o ) { - $isHideChecked = "checked"; + if ( $args{attr} =~ /h/o ) { + $isHideChecked = "checked"; } - # why log attach before post is called? + # SMELL: why log attach before post is called? # FIXME: Move down, log only if successful (or with error msg?) # Attach is a read function, only has potential for a change if( $TWiki::doLogTopicAttach ) { - # write log entry - &TWiki::Store::writeLog( "attach", "$webName.$topic", $fileName ); + # write log entry + TWiki::writeLog( "attach", "$webName.$topic", $fileName ); } - + my $fileWikiUser = ""; - $skin = TWiki::Prefs::getPreferencesValue( "SKIN" ) unless ( $skin ); if( $fileName && %args ) { - $tmpl = TWiki::Store::readTemplate( "attachagain", $skin ); - $fileWikiUser = &TWiki::userToWikiName( $args{"user"} ); + $tmpl = TWiki::Templates::readTemplate( "attachagain", $skin ); + $fileWikiUser = &TWiki::User::userToWikiName( $args{"user"} ); } else { - $tmpl = TWiki::Store::readTemplate( "attachnew", $skin ); + $tmpl = TWiki::Templates::readTemplate( "attachnew", $skin ); } if ( $fileName ) { # must come after templates have been read - $atext .= TWiki::Attach::formatVersions( $webName, $topic, $fileName, %args ); + $atext .= TWiki::Attach::formatVersions( $webName, $topic, %args ); } $tmpl =~ s/%ATTACHTABLE%/$atext/go; $tmpl =~ s/%FILEUSER%/$fileWikiUser/go; $tmpl = &TWiki::handleCommonTags( $tmpl, $topic ); + # SMELL: The following two calls are done in the reverse order in all + # the other handlers. Why are they done in this order here? $tmpl = &TWiki::Render::getRenderedVersion( $tmpl ); - $tmpl = &TWiki::handleMetaTags( $webName, $topic, $tmpl, $meta ); + $tmpl = TWiki::Render::renderMetaTags( $webName, $topic, $tmpl, $meta, 0 ); $tmpl =~ s/%HIDEFILE%/$isHideChecked/go; $tmpl =~ s/%FILENAME%/$fileName/go; $tmpl =~ s/%FILEPATH%/$args{"path"}/go; $tmpl =~ s/%FILECOMMENT%/$args{"comment"}/go; $tmpl =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - TWiki::writeHeader( TWiki::getCgiQuery() ); + TWiki::writeHeader( TWiki::getCgiQuery(), length( $tmpl )); print $tmpl; } -# ========================= -# code fragment to extract pixel size from images -# taken from http://www.tardis.ed.ac.uk/~ark/wwwis/ -# subroutines: _imgsize, _gifsize, _OLDgifsize, _gif_blockskip, -# _NEWgifsize, _jpegsize -# -# looking at the filename really sucks I should be using the first 4 bytes -# of the image. If I ever do it these are the numbers.... (from chris@w3.org) -# PNG 89 50 4e 47 -# GIF 47 49 46 38 -# JPG ff d8 ff e0 -# XBM 23 64 65 66 - - -# ========================= -sub _imgsize { - my( $file ) = shift @_; - my( $x, $y) = ( 0, 0 ); - - if( defined( $file ) && open( STRM, "<$file" ) ) { - binmode( STRM ); # for crappy MS OSes - Win/Dos/NT use is NOT SUPPORTED - if( $file =~ /\.jpg$/i || $file =~ /\.jpeg$/i ) { - ( $x, $y ) = &_jpegsize( \*STRM ); - } elsif( $file =~ /\.gif$/i ) { - ( $x, $y ) = &_gifsize(\*STRM); - } elsif( $file =~ /\.png$/i ) { - ( $x, $y ) = &_pngsize(\*STRM); - } - close( STRM ); - } - return( $x, $y ); -} - - -# ========================= -sub _gifsize -{ - my( $GIF ) = @_; - if( 0 ) { - return &_NEWgifsize( $GIF ); - } else { - return &_OLDgifsize( $GIF ); - } -} - - -# ========================= -sub _OLDgifsize { - my( $GIF ) = @_; - my( $type, $a, $b, $c, $d, $s ) = ( 0, 0, 0, 0, 0, 0 ); - - if( defined( $GIF ) && - read( $GIF, $type, 6 ) && - $type =~ /GIF8[7,9]a/ && - read( $GIF, $s, 4 ) == 4 ) { - ( $a, $b, $c, $d ) = unpack( "C"x4, $s ); - return( $b<<8|$a, $d<<8|$c ); - } - return( 0, 0 ); -} - - -# ========================= -# part of _NEWgifsize -sub _gif_blockskip { - my ( $GIF, $skip, $type ) = @_; - my ( $s ) = 0; - my ( $dummy ) = ''; - - read( $GIF, $dummy, $skip ); # Skip header (if any) - while( 1 ) { - if( eof( $GIF ) ) { - #warn "Invalid/Corrupted GIF (at EOF in GIF $type)\n"; - return ""; - } - read( $GIF, $s, 1 ); # Block size - last if ord( $s ) == 0; # Block terminator - read( $GIF, $dummy, ord( $s ) ); # Skip data - } -} - - -# ========================= -# this code by "Daniel V. Klein" -sub _NEWgifsize { - my( $GIF ) = @_; - my( $cmapsize, $a, $b, $c, $d, $e ) = 0; - my( $type, $s ) = ( 0, 0 ); - my( $x, $y ) = ( 0, 0 ); - my( $dummy ) = ''; - - return( $x,$y ) if( !defined $GIF ); - - read( $GIF, $type, 6 ); - if( $type !~ /GIF8[7,9]a/ || read( $GIF, $s, 7 ) != 7 ) { - #warn "Invalid/Corrupted GIF (bad header)\n"; - return( $x, $y ); - } - ( $e ) = unpack( "x4 C", $s ); - if( $e & 0x80 ) { - $cmapsize = 3 * 2**(($e & 0x07) + 1); - if( !read( $GIF, $dummy, $cmapsize ) ) { - #warn "Invalid/Corrupted GIF (global color map too small?)\n"; - return( $x, $y ); - } - } - FINDIMAGE: - while( 1 ) { - if( eof( $GIF ) ) { - #warn "Invalid/Corrupted GIF (at EOF w/o Image Descriptors)\n"; - return( $x, $y ); - } - read( $GIF, $s, 1 ); - ( $e ) = unpack( "C", $s ); - if( $e == 0x2c ) { # Image Descriptor (GIF87a, GIF89a 20.c.i) - if( read( $GIF, $s, 8 ) != 8 ) { - #warn "Invalid/Corrupted GIF (missing image header?)\n"; - return( $x, $y ); - } - ( $a, $b, $c, $d ) = unpack( "x4 C4", $s ); - $x = $b<<8|$a; - $y = $d<<8|$c; - return( $x, $y ); - } - if( $type eq "GIF89a" ) { - if( $e == 0x21 ) { # Extension Introducer (GIF89a 23.c.i) - read( $GIF, $s, 1 ); - ( $e ) = unpack( "C", $s ); - if( $e == 0xF9 ) { # Graphic Control Extension (GIF89a 23.c.ii) - read( $GIF, $dummy, 6 ); # Skip it - next FINDIMAGE; # Look again for Image Descriptor - } elsif( $e == 0xFE ) { # Comment Extension (GIF89a 24.c.ii) - &_gif_blockskip( $GIF, 0, "Comment" ); - next FINDIMAGE; # Look again for Image Descriptor - } elsif( $e == 0x01 ) { # Plain Text Label (GIF89a 25.c.ii) - &_gif_blockskip( $GIF, 12, "text data" ); - next FINDIMAGE; # Look again for Image Descriptor - } elsif( $e == 0xFF ) { # Application Extension Label (GIF89a 26.c.ii) - &_gif_blockskip( $GIF, 11, "application data" ); - next FINDIMAGE; # Look again for Image Descriptor - } else { - #printf STDERR "Invalid/Corrupted GIF (Unknown extension %#x)\n", $e; - return( $x, $y ); - } - } else { - #printf STDERR "Invalid/Corrupted GIF (Unknown code %#x)\n", $e; - return( $x, $y ); - } - } else { - #warn "Invalid/Corrupted GIF (missing GIF87a Image Descriptor)\n"; - return( $x, $y ); - } - } -} - -# ========================= -# _jpegsize : gets the width and height (in pixels) of a jpeg file -# Andrew Tong, werdna@ugcs.caltech.edu February 14, 1995 -# modified slightly by alex@ed.ac.uk -sub _jpegsize { - my( $JPEG ) = @_; - my( $done ) = 0; - my( $c1, $c2, $ch, $s, $length, $dummy ) = ( 0, 0, 0, 0, 0, 0 ); - my( $a, $b, $c, $d ); - - if( defined( $JPEG ) && - read( $JPEG, $c1, 1 ) && - read( $JPEG, $c2, 1 ) && - ord( $c1 ) == 0xFF && - ord( $c2 ) == 0xD8 ) { - while ( ord( $ch ) != 0xDA && !$done ) { - # Find next marker (JPEG markers begin with 0xFF) - # This can hang the program!! - while( ord( $ch ) != 0xFF ) { - return( 0, 0 ) unless read( $JPEG, $ch, 1 ); - } - # JPEG markers can be padded with unlimited 0xFF's - while( ord( $ch ) == 0xFF ) { - return( 0, 0 ) unless read( $JPEG, $ch, 1 ); - } - # Now, $ch contains the value of the marker. - if( ( ord( $ch ) >= 0xC0 ) && ( ord( $ch ) <= 0xC3 ) ) { - return( 0, 0 ) unless read( $JPEG, $dummy, 3 ); - return( 0, 0 ) unless read( $JPEG, $s, 4 ); - ( $a, $b, $c, $d ) = unpack( "C"x4, $s ); - return( $c<<8|$d, $a<<8|$b ); - } else { - # We **MUST** skip variables, since FF's within variable names are - # NOT valid JPEG markers - return( 0, 0 ) unless read( $JPEG, $s, 2 ); - ( $c1, $c2 ) = unpack( "C"x2, $s ); - $length = $c1<<8|$c2; - last if( !defined( $length ) || $length < 2 ); - read( $JPEG, $dummy, $length-2 ); - } - } - } - return( 0, 0 ); -} - -# ========================= -# _pngsize : gets the width & height (in pixels) of a png file -# cor this program is on the cutting edge of technology! (pity it's blunt!) -# GRR 970619: fixed bytesex assumption -# source: http://www.la-grange.net/2000/05/04-png.html -sub _pngsize { - my ($PNG) = @_; - my ($head) = ""; - my($a, $b, $c, $d, $e, $f, $g, $h)=0; - if(defined($PNG) && - read( $PNG, $head, 8 ) == 8 && - $head eq "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a" && - read($PNG, $head, 4) == 4 && - read($PNG, $head, 4) == 4 && - $head eq "IHDR" && - read($PNG, $head, 8) == 8 ){ - ($a,$b,$c,$d,$e,$f,$g,$h)=unpack("C"x8,$head); - return ($a<<24|$b<<16|$c<<8|$d, $e<<24|$f<<16|$g<<8|$h); - } - return (0,0); -} - -# ========================= -sub _addLinkToEndOfTopic -{ - my ( $text, $pathFilename, $fileName, $fileComment ) = @_; - my $fileLink = ""; - my $imgSize = ""; - - if( $fileName =~ /\.(gif|jpg|jpeg|png)$/i ) { - # inline image - $fileComment = $fileName if( ! $fileComment ); - my( $nx, $ny ) = &_imgsize( $pathFilename ); - if( ( $nx > 0 ) && ( $ny > 0 ) ) { - $imgSize = " width=\"$nx\" height=\"$ny\" "; - } - $fileLink = &TWiki::Prefs::getPreferencesValue( "ATTACHEDIMAGEFORMAT" ) - || ' * $comment:
' - . ' $name'; - } else { - # normal attached file - $fileLink = &TWiki::Prefs::getPreferencesValue( "ATTACHEDFILELINKFORMAT" ) - || ' * [[%ATTACHURL%/$name][$name]]: $comment'; - } - - $fileLink =~ s/^ /\t\t/go; - $fileLink =~ s/^ /\t/go; - $fileLink =~ s/\$name/$fileName/g; - $fileLink =~ s/\$comment/$fileComment/g; - $fileLink =~ s/\$size/$imgSize/g; - $fileLink =~ s/\\t/\t/go; - $fileLink =~ s/\\n/\n/go; - $fileLink =~ s/([^\n])$/$1\n/; - - return "$text$fileLink"; -} - =pod ---++ upload( $web, $topic, $userName, $query) @@ -448,7 +197,7 @@ $filePath, $localFile, $attName, $hideFile, $comment ) = @_; - my $wikiUserName = TWiki::userToWikiName( $userName ); + my $wikiUserName = TWiki::User::userToWikiName( $userName ); return ( 0 ) unless TWiki::UI::webExists( $webName, $topic ); return ( 0 ) if TWiki::UI::isMirror( $webName, $topic ); return ( 0 ) unless TWiki::UI::isAccessPermitted( $webName, $topic, @@ -516,7 +265,7 @@ if( $TWiki::doLogTopicUpload ) { # write log entry - TWiki::Store::writeLog( "upload", "$webName.$topic", $attName ); + TWiki::writeLog( "upload", "$webName.$topic", $attName ); #FIXE also do log for change property? } } @@ -535,8 +284,8 @@ } if( $createLink ) { - $filePath = TWiki::Store::getFileName( $webName, $topic, $attName ); - $text = _addLinkToEndOfTopic( $text, $filePath, $attName, $comment ); + $text .= TWiki::Attach::getAttachmentLink( $webName, $topic, + $attName, $meta ); } # update topic Index: lib/TWiki/UI/Search.pm =================================================================== --- lib/TWiki/UI/Search.pm (revision 1767) +++ lib/TWiki/UI/Search.pm (working copy) @@ -26,6 +26,7 @@ use strict; use TWiki; use TWiki::UI; +use TWiki::Templates; =pod @@ -83,7 +84,7 @@ # correct string, but so what? The pipline is the second # parameter to the join, and consists of the last two lines. The # join takes the results of the pipeline and strings them back - # together, space delimited, which is exactly what &searchWikiWeb + # together, space delimited, which is exactly what &searchWeb # needs. # Note that mod_perl/cgi appears to use ';' as separator, whereas plain cgi uses '&' @@ -95,9 +96,11 @@ $attrWeb =~ tr/+/ /; # pluses become spaces $attrWeb =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; # %20 becomes space - &TWiki::writeHeader( $query ); - &TWiki::Search::searchWeb( - "inline" => "0", + TWiki::writeHeader( $query, 0); + + TWiki::Search::searchWeb( + _callback => \&_contentCallback, + inline => 0, "search" => scalar $query->param( "search" ), "web" => $attrWeb, "topic" => scalar $query->param( "topic" ), @@ -127,5 +130,9 @@ ); } +sub _contentCallback { + print @_; +} + 1; Index: lib/TWiki/UI/Edit.pm =================================================================== --- lib/TWiki/UI/Edit.pm (revision 1767) +++ lib/TWiki/UI/Edit.pm (working copy) @@ -32,6 +32,7 @@ use TWiki::Prefs; use TWiki::Store; use TWiki::UI; +use TWiki::Templates; =pod @@ -60,7 +61,7 @@ my $templateTopic = $query->param( "templatetopic" ) || ""; # apptype is undocumented legacy my $cgiAppType = $query->param( 'contenttype' ) || $query->param( 'apptype' ) || "text/html"; - my $skin = $query->param( "skin" ); + my $skin = TWiki::getSkin(); my $theParent = $query->param( 'topicparent' ) || ""; my $ptext = $query->param( 'text' ); @@ -69,7 +70,7 @@ return unless TWiki::UI::webExists( $webName, $topic ); return if TWiki::UI::isMirror( $webName, $topic ); - +print STDERR "One\n"; my $tmpl = ""; my $text = ""; my $meta = ""; @@ -86,7 +87,7 @@ # prevent non-Wiki names? if( ( $onlyWikiName ) && ( ! $topicExists ) - && ( ! ( &TWiki::isWikiName( $topic ) || &TWiki::isAbbrev( $topic ) ) ) ) { + && ( ! TWiki::isValidTopicName( $topic ) ) ) { # do not allow non-wikinames, redirect to view topic TWiki::UI::redirect( TWiki::getViewUrl( $webName, $topic ) ); return; @@ -97,7 +98,7 @@ ( $meta, $text ) = &TWiki::Store::readTopic( $webName, $topic ); } - my $wikiUserName = &TWiki::userToWikiName( $userName ); + my $wikiUserName = &TWiki::User::userToWikiName( $userName ); return unless TWiki::UI::isAccessPermitted( $webName, $topic, "change", $wikiUserName ); @@ -108,7 +109,7 @@ my( $lockUser, $lockTime ) = &TWiki::Store::topicIsLockedBy( $webName, $topic ); if( ( ! $breakLock ) && ( $lockUser ) ) { # warn user that other person is editing this topic - $lockUser = &TWiki::userToWikiName( $lockUser ); + $lockUser = &TWiki::User::userToWikiName( $lockUser ); use integer; $lockTime = ( $lockTime / 60 ) + 1; # convert to minutes my $editLock = $TWiki::editLockTime / 60; @@ -116,13 +117,13 @@ $lockUser, $editLock, $lockTime ); return; } - &TWiki::Store::lockTopic( $topic ); + TWiki::Store::lockTopic( $webName, $topic ); my $templateWeb = $webName; +print STDERR "Two\n"; # Get edit template, standard or a different skin - $skin = TWiki::Prefs::getPreferencesValue( "SKIN" ) unless ( $skin ); - $tmpl = &TWiki::Store::readTemplate( "edit", $skin ); + $tmpl = &TWiki::Templates::readTemplate( "edit", $skin ); unless( $topicExists ) { if( $templateTopic ) { if( $templateTopic =~ /^(.+)\.(.+)$/ ) { @@ -131,10 +132,10 @@ $templateTopic = $2; } - ( $meta, $text ) = &TWiki::Store::readTopic( $templateWeb, $templateTopic ); + ( $meta, $text ) = TWiki::Templates::readTopic( $templateWeb, $templateTopic ); } unless( $text ) { - ( $meta, $text ) = &TWiki::Store::readTemplateTopic( "WebTopicEditTemplate" ); + ( $meta, $text ) = TWiki::UI::readTemplateTopic( "WebTopicEditTemplate" ); } $extra = "(not exist)"; @@ -179,6 +180,7 @@ } } +print STDERR "Three\n"; if( $saveCmd eq "repRev" ) { $text = TWiki::Store::readTopicRaw( $webName, $topic ); } @@ -194,7 +196,7 @@ if( $TWiki::doLogTopicEdit ) { # write log entry - &TWiki::Store::writeLog( "edit", "$webName.$topic", $extra ); + TWiki::writeLog( "edit", "$webName.$topic", $extra ); } if( $saveCmd ) { @@ -202,11 +204,7 @@ } $tmpl =~ s/%CMD%/$saveCmd/go; $tmpl = &TWiki::handleCommonTags( $tmpl, $topic ); - if( $saveCmd ne "repRev" ) { - $tmpl = &TWiki::handleMetaTags( $webName, $topic, $tmpl, $meta ); - } else { - $tmpl =~ s/%META{[^}]*}%//go; - } + $tmpl = &TWiki::Render::renderMetaTags( $webName, $topic, $tmpl, $meta, $saveCmd eq "repRev" ); $tmpl = &TWiki::Render::getRenderedVersion( $tmpl ); # Don't want to render form fields, so this after getRenderedVersion @@ -233,6 +231,7 @@ $tmpl =~ s/%FORMFIELDS%//go; } +print STDERR "Four\n"; $tmpl =~ s/%FORMTEMPLATE%//go; # Clear if not being used $tmpl =~ s/%TEXT%/$text/go; $tmpl =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags Index: lib/TWiki/UI/Changes.pm =================================================================== --- lib/TWiki/UI/Changes.pm (revision 1767) +++ lib/TWiki/UI/Changes.pm (working copy) @@ -34,10 +34,9 @@ return unless TWiki::UI::webExists( $webName, $topic ); - my $skin = $query->param( "skin" ); - $skin = TWiki::Prefs::getPreferencesValue( "SKIN" ) unless ( $skin ); + my $skin = TWiki::getSkin(); - my $text = TWiki::Store::readTemplate( "changes", $skin ); + my $text = TWiki::Templates::readTemplate( "changes", $skin ); my $changes= TWiki::Store::readFile( "$TWiki::dataDir/$webName/.changes" ); my @bar = (); @@ -54,17 +53,18 @@ my $before = ""; my $after = ""; ( $before, $text, $after) = split( /%REPEAT%/, $text ); - &TWiki::writeHeader( $query ); + $before =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - print $before; + my $page = $before; + foreach( reverse split( /\n/, $changes ) ) { @bar = split( /\t/ ); if( ( ! %exclude ) || ( ! $exclude{ $bar[0] } ) ) { next unless TWiki::Store::topicExists( $webName, $bar[0] ); $foo = $text; $foo =~ s/%TOPICNAME%/$bar[0]/go; - my $wikiuser = &TWiki::userToWikiName( $bar[1] ); + my $wikiuser = &TWiki::User::userToWikiName( $bar[1] ); $foo =~ s/%AUTHOR%/$wikiuser/go; $foo =~ s/%LOCKED%//go; $time = &TWiki::formatTime( $bar[2] ); @@ -78,24 +78,27 @@ } $foo =~ s/%TIME%/$time/go; $foo =~ s/%REVISION%/$frev/go; - $foo = &TWiki::Render::getRenderedVersion( $foo ); + $foo = TWiki::Render::getRenderedVersion( $foo ); - $summary = &TWiki::Store::readFileHead( "$TWiki::dataDir\/$webName\/$bar[0].txt", 16 ); - $summary = &TWiki::makeTopicSummary( $summary, $bar[0], $webName ); + $summary = TWiki::Store::readFileHead( "$TWiki::dataDir\/$webName\/$bar[0].txt", 16 ); + $summary = TWiki::Render::makeTopicSummary( $summary, $bar[0], $webName ); $foo =~ s/%TEXTHEAD%/$summary/go; $foo =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - print $foo; + $page .= $foo; $exclude{ $bar[0] } = "1"; } } if( $TWiki::doLogTopicChanges ) { # write log entry - &TWiki::Store::writeLog( "changes", $webName, "" ); + TWiki::writeLog( "changes", $webName, "" ); } $after =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - print $after; + $page .= $after; + + TWiki::writeHeader( $query, length( $page )); + print $page; } 1; Index: lib/TWiki/UI/Manage.pm =================================================================== --- lib/TWiki/UI/Manage.pm (revision 1767) +++ lib/TWiki/UI/Manage.pm (working copy) @@ -28,6 +28,7 @@ use TWiki; use TWiki::UI; use TWiki::User; +use TWiki::Templates; =pod @@ -83,7 +84,7 @@ # my @refs = &TWiki::Store::findReferringPages( $oldWeb, $oldTopic ); # my $problems; # ( $lockFailure, $problems ) = - # &TWiki::Store::updateReferingPages( $oldWeb, $oldTopic, $wikiUserName, $newWeb, $newTopic, @refs ); + # &TWiki::Store::updateReferringPages( $oldWeb, $oldTopic, $wikiUserName, $newWeb, $newTopic, @refs ); TWiki::User::RemoveUser($wikiName); @@ -188,7 +189,7 @@ my $oopsTmpl = "mngcreateweb"; # check permission, user authorized to create webs? - my $wikiUserName = TWiki::userToWikiName( $userName ); + my $wikiUserName = TWiki::User::userToWikiName( $userName ); return unless TWiki::UI::isAccessPermitted( $webName, $topicName, "manage", $wikiUserName ); @@ -196,7 +197,7 @@ # valid template web name, untaint $newWeb =~ /(.*)/; $newWeb = $1; - } elsif( TWiki::isWebName( $newWeb ) ) { + } elsif( TWiki::isValidWebName( $newWeb ) ) { # valid web name, untaint $newWeb =~ /(.*)/; $newWeb = $1; @@ -391,7 +392,7 @@ my $doAllowNonWikiWord = $query->param( 'nonwikiword' ) || ""; my $justChangeRefs = $query->param( 'changeRefs' ) || ""; - my $skin = $query->param( "skin" ) || TWiki::Prefs::getPreferencesValue( "SKIN" ); + my $skin = TWiki::getSkin(); $newTopic =~ s/\s//go; $newTopic =~ s/$TWiki::securityFilter//go; @@ -400,17 +401,13 @@ $theAttachment = ""; } - my $wikiUserName = &TWiki::userToWikiName( $userName ); + my $wikiUserName = &TWiki::User::userToWikiName( $userName ); # justChangeRefs will be true when some topics that had links to $oldTopic # still need updating, previous update being prevented by a lock. - my $fileName = &TWiki::Store::getFileName( $oldWeb, $oldTopic ); - my $newName; - $newName = &TWiki::Store::getFileName( $newWeb, $newTopic ) if( $newWeb ); - if( ! $justChangeRefs ) { - if( _checkExist( $oldWeb, $oldTopic, $newWeb, $newTopic, $theAttachment, $fileName, $newName ) ) { + if( _checkExist( $oldWeb, $oldTopic, $newWeb, $newTopic, $theAttachment )) { return; } @@ -435,14 +432,46 @@ if( ! $justChangeRefs ) { if( $theAttachment ) { my $moveError = - &TWiki::Store::moveAttachment( $oldWeb, $oldTopic, $newWeb, $newTopic, $theAttachment ); + TWiki::Store::moveAttachment( $oldWeb, $oldTopic, + $newWeb, $newTopic, + $theAttachment ); + + my( $meta, $text ) = readTopic( $oldWeb, $oldTopic ); + my %fileAttachment = + $meta->findOne( "FILEATTACHMENT", $theAttachment ); + $meta->remove( "FILEATTACHMENT", $theAttachment ); + $moveError .= + TWiki::Store::noHandlersSave( $oldWeb, $oldTopic, $text, $meta, + "", "", "", "doUnlock", + "dont notify", "" ); + # Remove lock + lockTopic( $oldWeb, $oldTopic, 1 ); + + # Add file attachment to new topic + ( $meta, $text ) = readTopic( $newWeb, $newTopic ); + $fileAttachment{"movefrom"} = "$oldWeb.$oldTopic"; + $fileAttachment{"moveby"} = $TWiki::userName; + $fileAttachment{"movedto"} = "$newWeb.$newTopic"; + $fileAttachment{"movedwhen"} = time(); + $meta->put( "FILEATTACHMENT", %fileAttachment ); + + $moveError .= + TWiki::Store::noHandlersSave( $newWeb, $newTopic, $text, $meta, + "", "", "", "doUnlock", + "dont notify", "" ); + # Remove lock file. + lockTopic( $newWeb, $newTopic, 1 ); + + TWiki::writeLog( "move", "$oldWeb.$oldTopic", + "Attachment $theAttachment moved to $newWeb.$newTopic" ); + if( $moveError ) { TWiki::UI::oops( $newWeb, $newTopic, "moveerr", $theAttachment, $moveError ); return; } } else { - if( ! $doAllowNonWikiWord && ! &TWiki::isWikiName( $newTopic ) ) { + if( ! $doAllowNonWikiWord && ! TWiki::isValidWikiWord( $newTopic ) ) { TWiki::UI::oops( $newWeb, $newTopic, "renamenotwikiword" ); return; } @@ -462,7 +491,7 @@ my $problems; ( $lockFailure, $problems ) = - &TWiki::Store::updateReferingPages( $oldWeb, $oldTopic, $wikiUserName, $newWeb, $newTopic, @refs ); + &TWiki::Store::updateReferringPages( $oldWeb, $oldTopic, $wikiUserName, $newWeb, $newTopic, @refs ); } my $new_url = ""; @@ -610,7 +639,7 @@ #========================================== # Check that various webs and topics exist or don't exist as required sub _checkExist { - my( $oldWeb, $oldTopic, $newWeb, $newTopic, $theAttachment, $oldFileName, $newFileName ) = @_; + my( $oldWeb, $oldTopic, $newWeb, $newTopic, $theAttachment ) = @_; my $ret = 0; my $query = TWiki::getCgiQuery(); @@ -618,30 +647,34 @@ $ret = 1 unless TWiki::UI::webExists( $oldWeb, $oldTopic ); $ret = 1 unless TWiki::UI::webExists( $newWeb, $newTopic ); - # Does old attachment exist? - if( ! -e $oldFileName) { - TWiki::UI::oops( $oldWeb, $oldTopic, "missing" ); - $ret = 1; + if ( $theAttachment) { + # Does old attachment exist? + unless( TWiki::Store::attachmentExists( $oldWeb, $oldTopic, + $theAttachment )) { + TWiki::UI::oops( $oldWeb, $oldTopic, "moveerr", $theAttachment ); + $ret = 1; + } + # does new attachment already exist? + if( TWiki::Store::attachmentExists( $newWeb, $newTopic, + $theAttachment )) { + TWiki::UI::oops( $newWeb, $newTopic, "moverr", $theAttachment ); + $ret = 1; + } + } else { + # Check new topic doesn't exist + if( TWiki::Store::topicExists( $newWeb, $newTopic)) { + # Unless moving an attachment, new topic should not already exist + TWiki::UI::oops( $newWeb, $newTopic, "topicexists" ); + $ret = 1; + } } - # Check new topic doesn't exist (opposite if we've moving an attachment) - if( defined( $newFileName ) && -e $newFileName && ! $theAttachment ) { - # Unless moving an attachment, new topic should not already exist - TWiki::UI::oops( $newWeb, $newTopic, "topicexists" ); - $ret = 1; - } - - if( defined( $newFileName ) && $theAttachment && ! -e $newFileName ) { - TWiki::UI::oops( $newWeb, $newTopic, "missing" ); - $ret = 1; - } - return $ret; } #============================ -#Return "" if can't get lock, otherwise "okay" +# Return 1 if can't get lock, otherwise 0 sub _getLocks { my( $oldWeb, $oldTopic, $newWeb, $newTopic, $theAttachment, $breakLock, $skin ) = @_; @@ -652,7 +685,7 @@ # Check for lock - at present the lock can't be broken ( $oldLockUser, $oldLockTime ) = &TWiki::Store::topicIsLockedBy( $oldWeb, $oldTopic ); if( $oldLockUser ) { - $oldLockUser = &TWiki::userToWikiName( $oldLockUser ); + $oldLockUser = &TWiki::User::userToWikiName( $oldLockUser ); use integer; $oldLockTime = ( $oldLockTime / 60 ) + 1; # convert to minutes } @@ -660,7 +693,7 @@ if( $theAttachment ) { ( $newLockUser, $newLockTime ) = &TWiki::Store::topicIsLockedBy( $newWeb, $newTopic ); if( $newLockUser ) { - $newLockUser = &TWiki::userToWikiName( $newLockUser ); + $newLockUser = &TWiki::User::userToWikiName( $newLockUser ); use integer; $newLockTime = ( $newLockTime / 60 ) + 1; # convert to minutes my $editLock = $TWiki::editLockTime / 60; @@ -669,7 +702,7 @@ } if( $oldLockUser || $newLockUser ) { - my $tmpl = &TWiki::Store::readTemplate( "oopslockedrename", $skin ); + my $tmpl = TWiki::Templates::readTemplate( "oopslockedrename", $skin ); my $editLock = $TWiki::editLockTime / 60; if( $oldLockUser ) { $tmpl =~ s/%OLD_LOCK%/Source topic $oldWeb.$oldTopic is locked by $oldLockUser, lock expires in $oldLockTime minutes.
/go; @@ -687,17 +720,18 @@ $tmpl = &TWiki::handleCommonTags( $tmpl, $oldTopic, $oldWeb ); $tmpl = &TWiki::Render::getRenderedVersion( $tmpl, $oldWeb ); $tmpl =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - TWiki::writeHeader( $query ); + # SMELL: this is a redirect! + TWiki::writeHeader( $query, length( $tmpl )); print $tmpl; - return ""; + return 0; } else { - &TWiki::Store::lockTopicNew( $oldWeb, $oldTopic ); + TWiki::Store::lockTopic( $oldWeb, $oldTopic ); if( $theAttachment ) { - &TWiki::Store::lockTopicNew( $newWeb, $newTopic ); + TWiki::Store::lockTopic( $newWeb, $newTopic ); } } - return "okay"; + return 1; } #============================ @@ -714,16 +748,15 @@ my $nonWikiWordFlag = ""; $nonWikiWordFlag = 'checked="checked"' if( $doAllowNonWikiWord ); - TWiki::writeHeader( $query ); if( $theAttachment ) { - $tmpl = TWiki::Store::readTemplate( "moveattachment", $skin ); + $tmpl = TWiki::Templates::readTemplate( "moveattachment", $skin ); $tmpl =~ s/%FILENAME%/$theAttachment/go; } elsif( $confirm ) { - $tmpl = TWiki::Store::readTemplate( "renameconfirm", $skin ); + $tmpl = TWiki::Templates::readTemplate( "renameconfirm", $skin ); } elsif( $newWeb eq "Trash" ) { - $tmpl = TWiki::Store::readTemplate( "renamedelete", $skin ); + $tmpl = TWiki::Templates::readTemplate( "renamedelete", $skin ); } else { - $tmpl = &TWiki::Store::readTemplate( "rename", $skin ); + $tmpl = TWiki::Templates::readTemplate( "rename", $skin ); } $tmpl = _setVars( $tmpl, $oldTopic, $newWeb, $newTopic, $nonWikiWordFlag ); @@ -735,6 +768,8 @@ $tmpl =~ s/%RESEARCH/%SEARCH/go; # Pre search result from being rendered $tmpl = &TWiki::handleCommonTags( $tmpl, $oldTopic, $oldWeb ); $tmpl =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags + + TWiki::writeHeader( $query, length( $tmpl )); print $tmpl; } @@ -752,13 +787,14 @@ my( $oldWeb, $oldTopic, $newWeb, $newTopic, $skin ) = @_; my $query = TWiki::getCgiQuery(); - TWiki::writeHeader( $query ); - my $tmpl = TWiki::Store::readTemplate( "renamerefs", $skin ); + my $tmpl = TWiki::Templates::readTemplate( "renamerefs", $skin ); $tmpl = _setVars( $tmpl, $oldTopic, $newWeb, $newTopic ); $tmpl = TWiki::Render::getRenderedVersion( $tmpl ); $tmpl =~ s/%RESEARCH/%SEARCH/go; # Pre search result from being rendered $tmpl = TWiki::handleCommonTags( $tmpl, $oldTopic, $oldWeb ); $tmpl =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags + + TWiki::writeHeader( $query, length( $tmpl )); print $tmpl; } Index: lib/TWiki/UI/Viewfile.pm =================================================================== --- lib/TWiki/UI/Viewfile.pm (revision 1767) +++ lib/TWiki/UI/Viewfile.pm (working copy) @@ -66,7 +66,7 @@ # Convert only if html file does not yet exist # for now, show the original document: - my $pubUrlPath = &TWiki::getPubUrlPath(); + my $pubUrlPath = $TWiki::pubUrlPath; my $host = $TWiki::urlHost; TWiki::UI::redirect( "$host$pubUrlPath/$webName/$topic/$fileName" ); } Index: lib/TWiki/UI/RDiff.pm =================================================================== --- lib/TWiki/UI/RDiff.pm (revision 1767) +++ lib/TWiki/UI/RDiff.pm (working copy) @@ -329,7 +329,7 @@ my( $web, $rev, $topic, $short ) = @_; my( $date, $user ) = &TWiki::Store::getRevisionInfo( $web, $topic, "1.$rev"); - $user = TWiki::Render::getRenderedVersion( TWiki::userToWikiName( $user ) ); + $user = TWiki::Render::getRenderedVersion( TWiki::User::userToWikiName( $user ) ); if ( $short ) { $date = TWiki::formatTime( $date, "\$day \$month \$year" ); @@ -373,8 +373,7 @@ my $diffType = $query->param('type'); my $contextLines = $query->param('context'); $contextLines = &TWiki::Prefs::getPreferencesValue( "DIFFCONTEXTLINES" ) unless ( $contextLines ); - my $skin = $query->param( "skin" ); - $skin = &TWiki::Prefs::getPreferencesValue( "SKIN" ) unless ( $skin ); + my $skin = TWiki::getSkin(); my $rev1 = $query->param( "rev1" ); my $rev2 = $query->param( "rev2" ); @@ -396,7 +395,7 @@ my $isMultipleDiff = 0; my $scriptUrlPath = $TWiki::scriptUrlPath; - $tmpl = &TWiki::Store::readTemplate( "rdiff", $skin ); + $tmpl = TWiki::Templates::readTemplate( "rdiff", $skin ); $tmpl =~ s/\%META{.*?}\%//go; # remove %META{"parent"}% my( $before, $difftmpl, $after) = split( /%REPEAT%/, $tmpl); @@ -429,7 +428,7 @@ } # check access permission - my $wikiUserName = &TWiki::userToWikiName( $userName ); + my $wikiUserName = &TWiki::User::userToWikiName( $userName ); my $viewAccessOK = &TWiki::Access::checkAccessPermission( "view", $wikiUserName, "", $topic, $webName ); if( $TWiki::readTopicPermissionFailed ) { # Can't read requested topic and/or included (or other accessed topics) @@ -462,8 +461,7 @@ $before = &TWiki::handleCommonTags( $before, $topic ); $before = &TWiki::Render::getRenderedVersion( $before ); $before =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - &TWiki::writeHeader( $query ); - print $before; + my $page = $before; # do one or more diffs $difftmpl = &TWiki::handleCommonTags( $difftmpl, $topic ); @@ -490,7 +488,7 @@ # } $diff =~ s/%TEXT%/$text/go; $diff =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - print $diff; + $page .= $diff; $r1 = $r1 - 1; $r2 = $r2 - 1; if( $r2 < 1 ) { $r2 = 1; } @@ -502,12 +500,12 @@ $diff =~ s/%REVTITLE2%/$revTitle2/go; $diff =~ s/%TEXT%//go; $diff =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - print $diff; + $page .= $diff; } if( $TWiki::doLogTopicRdiff ) { # write log entry - &TWiki::Store::writeLog( "rdiff", "$webName.$topic", "r1.$rev1 r1.$rev2" ); + TWiki::writeLog( "rdiff", "$webName.$topic", "r1.$rev1 r1.$rev2" ); } # format "after" part @@ -550,7 +548,10 @@ $after = &TWiki::Render::getRenderedVersion( $after ); $after =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - print $after; + $page .= $after; + + TWiki::writeHeader( $query, length( $page )); + print $page; } 1; Index: lib/TWiki/UI/Statistics.pm =================================================================== --- lib/TWiki/UI/Statistics.pm (revision 1767) +++ lib/TWiki/UI/Statistics.pm (working copy) @@ -50,9 +50,11 @@ if( $query ) { # running from CGI - TWiki::writeHeader( $query ); - print "\n\nTWiki: Create Usage Statistics\n"; - print "\n\n"; + my $mess = + "\n\nTWiki: Create Usage Statistics\n" . + "\n\n"; + TWiki::writeHeader( $query, length( $mess )); + print $mess; } # Initial messages @@ -368,7 +370,7 @@ $dummy = ""; # to suppress warning if( $isFirstTime ) { - my $tmp = &TWiki::userToWikiName( $userName, 1 ); + my $tmp = &TWiki::User::userToWikiName( $userName, 1 ); $tmp .= " as shell script" unless( $query ); _printMsg( "* Executed by $tmp", $query ); } Index: lib/TWiki/UI/View.pm =================================================================== --- lib/TWiki/UI/View.pm (revision 1767) +++ lib/TWiki/UI/View.pm (working copy) @@ -29,7 +29,9 @@ use strict; use TWiki; +use TWiki::User; use TWiki::UI; +use TWiki::Templates; =pod @@ -45,274 +47,274 @@ =cut sub view { - my ( $webName, $topic, $userName, $query ) = @_; + my ( $webName, $topic, $userName, $query ) = @_; - my $rev = $query->param( "rev" ); - my $viewRaw = $query->param( "raw" ) || ""; - my $unlock = $query->param( "unlock" ) || ""; - my $skin = $query->param( "skin" ); - my $contentType = $query->param( "contenttype" ); + my $rev = $query->param( "rev" ); + my $viewRaw = $query->param( "raw" ) || ""; + my $unlock = $query->param( "unlock" ) || ""; + my $contentType = $query->param( "contenttype" ); - TWiki::UI::writeDebugTimes( "view - initialized" ); + my $text = ""; + my $meta = ""; + my $maxrev = 1; + my $extra = ""; + my $wikiUserName = TWiki::User::userToWikiName( $userName ); + my $revdate = ""; + my $revuser = ""; - my $tmpl = ""; - my $text = ""; - my $meta = ""; - my $maxrev = 1; - my $extra = ""; - my $wikiUserName = &TWiki::userToWikiName( $userName ); - my $revdate = ""; - my $revuser = ""; + return unless TWiki::UI::webExists( $webName, $topic ); - $skin = &TWiki::Prefs::getPreferencesValue( "SKIN" ) unless ( $skin ); + my $skin = TWiki::getSkin(); - # Set page generation mode to RSS if using an RSS skin - if( $skin =~ /^rss/ ) { - TWiki::setPageMode( 'rss' ); - } + # Set page generation mode to RSS if using an RSS skin + if( $skin =~ /^rss/ ) { + TWiki::Render::setRenderMode( 'rss' ); + } - # get view template, standard view or a view with a different skin - $tmpl = &TWiki::Store::readTemplate( "view", $skin ); - if( ! $tmpl ) { - TWiki::writeHeader( $query ); - print "\n" - . "

TWiki Installation Error

\n" - . "Template file view.tmpl not found or template directory \n" - . "$TWiki::templateDir not found.

\n" - . "Check the \$templateDir variable in TWiki.cfg.\n" - . "\n"; - return; - } - TWiki::UI::writeDebugTimes( "view - readTemplate" ); + if( $unlock eq "on" ) { + # unlock topic, user cancelled out of edit + TWiki::Store::lockTopic( $webName, $topic, "on" ); + } - return unless TWiki::UI::webExists( $webName, $topic ); - TWiki::UI::writeDebugTimes( "view - webExists" ); + my $topicExists = TWiki::Store::topicExists( $webName, $topic ); + if( $topicExists ) { + ( $meta, $text ) = TWiki::Store::readTopic( $webName, $topic ); + ( $revdate, $revuser, $maxrev ) = + $meta->getRevisionInfo( $webName, $topic ); - if( $unlock eq "on" ) { - # unlock topic, user cancelled out of edit - &TWiki::Store::lockTopic( $topic, "on" ); - } + $revdate = TWiki::formatTime( $revdate ); - # Most recent topic read in even if earlier topic requested - makes - # code simpler and performance impact should be minimal - my $topicExists = &TWiki::Store::topicExists( $webName, $topic ); - if( $topicExists ) { - if( $viewRaw ) { - $text = &TWiki::Store::readTopicRaw( $webName, $topic ); - } else { - ( $meta, $text ) = &TWiki::Store::readTopic( $webName, $topic ); + if( $rev ) { + $rev =~ s/r?1\.//go; # cut 'r' and major + $rev = 1 if( $rev < 1 ); + $rev = $maxrev if( $rev > $maxrev ); + } else { + $rev = $maxrev; + } + + if( $rev < $maxrev ) { + # Most recent topic read in even if earlier topic requested - makes + # code simpler and performance impact should be minimal + ( $meta, $text ) = + TWiki::Store::readTopicVersion( $webName, $topic, "1.$rev" ); + + ( $revdate, $revuser ) = + TWiki::Store::getRevisionInfo( $webName, $topic, "1.$rev"); + $revdate = TWiki::formatTime( $revdate ); + $extra .= "r1.$rev"; + } + } else { # Topic does not exist yet + $rev = 1; + if( TWiki::isValidTopicName( $topic )) { + ( $meta, $text ) = + TWiki::UI::readTemplateTopic( "WebTopicViewTemplate" ); + } else { + ( $meta, $text ) = + TWiki::UI::readTemplateTopic( "WebTopicNonWikiTemplate" ); + } + $extra .= " (not exist)"; } - ( $revdate, $revuser, $maxrev ) = &TWiki::Store::getRevisionInfoFromMeta( $webName, $topic, $meta); - $revdate = TWiki::formatTime( $revdate ); - if( $rev ) { - $rev =~ s/r?1\.//go; # cut 'r' and major - if( $rev < 1 ) { $rev = 1; } - if( $rev > $maxrev ) { $rev = $maxrev; } + if( $viewRaw ) { + $extra .= " raw=$viewRaw"; + if( $viewRaw =~ /debug/i ) { + $text = TWiki::Store::getDebugText( $meta, $text ); + } + # a skin name starting with the word 'text' is intended to be + # used like this: + # http://.../view/Codev/MyTopic?skin=text&contenttype=text/plain&raw=on + # which shows the topic as plain text; useful for those who want + # to download plain text for the topic. + # SMELL: this is not documented anywhere that I can find, and the + # poor slob who creates "texture_skin" is going to get a hell of + # a shock! This should be done with "raw=text", not with a skin. + if( $skin !~ /^text/ ) { + my $vtext = "

"; + } } else { - $rev = $maxrev; + $text = TWiki::handleCommonTags( $text, $topic ); + $text = TWiki::Render::getRenderedVersion( $text ); } - if( $rev < $maxrev ) { - if( $viewRaw ) { - $text = &TWiki::Store::readTopicRaw( $webName, $topic, "1.$rev" ); - } else { - ( $meta, $text ) = &TWiki::Store::readTopicVersion( $webName, $topic, "1.$rev" ); - } - ( $revdate, $revuser ) = &TWiki::Store::getRevisionInfo( $webName, $topic, "1.$rev"); - $revdate = TWiki::formatTime( $revdate ); - $extra .= "r1.$rev"; + if( $TWiki::doLogTopicView ) { + # write log entry + TWiki::writeLog( "view", "$webName.$topic", $extra ); } - } else { - $rev = 1; - if( &TWiki::isWikiName( $topic ) || &TWiki::isAbbrev( $topic ) ) { - ( $meta, $text ) = &TWiki::Store::readTemplateTopic( "WebTopicViewTemplate" ); - } else { - ( $meta, $text ) = &TWiki::Store::readTemplateTopic( "WebTopicNonWikiTemplate" ); - } - $extra .= " (not exist)"; - } - if( $viewRaw ) { - $extra .= " raw=$viewRaw"; - if( $viewRaw !~ /debug/i ) { - $text = join( "\n", grep{ !/^%META:([^{]+){(.*)}%$/ } split( /\r?\n/, $text ) ); + # get view template, standard view or a view with a different skin + my $tmpl = TWiki::Templates::readTemplate( "view", $skin ); + if( ! $tmpl ) { + my $mess = "\n" + . "

TWiki Installation Error

\n" + . "Template file view.tmpl not found or template directory \n" + . "$TWiki::templateDir not found.

\n" + . "Check the \$templateDir variable in TWiki.cfg.\n" + . "\n"; + TWiki::writeHeader( $query, length( $mess )); + print $mess; + return; } - if( $skin !~ /^text/ ) { - my $vtext = "

"; - } - } - TWiki::UI::writeDebugTimes( "view - get rev info" ); + my( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote ) = + TWiki::readOnlyMirrorWeb( $webName ); - if( ! $viewRaw ) { - $text = &TWiki::handleCommonTags( $text, $topic ); - TWiki::UI::writeDebugTimes( "view - handleCommonTags done" ); - $text = &TWiki::Render::getRenderedVersion( $text ); - TWiki::UI::writeDebugTimes( "view - getRendereredVersion done" ); - } + if( $mirrorSiteName ) { + # disable edit and attach + # FIXME: won't work with non-default skins, see %EDITURL% + $tmpl =~ s/%EDITTOPIC%/$mirrorLink | Edit<\/strike>/go; + $tmpl =~ s/]*?>Attach<\/a>/Attach<\/strike>/goi; + if( $topicExists ) { + # remove the NOINDEX meta tag + $tmpl =~ s/]*>//goi; + } else { + $text = ""; + } + $tmpl =~ s/%REVTITLE%//go; + } elsif( $rev < $maxrev ) { + # disable edit of previous revisions - FIXME consider change + # to use two templates + # SMELL: won't work with non-default skins, see %EDITURL% + $tmpl =~ s/%EDITTOPIC%/Edit<\/strike>/go; + $tmpl =~ s/]*?>Attach<\/a>/Attach<\/strike>/goi; + $tmpl =~ s|]*?>Rename/move<\/a>|Rename/move<\/strike>|goi; + $tmpl =~ s/%REVTITLE%/\(r1.$rev\)/go; + $tmpl =~ s/%REVARG%/&rev=1.$rev/go; + } else { + # Remove the NOINDEX meta tag (for robots) from both Edit and + # Create pages + $tmpl =~ s/]*>//goi; + my $editAction = $topicExists ? 'Edit' : 'Create'; - if( $TWiki::doLogTopicView ) { - # write log entry - &TWiki::Store::writeLog( "view", "$webName.$topic", $extra ); - } + # Special case for 'view' to handle %EDITTOPIC% and Edit vs. Create. + # New %EDITURL% variable is implemented by handleCommonTags, suffixes + # '?t=NNNN' to ensure that every Edit link is unique, fixing + # Codev.RefreshEditPage bug relating to caching of Edit page. + $tmpl =~ s!%EDITTOPIC%!$editAction!go; - my( $mirrorSiteName, $mirrorViewURL, $mirrorLink, $mirrorNote ) = &TWiki::readOnlyMirrorWeb( $webName ); - if( $mirrorSiteName ) { - # disable edit and attach - # FIXME: won't work with non-default skins, see %EDITURL% - $tmpl =~ s/%EDITTOPIC%/$mirrorLink | Edit<\/strike>/go; - $tmpl =~ s/]*?>Attach<\/a>/Attach<\/strike>/goi; - if( $topicExists ) { - # remove the NOINDEX meta tag - $tmpl =~ s/]*>//goi; - } else { - $text = ""; + # FIXME: Implement ColasNahaboo's suggested %EDITLINK% along the + # same lines, within handleCommonTags + $tmpl =~ s/%REVTITLE%//go; + $tmpl =~ s/%REVARG%//go; } - $tmpl =~ s/%REVTITLE%//go; - } elsif( $rev < $maxrev ) { - # disable edit of previous revisions - FIXME consider change to use two templates - # FIXME: won't work with non-default skins, see %EDITURL% - $tmpl =~ s/%EDITTOPIC%/Edit<\/strike>/go; - $tmpl =~ s/]*?>Attach<\/a>/Attach<\/strike>/goi; - $tmpl =~ s|]*?>Rename/move<\/a>|Rename/move<\/strike>|goi; - $tmpl =~ s/%REVTITLE%/\(r1.$rev\)/go; - $tmpl =~ s/%REVARG%/&rev=1.$rev/go; - } else { - # Remove the NOINDEX meta tag (for robots) from both Edit and - # Create pages - $tmpl =~ s/]*>//goi; - my $editAction = $topicExists ? 'Edit' : 'Create'; - # Special case for 'view' to handle %EDITTOPIC% and Edit vs. Create. - # New %EDITURL% variable is implemented by handleCommonTags, suffixes - # '?t=NNNN' to ensure that every Edit link is unique, fixing - # Codev.RefreshEditPage bug relating to caching of Edit page. - $tmpl =~ s!%EDITTOPIC%!$editAction!go; + # SMELL: HUH? - TODO: why would you not show the revisions around + # the version that you are displaying? and this logic is yucky@! + my $i = $maxrev; + my $j = $maxrev; + my $revisions = ""; + my $breakRev = 0; + if( ( $TWiki::numberOfRevisions > 0 ) && + ( $TWiki::numberOfRevisions < $maxrev ) ) { + $breakRev = $maxrev - $TWiki::numberOfRevisions + 1; + } + while( $i > 0 ) { + if( $i == $rev) { + $revisions = "$revisions | r1.$i"; + } else { + $revisions = "$revisions | r1.$i"; + } + if( $i != 1 ) { + if( $i == $breakRev ) { + $i = 1; + } else { + $j = $i - 1; + $revisions = "$revisions | >"; + } + } + $i = $i - 1; + } + $tmpl =~ s/%REVISIONS%/$revisions/go; - # FIXME: Implement ColasNahaboo's suggested %EDITLINK% along the - # same lines, within handleCommonTags - $tmpl =~ s/%REVTITLE%//go; - $tmpl =~ s/%REVARG%//go; - } + $tmpl =~ s/%REVINFO%/%REVINFO%$mirrorNote/go; + $tmpl = TWiki::handleCommonTags( $tmpl, $topic ); -#SMELL: HUH? - TODO: why would you not show the revisions around the version that you are displaying? and this logic is yucky@! - my $i = $maxrev; - my $j = $maxrev; - my $revisions = ""; - my $breakRev = 0; - if( ( $TWiki::numberOfRevisions > 0 ) && ( $TWiki::numberOfRevisions < $maxrev ) ) { - $breakRev = $maxrev - $TWiki::numberOfRevisions + 1; - } - while( $i > 0 ) { - if( $i == $rev) { - $revisions = "$revisions | r1.$i"; + if( $viewRaw ) { + $tmpl =~ s/%META{[^}]*}%//go; } else { - $revisions = "$revisions | r1.$i"; + $tmpl = TWiki::Render::renderMetaTags( $webName, $topic, $tmpl, $meta, ( $rev == $maxrev ) ); } - if( $i != 1 ) { - if( $i == $breakRev ) { - $i = 1; - } else { - $j = $i - 1; - $revisions = "$revisions | >"; - } - } - $i = $i - 1; - } - $tmpl =~ s/%REVISIONS%/$revisions/go; + $tmpl = TWiki::Render::getRenderedVersion( $tmpl, "", $meta ); ## better to use meta rendering? - $tmpl =~ s/%REVINFO%/%REVINFO%$mirrorNote/go; + $tmpl =~ s/%TEXT%/$text/go; + $tmpl =~ s/%MAXREV%/1.$maxrev/go; + $tmpl =~ s/%CURRREV%/1.$rev/go; + $tmpl =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove tags (PTh 06 Nov 2000) - $tmpl = &TWiki::handleCommonTags( $tmpl, $topic ); - if( $viewRaw ) { - $tmpl =~ s/%META{[^}]*}%//go; - } else { - $tmpl = &TWiki::handleMetaTags( $webName, $topic, $tmpl, $meta, ( $rev == $maxrev ) ); - } - TWiki::UI::writeDebugTimes( "view - handleCommonTags for template done" ); - $tmpl = &TWiki::Render::getRenderedVersion( $tmpl, "", $meta ); ## better to use meta rendering? - $tmpl =~ s/%TEXT%/$text/go; - $tmpl =~ s/%MAXREV%/1.$maxrev/go; - $tmpl =~ s/%CURRREV%/1.$rev/go; - $tmpl =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove tags (PTh 06 Nov 2000) + # check access permission + my $viewAccessOK = TWiki::Access::checkAccessPermission( "view", $wikiUserName, $text, $topic, $webName ); - # check access permission - my $viewAccessOK = &TWiki::Access::checkAccessPermission( "view", $wikiUserName, $text, $topic, $webName ); - - if( (!$topicExists) || $TWiki::readTopicPermissionFailed ) { - # Can't read requested topic and/or included (or other accessed topics - # user could not be authenticated, may be not logged in yet? - my $viewauthFile = $ENV{'SCRIPT_FILENAME'}; - $viewauthFile =~ s|/view|/viewauth|o; - if( ( ! $query->remote_user() ) && (-e $viewauthFile ) ) { - # try again with authenticated viewauth script - # instead of non authenticated view script - my $url = $ENV{"REQUEST_URI"}; - if( $url && $url =~ m|/view| ) { - # $url i.e. is "twiki/bin/view.cgi/Web/Topic?cms1=val1&cmd2=val2" - $url =~ s|/view|/viewauth|o; - $url = "$TWiki::urlHost$url"; - } else { - # If REQUEST_URI is rewritten and does not contain the name "view" - # try looking at the CGI environment variable SCRIPT_NAME. - # - # Assemble the new URL using the host, the changed script name, - # the path info, and the query string. All three query variables - # are in the list of the canonical request meta variables in CGI 1.1. - my $script = $ENV{'SCRIPT_NAME'}; - my $pathInfo = $ENV{'PATH_INFO'}; - my $queryString = $ENV{'QUERY_STRING'}; - $pathInfo = '/' . $pathInfo if ($pathInfo); - $queryString = '?' . $queryString if ($queryString); - if ($script && $script =~ m|/view| ) { - $script =~ s|/view|/viewauth|o; - $url = "$TWiki::urlHost$script$pathInfo$queryString"; - } else { - # If SCRIPT_NAME does not contain the name "view" - # the last hope is to try the SCRIPT_FILENAME ... - $viewauthFile =~ s|^.*/viewauth|/viewauth|o; # strip off $Twiki::scriptUrlPath - $url = "$TWiki::urlHost$TWiki::scriptUrlPath/$viewauthFile$pathInfo$queryString"; - } - } - TWiki::UI::redirect( $url ); + # SMELL: why calculate viewAccessOK and then use readTopicPermissionFailed + # SMELL: readTopicPermissionFailed break TWiki encapsulation + if( (!$topicExists) || $TWiki::readTopicPermissionFailed ) { + # Can't read requested topic and/or included (or other accessed topics + # user could not be authenticated, may be not logged in yet? + my $viewauthFile = $ENV{'SCRIPT_FILENAME'}; + # SMELL: depends on view script being called view. And what if this + # script is _already_ viewauth? Could use \b, but still depends on + # the name. + $viewauthFile =~ s|/view|/viewauth|o; + if( ( ! $query->remote_user() ) && (-e $viewauthFile ) ) { + # try again with authenticated viewauth script + # instead of non authenticated view script + my $url = $ENV{"REQUEST_URI"}; + if( $url && $url =~ m|/view| ) { + # $url i.e. is "twiki/bin/view.cgi/Web/Topic?cms1=val1&cmd2=val2" + $url =~ s|/view|/viewauth|o; + $url = "$TWiki::urlHost$url"; + } else { + # If REQUEST_URI is rewritten and does not contain the name "view" + # try looking at the CGI environment variable SCRIPT_NAME. + # + # Assemble the new URL using the host, the changed script name, + # the path info, and the query string. All three query variables + # are in the list of the canonical request meta variables in CGI 1.1. + my $script = $ENV{'SCRIPT_NAME'}; + my $pathInfo = $ENV{'PATH_INFO'}; + my $queryString = $ENV{'QUERY_STRING'}; + $pathInfo = '/' . $pathInfo if ($pathInfo); + $queryString = '?' . $queryString if ($queryString); + if ($script && $script =~ m|/view| ) { + $script =~ s|/view|/viewauth|o; + $url = "$TWiki::urlHost$script$pathInfo$queryString"; + } else { + # If SCRIPT_NAME does not contain the name "view" + # the last hope is to try the SCRIPT_FILENAME ... + $viewauthFile =~ s|^.*/viewauth|/viewauth|o; # strip off $Twiki::scriptUrlPath + $url = "$TWiki::urlHost$TWiki::scriptUrlPath/$viewauthFile$pathInfo$queryString"; + } + } + TWiki::UI::redirect( $url ); + } } - } - if( ! $viewAccessOK ) { - TWiki::UI::oops( $webName, $topic, "accessview" ); - } + if( ! $viewAccessOK ) { + TWiki::UI::oops( $webName, $topic, "accessview" ); + } - TWiki::UI::writeDebugTimes( "view - checked access permissions" ); - - # Write header based on "contenttype" parameter, used to produce - # MIME types like text/plain or text/xml, e.g. for RSS feeds. - if( $contentType ) { - TWiki::writeHeaderFull( $query, 'basic', $contentType, 0); - if( $skin =~ /^rss/ ) { - $tmpl =~ s/]*>//g; # remove image tags - $tmpl =~ s/]*>//g; # remove anchor tags - $tmpl =~ s/<\/a>//g; # remove anchor tags + # Write header based on "contenttype" parameter, used to produce + # MIME types like text/plain or text/xml, e.g. for RSS feeds. + if( $contentType ) { + if( $skin =~ /^rss/ ) { + $tmpl =~ s/]*>//g; # remove image tags + $tmpl =~ s/]*>//g; # remove anchor tags + $tmpl =~ s/<\/a>//g; # remove anchor tags + } + } elsif( $skin =~ /^rss/ ) { + $tmpl =~ s/]*>//g; # remove image tags + $tmpl =~ s/]*>//g; # remove anchor tags + $tmpl =~ s/<\/a>//g; # remove anchor tags + $contentType = 'text/xml'; + } else { + $contentType = 'text/html' } - } elsif( $skin =~ /^rss/ ) { - TWiki::writeHeaderFull( $query, 'basic', 'text/xml', 0); - $tmpl =~ s/]*>//g; # remove image tags - $tmpl =~ s/]*>//g; # remove anchor tags - $tmpl =~ s/<\/a>//g; # remove anchor tags - } else { - TWiki::writeHeader( $query ); - } - # print page content - print $tmpl; - - TWiki::UI::writeDebugTimes( "view - done" ); + TWiki::writeHeaderFull( $query, 'basic', $contentType, length( $tmpl )); + print $tmpl; } 1; Index: lib/TWiki/UI/Save.pm =================================================================== --- lib/TWiki/UI/Save.pm (revision 1767) +++ lib/TWiki/UI/Save.pm (working copy) @@ -52,7 +52,7 @@ sub save { my( $webName, $topic, $userName, $query ) = @_; if ( _save( @_ )) { - TWiki::redirect( $query, TWiki::getViewUrl( TWiki::Store::normalizeWebTopicName($webName, $topic)) ); + TWiki::redirect( $query, TWiki::getViewUrl( TWiki::normalizeWebTopicName($webName, $topic)) ); } } @@ -82,10 +82,10 @@ my $topicExists = TWiki::Store::topicExists( $webName, $topic ); + return 0 if TWiki::UI::isMirror( $webName, $topic ); + return 0 unless TWiki::UI::webExists( $webName, $topic ); - return 0 if TWiki::UI::isMirror( $webName, $topic ); - # Prevent saving existing topic? if( $onlyNewTopic && $topicExists ) { # Topic exists and user requested oops if it exists @@ -96,13 +96,13 @@ # prevent non-Wiki names? if( ( $onlyWikiName ) && ( ! $topicExists ) - && ( ! ( &TWiki::isWikiName( $topic ) || &TWiki::isAbbrev( $topic ) ) ) ) { + && ( ! TWiki::isValidTopicName( $topic ) ) ) { # do not allow non-wikinames, redirect to view topic TWiki::UI::redirect( TWiki::getViewUrl( $webName, $topic ) ); return 0; } - my $wikiUserName = TWiki::userToWikiName( $userName ); + my $wikiUserName = TWiki::User::userToWikiName( $userName ); return 0 unless TWiki::UI::isAccessPermitted( $webName, $topic, "change", $wikiUserName ); @@ -185,7 +185,7 @@ sub savemulti { my( $webName, $topic, $userName, $query ) = @_; - my $redirecturl = TWiki::getViewUrl( TWiki::Store::normalizeWebTopicName($webName, $topic)); + my $redirecturl = TWiki::getViewUrl( TWiki::normalizeWebTopicName($webName, $topic)); my $saveaction = lc($query->param( 'action' )); if ( $saveaction eq "checkpoint" ) { Index: lib/TWiki/UI/Oops.pm =================================================================== --- lib/TWiki/UI/Oops.pm (revision 1767) +++ lib/TWiki/UI/Oops.pm (working copy) @@ -42,33 +42,32 @@ my ( $web, $topic, $user, $query ) = @_; my $tmplName = $query->param( 'template' ) || "oops"; - my $skin = $query->param( "skin" ) || TWiki::Prefs::getPreferencesValue( "SKIN" ); - my $tmplData = TWiki::Store::readTemplate( $tmplName, $skin ); + my $skin = TWiki::getSkin(); + + my $tmplData = TWiki::Templates::readTemplate( $tmplName, $skin ); if( ! $tmplData ) { - TWiki::writeHeader( $query ); - print "\n" - . "

TWiki Installation Error

\n" - . "Template file $tmplName.tmpl not found or template directory \n" - . "$TWiki::templateDir not found.

\n" - . "Check the \$templateDir variable in TWiki.cfg.\n" - . "\n"; - return; + $tmplData = "\n" + . "

TWiki Installation Error

\n" + . "Template file $tmplName.tmpl not found or template directory \n" + . "$TWiki::templateDir not found.

\n" + . "Check the \$templateDir variable in TWiki.cfg.\n" + . "\n"; + } else { + my $param = $query->param( 'param1' ) || ""; + $tmplData =~ s/%PARAM1%/$param/go; + $param = $query->param( 'param2' ) || ""; + $tmplData =~ s/%PARAM2%/$param/go; + $param = $query->param( 'param3' ) || ""; + $tmplData =~ s/%PARAM3%/$param/go; + $param = $query->param( 'param4' ) || ""; + $tmplData =~ s/%PARAM4%/$param/go; + + $tmplData = TWiki::handleCommonTags( $tmplData, $topic ); + $tmplData = TWiki::Render::getRenderedVersion( $tmplData ); + $tmplData =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags } - my $param = $query->param( 'param1' ) || ""; - $tmplData =~ s/%PARAM1%/$param/go; - $param = $query->param( 'param2' ) || ""; - $tmplData =~ s/%PARAM2%/$param/go; - $param = $query->param( 'param3' ) || ""; - $tmplData =~ s/%PARAM3%/$param/go; - $param = $query->param( 'param4' ) || ""; - $tmplData =~ s/%PARAM4%/$param/go; - - $tmplData = &TWiki::handleCommonTags( $tmplData, $topic ); - $tmplData = &TWiki::Render::getRenderedVersion( $tmplData ); - $tmplData =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - - TWiki::writeHeader( $query ); + TWiki::writeHeader( $query, length( $tmplData )); print $tmplData; } Index: lib/TWiki/UI/Preview.pm =================================================================== --- lib/TWiki/UI/Preview.pm (revision 1767) +++ lib/TWiki/UI/Preview.pm (working copy) @@ -18,11 +18,12 @@ use strict; use TWiki; use TWiki::UI; +use TWiki::Templates; sub preview { my ( $webName, $topic, $userName, $query ) = @_; - my $skin = $query->param( "skin" ); + my $skin = TWiki::getSkin(); my $changeform = $query->param( 'submitChangeForm' ) || ""; my $dontNotify = $query->param( "dontnotify" ) || ""; my $saveCmd = $query->param( "cmd" ) || ""; @@ -37,15 +38,13 @@ my $ptext = ""; my $meta = ""; my $formFields = ""; - my $wikiUserName = &TWiki::userToWikiName( $userName ); + my $wikiUserName = TWiki::User::userToWikiName( $userName ); return if TWiki::UI::isMirror( $webName, $topic ); # reset lock time, this is to prevent contention in case of a long edit session - &TWiki::Store::lockTopic( $topic ); + TWiki::Store::lockTopic( $webName, $topic ); - $skin = &TWiki::Prefs::getPreferencesValue( "SKIN" ) unless( $skin ); - # Is user looking to change the form used? Sits oddly in preview, but # to avoid Javascript and pick up text on edit page it has to be in preview. if( $changeform ) { @@ -54,7 +53,7 @@ } # get view template, standard view or a view with a different skin - $tmpl = &TWiki::Store::readTemplate( "preview", $skin ); + $tmpl = &TWiki::Templates::readTemplate( "preview", $skin ); $tmpl =~ s/%DONTNOTIFY%/$dontNotify/go; if( $saveCmd ) { return unless TWiki::UI::userIsAdmin( $webName, $topic, $wikiUserName ); @@ -105,7 +104,7 @@ } my @verbatim = (); - $ptext = &TWiki::takeOutVerbatim( $ptext, \@verbatim ); + $ptext = TWiki::Render::takeOutBlocks( $ptext, "verbatim", \@verbatim ); $ptext =~ s/ {3}/\t/go; $ptext = &TWiki::Prefs::updateSetFromForm( $meta, $ptext ); $ptext = &TWiki::handleCommonTags( $ptext, $topic ); @@ -118,10 +117,12 @@ $ptext =~ s@@

\n@goi; $ptext =~ s@(?<=<)([^\s]+?[^>]*)(onclick=(?:"location.href='.*?'"|location.href='[^']*?'(?=[\s>])))@$1onclick="location.href='$oopsUrl\?template=oopspreview'"@goi; - $ptext = &TWiki::putBackVerbatim( $ptext, "pre", @verbatim ); + $ptext = TWiki::Render::putBackBlocks( $ptext, \@verbatim, + "verbatim", "pre", + \&TWiki::Render::verbatimCallBack ); $tmpl = &TWiki::handleCommonTags( $tmpl, $topic ); - $tmpl = &TWiki::handleMetaTags( $webName, $topic, $tmpl, $meta ); + $tmpl = TWiki::Render::renderMetaTags( $webName, $topic, $tmpl, $meta, 0 ); $tmpl = &TWiki::Render::getRenderedVersion( $tmpl ); $tmpl =~ s/%TEXT%/$ptext/go; @@ -131,7 +132,7 @@ $tmpl =~ s/%FORMFIELDS%/$formFields/go; $tmpl =~ s/( ?) *<\/?(nop|noautolink)\/?>\n?/$1/gois; # remove and tags - &TWiki::writeHeader( $query ); + TWiki::writeHeader( $query, length( $tmpl )); print $tmpl; } Index: lib/TWiki/Form.pm =================================================================== --- lib/TWiki/Form.pm (revision 1767) +++ lib/TWiki/Form.pm (working copy) @@ -28,21 +28,14 @@ use strict; +use TWiki::Templates; # ============================ # Get definition from supplied topic text # Returns array of arrays # 1st - list fields # 2nd - name, title, type, size, vals, tooltip, setting -=pod - ----++ sub getFormDefinition ( $text ) - -Not yet documented. - -=cut - -sub getFormDefinition +sub _parseFormDefinition { my( $text ) = @_; @@ -117,13 +110,11 @@ } -# ============================ -# Possible field values for select, checkbox, radio from supplied topic text =pod ---++ sub getPossibleFieldValues ( $text ) -Not yet documented. +Possible field values for select, checkbox, radio from supplied topic text =cut @@ -156,14 +147,12 @@ } -# ============================ -# Get array of field definition, given form name -# If form contains Web this overrides webName =pod ---++ sub getFormDef ( $webName, $form ) -Not yet documented. +Get array of field definition, given form name +If form contains Web this overrides webName =cut @@ -181,7 +170,7 @@ # Read topic that defines the form if( &TWiki::Store::topicExists( $webName, $form ) ) { my( $meta, $text ) = &TWiki::Store::readTopic( $webName, $form ); - @fieldDefs = getFormDefinition( $text ); + @fieldDefs = _parseFormDefinition( $text ); } else { # FIXME - do what if there is an error? } @@ -250,7 +239,7 @@ my $link = "$name"; if( &TWiki::Store::topicExists( $web, $name ) ) { - ( $web, $name ) = &TWiki::Store::normalizeWebTopicName( $web, $name ); + ( $web, $name ) = TWiki::normalizeWebTopicName( $web, $name ); if( ! $tooltip ) { $tooltip = "Click to see details in separate window"; } @@ -282,13 +271,11 @@ } -# ============================ -# Render form information =pod ---++ sub renderForEdit ( $web, $topic, $form, $meta, $query, $getValuesFromFormTopic, @fieldsInfo ) -Not yet documented. +Render form information =cut @@ -304,7 +291,7 @@ # FIXME could do with some of this being in template my $text = "
\n " . _link( $web, $form, "", "h", "", 2, $chooseForm ) . "\n"; - + fieldVars2Meta( $web, $query, $meta, "override" ); foreach my $c ( @fieldsInfo ) { @@ -449,50 +436,29 @@ } -# ============================= =pod ----++ sub getFormInfoFromMeta ( $webName, $meta ) +---++ sub fieldVars2Meta +Extract new values of form fields from a query. -Not yet documented. +Note that existing meta information for fields is removed unless $justOverride is true =cut -sub getFormInfoFromMeta +sub fieldVars2Meta { - my( $webName, $meta ) = @_; - + my( $webName, $query, $meta, $justOverride ) = @_; + + $meta->remove( "FIELD" ) if( ! $justOverride ); + + #TWiki::writeDebug( "Form::fieldVars2Meta " . $query->query_string ); + my @fieldsInfo = (); - my %form = $meta->findOne( "FORM" ); if( %form ) { - @fieldsInfo = getFormDef( $webName, $form{"name"} ); + @fieldsInfo = getFormDef( $webName, $form{"name"} ); } - - return @fieldsInfo; -} - -# ============================= -# Form parameters to meta -# Note that existing meta information for fields is removed unless $justOverride is true -=pod - ----++ sub fieldVars2Meta ( $webName, $query, $meta, $justOverride ) - -Not yet documented. - -=cut - -sub fieldVars2Meta -{ - my( $webName, $query, $meta, $justOverride ) = @_; - - $meta->remove( "FIELD" ) if( ! $justOverride ); - - #TWiki::writeDebug( "Form::fieldVars2Meta " . $query->query_string ); - - my @fieldsInfo = getFormInfoFromMeta( $webName, $meta ); foreach my $fieldInfop ( @fieldsInfo ) { my @fieldInfo = @$fieldInfop; my $fieldName = shift @fieldInfo; @@ -572,13 +538,11 @@ } -# ============================= -# Called by script to change the form for a topic =pod ---++ sub changeForm ( $theWeb, $theTopic, $theQuery ) -Not yet documented. +Called by script to change the form for a topic =cut @@ -586,12 +550,11 @@ { my( $theWeb, $theTopic, $theQuery ) = @_; - my $tmpl = &TWiki::Store::readTemplate( "changeform" ); - &TWiki::writeHeader( $theQuery ); - $tmpl = &TWiki::handleCommonTags( $tmpl, $theTopic ); - $tmpl = &TWiki::Render::getRenderedVersion( $tmpl ); + my $tmpl = TWiki::Templates::readTemplate( "changeform" ); + $tmpl = TWiki::handleCommonTags( $tmpl, $theTopic ); + $tmpl = TWiki::Render::getRenderedVersion( $tmpl ); my $text = $theQuery->param( 'text' ); - $text = &TWiki::Render::encodeSpecialChars( $text ); + $text = TWiki::Render::encodeSpecialChars( $text ); $tmpl =~ s/%TEXT%/$text/go; my $listForms = TWiki::Prefs::getPreferencesValue( "WEBFORMS", "$theWeb" ); @@ -599,7 +562,7 @@ $listForms =~ s/\s*$//go; my @forms = split( /\s*,\s*/, $listForms ); unshift @forms, ""; - my( $metat, $tmp ) = &TWiki::Store::readTopic( $theWeb, $theTopic ); + my( $metat, $tmp ) = TWiki::Store::readTopic( $theWeb, $theTopic ); my $formName = $theQuery->param( 'formtemplate' ) || ""; if( ! $formName ) { my %form = $metat->findOne( "FORM" ); @@ -622,21 +585,14 @@ $tmpl =~ s|||goi; + TWiki::writeHeader( $theQuery, length( $tmpl )); print $tmpl; } # ============================ # load old style category table item -=pod - ----++ sub upgradeCategoryItem ( $catitems, $ctext ) - -Not yet documented. - -=cut - -sub upgradeCategoryItem +sub _upgradeCategoryItem { my ( $catitems, $ctext ) = @_; my $catname = ""; @@ -716,15 +672,11 @@ return ( $catname, $catmodifier, $catvalue ) } - - -# ============================ -# load old style category table =pod ---++ sub upgradeCategoryTable ( $web, $topic, $meta, $text ) -Not yet documented. +load old style category table =cut @@ -732,7 +684,7 @@ { my( $web, $topic, $meta, $text ) = @_; - my $icat = &TWiki::Store::readTemplate( "twikicatitems" ); + my $icat = TWiki::Templates::readTemplate( "twikicatitems" ); if( $icat ) { my @items = (); @@ -746,7 +698,7 @@ my $ttext = ""; foreach( split( /\n/, $icat ) ) { - my( $catname, $catmod, $catvalue ) = upgradeCategoryItem( $_, $ctext ); + my( $catname, $catmod, $catvalue ) = _upgradeCategoryItem( $_, $ctext ); #TWiki::writeDebug( "Form: name, mod, value: $catname, $catmod, $catvalue" ); if( $catname ) { push @items, ( [$catname, $catmod, $catvalue] ); @@ -761,7 +713,7 @@ $defaultFormTemplate = $formTemplates[0] if ( @formTemplates ); if( ! $defaultFormTemplate ) { - &TWiki::writeWarning( "Form: can't get form definition to convert category table " . + TWiki::writeWarning( "Form: can't get form definition to convert category table " . " for topic $web.$topic" ); foreach my $oldCat ( @items ) { @@ -796,7 +748,7 @@ } } else { - &TWiki::writeWarning( "Form: get find category template twikicatitems for Web $web" ); + TWiki::writeWarning( "Form: get find category template twikicatitems for Web $web" ); } return $text; Index: lib/TWiki/User/HtPasswdUser.pm =================================================================== --- lib/TWiki/User/HtPasswdUser.pm (revision 1767) +++ lib/TWiki/User/HtPasswdUser.pm (working copy) @@ -57,10 +57,6 @@ } } -# FIXME: Move elsewhere? -# template variable hash: (built from %TMPL:DEF{"key"}% ... %TMPL:END%) -use vars qw( %templateVars ); # init in TWiki.pm so okay for modPerl - # ====================== sub new { Index: lib/TWiki/User/NoPasswdUser.pm =================================================================== --- lib/TWiki/User/NoPasswdUser.pm (revision 1767) +++ lib/TWiki/User/NoPasswdUser.pm (working copy) @@ -50,10 +50,6 @@ } } -# FIXME: Move elsewhere? -# template variable hash: (built from %TMPL:DEF{"key"}% ... %TMPL:END%) -use vars qw( %templateVars ); # init in TWiki.pm so okay for modPerl - # ====================== sub new { Index: bin/register =================================================================== --- bin/register (revision 1767) +++ bin/register (working copy) @@ -212,7 +212,7 @@ # write log entry if( $TWiki::doLogRegistration ) { - &TWiki::Store::writeLog( "register", "$webName.$wikiName", $emailAddress, $wikiName ); + TWiki::writeLog( "register", "$webName.$wikiName", $emailAddress, $wikiName ); } if( $senderr ) { Index: bin/installpasswd =================================================================== --- bin/installpasswd (revision 1767) +++ bin/installpasswd (working copy) @@ -147,7 +147,7 @@ { my ($webName, $topic, $userName) = @_; - my $wikiUserName = &TWiki::userToWikiName( $userName ); + my $wikiUserName = &TWiki::User::userToWikiName( $userName ); if( ! &TWiki::Access::userIsInGroup( $wikiUserName, $TWiki::superAdminGroup ) ) { # user has no permission to install the password Index: bin/view =================================================================== --- bin/view (revision 1767) +++ bin/view (working copy) @@ -1,4 +1,4 @@ -#!/usr/bin/perl -wT +#!/usr/bin/perl # # TWiki Collaboration Platform, http://TWiki.org/ # Index: bin/mailnotify =================================================================== --- bin/mailnotify (revision 1767) +++ bin/mailnotify (working copy) @@ -151,7 +151,7 @@ # Create entry in HTML attachment $newText = $text; $newText =~ s/%TOPICNAME%/$topicName/go; - $wikiuser = &TWiki::userToWikiName( $userName ); + $wikiuser = &TWiki::User::userToWikiName( $userName ); $newText =~ s/%AUTHOR%/$wikiuser/go; $newText =~ s/%LOCKED%//go; @@ -218,3 +218,103 @@ $debug && print "- End TWiki.$webName, mail notification sent\n"; } } + +=pod + +---++ getEmailNotifyList( $webName, $topicName ) +Return value: @emailNotifyList + +Get email list from WebNotify page - this now handles entries of the form: + * Main.UserName + * UserName + * Main.GroupName + * GroupName +The 'UserName' format (i.e. no Main webname) is supported in any web, but +is not recommended since this may make future data conversions more +complicated, especially if used outside the Main web. %MAINWEB% is OK +instead of 'Main'. The user's email address(es) are fetched from their +user topic (home page) as long as they are listed in the '* Email: +fred@example.com' format. Nested groups are supported. + +=cut + +sub getEmailNotifyList +{ + my( $web, $topicname ) = @_; + + $topicname = $notifyTopicname unless $topicname; + return() unless &TWiki::Store::topicExists( $web, $topicname ); + + # Allow %MAINWEB% as well as 'Main' in front of users/groups - + # non-capturing regex. + my $mainWebPattern = qr/(?:$mainWebname|%MAINWEB%)/; + + my @list = (); + my %seen; # Incremented when email address is seen + foreach ( split ( /\n/, TWiki::Store::readWebTopic( $web, $topicname ) ) ) { + if ( /^\s+\*\s(?:$mainWebPattern\.)?($regex{wikiWordRegex})\s+\-\s+($regex{emailAddrRegex})/o ) { + # Got full form: * Main.WikiName - email@domain + # (the 'Main.' part is optional, non-capturing) + if ( $1 ne 'TWikiGuest' ) { + # Add email address to list if non-guest and non-duplicate + push (@list, $2) unless $seen{$1}++; + } + } elsif ( /^\s+\*\s(?:$mainWebPattern\.)?($regex{wikiWordRegex})\s*$/o ) { + # Got short form: * Main.WikiName + # (the 'Main.' part is optional, non-capturing) + my $userWikiName = $1; + foreach ( getEmailOfUser($userWikiName) ) { + # Add email address to list if it's not a duplicate + push (@list, $_) unless $seen{$_}++; + } + } + } + ##writeDebug "list of emails: @list"; + return( @list); +} + +=pod + +---++ getEmailOfUser( $wikiName ) +Return value: ( $userEmail ) or @groupEmailList + +Get e-mail address for a given WikiName from the user's home page, or +list of e-mail addresses for a group. Nested groups are supported. +$wikiName must contain _only_ the WikiName; do *not* pass names of the +form "Main.JohnSmith". + +=cut + +sub getEmailOfUser +{ + my( $wikiName ) = @_; # WikiName without web prefix + + my @list = (); + # Ignore guest entry and non-existent pages + if ( $wikiName ne "TWikiGuest" && + TWiki::Store::topicExists( $mainWebname, $wikiName ) ) { + if ( $wikiName =~ /Group$/ ) { + # Page is for a group, get all users in group + ##writeDebug "using group: $mainWebname . $wikiName"; + my @userList = TWiki::Access::getUsersOfGroup( $wikiName ); + foreach my $user ( @userList ) { + $user =~ s/^.*\.//; # Get rid of 'Main.' part. + foreach my $email ( getEmailOfUser($user) ) { + push @list, $email; + } + } + } else { + # Page is for a user + ##writeDebug "reading home page: $mainWebname . $wikiName"; + foreach ( split ( /\n/, &TWiki::Store::readWebTopic( + $mainWebname, $wikiName ) ) ) { + if (/^\s\*\sEmail:\s+([\w\-\.\+]+\@[\w\-\.\+]+)/) { + # Add email address to list + push @list, $1; + } + } + } + } + return (@list); +}