wiki.pl

   1 #! /usr/bin/perl
   2 # Copyright (C) 2001-2013
   3 #     Alex Schroeder <alex@gnu.org>
   4 # Copyleft      2008 Brian Curry <http://www.raiazome.com>
   5 # ... including lots of patches from the UseModWiki site
   6 # Copyright (C) 2001, 2002  various authors
   7 # ... which was based on UseModWiki version 0.92 (April 21, 2001)
   8 # Copyright (C) 2000, 2001  Clifford A. Adams
   9 #    <caadams@frontiernet.net> or <usemod@usemod.com>
  10 # ... which was based on the GPLed AtisWiki 0.3
  11 # Copyright (C) 1998  Markus Denker <marcus@ira.uka.de>
  12 # ... which was based on the LGPLed CVWiki CVS-patches
  13 # Copyright (C) 1997  Peter Merel
  14 # ... and The Original WikiWikiWeb
  15 # Copyright (C) 1996, 1997  Ward Cunningham <ward@c2.com>
  16 #     (code reused with permission)
  17
  18 # This program is free software: you can redistribute it and/or modify it under
  19 # the terms of the GNU General Public License as published by the Free Software
  20 # Foundation, either version 3 of the License, or (at your option) any later
  21 # version.
  22 #
  23 # This program is distributed in the hope that it will be useful, but WITHOUT
  24 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  25 # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  26 #
  27 # You should have received a copy of the GNU General Public License along with
  28 # this program. If not, see <http://www.gnu.org/licenses/>.
  29
  30 package OddMuse;
  31 use strict;
  32 use utf8; # in case anybody ever addes UTF8 characters to the source
  33 use CGI qw/-utf8/;
  34 use CGI::Carp qw(fatalsToBrowser);
  35 use File::Glob ':glob';
  36 local $| = 1;  # Do not buffer output (localized for mod_perl)
  37
  38 # Options:
  39 use vars qw($RssLicense $RssCacheHours @RcDays $TempDir $LockDir $DataDir
  40 $KeepDir $PageDir $RcOldFile $IndexFile $BannedContent $NoEditFile $BannedHosts
  41 $ConfigFile $FullUrl $SiteName $HomePage $LogoUrl $RcDefault $RssDir
  42 $IndentLimit $RecentTop $RecentLink $EditAllowed $UseDiff $KeepDays $KeepMajor
  43 $EmbedWiki $BracketText $UseConfig $UseLookup $AdminPass $EditPass $NetworkFile
  44 $BracketWiki $FreeLinks $WikiLinks $SummaryHours $FreeLinkPattern $RCName
  45 $RunCGI $ShowEdits $LinkPattern $RssExclude $InterLinkPattern $MaxPost $UseGrep
  46 $UrlPattern $UrlProtocols $ImageExtensions $InterSitePattern $FS $CookieName
  47 $SiteBase $StyleSheet $NotFoundPg $FooterNote $NewText $EditNote $UserGotoBar
  48 $VisitorFile $RcFile %Smilies %SpecialDays $InterWikiMoniker $SiteDescription
  49 $RssImageUrl $ReadMe $RssRights $BannedCanRead $SurgeProtection $TopLinkBar
  50 $LanguageLimit $SurgeProtectionTime $SurgeProtectionViews $DeletedPage
  51 %Languages $InterMap $ValidatorLink %LockOnCreation $RssStyleSheet
  52 %CookieParameters @UserGotoBarPages $NewComment $HtmlHeaders $StyleSheetPage
  53 $ConfigPage $ScriptName $CommentsPrefix @UploadTypes $AllNetworkFiles
  54 $UsePathInfo $UploadAllowed $LastUpdate $PageCluster %PlainTextPages
  55 $RssInterwikiTranslate $UseCache $Counter $ModuleDir $FullUrlPattern
  56 $SummaryDefaultLength $FreeInterLinkPattern %InvisibleCookieParameters
  57 %AdminPages $UseQuestionmark $JournalLimit $LockExpiration $RssStrip
  58 %LockExpires @IndexOptions @Debugging $DocumentHeader %HtmlEnvironmentContainers
  59 @MyAdminCode @MyFooters @MyInitVariables @MyMacros @MyMaintenance @MyRules
  60 $Favicon @EditorGotoBarPages $EditorGotoBar @ExploreGotoBarPages $ExploreGotoBar);
  61
  62 # Internal variables:
  63 use vars qw(%Page %InterSite %IndexHash %Translate %OldCookie $FootnoteNumber
  64 $OpenPageName @IndexList $Message $q $Now %RecentVisitors @HtmlStack
  65 @HtmlAttrStack $ReplaceForm %MyInc $CollectingJournal $bol $WikiDescription
  66 $PrintedHeader %Locks $Fragment @Blocks @Flags $Today @KnownLocks
  67 $ModulesDescription %Action %RuleOrder %Includes %RssInterwikiTranslate);
  68
  69 # Can be set outside the script: $DataDir, $UseConfig, $ConfigFile, $ModuleDir,
  70 # $ConfigPage, $AdminPass, $EditPass, $ScriptName, $FullUrl, $RunCGI.
  71
  72 # 1 = load config file in the data directory
  73 $UseConfig   = 1 unless defined $UseConfig;
  74
  75 # Main wiki directory
  76 $DataDir     = $ENV{WikiDataDir} if $UseConfig and not $DataDir;
  77 $DataDir     = '/tmp/oddmuse' unless $DataDir; # FIXME: /var/opt/oddmuse/wiki ?
  78 $ConfigPage  = '' unless $ConfigPage; # config page
  79
  80 # 1 = Run script as CGI instead of loading as module
  81 $RunCGI      = 1  unless defined $RunCGI;
  82
  83 # 1 = allow page views using wiki.pl/PageName
  84 $UsePathInfo = 1;
  85
  86 # -1 = disabled, 0 = 10s; 1 = partial HTML cache; 2 = HTTP/1.1 caching
  87 $UseCache    = 2;
  88
  89 $SiteName    = 'Wiki';          # Name of site (used for titles)
  90 $HomePage    = 'HomePage';      # Home page
  91 $CookieName  = 'Wiki';          # Name for this wiki (for multi-wiki sites)
  92
  93 $SiteBase    = '';              # Full URL for <BASE> header
  94 $MaxPost     = 1024 * 210;      # Maximum 210K posts (about 200K for pages)
  95 $StyleSheet  = '';              # URL for CSS stylesheet (like '/wiki.css')
  96 $StyleSheetPage = 'css';        # Page for CSS sheet
  97 $LogoUrl     = '';              # URL for site logo ('' for no logo)
  98 $Favicon     = '';              # URL for favicon   ('' for no icon)
  99 $NotFoundPg  = '';              # Page for not-found links ('' for blank pg)
 100
 101 $NewText     = "This page is empty.\n";  # New page text
 102 $NewComment  = "Add your comment here.\n";       # New comment text
 103
 104 $EditAllowed = 1; # 0 = no, 1 = yes, 2 = comments pages only, 3 = comments only
 105 $AdminPass   = '' unless defined $AdminPass; # Whitespace separated passwords.
 106 $EditPass    = '' unless defined $EditPass;  # Whitespace separated passwords.
 107
 108 $BannedHosts = 'BannedHosts';   # Page for banned hosts
 109 $BannedCanRead = 1;             # 1 = banned cannot edit, 0 = banned cannot read
 110 $BannedContent = 'BannedContent'; # Page for banned content (usually for link-ban)
 111 $WikiLinks   = 1;               # 1 = LinkPattern is a link
 112 $FreeLinks   = 1;               # 1 = [[some text]] is a link
 113 $UseQuestionmark = 1;           # 1 = append questionmark to links to nonexisting pages
 114 $BracketText = 1;               # 1 = [URL desc] uses a description for the URL
 115 $BracketWiki = 1;               # 1 = [WikiLink desc] uses a desc for the local link
 116 $NetworkFile = 1;               # 1 = file: is a valid protocol for URLs
 117 $AllNetworkFiles = 0;           # 1 = file:///foo is allowed -- the default allows only file://foo
 118 $InterMap    = 'InterMap';      # name of the intermap page, '' = disable
 119 $RssInterwikiTranslate = 'RssInterwikiTranslate'; # name of RSS interwiki translation page, '' = disable
 120 $ENV{PATH}   = '/bin:/usr/bin'; # Path used to find 'diff' and 'grep'
 121 $UseDiff     = 1;               # 1 = use diff
 122 $UseGrep     = 1;               # 1 = use grep to speed up searches
 123 $SurgeProtection      = 1;      # 1 = protect against leeches
 124 $SurgeProtectionTime  = 20;     # Size of the protected window in seconds
 125 $SurgeProtectionViews = 10;     # How many page views to allow in this window
 126 $DeletedPage = 'DeletedPage';   # Pages starting with this can be deleted
 127 $RCName      = 'RecentChanges'; # Name of changes page
 128 @RcDays      = qw(1 3 7 30 90); # Days for links on RecentChanges
 129 $RcDefault   = 30;              # Default number of RecentChanges days
 130 $KeepDays    = 14;              # Days to keep old revisions
 131 $KeepMajor   = 1;               # 1 = keep at least one major rev when expiring pages
 132 $SummaryHours = 4;              # Hours to offer the old subject when editing a page
 133 $SummaryDefaultLength = 150;    # Length of default text for summary (0 to disable)
 134 $ShowEdits   = 0;               # 1 = major and show minor edits in recent changes
 135 $UseLookup   = 1;               # 1 = lookup host names instead of using only IP numbers
 136 $RecentTop   = 1;               # 1 = most recent entries at the top of the list
 137 $RecentLink  = 1;               # 1 = link to usernames
 138 $PageCluster = '';              # name of cluster page, eg. 'Cluster' to enable
 139 $InterWikiMoniker = '';         # InterWiki prefix for this wiki for RSS
 140 $SiteDescription  = '';         # RSS Description of this wiki
 141 $RssStrip = '^\d\d\d\d-\d\d-\d\d_'; # Regexp to strip from feed item titles
 142 $RssImageUrl      = $LogoUrl;   # URL to image to associate with your RSS feed
 143 $RssRights        = '';         # Copyright notice for RSS, usually an URL to the appropriate text
 144 $RssExclude       = 'RssExclude'; # name of the page that lists pages to be excluded from the feed
 145 $RssCacheHours    =  1;         # How many hours to cache remote RSS files
 146 $RssStyleSheet    = '';         # External style sheet for RSS files
 147 $UploadAllowed    = 0;          # 1 = yes, 0 = administrators only
 148 @UploadTypes = ('image/jpeg',   # MIME types allowed, all allowed if empty list
 149                 'image/png',
 150                 'image/vnd.microsoft.icon');
 151 $EmbedWiki   = 0;               # 1 = no headers/footers
 152 $FooterNote  = '';              # HTML for bottom of every page
 153 $EditNote    = '';              # HTML notice above buttons on edit page
 154 $TopLinkBar  = 1;               # Pick and choose what gets displayed on top
 155                                 # Summary of useful values.
 156                                 # +-------+---------+---------+------+
 157                                 # | Value | EditBar | GotoBar | Motd |
 158                                 # |-------+---------+---------+------|
 159                                 # |     0 | No      | No      | No   |
 160                                 # |     1 | No      | Yes     | Yes  |
 161                                 # |     2 | Yes     | No      | Yes  |
 162                                 # |     3 | Yes     | Yes     | Yes  |
 163                                 # +-------+---------+---------+------+
 164 @UserGotoBarPages = ();         # List of pagenames
 165 $UserGotoBar = '';              # HTML added to end of goto bar
 166 @EditorGotoBarPages = ();       # List of pagenames available only to editors
 167 $EditorGotoBar = '';            # HTML added to end of editor goto bar
 168 @ExploreGotoBarPages = ();       # List of pagenames available only to editors
 169 $ExploreGotoBar = '';            # HTML added to end of editor goto bar
 170 $ValidatorLink = 0;             # 1 = Link to the W3C HTML validator service
 171 $CommentsPrefix = '';           # prefix for comment pages, eg. 'Comments_on_' to enable
 172 $HtmlHeaders = '';              # Additional stuff to put in the HTML <head> section
 173 $IndentLimit = 20;              # Maximum depth of nested lists
 174 $LanguageLimit = 3;             # Number of matches req. for each language
 175 $JournalLimit = 200;            # how many pages can be collected in one go?
 176 $DocumentHeader = qq(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN")
 177   . qq( "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">\n)
 178   . qq(<html xmlns="http://www.w3.org/1999/xhtml">);
 179 # Checkboxes at the end of the index.
 180 @IndexOptions = (['pages', T('Include normal pages'), 1, \&AllPagesList]);
 181 # Display short comments below the GotoBar for special days
 182 # Example: %SpecialDays = ('1-1' => 'New Year', '1-2' => 'Next Day');
 183 %SpecialDays = ();
 184 # Replace regular expressions with inlined images
 185 # Example: %Smilies = (":-?D(?=\\W)" => '/pics/grin.png');
 186 %Smilies = ();
 187 # Detect page languages when saving edits
 188 # Example: %Languages = ('de' => '\b(der|die|das|und|oder)\b');
 189 %Languages = ();
 190 @KnownLocks = qw(main diff index merge visitors); # locks to remove
 191 $LockExpiration = 60; # How long before expirable locks are expired
 192 %LockExpires = (diff=>1, index=>1, merge=>1, visitors=>1); # locks to expire after some time
 193 %CookieParameters = (username=>'', pwd=>'', homepage=>'', theme=>'', css=>'', msg=>'',
 194                     lang=>'', toplinkbar=>$TopLinkBar, embed=>$EmbedWiki, );
 195 %InvisibleCookieParameters = (msg=>1, pwd=>1,);
 196 %Action = (rc => \&BrowseRc,               rollback => \&DoRollback,
 197            browse => \&BrowseResolvedPage, maintain => \&DoMaintain,
 198            random => \&DoRandom,           pagelock => \&DoPageLock,
 199            history => \&DoHistory,         editlock => \&DoEditLock,
 200            edit => \&DoEdit,               version => \&DoShowVersion,
 201            download => \&DoDownload,       rss => \&DoRss,
 202            unlock => \&DoUnlock,           password => \&DoPassword,
 203            index => \&DoIndex,             admin => \&DoAdminPage,
 204            clear => \&DoClearCache,        debug => \&DoDebug,
 205            contrib => \&DoContributors,    more => \&DoJournal);
 206 @MyRules = (\&LinkRules, \&ListRule); # don't set this variable, add to it!
 207 %RuleOrder = (\&LinkRules => 0, \&ListRule => 0);
 208
 209 # The 'main' program, called at the end of this script file (aka. as handler)
 210 sub DoWikiRequest {
 211   Init();
 212   DoSurgeProtection();
 213   if (not $BannedCanRead and UserIsBanned() and not UserIsEditor()) {
 214     ReportError(T('Reading not allowed: user, ip, or network is blocked.'), '403 FORBIDDEN',
 215     0, $q->p(ScriptLink('action=password', T('Login'), 'password')));
 216   }
 217   DoBrowseRequest();
 218 }
 219
 220 sub ReportError {   # fatal!
 221   my ($errmsg, $status, $log, @html) = @_;
 222   InitRequest(); # make sure we can report errors before InitRequest
 223   print GetHttpHeader('text/html', 'nocache', $status), GetHtmlHeader(T('Error')),
 224     $q->start_div({class=>"error"}), $q->h1(QuoteHtml($errmsg)), @html, $q->end_div,
 225       $q->end_html, "\n\n"; # newlines for FCGI because of exit()
 226   WriteStringToFile("$TempDir/error", '<body>' . $q->h1("$status $errmsg") . $q->Dump) if $log;
 227   map { ReleaseLockDir($_); } keys %Locks;
 228   exit (2);
 229 }
 230
 231 sub Init {
 232   binmode(STDOUT, ':utf8'); # this is where the HTML gets printed
 233   binmode(STDERR, ':utf8'); # just in case somebody prints debug info to stderr
 234   InitDirConfig();
 235   $FS  = "\x1e"; # The FS character is the RECORD SEPARATOR control char in ASCII
 236   $Message = ''; # Warnings and non-fatal errors.
 237   InitLinkPatterns(); # Link pattern can be changed in config files
 238   InitModules(); # Modules come first so that users can change module variables in config
 239   InitConfig(); # Config comes as early as possible; remember $q is not available here
 240   InitRequest(); # get $q with $MaxPost; set these in the config file
 241   InitCookie(); # After InitRequest, because $q is used
 242   InitVariables(); # After config, to change variables, after InitCookie for GetParam
 243 }
 244
 245 sub InitModules {
 246   if ($UseConfig and $ModuleDir and -d $ModuleDir) {
 247     foreach my $lib (bsd_glob("$ModuleDir/*.p[ml]")) {
 248       do $lib unless $MyInc{$lib};
 249       $MyInc{$lib} = 1;   # Cannot use %INC in mod_perl settings
 250       $Message .= CGI::p("$lib: $@") if $@; # no $q exists, yet
 251     }
 252   }
 253 }
 254
 255 sub InitConfig {
 256   if ($UseConfig and $ConfigFile and not $INC{$ConfigFile} and -f $ConfigFile) {
 257     do $ConfigFile; # these options must be set in a wrapper script or via the environment
 258     $Message .= CGI::p("$ConfigFile: $@") if $@; # remember, no $q exists, yet
 259   }
 260   if ($ConfigPage) { # $FS and $MaxPost must be set in config file!
 261     my ($status, $data) = ReadFile(GetPageFile(FreeToNormal($ConfigPage)));
 262     my %data = ParseData($data); # before InitVariables so GetPageContent won't work
 263     eval $data{text} if $data{text};
 264     $Message .= CGI::p("$ConfigPage: $@") if $@;
 265   }
 266 }
 267
 268 sub InitDirConfig {
 269   utf8::decode($DataDir); # just in case, eg. "WikiDataDir=/tmp/Zürich♥ perl wiki.pl"
 270   $PageDir     = "$DataDir/page";  # Stores page data
 271   $KeepDir     = "$DataDir/keep";  # Stores kept (old) page data
 272   $TempDir     = "$DataDir/temp";  # Temporary files and locks
 273   $LockDir     = "$TempDir/lock";  # DB is locked if this exists
 274   $NoEditFile  = "$DataDir/noedit"; # Indicates that the site is read-only
 275   $RcFile      = "$DataDir/rc.log"; # New RecentChanges logfile
 276   $RcOldFile   = "$DataDir/oldrc.log";   # Old RecentChanges logfile
 277   $IndexFile   = "$DataDir/pageidx";   # List of all pages
 278   $VisitorFile = "$DataDir/visitors.log"; # List of recent visitors
 279   $RssDir      = "$DataDir/rss";    # For rss feed cache
 280   $ReadMe      = "$DataDir/README"; # file with default content for the HomePage
 281   # Config file with Perl code to execute
 282   $ConfigFile  = "$DataDir/config" unless $ConfigFile;
 283   # For extensions (ending in .pm or .pl)
 284   $ModuleDir   = "$DataDir/modules" unless $ModuleDir;
 285 }
 286
 287 sub InitRequest { # set up $q
 288   $CGI::POST_MAX = $MaxPost;
 289   $q = new CGI unless $q;
 290 }
 291
 292 sub InitVariables {  # Init global session variables for mod_perl!
 293   $WikiDescription = $q->p($q->a({-href=>'http://www.oddmuse.org/'}, 'Oddmuse'),
 294          $Counter++ > 0 ? Ts('%s calls', $Counter) : '');
 295   $WikiDescription .= $ModulesDescription if $ModulesDescription;
 296   $PrintedHeader = 0; # Error messages don't print headers unless necessary
 297   $ReplaceForm = 0;   # Only admins may search and replace
 298   $ScriptName = $q->url() unless defined $ScriptName; # URL used in links
 299   $FullUrl = $ScriptName unless $FullUrl; # URL used in forms
 300   %Locks = ();
 301   @Blocks = ();
 302   @Flags = ();
 303   $Fragment = '';
 304   %RecentVisitors = ();
 305   $OpenPageName = '';   # Currently open page
 306   my $add_space = $CommentsPrefix =~ /[ \t_]$/;
 307   map { $$_ = FreeToNormal($$_); } # convert spaces to underscores on all configurable pagenames
 308     (\$HomePage, \$RCName, \$BannedHosts, \$InterMap, \$StyleSheetPage, \$CommentsPrefix,
 309      \$ConfigPage, \$NotFoundPg, \$RssInterwikiTranslate, \$BannedContent, \$RssExclude, );
 310   $CommentsPrefix .= '_' if $add_space;
 311   @UserGotoBarPages = ($HomePage) unless @UserGotoBarPages;
 312   @ExploreGotoBarPages = ($RCName) unless @ExploreGotoBarPages;
 313   my @pages = sort($BannedHosts, $StyleSheetPage, $ConfigPage, $InterMap,
 314                    $RssInterwikiTranslate, $BannedContent);
 315   %AdminPages = map { $_ => 1} @pages, $RssExclude unless %AdminPages;
 316   %LockOnCreation = map { $_ => 1} @pages unless %LockOnCreation;
 317   %PlainTextPages = ($BannedHosts => 1, $BannedContent => 1,
 318          $StyleSheetPage => 1, $ConfigPage => 1) unless %PlainTextPages;
 319   delete $PlainTextPages{''}; # $ConfigPage and others might be empty.
 320   CreateDir($DataDir);    # Create directory if it doesn't exist
 321   $Now = time;      # Reset in case script is persistent
 322   my $ts = (stat($IndexFile))[9]; # always stat for multiple server processes
 323   ReInit() if not $ts or $LastUpdate != $ts; # reinit if another process changed files (requires $DataDir)
 324   $LastUpdate = $ts;
 325   unshift(@MyRules, \&MyRules) if defined(&MyRules) && (not @MyRules or $MyRules[0] != \&MyRules);
 326   @MyRules = sort {$RuleOrder{$a} <=> $RuleOrder{$b}} @MyRules; # default is 0
 327   ReportError(Ts('Cannot create %s', $DataDir) . ": $!", '500 INTERNAL SERVER ERROR')
 328     unless -d $DataDir;
 329   foreach my $sub (@MyInitVariables) {
 330     my $result = &$sub;
 331     $Message .= $q->p($@) if $@;
 332   }
 333 }
 334
 335 sub ReInit {   # init everything we need if we want to link to stuff
 336   my $id = shift; # when saving a page, what to do depends on the page being saved
 337   AllPagesList() if not $id;
 338   InterInit() if $InterMap and (not $id or $id eq $InterMap);
 339   %RssInterwikiTranslate = () if not $id or $id eq $RssInterwikiTranslate; # special since rarely used
 340 }
 341
 342 sub InitCookie {
 343   undef $q->{'.cookies'};   # Clear cache if it exists (for SpeedyCGI)
 344   my $cookie = $q->cookie($CookieName);
 345   %OldCookie = split(/$FS/o, UrlDecode($cookie));
 346   my %provided = map { $_ => 1 } $q->param;
 347   for my $key (keys %OldCookie) {
 348     SetParam($key, $OldCookie{$key}) unless $provided{$key};
 349   }
 350   CookieUsernameFix();
 351   CookieRollbackFix();
 352 }
 353
 354 sub CookieUsernameFix {
 355   # Only valid usernames get stored in the new cookie.
 356   my $name = GetParam('username', '');
 357   $q->delete('username');
 358   if (!$name) {
 359     # do nothing
 360   } elsif ($WikiLinks && !$FreeLinks && !($name =~ /^$LinkPattern$/o)) {
 361     $Message .= $q->p(Ts('Invalid UserName %s: not saved.', $name));
 362   } elsif ($FreeLinks && (!($name =~ /^$FreeLinkPattern$/o))) {
 363     $Message .= $q->p(Ts('Invalid UserName %s: not saved.', $name));
 364   } elsif (length($name) > 50) { # Too long
 365     $Message .= $q->p(T('UserName must be 50 characters or less: not saved'));
 366   } else {
 367     SetParam('username', $name);
 368   }
 369 }
 370
 371 sub CookieRollbackFix {
 372   my @rollback = grep(/rollback-(\d+)/, $q->param);
 373   if (@rollback and $rollback[0] =~ /(\d+)/) {
 374     SetParam('to', $1);
 375     $q->delete('action');
 376     SetParam('action', 'rollback');
 377   }
 378 }
 379
 380 sub GetParam {
 381   my ($name, $default) = @_;
 382   utf8::encode($name); # turn to byte string
 383   my $result = $q->param($name);
 384   $result = $default unless defined($result);
 385   return QuoteHtml($result); # you need to unquote anything that can have <tags>
 386 }
 387
 388 sub SetParam {
 389   my ($name, $val) = @_;
 390   $q->param($name, $val);
 391 }
 392
 393 sub InitLinkPatterns {
 394   my ($WikiWord, $QDelim);
 395   $QDelim = '(?:"")?'; # Optional quote delimiter (removed from the output)
 396   $WikiWord = '[A-Z]+[a-z\x{0080}-\x{fffd}]+[A-Z][A-Za-z\x{0080}-\x{fffd}]*'; # exclude noncharacters FFFE and FFFF
 397   $LinkPattern = "($WikiWord)$QDelim";
 398   $FreeLinkPattern = "([-,.()'%&?;<> _1-9A-Za-z\x{0080}-\x{fffd}]|[-,.()'%&?;<> _0-9A-Za-z\x{0080}-\x{fffd}][-,.()'%&?;<> _0-9A-Za-z\x{0080}-\x{fffd}]+)"; # disallow "0" and must match HTML and plain text (ie. > and &gt;)
 399   # Intersites must start with uppercase letter to avoid confusion with URLs.
 400   $InterSitePattern = '[A-Z\x{0080}-\x{fffd}]+[A-Za-z\x{0080}-\x{fffd}]+';
 401   $InterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,]*[-a-zA-Z0-9\x{0080}-\x{fffd}_=#\$\@~`\%&*+\\/])$QDelim";
 402   $FreeInterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,()' ]+)"; # plus space and other characters, and no restrictions on the end of the pattern
 403   $UrlProtocols = 'http|https|ftp|afs|news|nntp|mid|cid|mailto|wais|prospero|telnet|gopher|irc|feed';
 404   $UrlProtocols .= '|file'  if $NetworkFile;
 405   my $UrlChars = '[-a-zA-Z0-9/@=+$_~*.,;:?!\'"()&#%]'; # see RFC 2396
 406   my $EndChars = '[-a-zA-Z0-9/@=+$_~*]'; # no punctuation at the end of the url.
 407   $UrlPattern = "((?:$UrlProtocols):$UrlChars+$EndChars)";
 408   $FullUrlPattern="((?:$UrlProtocols):$UrlChars+)"; # when used in square brackets
 409   $ImageExtensions = '(gif|jpg|png|bmp|jpeg|svg)';
 410 }
 411
 412 sub Clean {
 413   my $block = shift;
 414   return 0 unless defined($block); # "0" must print
 415   return 1 if $block eq '';        # '' is the result of a dirty rule
 416   $Fragment .= $block;
 417   return 1;
 418 }
 419
 420 sub Dirty { # arg 1 is the raw text; the real output must be printed instead
 421   if ($Fragment ne '') {
 422     $Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end of ApplyRules)
 423     print $Fragment;
 424     push(@Blocks, $Fragment);
 425     push(@Flags, 0);
 426   }
 427   push(@Blocks, (shift));
 428   push(@Flags, 1);
 429   $Fragment = '';
 430 }
 431
 432 sub ApplyRules {
 433   # locallinks: apply rules that create links depending on local config (incl. interlink!)
 434   my ($text, $locallinks, $withanchors, $revision, @tags) = @_; # $revision is used for images
 435   $text =~ s/\r\n/\n/g;   # DOS to Unix
 436   $text =~ s/\n+$//g;   # No trailing paragraphs
 437   $text =~ s/^\n+//g;   # No leading paragraphs
 438   return unless $text ne '';  # allow the text '0'
 439   local $Fragment = '';  # the clean HTML fragment not yet on @Blocks
 440   local @Blocks=();  # the list of cached HTML blocks
 441   local @Flags=();   # a list for each block, 1 = dirty, 0 = clean
 442   Clean(join('', map { AddHtmlEnvironment($_) } @tags));
 443   if ($OpenPageName and $PlainTextPages{$OpenPageName}) { # there should be no $PlainTextPages{''}
 444     Clean(CloseHtmlEnvironments() . $q->pre($text));
 445   } elsif (my ($type) = TextIsFile($text)) {
 446     Clean(CloseHtmlEnvironments() . $q->p(T('This page contains an uploaded file:'))
 447           . $q->p(GetDownloadLink($OpenPageName, (substr($type, 0, 6) eq 'image/'), $revision)));
 448   } else {
 449     my $smileyregex = join "|", keys %Smilies;
 450     $smileyregex = qr/(?=$smileyregex)/;
 451     local $_ = $text;
 452     local $bol = 1;
 453     while (1) {
 454       # Block level elements should eat trailing empty lines to prevent empty p elements.
 455       if ($bol && m/\G(\s*\n)+/cg) {
 456         Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p'));
 457       } elsif ($bol && m/\G(\&lt;include(\s+(text|with-anchors))?\s+"(.*)"\&gt;[ \t]*\n?)/cgi) {
 458         # <include "uri..."> includes the text of the given URI verbatim
 459         Clean(CloseHtmlEnvironments());
 460         Dirty($1);
 461         my ($oldpos, $old_, $type, $uri) = ((pos), $_, $3, UnquoteHtml($4)); # remember, page content is quoted!
 462         if ($uri =~ /^($UrlProtocols):/o) {
 463           if ($type eq 'text') {
 464             print $q->pre({class=>"include $uri"}, QuoteHtml(GetRaw($uri)));
 465           } else { # never use local links for remote pages, with a starting tag
 466             print $q->start_div({class=>"include $uri"});
 467             ApplyRules(QuoteHtml(GetRaw($uri)), 0, ($type eq 'with-anchors'), undef, 'p');
 468             print $q->end_div();
 469           }
 470         } else {
 471           $Includes{$OpenPageName} = 1;
 472           local $OpenPageName = FreeToNormal($uri);
 473           if ($type eq 'text') {
 474             print $q->pre({class=>"include $OpenPageName"}, QuoteHtml(GetPageContent($OpenPageName)));
 475           } elsif (not $Includes{$OpenPageName}) { # with a starting tag, watch out for recursion
 476             print $q->start_div({class=>"include $OpenPageName"});
 477             ApplyRules(QuoteHtml(GetPageContent($OpenPageName)), $locallinks, $withanchors, undef, 'p');
 478             print $q->end_div();
 479             delete $Includes{$OpenPageName};
 480           } else {
 481             print $q->p({-class=>'error'}, $q->strong(Ts('Recursive include of %s!', $OpenPageName)));
 482           }
 483         }
 484         Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
 485         ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
 486       } elsif ($bol && m/\G(\&lt;journal(\s+(\d*))?(\s+"(.*?)")?(\s+(reverse|past|future))?(\s+search\s+(.*))?\&gt;[ \t]*\n?)/cgi) {
 487         # <journal 10 "regexp"> includes 10 pages matching regexp
 488         Clean(CloseHtmlEnvironments());
 489         Dirty($1);
 490         my ($oldpos, $old_) = (pos, $_); # remember these because of the call to PrintJournal()
 491         PrintJournal($3, $5, $7, 0, $9); # no offset
 492         Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
 493         ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
 494       } elsif ($bol && m/\G(\&lt;rss(\s+(\d*))?\s+(.*?)\&gt;[ \t]*\n?)/cgis) {
 495         # <rss "uri..."> stores the parsed RSS of the given URI
 496         Clean(CloseHtmlEnvironments());
 497         Dirty($1);
 498         my ($oldpos, $old_) = (pos, $_); # remember these because of the call to RSS()
 499         print RSS($3 ? $3 : 15, split(/\s+/, UnquoteHtml($4)));
 500         Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
 501         ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
 502       } elsif (/\G(&lt;search (.*?)&gt;)/cgis) {
 503         # <search regexp>
 504         Clean(CloseHtmlEnvironments());
 505         Dirty($1);
 506         my ($oldpos, $old_) = (pos, $_);
 507         print $q->start_div({-class=>'search'});
 508         SearchTitleAndBody($2, \&PrintSearchResult, SearchRegexp($2));
 509         print $q->end_div;
 510         Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
 511         ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
 512       } elsif ($bol && m/\G(&lt;&lt;&lt;&lt;&lt;&lt;&lt; )/cg) {
 513         my ($str, $count, $limit, $oldpos) = ($1, 0, 100, pos);
 514         while (m/\G(.*\n)/cg and $count++ < $limit) {
 515           $str .= $1;
 516           last if (substr($1, 0, 29) eq '&gt;&gt;&gt;&gt;&gt;&gt;&gt; ');
 517         }
 518         if ($count >= $limit) {
 519           pos = $oldpos; # reset because we did not find a match
 520           Clean('&lt;&lt;&lt;&lt;&lt;&lt;&lt; ');
 521         } else {
 522           Clean(CloseHtmlEnvironments() . $q->pre({-class=>'conflict'}, $str) . AddHtmlEnvironment('p'));
 523         }
 524       } elsif ($bol and m/\G#REDIRECT/cg) {
 525         Clean('#REDIRECT');
 526       } elsif (%Smilies && m/\G$smileyregex/cog && Clean(SmileyReplace())) {
 527       } elsif (Clean(RunMyRules($locallinks, $withanchors))) {
 528       } elsif (m/\G\s*\n(\s*\n)+/cg) { # paragraphs: at least two newlines
 529         Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p')); # another one like this further up
 530       } elsif (m/\G&amp;([A-Za-z]+|#[0-9]+|#x[A-Za-f0-9]+);/cg) { # entity references
 531         Clean("&$1;");
 532       } elsif (m/\G\s+/cg) {
 533         Clean(' ');
 534       } elsif (m/\G([A-Za-z\x{0080}-\x{fffd}]+([ \t]+[a-z\x{0080}-\x{fffd}]+)*[ \t]+)/cg
 535                or m/\G([A-Za-z\x{0080}-\x{fffd}]+)/cg or m/\G(\S)/cg) {
 536         Clean($1);    # multiple words but do not match http://foo
 537       } else {
 538         last;
 539       }
 540       $bol = (substr($_,pos()-1,1) eq "\n");
 541     }
 542   }
 543   pos = length $_;  # notify module functions we've completed rule handling
 544   Clean(CloseHtmlEnvironments());  # last block -- close it, cache it
 545   if ($Fragment ne '') {
 546     $Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end Dirty())
 547     print $Fragment;
 548     push(@Blocks, $Fragment);
 549     push(@Flags, 0);
 550   }
 551   # this can be stored in the page cache -- see PrintCache
 552   return (join($FS, @Blocks), join($FS, @Flags));
 553 }
 554
 555 sub ListRule {
 556   if ($bol && m/\G(\s*\n)*(\*+)[ \t]+/cg
 557       or InElement('li') && m/\G(\s*\n)+(\*+)[ \t]+/cg) {
 558     return CloseHtmlEnvironmentUntil('li')
 559       . OpenHtmlEnvironment('ul',length($2)) . AddHtmlEnvironment('li');
 560   }
 561   return undef;
 562 }
 563
 564 sub LinkRules {
 565   my ($locallinks, $withanchors) = @_;
 566   if ($locallinks
 567       and ($BracketText && m/\G(\[$InterLinkPattern\s+([^\]]+?)\])/cog
 568      or $BracketText && m/\G(\[\[$FreeInterLinkPattern\|([^\]]+?)\]\])/cog
 569      or m/\G(\[$InterLinkPattern\])/cog or m/\G(\[\[\[$FreeInterLinkPattern\]\]\])/cog
 570      or m/\G($InterLinkPattern)/cog or m/\G(\[\[$FreeInterLinkPattern\]\])/cog)) {
 571     # [InterWiki:FooBar text] or [InterWiki:FooBar] or
 572     # InterWiki:FooBar or [[InterWiki:foo bar|text]] or
 573     # [[InterWiki:foo bar]] or [[[InterWiki:foo bar]]]-- Interlinks
 574     # can change when the intermap changes (local config, therefore
 575     # depend on $locallinks).  The intermap is only read if
 576     # necessary, so if this not an interlink, we have to backtrack a
 577     # bit.
 578     my $bracket = (substr($1, 0, 1) eq '[') # but \[\[$FreeInterLinkPattern\]\] it not bracket!
 579       && !((substr($1, 0, 2) eq '[[') && (substr($1, 2, 1) ne '[') && index($1, '|') < 0);
 580     my $quote = (substr($1, 0, 2) eq '[[');
 581     my ($oldmatch, $output) = ($1, GetInterLink($2, $3, $bracket, $quote)); # $3 may be empty
 582     if ($oldmatch eq $output) { # no interlink
 583       my ($site, $rest) = split(/:/, $oldmatch, 2);
 584       Clean($site);
 585       pos = (pos) - length($rest) - 1; # skip site, but reparse rest
 586     } else {
 587       Dirty($oldmatch);
 588       print $output;            # this is an interlink
 589     }
 590   } elsif ($BracketText && m/\G(\[$FullUrlPattern[|[:space:]]([^\]]+?)\])/cog
 591      or $BracketText && m/\G(\[\[$FullUrlPattern[|[:space:]]([^\]]+?)\]\])/cog
 592      or m/\G(\[$FullUrlPattern\])/cog or m/\G($UrlPattern)/cog) {
 593     # [URL text] makes [text] link to URL, [URL] makes footnotes [1]
 594     my ($str, $url, $text, $bracket, $rest) = ($1, $2, $3, (substr($1, 0, 1) eq '['), '');
 595     if ($url =~ /(&lt|&gt|&amp)$/) { # remove trailing partial named entitites and add them as
 596       $rest = $1;      # back again at the end as trailing text.
 597       $url =~ s/&(lt|gt|amp)$//;
 598     }
 599     if ($bracket and not defined $text) { # [URL] is dirty because the number may change
 600       Dirty($str);
 601       print GetUrl($url, $text, $bracket), $rest;
 602     } else {
 603       Clean(GetUrl($url, $text, $bracket, not $bracket) . $rest); # $text may be empty, no images in brackets
 604     }
 605   } elsif ($WikiLinks && m/\G!$LinkPattern/cog) {
 606     Clean($1);                  # ! gets eaten
 607   } elsif ($WikiLinks && $locallinks
 608      && ($BracketWiki && m/\G(\[$LinkPattern\s+([^\]]+?)\])/cog
 609          or m/\G(\[$LinkPattern\])/cog or m/\G($LinkPattern)/cog)) {
 610     # [LocalPage text], [LocalPage], LocalPage
 611     Dirty($1);
 612     my $bracket = (substr($1, 0, 1) eq '[' and not $3);
 613     print GetPageOrEditLink($2, $3, $bracket);
 614   } elsif ($locallinks && $FreeLinks && (m/\G(\[\[image:$FreeLinkPattern\]\])/cog
 615            or m/\G(\[\[image:$FreeLinkPattern\|([^]|]+)\]\])/cog)) {
 616     # [[image:Free Link]], [[image:Free Link|alt text]]
 617     Dirty($1);
 618     print GetDownloadLink(FreeToNormal($2), 1, undef, UnquoteHtml($3));
 619   } elsif ($FreeLinks && $locallinks
 620      && ($BracketWiki && m/\G(\[\[$FreeLinkPattern\|([^\]]+)\]\])/cog
 621          or m/\G(\[\[\[$FreeLinkPattern\]\]\])/cog
 622          or m/\G(\[\[$FreeLinkPattern\]\])/cog)) {
 623     # [[Free Link|text]], [[[Free Link]]], [[Free Link]]
 624     Dirty($1);
 625     my $bracket = (substr($1, 0, 3) eq '[[[');
 626     print GetPageOrEditLink($2, $3, $bracket, 1); # $3 may be empty
 627   } else {
 628     return undef;   # nothing matched
 629   }
 630   return '';     # one of the dirty rules matched (and they all are)
 631 }
 632
 633 sub SetHtmlEnvironmentContainer {
 634   my ($html_tag, $html_tag_attr) = @_;
 635   $HtmlEnvironmentContainers{$html_tag} = defined $html_tag_attr ? (
 636   $HtmlEnvironmentContainers{$html_tag} ? '|'.$HtmlEnvironmentContainers{$html_tag} : '').
 637     $html_tag_attr : '';
 638 }
 639
 640 # A stashed attribute is an attribute that is meant for internal use
 641 # by the Wiki engine i.e., they don't make their way in to final HTML.
 642 # You can use stashed attributes for storing additional paramaters
 643 # along with a HTML tag.
 644
 645 # As of this writing, only the Org markup engine uses stashed
 646 # attributes.  The value that is stashed is the leading indentation of
 647 # an list item. (NOTE: in case of Emacs Org-mode markup the *relative*
 648 # indentation between the list items signifies the depth of a list
 649 # item i.e., an item that (i) begins at the same column as an earlier
 650 # item is a sibling (ii) is more indented starts a sub-list (iii) that
 651 # is less indented continues a super-list.)
 652
 653 # IMPLEMENTATION NOTE: To distinguish stashed attributes from regular
 654 # user-provided attributes, they are enclosed between `%%' markers.
 655
 656 sub StashAttributeValue {       # See note above
 657   my ($html_tag_attr, $attr, $value) = @_;
 658   return $html_tag_attr unless ($attr and $value);
 659   return "$html_tag_attr %$attr% = \"$value\"";
 660 }
 661
 662 sub GetStashedAttributeValue {  # See note above
 663   my ($html_tag_attr, $attr) = @_;
 664   if ($html_tag_attr =~ /(^|\s+)%$attr%\s*=\s*"(.*?)"(\s+|$)/) {
 665     return $2;
 666   }
 667   return undef;
 668 }
 669
 670 sub ClearStashedAttributes {    # See note above
 671     my ($html_tag_attr) = @_;
 672     $html_tag_attr =~ s/(^|\s+)%.*?%\s*=\s*".*?"(?=($|\s))//g;
 673     return $html_tag_attr;
 674 }
 675
 676 sub OpenHtmlTag {
 677   my ($html_tag, $html_tag_attr) = @_;
 678   if ($html_tag eq 'list') {
 679     $html_tag =  GetStashedAttributeValue($html_tag_attr, 'type') eq
 680         'numbered' ? 'ol' : 'ul';
 681   }
 682   $html_tag_attr = ClearStashedAttributes($html_tag_attr);
 683   return $html_tag_attr ? "<$html_tag $html_tag_attr>" : "<$html_tag>";
 684 }
 685
 686 sub CloseHtmlTag {
 687   my ($html_tag, $html_tag_attr) = @_;
 688   if ($html_tag eq 'list') {
 689     $html_tag =  GetStashedAttributeValue($html_tag_attr, 'type') eq
 690       'numbered' ? 'ol' : 'ul';
 691   }
 692   return "</$html_tag>";
 693 }
 694
 695 sub InElement {  # is $html_tag in @HtmlStack?
 696   my ($html_tag, $html_tag_attr) = @_;
 697   my  $i = 0;
 698   foreach my $html_tag_current (@HtmlStack) {
 699     return 1 if $html_tag_current eq $html_tag and
 700                ($html_tag_attr ? $HtmlAttrStack[$i] =~ m/$html_tag_attr/ : 1);
 701     $i++;
 702   } return '';
 703 }
 704
 705 sub AddOrCloseHtmlEnvironment {  # add $html_tag, if not already added; close, otherwise
 706   my ($html_tag, $html_tag_attr) = @_;
 707   return InElement        ($html_tag, '^'.$html_tag_attr.'$')
 708     ? CloseHtmlEnvironment($html_tag, '^'.$html_tag_attr.'$')
 709     : AddHtmlEnvironment  ($html_tag, $html_tag_attr);
 710 }
 711
 712 sub AddHtmlEnvironment {  # add a new $html_tag
 713   my ($html_tag, $html_tag_attr) = @_;
 714   $html_tag_attr = '' if not defined $html_tag_attr;
 715   if ($html_tag and not (@HtmlStack and $HtmlStack[0] eq $html_tag and
 716      ($html_tag_attr ? $HtmlAttrStack[0] =~ m/$html_tag_attr/ : 1))) {
 717     unshift(@HtmlStack,     $html_tag);
 718     unshift(@HtmlAttrStack, $html_tag_attr);
 719     return OpenHtmlTag($html_tag, $html_tag_attr);
 720   } return '';  # always return something
 721 }
 722
 723 sub OpenHtmlEnvironment {  # close the previous $html_tag and open a new one
 724   my ($html_tag, $depth, $html_tag_attr) = @_;
 725   my ($html, $found, @stack) = ('', 0);  # always return something
 726   while (@HtmlStack and $found < $depth) { # determine new stack
 727     my $tag = pop(@HtmlStack);
 728     $found++ if $tag eq $html_tag; # this ignores that ul and ol can be equivalent for nesting purposes
 729     unshift(@stack, $tag);
 730   }
 731   unshift(@stack, pop(@HtmlStack)) if @HtmlStack and $found < $depth; # nested sublist coming up, keep list item
 732   @HtmlStack = @stack if not $found; # if starting a new list
 733   $html .= CloseHtmlEnvironments();  # close remaining elements (or all elements if a new list)
 734   @HtmlStack = @stack if $found; # if not starting a new list
 735   $depth = $IndentLimit if $depth > $IndentLimit; # requested depth 0 makes no sense
 736   $html_tag_attr = qq/class="$html_tag_attr"/ # backwards-compatibility hack: classically, the third argument to this function was a single CSS class, rather than string of HTML tag attributes as in the second argument to the "AddHtmlEnvironment" function. To allow both sorts, we conditionally change this string to 'class="$html_tag_attr"' when this string is a single CSS class.
 737     if $html_tag_attr && $html_tag_attr !~ m/^\s*.+?\s*=\s*('|").+\1/;
 738   splice(@HtmlAttrStack, 0, @HtmlAttrStack - @HtmlStack); # truncate to size of @HtmlStack
 739   foreach ($found..$depth-1) {
 740     unshift(@HtmlStack,     $html_tag);
 741     unshift(@HtmlAttrStack, $html_tag_attr);
 742     $html .= OpenHtmlTag($html_tag, $html_tag_attr);
 743   }
 744   return $html;
 745 }
 746
 747 sub CloseHtmlEnvironments { # close all -- remember to use AddHtmlEnvironment('p') if required!
 748   return CloseHtmlEnvironmentUntil() if pos($_) == length($_);  # close all HTML environments if we're are at the end of this page
 749   my $html = '';
 750   while (@HtmlStack) {
 751     defined $HtmlEnvironmentContainers{$HtmlStack[0]} and  # avoid closing block level elements
 752            ($HtmlEnvironmentContainers{$HtmlStack[0]} ? $HtmlAttrStack[0] =~
 753           m/$HtmlEnvironmentContainers{$HtmlStack[0]}/ : 1) and return $html;
 754     $html .= CloseHtmlTag(shift(@HtmlStack), shift(@HtmlAttrStack));
 755   } return $html;
 756 }
 757
 758 sub CloseHtmlEnvironment {  # close environments up to and including $html_tag
 759   my $html = CloseHtmlEnvironmentUntil(@_) if @_ and InElement(@_);
 760   if (@HtmlStack and (not(@_) or defined $html)) {
 761     return $html.CloseHtmlTag(shift(@HtmlStack), shift(@HtmlAttrStack));
 762   } return $html or '';  # always return something
 763 }
 764
 765 sub CloseHtmlEnvironmentUntil {  # close environments up to but not including $html_tag
 766   my ($html_tag,  $html_tag_attr) = @_;
 767   my  $html = '';
 768   while (@HtmlStack && (pos($_) == length($_) ||  # while there is an HTML tag-stack and we are at the end of this page or...
 769     !($html_tag ? $HtmlStack[0] eq $html_tag &&   # the top tag is not the desired tag and...
 770      ($html_tag_attr ? $HtmlAttrStack[0] =~       # its attributes do not match,
 771     m/$html_tag_attr/ : 1) : ''))) {      # then...
 772     # shift off the top tag and append it to our HTML string.
 773     $html .= CloseHtmlTag(shift(@HtmlStack), shift(@HtmlAttrStack));
 774   } return $html;
 775 }
 776
 777 sub SmileyReplace {
 778   foreach my $regexp (keys %Smilies) {
 779     if (m/\G($regexp)/cg) {
 780       return $q->img({-src=>$Smilies{$regexp}, -alt=>UnquoteHtml($1), -class=>'smiley'});
 781     }
 782   }
 783 }
 784
 785 sub RunMyRules {
 786   my ($locallinks, $withanchors) = @_;
 787   foreach my $sub (@MyRules) {
 788     my $result = &$sub($locallinks, $withanchors);
 789     SetParam('msg', $@) if $@;
 790     return $result if defined($result);
 791   }
 792   return undef;
 793 }
 794
 795 sub RunMyMacros {
 796   $_ = shift;
 797   foreach my $macro (@MyMacros) { &$macro };
 798   return $_;
 799 }
 800
 801 sub PrintWikiToHTML {
 802   my ($markup, $is_saving_cache, $revision, $is_locked) = @_;
 803   my ($blocks, $flags);
 804   $FootnoteNumber = 0;
 805   $markup =~ s/$FS//go if $markup;  # Remove separators (paranoia)
 806   $markup = QuoteHtml($markup);
 807   ($blocks, $flags) = ApplyRules($markup, 1, $is_saving_cache, $revision, 'p');
 808   if ($is_saving_cache and not $revision and $Page{revision} # don't save revision 0 pages
 809       and $Page{blocks} ne $blocks and $Page{flags} ne $flags) {
 810     $Page{blocks} = $blocks;
 811     $Page{flags} =  $flags;
 812     if ($is_locked or RequestLockDir('main')) { # not fatal!
 813       SavePage();
 814       ReleaseLock() unless $is_locked;
 815     }
 816   }
 817 }
 818
 819 sub DoClearCache {
 820   return unless UserIsAdminOrError();
 821   RequestLockOrError();
 822   print GetHeader('', T('Clear Cache')), $q->start_div({-class=>'content clear'}),
 823     $q->p(T('Main lock obtained.')), '<p>';
 824   foreach my $id (AllPagesList()) {
 825     OpenPage($id);
 826     delete $Page{blocks};
 827     delete $Page{flags};
 828     delete $Page{languages};
 829     $Page{languages} = GetLanguages($Page{blocks}) unless TextIsFile($Page{blocks});
 830     SavePage();
 831     print $q->br(), GetPageLink($id);
 832   }
 833   print '</p>', $q->p(T('Main lock released.')), $q->end_div();
 834   utime time, time, $IndexFile; # touch index file
 835   ReleaseLock();
 836   PrintFooter();
 837 }
 838
 839 sub QuoteHtml {
 840   my $html = shift;
 841   $html =~ s/&/&amp;/g;
 842   $html =~ s/</&lt;/g;
 843   $html =~ s/>/&gt;/g;
 844   $html =~ s/[\x00-\x08\x0b\x0c\x0e-\x1f]/ /g; # legal xml: #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
 845   return $html;
 846 }
 847
 848 sub UnquoteHtml {
 849   my $html = shift;
 850   $html =~ s/&lt;/</g;
 851   $html =~ s/&gt;/>/g;
 852   $html =~ s/&amp;/&/g;
 853   $html =~ s/%26/&/g;
 854   return $html;
 855 }
 856
 857 sub UrlEncode {
 858   my $str = shift;
 859   return '' unless $str;
 860   utf8::encode($str); # turn to byte string
 861   my @letters = split(//, $str);
 862   my %safe = map {$_ => 1} ('a' .. 'z', 'A' .. 'Z', '0' .. '9', '-', '_', '.', '!', '~', '*', "'", '(', ')', '#');
 863   foreach my $letter (@letters) {
 864     $letter = sprintf("%%%02x", ord($letter)) unless $safe{$letter};
 865   }
 866   return join('', @letters);
 867 }
 868
 869 sub UrlDecode {
 870   my $str = shift;
 871   $str =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/ge;
 872   utf8::decode($str); # make internal string
 873   return $str;
 874 }
 875
 876 sub QuoteRegexp {
 877   my $re = shift;
 878   $re =~ s/([\\\[\]\$()^.])/\\$1/g;
 879   return $re;
 880 }
 881
 882 sub GetRaw {
 883   my $uri = shift;
 884   return unless eval { require LWP::UserAgent; };
 885   my $ua = LWP::UserAgent->new;
 886   my $response = $ua->get($uri);
 887   return $response->decoded_content if $response->is_success;
 888 }
 889
 890 sub DoJournal {
 891   print GetHeader(undef, T('Journal'));
 892   print $q->start_div({-class=>'content'});
 893   PrintJournal(map { GetParam($_, ''); } qw(num regexp mode offset search));
 894   print $q->end_div();
 895   PrintFooter();
 896 }
 897
 898 sub JournalSort { $b cmp $a }
 899
 900 sub PrintJournal {
 901   return if $CollectingJournal; # avoid infinite loops
 902   local $CollectingJournal = 1;
 903   my ($num, $regexp, $mode, $offset, $search) = @_;
 904   $regexp = '^\d\d\d\d-\d\d-\d\d' unless $regexp;
 905   $num = 10 unless $num;
 906   $offset = 0 unless $offset;
 907   # FIXME: Should pass filtered list of pages to SearchTitleAndBody to save time?
 908   my @pages = sort JournalSort (grep(/$regexp/, $search ? SearchTitleAndBody($search) : AllPagesList()));
 909   if ($mode eq 'reverse' or $mode eq 'future') {
 910     @pages = reverse @pages;
 911   }
 912   $b = defined($Today) ? $Today : CalcDay($Now);
 913   if ($mode eq 'future') {
 914     for (my $i = 0; $i < @pages; $i++) {
 915       $a = $pages[$i];
 916       if (JournalSort() == -1) {
 917         @pages = @pages[$i..$#pages];
 918         last;
 919       }
 920     }
 921   } elsif ($mode eq 'past') {
 922     for (my $i = 0; $i < @pages; $i++) {
 923       $a = $pages[$i];
 924       if (JournalSort() == 1) {
 925         @pages = @pages[$i..$#pages];
 926         last;
 927       }
 928     }
 929   }
 930   return unless $pages[$offset];
 931   print $q->start_div({-class=>'journal'});
 932   my $next = $offset + PrintAllPages(1, 1, $num, @pages[$offset .. $#pages]);
 933   print $q->end_div();
 934   print $q->p({-class=>'more'}, ScriptLink("action=more;num=$num;regexp=$regexp;search=$search;mode=$mode;offset=$next", T('More...'), 'more')) if $pages[$next];
 935 }
 936
 937 sub PrintAllPages {
 938   my ($links, $comments, $num, @pages) = @_;
 939   my $lang = GetParam('lang', 0);
 940   my ($i, $n) = 0;
 941   for my $id (@pages) {
 942     last if $n >= $JournalLimit and not UserIsAdmin() or $num and $n >= $num;
 943     $i++; # pages looked at
 944     local ($OpenPageName, %Page); # this is local!
 945     OpenPage($id);
 946     my @languages = split(/,/, $Page{languages});
 947     next if $lang and @languages and not grep(/$lang/, @languages);
 948     next if PageMarkedForDeletion();
 949     next if substr($Page{text}, 0, 10) eq '#REDIRECT ';
 950     print $q->start_div({-class=>'page'}),
 951       $q->h1($links ? GetPageLink($id)
 952              : $q->a({-name=>$id}, UrlEncode(FreeToNormal($id))));
 953     PrintPageHtml();
 954     if ($comments and $id !~ /^$CommentsPrefix/o) {
 955       print $q->p({-class=>'comment'},
 956       GetPageLink($CommentsPrefix . $id,
 957             T('Comments on this page')));
 958     }
 959     print $q->end_div();
 960     $n++; # pages actually printed
 961   }
 962   return $i;
 963 }
 964
 965 sub RSS {
 966   return if $CollectingJournal; # avoid infinite loops when using full=1
 967   local $CollectingJournal = 1;
 968   my $maxitems = shift;
 969   my @uris = @_;
 970   my %lines;
 971   if (not eval { require XML::RSS;  }) {
 972     my $err = $@;
 973     return $q->div({-class=>'rss'}, $q->p({-class=>'error'}, $q->strong(T('XML::RSS is not available on this system.')),  $err));
 974   }
 975   # All strings that are concatenated with strings returned by the RSS
 976   # feed must be decoded.  Without this decoding, 'diff' and 'history'
 977   # translations will be double encoded when printing the result.
 978   my $tDiff = T('diff');
 979   my $tHistory = T('history');
 980   my $wikins = 'http://purl.org/rss/1.0/modules/wiki/';
 981   my $rdfns = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#';
 982   @uris = map { s/^"?(.*?)"?$/$1/; $_; } @uris; # strip quotes of uris
 983   my ($str, %data) = GetRss(@uris);
 984   foreach my $uri (keys %data) {
 985     my $data = $data{$uri};
 986     if (not $data) {
 987       $str .= $q->p({-class=>'error'}, $q->strong(Ts('%s returned no data, or LWP::UserAgent is not available.',
 988                                                      $q->a({-href=>$uri}, $uri))));
 989     } else {
 990       my $rss = new XML::RSS;
 991       eval { local $SIG{__DIE__}; $rss->parse($data); };
 992       if ($@) {
 993         $str .= $q->p({-class=>'error'}, $q->strong(Ts('RSS parsing failed for %s', $q->a({-href=>$uri}, $uri)) . ': ' . $@));
 994       } else {
 995         my $interwiki;
 996         if (@uris > 1) {
 997           RssInterwikiTranslateInit(); # not needed anywhere else thus init only now and not in ReInit
 998           $interwiki = $rss->{channel}->{$wikins}->{interwiki};
 999           $interwiki =~ s/^\s+//; # when RDF is used, sometimes whitespace remains,
1000           $interwiki =~ s/\s+$//; # which breaks the test for an existing $interwiki below
1001           if (!$interwiki) {
1002             $interwiki = $rss->{channel}->{$rdfns}->{value};
1003           }
1004           $interwiki = $RssInterwikiTranslate{$interwiki} if $RssInterwikiTranslate{$interwiki};
1005           $interwiki = $RssInterwikiTranslate{$uri} unless $interwiki;
1006         }
1007         my $num = 999;
1008         $str .= $q->p({-class=>'error'}, $q->strong(Ts('No items found in %s.', $q->a({-href=>$uri}, $uri))))
1009           unless @{$rss->{items}};
1010         foreach my $i (@{$rss->{items}}) {
1011           my $line;
1012           my $date = $i->{dc}->{date};
1013           if (not $date and $i->{pubDate}) {
1014             $date = $i->{pubDate};
1015             my %mon = (Jan=>1, Feb=>2, Mar=>3, Apr=>4, May=>5, Jun=>6,
1016                        Jul=>7, Aug=>8, Sep=>9, Oct=>10, Nov=>11, Dec=>12);
1017             $date =~ s/^(?:[A-Z][a-z][a-z], )?(\d\d?) ([A-Z][a-z][a-z]) (\d\d(?:\d\d)?)/ # pubDate uses RFC 822
1018               sprintf('%04d-%02d-%02d', ($3 < 100 ? 1900 + $3 : $3), $mon{$2}, $1)/e;
1019           }
1020           $date = sprintf("%03d", $num--) unless $date; # for RSS 0.91 feeds without date, descending
1021           my $title = $i->{title};
1022           my $description = $i->{description};
1023           if (not $title and $description) { # title may be missing in RSS 2.00
1024             $title = $description;
1025             $description = '';
1026           }
1027           $title = $i->{link} if not $title and $i->{link}; # if description and title are missing
1028           $line .= ' (' . $q->a({-href=>$i->{$wikins}->{diff}}, $tDiff) . ')'
1029             if $i->{$wikins}->{diff};
1030           $line .= ' (' . $q->a({-href=>$i->{$wikins}->{history}}, $tHistory) . ')'
1031             if $i->{$wikins}->{history};
1032           if ($title) {
1033             if ($i->{link}) {
1034               $line .= ' ' . $q->a({-href=>$i->{link}, -title=>$date},
1035                                    ($interwiki ? $interwiki . ':' : '') . $title);
1036             } else {
1037               $line .= ' ' . $title;
1038             }
1039           }
1040           my $contributor = $i->{dc}->{contributor};
1041           $contributor = $i->{$wikins}->{username} unless $contributor;
1042           $contributor =~ s/^\s+//;
1043           $contributor =~ s/\s+$//;
1044           $contributor = $i->{$rdfns}->{value} unless $contributor;
1045           $line .= $q->span({-class=>'contributor'}, $q->span(T(' . . . . ')) . $contributor) if $contributor;
1046           if ($description) {
1047             if ($description =~ /</) {
1048               $line .= $q->div({-class=>'description'}, $description);
1049             } else {
1050               $line .= $q->span({class=>'dash'}, ' &#8211; ') . $q->strong({-class=>'description'}, $description);
1051             }
1052           }
1053           while ($lines{$date}) {
1054             $date .= ' ';
1055           }                     # make sure this is unique
1056           $lines{$date} = $line;
1057         }
1058       }
1059     }
1060   }
1061   my @lines = sort { $b cmp $a } keys %lines;
1062   @lines = @lines[0..$maxitems-1] if $maxitems and $#lines > $maxitems;
1063   my $date = '';
1064   foreach my $key (@lines) {
1065     my $line = $lines{$key};
1066     if ($key =~ /(\d\d\d\d(?:-\d?\d)?(?:-\d?\d)?)(?:[T ](\d?\d:\d\d))?/) {
1067       my ($day, $time) = ($1, $2);
1068       if ($day ne $date) {
1069         $str .= '</ul>' if $date; # close ul except for the first time where no open ul exists
1070         $date = $day;
1071         $str .= $q->p($q->strong($day)) . '<ul>';
1072       }
1073       $line = $q->span({-class=>'time'}, $time . ' UTC ') . $line if $time;
1074     } elsif (not $date) {
1075       $str .= '<ul>'; # if the feed doesn't have any dates we need to start the list anyhow
1076       $date = $Now;   # to ensure the list starts only once
1077     }
1078     $str .= $q->li($line);
1079   }
1080   $str .= '</ul>' if $date;
1081   return $q->div({-class=>'rss'}, $str);
1082 }
1083
1084 sub GetRss {
1085   my %todo = map {$_, GetRssFile($_)} @_;
1086   my %data = ();
1087   my $str = '';
1088   if (GetParam('cache', $UseCache) > 0) {
1089     foreach my $uri (keys %todo) { # read cached rss files if possible
1090       if ($Now - (stat($todo{$uri}))[9] < $RssCacheHours * 3600) {
1091         $data{$uri} = ReadFile($todo{$uri});
1092         delete($todo{$uri});  # no need to fetch them below
1093       }
1094     }
1095   }
1096   my @need_cache = keys %todo;
1097   if (keys %todo > 1) {   # try parallel access if available
1098     eval { # see code example in LWP::Parallel, not LWP::Parallel::UserAgent (no callbacks here)
1099       require LWP::Parallel::UserAgent;
1100       my $pua = LWP::Parallel::UserAgent->new();
1101       foreach my $uri (keys %todo) {
1102         if (my $res = $pua->register(HTTP::Request->new('GET', $uri))) {
1103           $str .= $res->error_as_HTML;
1104         }
1105       }
1106       %todo = (); # because the uris in the response may have changed due to redirects
1107       my $entries = $pua->wait();
1108       foreach (keys %$entries) {
1109         my $uri = $entries->{$_}->request->uri;
1110         $data{$uri} = $entries->{$_}->response->decoded_content;
1111       }
1112     }
1113   }
1114   foreach my $uri (keys %todo) { # default operation: synchronous fetching
1115     $data{$uri} = GetRaw($uri);
1116   }
1117   if (GetParam('cache', $UseCache) > 0) {
1118     CreateDir($RssDir);
1119     foreach my $uri (@need_cache) {
1120       my $data = $data{$uri};
1121       # possibly a Latin-1 file without encoding attribute will cause a problem?
1122       $data =~ s/encoding="[^"]*"/encoding="UTF-8"/; # content was converted
1123       WriteStringToFile(GetRssFile($uri), $data) if $data;
1124     }
1125   }
1126   return $str, %data;
1127 }
1128
1129 sub GetRssFile {
1130   return $RssDir . '/' . UrlEncode(shift);
1131 }
1132
1133 sub RssInterwikiTranslateInit {
1134   return unless $RssInterwikiTranslate;
1135   %RssInterwikiTranslate = ();
1136   foreach (split(/\n/, GetPageContent($RssInterwikiTranslate))) {
1137     if (/^ ([^ ]+)[ \t]+([^ ]+)$/) {
1138       $RssInterwikiTranslate{$1} = $2;
1139     }
1140   }
1141 }
1142
1143 sub GetInterSiteUrl {
1144   my ($site, $page, $quote) = @_;
1145   return unless $page;
1146   $page = join('/', map { UrlEncode($_) } split(/\//, $page)) if $quote; # Foo:bar+baz is not quoted, [[Foo:bar baz]] is.
1147   my $url = $InterSite{$site} or return;
1148   $url =~ s/\%s/$page/g or $url .= $page;
1149   return $url;
1150 }
1151
1152 sub BracketLink {   # brackets can be removed via CSS
1153   return $q->span($q->span({class=>'bracket'}, '[') . (shift) . $q->span({class=>'bracket'}, ']'));
1154 }
1155
1156 sub GetInterLink {
1157   my ($id, $text, $bracket, $quote) = @_;
1158   my ($site, $page) = split(/:/, $id, 2);
1159   $page =~ s/&amp;/&/g;   # Unquote common URL HTML
1160   my $url = GetInterSiteUrl($site, $page, $quote);
1161   my $class = 'inter ' . $site;
1162   if ($text && $bracket && !$url) {
1163     return "[$id $text]";
1164   } elsif ($bracket && !$url) {
1165     return "[$id]";
1166   } elsif (!$url) {
1167     return $id;
1168   } elsif ($bracket && !$text) {
1169     $text = BracketLink(++$FootnoteNumber);
1170     $class .= ' number';
1171   } elsif (!$text) {
1172     $text = $q->span({-class=>'site'}, $site)
1173       . $q->span({-class=>'separator'}, ':')
1174   . $q->span({-class=>'page'}, $page);
1175   } elsif ($bracket) {    # and $text is set
1176     $class .= ' outside';
1177   }
1178   return $q->a({-href=>$url, -class=>$class}, $text);
1179 }
1180
1181 sub InterInit {
1182   %InterSite = ();
1183   foreach (split(/\n/, GetPageContent($InterMap))) {
1184     if (/^ ($InterSitePattern)[ \t]+([^ ]+)$/) {
1185       $InterSite{$1} = $2;
1186     }
1187   }
1188 }
1189
1190 sub GetUrl {
1191   my ($url, $text, $bracket, $images) = @_;
1192   $url =~ /^($UrlProtocols)/;
1193   my $class = "url $1";
1194   if ($NetworkFile && $url =~ m|^file:///| && !$AllNetworkFiles
1195       or !$NetworkFile && $url =~ m|^file:|) {
1196     # Only do remote file:// links. No file:///c|/windows.
1197     return $url;
1198   } elsif ($bracket and not defined $text) {
1199     $text = BracketLink(++$FootnoteNumber);
1200     $class .= ' number';
1201   } elsif (not defined $text) {
1202     $text = $url;
1203   } elsif ($bracket) {    # and $text is set
1204     $class .= ' outside';
1205   }
1206   $url = UnquoteHtml($url); # links should be unquoted again
1207   if ($images && $url =~ /^(http:|https:|ftp:).+\.$ImageExtensions$/i) {
1208     return $q->img({-src=>$url, -alt=>$url, -class=>$class});
1209   } else {
1210     return $q->a({-href=>$url, -class=>$class}, $text);
1211   }
1212 }
1213
1214 sub GetPageOrEditLink { # use GetPageLink and GetEditLink if you know the result!
1215   my ($id, $text, $bracket, $free) = @_;
1216   $id = FreeToNormal($id);
1217   my ($class, $resolved, $title, $exists) = ResolveId($id);
1218   if (!$text && $resolved && $bracket) {
1219     $text = BracketLink(++$FootnoteNumber);
1220     $class .= ' number';
1221     $title = NormalToFree($id);
1222   }
1223   my $link = $text||NormalToFree($id);
1224   if ($resolved) { # anchors don't exist as pages, therefore do not use $exists
1225     return ScriptLink(UrlEncode($resolved), $link, $class, undef, $title);
1226   } else {      # reproduce markup if $UseQuestionmark
1227     return GetEditLink($id, UnquoteHtml($bracket ? "[$link]" : $link)) if not $UseQuestionmark;
1228     $link = QuoteHtml($id) . GetEditLink($id, '?');
1229     $link .= ($free ? '|' : ' ') . $text if $text and $text ne $id;
1230     $link = "[[$link]]" if $free;
1231     $link = "[$link]" if $bracket or not $free and $text;
1232     return $link;
1233   }
1234 }
1235
1236 sub GetPageLink { # use if you want to force a link to local pages, whether it exists or not
1237   my ($id, $name, $class, $accesskey) = @_;
1238   $id = FreeToNormal($id);
1239   $name = $id unless $name;
1240   $class .= ' ' if $class;
1241   return ScriptLink(UrlEncode($id), NormalToFree($name), $class . 'local',
1242                     undef, undef, $accesskey);
1243 }
1244
1245 sub GetEditLink {   # shortcut
1246   my ($id, $name, $upload, $accesskey) = @_;
1247   $id = FreeToNormal($id);
1248   my $action = 'action=edit;id=' . UrlEncode($id);
1249   $action .= ';upload=1' if $upload;
1250   return ScriptLink($action, NormalToFree($name), 'edit', undef, T('Click to edit this page'), $accesskey);
1251 }
1252
1253 sub GetRawLink {   # shortcut
1254   my ($id, $name, $accesskey) = @_;
1255   $id = FreeToNormal($id);
1256   my $action = 'raw=1;id=' . UrlEncode($id);
1257   return ScriptLink($action, NormalToFree($name), 'raw', undef, T('View raw text of this page'), $accesskey);
1258 }
1259
1260 sub ScriptUrl {
1261   my $action = shift;
1262   if ($action =~ /^($UrlProtocols)\%3a/ or $action =~ /^\%2f/) { # nearlinks and other URLs
1263     $action =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/ge; # undo urlencode
1264     # do nothing
1265   } elsif ($UsePathInfo and index($action, '=') == -1) {
1266     $action = $ScriptName . '/' . $action;
1267   } else {
1268     $action = $ScriptName . '?' . $action;
1269   }
1270   return $action unless wantarray;
1271   return ($action, index($action, '=') != -1);
1272 }
1273
1274 sub ScriptLink {
1275   my ($action, $text, $class, $name, $title, $accesskey) = @_;
1276   my ($url, $nofollow) = ScriptUrl($action);
1277   my %params;
1278   $params{-href} = $url;
1279   $params{'-rel'} = 'nofollow' if $nofollow;
1280   $params{'-class'} = $class if $class;
1281   $params{'-name'} = $name if $name;
1282   $params{'-title'} = $title if $title;
1283   $params{'-accesskey'} = $accesskey  if $accesskey;
1284   return $q->a(\%params, $text);
1285 }
1286
1287 sub GetDownloadLink {
1288   my ($id, $image, $revision, $alt) = @_;
1289   $alt = NormalToFree($id) unless $alt;
1290   # if the page does not exist
1291   return '[[' . ($image ? 'image' : 'download') . ':'
1292     . ($UseQuestionmark ? QuoteHtml($id) . GetEditLink($id, '?', 1)
1293        : GetEditLink($id, $id, 1)) . ']]'
1294       unless $IndexHash{$id};
1295   my $action;
1296   if ($revision) {
1297     $action = "action=download;id=" . UrlEncode($id) . ";revision=$revision";
1298   } elsif ($UsePathInfo) {
1299     $action = "download/" . UrlEncode($id);
1300   } else {
1301     $action = "action=download;id=" . UrlEncode($id);
1302   }
1303   if ($image) {
1304     if ($UsePathInfo and not $revision) {
1305       $action = $ScriptName . '/' . $action;
1306     } else {
1307       $action = $ScriptName . '?' . $action;
1308     }
1309     return $action if $image == 2;
1310     my $result = $q->img({-src=>$action, -alt=>UnquoteHtml($alt), -class=>'upload'});
1311     $result = ScriptLink(UrlEncode($id), $result, 'image')
1312       unless $id eq $OpenPageName;
1313     return $result;
1314   } else {
1315     return ScriptLink($action, $alt, 'upload');
1316   }
1317 }
1318
1319 sub PrintCache {    # Use after OpenPage!
1320   my @blocks = split($FS,$Page{blocks});
1321   my @flags = split($FS,$Page{flags});
1322   $FootnoteNumber = 0;
1323   foreach my $block (@blocks) {
1324     if (shift(@flags)) {
1325       ApplyRules($block, 1, 1); # local links, anchors, current revision, no start tag
1326     } else {
1327       print $block;
1328     }
1329   }
1330 }
1331
1332 sub PrintPageHtml {   # print an open page
1333   return unless GetParam('page', 1);
1334   if ($Page{blocks} && $Page{flags} && GetParam('cache', $UseCache) > 0) {
1335     PrintCache();
1336   } else {
1337     PrintWikiToHTML($Page{text}, 1); # save cache, current revision, no main lock
1338   }
1339 }
1340
1341 sub PrintPageDiff {   # print diff for open page
1342   my $diff = GetParam('diff', 0);
1343   if ($UseDiff && $diff) {
1344     PrintHtmlDiff($diff);
1345     print $q->hr() if GetParam('page', 1);
1346   }
1347 }
1348
1349 sub PageHtml {
1350   my ($id, $limit, $error) = @_;
1351   my ($diff, $page);
1352   local *STDOUT;
1353   OpenPage($id);
1354   open(STDOUT, '>', \$diff) or die "Can't open memory file: $!";
1355   binmode(STDOUT); # works whether STDOUT already has the UTF8 layer or not
1356   binmode(STDOUT, ":utf8");
1357   PrintPageDiff();
1358   utf8::decode($diff);
1359   return $error if $limit and length($diff) > $limit;
1360   open(STDOUT, '>', \$page) or die "Can't open memory file: $!";
1361   binmode(STDOUT); # works whether STDOUT already has the UTF8 layer or not
1362   binmode(STDOUT, ":utf8");
1363   PrintPageHtml();
1364   utf8::decode($page);
1365   return $diff . $q->p($error) if $limit and length($diff . $page) > $limit;
1366   return $diff . $page;
1367 }
1368
1369 sub T {
1370   my $text = shift;
1371   return $Translate{$text} if $Translate{$text};
1372   return $text;
1373 }
1374
1375 sub Ts {
1376   my ($text, $string) = @_;
1377   $text = T($text);
1378   $text =~ s/\%s/$string/ if defined($string);
1379   return $text;
1380 }
1381
1382 sub Tss {
1383   my $text = $_[0];
1384   $text = T($text);
1385   $text =~ s/\%([1-9])/$_[$1]/ge;
1386   return $text;
1387 }
1388
1389 sub GetId {
1390   my $id = UnquoteHtml(GetParam('id', GetParam('title', ''))); # id=x or title=x -> x
1391   if (not $id) {
1392     my @keywords = $q->keywords;
1393     foreach my $keyword (@keywords) {
1394       utf8::decode($keyword);
1395     }
1396     $id = join('_', @keywords) unless $id; # script?p+q -> p_q
1397   }
1398   if ($UsePathInfo) {
1399     my $path = $q->path_info;
1400     utf8::decode($path);
1401     my @path = split(/\//, $path);
1402     $id = pop(@path) unless $id; # script/p/q -> q
1403     foreach my $p (@path) {
1404       SetParam($p, 1);    # script/p/q -> p=1
1405     }
1406   }
1407   return $id;
1408 }
1409
1410 sub DoBrowseRequest {
1411   # We can use the error message as the HTTP error code
1412   ReportError(Ts('CGI Internal error: %s',$q->cgi_error), $q->cgi_error) if $q->cgi_error;
1413   print $q->header(-status=>'304 NOT MODIFIED') and return if PageFresh(); # return value is ignored
1414   my $id = GetId();
1415   my $action = lc(GetParam('action', '')); # script?action=foo;id=bar
1416   $action = 'download' if GetParam('download', '') and not $action; # script/download/id
1417   my $search = GetParam('search', '');
1418   if ($Action{$action}) {
1419     &{$Action{$action}}($id);
1420   } elsif ($action and defined &MyActions) {
1421     eval { local $SIG{__DIE__}; MyActions(); };
1422   } elsif ($action) {
1423     ReportError(Ts('Invalid action parameter %s', $action), '501 NOT IMPLEMENTED');
1424   } elsif ($search ne '') { # allow search for "0"
1425     SetParam('action', 'search'); # fake it
1426     DoSearch($search);
1427   } elsif (GetParam('title', '') and not GetParam('Cancel', '')) {
1428     DoPost(GetParam('title', ''));
1429   } else {
1430     BrowseResolvedPage($id||$HomePage);  # default action!
1431   }
1432 }
1433
1434 sub ValidId { # hack alert: returns error message if invalid, and unfortunately the empty string if valid!
1435   my $id = FreeToNormal(shift);
1436   return T('Page name is missing') unless $id;
1437   return Ts('Page name is too long: %s', $id) if length($id) > 120;
1438   return Ts('Invalid Page %s (must not end with .db)', $id) if $id =~ m|\.db$|;
1439   return Ts('Invalid Page %s (must not end with .lck)', $id) if $id =~ m|\.lck$|;
1440   return Ts('Invalid Page %s', $id) if $FreeLinks ? $id !~ m|^$FreeLinkPattern$| : $id !~ m|^$LinkPattern$|;
1441 }
1442
1443 sub ValidIdOrDie {
1444   my $id = shift;
1445   my $error = ValidId($id);
1446   ReportError($error, '400 BAD REQUEST') if $error;
1447   return 1;
1448 }
1449
1450 sub ResolveId { # return css class, resolved id, title (eg. for popups), exist-or-not
1451   my $id = shift;
1452   return ('local', $id, '', 1) if $IndexHash{$id};
1453   return ('', '', '', '');
1454 }
1455
1456 sub BrowseResolvedPage {
1457   my $id = FreeToNormal(shift);
1458   my ($class, $resolved, $title, $exists) = ResolveId($id);
1459   if ($class && $class eq 'near' && not GetParam('rcclusteronly', 0)) { # nearlink (is url)
1460     print $q->redirect({-uri=>$resolved});
1461   } elsif ($class && $class eq 'alias') { # an anchor was found instead of a page
1462     ReBrowsePage($resolved);
1463   } elsif (not $resolved and $NotFoundPg and $id !~ /^$CommentsPrefix/o) { # custom page-not-found message
1464     BrowsePage($NotFoundPg);
1465   } elsif ($resolved) {   # an existing page was found
1466     BrowsePage($resolved, GetParam('raw', 0));
1467   } else {      # new page!
1468     BrowsePage($id, GetParam('raw', 0), undef, '404 NOT FOUND') if ValidIdOrDie($id);
1469   }
1470 }
1471
1472 sub BrowsePage {
1473   my ($id, $raw, $comment, $status) = @_;
1474   OpenPage($id);
1475   my ($text, $revision, $summary) = GetTextRevision(GetParam('revision', ''));
1476   $text = $NewText unless $revision or $Page{revision}; # new text for new pages
1477   # handle a single-level redirect
1478   my $oldId = GetParam('oldid', '');
1479   if ((substr($text, 0, 10) eq '#REDIRECT ')) {
1480     if ($oldId) {
1481       $Message .= $q->p(T('Too many redirections'));
1482     } elsif ($revision) {
1483       $Message .= $q->p(T('No redirection for old revisions'));
1484     } elsif (($FreeLinks and $text =~ /^\#REDIRECT\s+\[\[$FreeLinkPattern\]\]/)
1485        or ($WikiLinks and $text =~ /^\#REDIRECT\s+$LinkPattern/)) {
1486       return ReBrowsePage(FreeToNormal($1), $id);
1487     } else {
1488       $Message .= $q->p(T('Invalid link pattern for #REDIRECT'));
1489     }
1490   }
1491   # shortcut if we only need the raw text: no caching, no diffs, no html.
1492   if ($raw) {
1493     print GetHttpHeader('text/plain', $Page{ts}, $IndexHash{$id} ? undef : '404 NOT FOUND');
1494     if ($raw == 2) {
1495       print $Page{ts} . " # Do not delete this line when editing!\n";
1496     }
1497     print $text;
1498     return;
1499   }
1500   # normal page view
1501   my $msg = GetParam('msg', '');
1502   $Message .= $q->p($msg) if $msg; # show message if the page is shown
1503   SetParam('msg', '');
1504   print GetHeader($id, NormalToFree($id), $oldId, undef, $status,
1505                   GetFooterLinks($id, $revision));
1506   my $showDiff = GetParam('diff', 0);
1507   if ($UseDiff && $showDiff) {
1508     PrintHtmlDiff($showDiff, GetParam('diffrevision', $revision), $revision, $text, $summary);
1509     print $q->hr();
1510   }
1511   PrintPageContent($text, $revision, $comment);
1512   SetParam('rcclusteronly', $id) if FreeToNormal(GetCluster($text)) eq $id; # automatically filter by cluster
1513   PrintRcHtml($id);
1514   PrintFooter($id, $revision, $comment);
1515 }
1516
1517 sub ReBrowsePage {
1518   my ($id, $oldId) = map { UrlEncode($_); } @_; # encode before printing URL
1519   if ($oldId) {     # Target of #REDIRECT (loop breaking)
1520     print GetRedirectPage("action=browse;oldid=$oldId;id=$id", $id);
1521   } else {
1522     print GetRedirectPage($id, $id);
1523   }
1524 }
1525
1526 sub GetRedirectPage {
1527   my ($action, $name) = @_;
1528   my ($url, $html);
1529   if (GetParam('raw', 0)) {
1530     $html = GetHttpHeader('text/plain');
1531     $html .= Ts('Please go on to %s.', $action); # no redirect
1532     return $html;
1533   }
1534   if ($UsePathInfo and $action !~ /=/) {
1535     $url = $ScriptName . '/' . $action;
1536   } else {
1537     $url = $ScriptName . '?' . $action;
1538   }
1539   my $nameLink = $q->a({-href=>$url}, $name);
1540   my %headers = (-uri=>$url);
1541   my $cookie = Cookie();
1542   if ($cookie) {
1543     $headers{-cookie} = $cookie;
1544   }
1545   return $q->redirect(%headers);
1546 }
1547
1548 sub DoRandom {
1549   my @pages = AllPagesList();
1550   ReBrowsePage($pages[int(rand($#pages + 1))]);
1551 }
1552
1553 sub PageFresh { # pages can depend on other pages (ie. last update), admin status, and css
1554   return 1 if $q->http('HTTP_IF_NONE_MATCH') and GetParam('cache', $UseCache) >= 2
1555     and $q->http('HTTP_IF_NONE_MATCH') eq PageEtag();
1556 }
1557
1558 sub PageEtag {
1559   my ($changed, $visible, %params) = CookieData();
1560   return UrlEncode(join($FS, $LastUpdate||$Now, sort(values %params))); # no CTL in field values
1561 }
1562
1563 sub FileFresh { # old files are never stale, current files are stale when the page was modified
1564   return 1 if $q->http('HTTP_IF_NONE_MATCH') and GetParam('cache', $UseCache) >= 2
1565     and (GetParam('revision', 0) or $q->http('HTTP_IF_NONE_MATCH') eq $Page{ts});
1566 }
1567
1568 sub BrowseRc {
1569   my $id = shift;
1570   if (GetParam('raw', 0)) {
1571     print GetHttpHeader('text/plain');
1572     PrintRcText();
1573   } else {
1574     PrintRcHtml($id || $RCName, 1);
1575   }
1576 }
1577
1578 sub GetRcLines { # starttime, hash of seen pages to use as a second return value
1579   my $starttime = shift || GetParam('from', 0) ||
1580     $Now - GetParam('days', $RcDefault) * 86400; # 24*60*60
1581   my $filterOnly = GetParam('rcfilteronly', '');
1582   # these variables apply accross logfiles
1583   my %match = $filterOnly ? map { $_ => 1 } SearchTitleAndBody($filterOnly) : ();
1584   my %following = ();
1585   my @result = ();
1586   # check the first timestamp in the default file, maybe read old log file
1587   open(F, '<:utf8', $RcFile);
1588   my $line = <F>;
1589   my ($ts) = split(/$FS/o, $line); # the first timestamp in the regular rc file
1590   if (not $ts or $ts > $starttime) { # we need to read the old rc file, too
1591     push(@result, GetRcLinesFor($RcOldFile, $starttime,\%match, \%following));
1592   }
1593   push(@result, GetRcLinesFor($RcFile, $starttime, \%match, \%following));
1594   # GetRcLinesFor is trying to save memory space, but some operations
1595   # can only happen once we have all the data.
1596   return LatestChanges(StripRollbacks(@result));
1597 }
1598
1599 sub LatestChanges {
1600   my $all = GetParam('all', 0);
1601   my @result = @_;
1602   my %seen = ();
1603   for (my $i = $#result; $i >= 0; $i--) {
1604     my $id = $result[$i][1];
1605     if ($all) {
1606       $result[$i][9] = 1 unless $seen{$id}; # mark latest edit
1607     } else {
1608       splice(@result, $i, 1) if $seen{$id}; # remove older edits
1609     }
1610     $seen{$id} = 1;
1611   }
1612   my $to = GetParam('upto', 0);
1613   if ($to) {
1614     for (my $i = 0; $i < $#result; $i++) {
1615       if ($result[$i][0] > $to) {
1616         splice(@result, $i);
1617         last;
1618       }
1619     }
1620   }
1621   return reverse @result;
1622 }
1623
1624 sub StripRollbacks {
1625   my @result = @_;
1626   if (not (GetParam('all', 0) or GetParam('rollback', 0))) { # strip rollbacks
1627     my (%rollback);
1628     for (my $i = $#result; $i >= 0; $i--) {
1629       # some fields have a different meaning if looking at rollbacks
1630       my $ts = $result[$i][0];
1631       my $id = $result[$i][1];
1632       my $target_ts = $result[$i][2];
1633       my $target_id = $result[$i][3];
1634       if ($id eq '[[rollback]]') {
1635         if ($target_id) {
1636           $rollback{$target_id} = $target_ts; # single page rollback
1637           splice(@result, $i, 1);             # strip marker
1638         } else {
1639           my $end = $i;
1640           while ($ts > $target_ts and $i > 0) {
1641             $i--; # quickly skip all these lines
1642             $ts = $result[$i][0];
1643           }
1644           splice(@result, $i + 1, $end - $i);
1645           $i++; # compensate $i-- in for loop
1646         }
1647       } elsif ($rollback{$id} and $ts > $rollback{$id}) {
1648         splice(@result, $i, 1); # strip rolled back single pages
1649       }
1650     }
1651   } else {                # just strip the marker left by DoRollback()
1652     for (my $i = $#result; $i >= 0; $i--) {
1653       splice(@result, $i, 1) if $result[$i][1] eq '[[rollback]]'; # id
1654     }
1655   }
1656   return @result;
1657 }
1658
1659 sub GetRcLinesFor {
1660   my $file = shift;
1661   my $starttime = shift;
1662   my %match = %{$_[0]}; # deref
1663   my %following = %{$_[1]}; # deref
1664   # parameters
1665   my $showminoredit = GetParam('showedit', $ShowEdits); # show minor edits
1666   my $all = GetParam('all', 0);
1667   my ($idOnly, $userOnly, $hostOnly, $clusterOnly, $filterOnly, $match, $lang,
1668       $followup) = map { UnquoteHtml(GetParam($_, '')); }
1669         qw(rcidonly rcuseronly rchostonly
1670         rcclusteronly rcfilteronly match lang followup);
1671   # parsing and filtering
1672   my @result = ();
1673   open(F, '<:utf8', $file) or return ();
1674   while (my $line = <F>) {
1675     chomp($line);
1676     my ($ts, $id, $minor, $summary, $host, $username, $revision,
1677         $languages, $cluster) = split(/$FS/o, $line);
1678     next if $ts < $starttime;
1679     $following{$id} = $ts if $followup and $followup eq $username;
1680     next if $followup and (not $following{$id} or $ts <= $following{$id});
1681     next if $idOnly and $idOnly ne $id;
1682     next if $filterOnly and not $match{$id};
1683     next if ($userOnly and $userOnly ne $username);
1684     next if $minor == 1 and !$showminoredit; # skip minor edits (if [[rollback]] this is bogus)
1685     next if !$minor and $showminoredit == 2; # skip major edits
1686     next if $match and $id !~ /$match/i;
1687     next if $hostOnly and $host !~ /$hostOnly/i;
1688     my @languages = split(/,/, $languages);
1689     next if $lang and @languages and not grep(/$lang/, @languages);
1690     if ($PageCluster) {
1691       ($cluster, $summary) = ($1, $2) if $summary =~ /^\[\[$FreeLinkPattern\]\] ?: *(.*)/
1692         or $summary =~ /^$LinkPattern ?: *(.*)/o;
1693       next if ($clusterOnly and $clusterOnly ne $cluster);
1694       $cluster = '' if $clusterOnly; # don't show cluster if $clusterOnly eq $cluster
1695       if ($all < 2 and not $clusterOnly and $cluster) {
1696         $summary = "$id: $summary"; # print the cluster instead of the page
1697         $id = $cluster;
1698         $revision = '';
1699       }
1700     } else {
1701       $cluster = '';
1702     }
1703     $following{$id} = $ts if $followup and $followup eq $username;
1704     push(@result, [$ts, $id, $minor, $summary, $host, $username, $revision,
1705                    \@languages, $cluster]);
1706   }
1707   return @result;
1708 }
1709
1710 sub ProcessRcLines {
1711   my ($printDailyTear, $printRCLine) = @_; # code references
1712   # needed for output
1713   my $date = '';
1714   for my $line (GetRcLines()) {
1715     my ($ts, $id, $minor, $summary, $host, $username, $revision, $languageref,
1716         $cluster, $last) = @$line;
1717     if ($date ne CalcDay($ts)) {
1718       $date = CalcDay($ts);
1719       &$printDailyTear($date);
1720     }
1721     &$printRCLine($id, $ts, $host, $username, $summary, $minor, $revision,
1722       $languageref, $cluster, $last);
1723   }
1724 }
1725
1726 sub RcHeader {
1727   my ($from, $upto, $html) = (GetParam('from', 0), GetParam('upto', 0), '');
1728   if ($from) {
1729     $html .= $q->h2(Ts('Updates since %s', TimeToText(GetParam('from', 0))) . ' '
1730                     . ($upto ? Ts('up to %s', TimeToText($upto)) : ''));
1731   } else {
1732     $html .= $q->h2((GetParam('days', $RcDefault) != 1)
1733         ? Ts('Updates in the last %s days',
1734        GetParam('days', $RcDefault))
1735         : Ts('Updates in the last %s day',
1736        GetParam('days', $RcDefault)))
1737   }
1738   my $days = GetParam('days', $RcDefault);
1739   my $all = GetParam('all', 0);
1740   my $edits = GetParam('showedit', 0);
1741   my $rollback = GetParam('rollback', 0);
1742   my $action = '';
1743   my ($idOnly, $userOnly, $hostOnly, $clusterOnly, $filterOnly,
1744       $match, $lang, $followup) =
1745   map {
1746     my $val = GetParam($_, '');
1747     $html .= $q->p($q->b('(' . Ts('for %s only', $val) . ')')) if $val;
1748     $action .= ";$_=$val" if $val; # remember these parameters later!
1749     $val;
1750   } qw(rcidonly rcuseronly rchostonly rcclusteronly rcfilteronly
1751        match lang followup);
1752   my $rss = "action=rss$action;days=$days;all=$all;showedit=$edits";
1753   if ($clusterOnly) {
1754     $action = GetPageParameters('browse', $clusterOnly) . $action;
1755   } else {
1756     $action = "action=rc$action";
1757   }
1758   my @menu;
1759   if ($all) {
1760     push(@menu, ScriptLink("$action;days=$days;all=0;showedit=$edits",
1761          T('List latest change per page only')));
1762   } else {
1763     push(@menu, ScriptLink("$action;days=$days;all=1;showedit=$edits",
1764          T('List all changes')));
1765     if ($rollback) {
1766       push(@menu, ScriptLink("$action;days=$days;all=0;rollback=0;"
1767            . "showedit=$edits", T('Skip rollbacks')));
1768     } else {
1769       push(@menu, ScriptLink("$action;days=$days;all=0;rollback=1;"
1770            . "showedit=$edits", T('Include rollbacks')));
1771     }
1772   }
1773   if ($edits) {
1774     push(@menu, ScriptLink("$action;days=$days;all=$all;showedit=0",
1775          T('List only major changes')));
1776   } else {
1777     push(@menu, ScriptLink("$action;days=$days;all=$all;showedit=1",
1778          T('Include minor changes')));
1779   }
1780   return $html .
1781     $q->p((map { ScriptLink("$action;days=$_;all=$all;showedit=$edits",
1782                             ($_ != 1) ? Ts('%s days', $_) : Ts('%s days', $_));
1783                } @RcDays), $q->br(), @menu, $q->br(),
1784           ScriptLink($action . ';from=' . ($LastUpdate + 1)
1785                      . ";all=$all;showedit=$edits", T('List later changes')),
1786           ScriptLink($rss, T('RSS'), 'rss nopages nodiff'),
1787           ScriptLink("$rss;full=1", T('RSS with pages'), 'rss pages nodiff'),
1788           ScriptLink("$rss;full=1;diff=1", T('RSS with pages and diff'),
1789                      'rss pages diff'));
1790 }
1791
1792 sub GetScriptUrlWithRcParameters {
1793   my $url = "$ScriptName?action=rss";
1794   foreach my $param (qw(from upto days all showedit rollback rcidonly rcuseronly
1795                         rchostonly rcclusteronly rcfilteronly match lang
1796                         followup page diff full)) {
1797     my $val = GetParam($param, undef);
1798     $url .= ";$param=$val" if defined $val;
1799   }
1800   return $url;
1801 }
1802
1803 sub GetFilterForm {
1804   my $form = $q->strong(T('Filters'));
1805   $form .= $q->input({-type=>'hidden', -name=>'action', -value=>'rc'});
1806   $form .= $q->input({-type=>'hidden', -name=>'all', -value=>1})
1807     if (GetParam('all', 0));
1808   $form .= $q->input({-type=>'hidden', -name=>'showedit', -value=>1})
1809     if (GetParam('showedit', 0));
1810   $form .= $q->input({-type=>'hidden', -name=>'days',
1811           -value=>GetParam('days', $RcDefault)})
1812     if (GetParam('days', $RcDefault) != $RcDefault);
1813   my $table = '';
1814   foreach my $h (['match' => T('Title:')],
1815      ['rcfilteronly' => T('Title and Body:')],
1816      ['rcuseronly' => T('Username:')], ['rchostonly' => T('Host:')],
1817      ['followup' => T('Follow up to:')]) {
1818     $table .= $q->Tr($q->td($q->label({-for=>$h->[0]}, $h->[1])),
1819          $q->td($q->textfield(-name=>$h->[0], -id=>$h->[0],
1820             -size=>20)));
1821   }
1822   $table .= $q->Tr($q->td($q->label({-for=>'rclang'}, T('Language:')))
1823        . $q->td($q->textfield(-name=>'lang', -id=>'rclang',
1824             -size=>10,
1825             -default=>GetParam('lang', ''))))
1826     if %Languages;
1827   return GetFormStart(undef, 'get', 'filter') . $q->p($form) . $q->table($table)
1828     . $q->p($q->submit('dofilter', T('Go!'))) . $q->endform;
1829 }
1830
1831 sub RcHtml {
1832   my ($html, $inlist) = ('', 0);
1833   # Optimize param fetches and translations out of main loop
1834   my $all = GetParam('all', 0);
1835   my $admin = UserIsAdmin();
1836   my $rollback_was_possible = 0;
1837   my $printDailyTear = sub {
1838     my $date = shift;
1839     if ($inlist) {
1840       $html .= '</ul>';
1841       $inlist = 0;
1842     }
1843     $html .= $q->p($q->strong($date));
1844     if (!$inlist) {
1845       $html .= '<ul>';
1846       $inlist = 1;
1847     }
1848   };
1849   my $printRCLine = sub {
1850     my($id, $ts, $host, $username, $summary, $minor, $revision,
1851        $languages, $cluster, $last) = @_;
1852     my $all_revision = $last ? undef : $revision; # no revision for the last one
1853     $host = QuoteHtml($host);
1854     my $author = GetAuthorLink($host, $username);
1855     my $sum = $summary ? $q->span({class=>'dash'}, ' &#8211; ')
1856       . $q->strong(QuoteHtml($summary)) : '';
1857     my $edit = $minor ? $q->em({class=>'type'}, T('(minor)')) : '';
1858     my $lang = @{$languages}
1859       ? $q->span({class=>'lang'}, '[' . join(', ', @{$languages}) . ']') : '';
1860     my ($pagelink, $history, $diff, $rollback) = ('', '', '', '');
1861     if ($all) {
1862       $pagelink = GetOldPageLink('browse', $id, $all_revision, $id, $cluster);
1863       my $rollback_is_possible = RollbackPossible($ts);
1864       if ($admin and ($rollback_is_possible or $rollback_was_possible)) {
1865         $rollback = $q->submit("rollback-$ts", T('rollback'));
1866         $rollback_was_possible = $rollback_is_possible;
1867       } else {
1868         $rollback_was_possible = 0;
1869       }
1870     } elsif ($cluster) {
1871       $pagelink = GetOldPageLink('browse', $id, $revision, $id, $cluster);
1872     } else {
1873       $pagelink = GetPageLink($id, $cluster);
1874       $history = '(' . GetHistoryLink($id, T('history')) . ')';
1875     }
1876     if ($cluster and $PageCluster) {
1877       $diff .= GetPageLink($PageCluster) . ':';
1878     } elsif ($UseDiff and GetParam('diffrclink', 1)) {
1879       if ($revision == 1) {
1880         $diff .= '(' . $q->span({-class=>'new'}, T('new')) . ')';
1881       } elsif ($all) {
1882         $diff .= '(' . ScriptLinkDiff(2, $id, T('diff'), '', $all_revision) .')';
1883       } else {
1884         $diff .= '(' . ScriptLinkDiff($minor ? 2 : 1, $id, T('diff'), '') . ')';
1885       }
1886     }
1887     $html .= $q->li($q->span({-class=>'time'}, CalcTime($ts)), $diff, $history,
1888                     $rollback, $pagelink, T(' . . . . '), $author, $sum, $lang,
1889                     $edit);
1890   };
1891   ProcessRcLines($printDailyTear, $printRCLine);
1892   $html .= '</ul>' if $inlist;
1893   my $to = GetParam('from', $Now - GetParam('days', $RcDefault) * 86400);
1894   my $from = $to - GetParam('days', $RcDefault) * 86400;
1895   my $more = "action=rc;from=$from;upto=$to";
1896   foreach (qw(all showedit rollback rcidonly rcuseronly rchostonly
1897               rcclusteronly rcfilteronly match lang followup)) {
1898     my $val = GetParam($_, '');
1899     $more .= ";$_=$val" if $val;
1900   }
1901   $html .= $q->p({-class=>'more'}, ScriptLink($more, T('More...'), 'more'));
1902   return GetFormStart(undef, 'get', 'rc') . $html . $q->endform;
1903 }
1904
1905 sub PrintRcHtml { # to append RC to existing page, or action=rc directly
1906   my ($id, $standalone) = @_;
1907   my $rc = ($id eq $RCName or $id eq T($RCName) or T($id) eq $RCName);
1908   print GetHeader('', $rc ? NormalToFree($id) : Ts('All changes for %s', NormalToFree($id)), undef, undef, undef, GetFooterLinks($id))
1909     if $standalone;
1910   if ($standalone or $rc or GetParam('rcclusteronly', '')) {
1911     print $q->start_div({-class=>'rc'});
1912     print $q->hr() unless $standalone or GetParam('embed', $EmbedWiki);
1913     print RcHeader() . RcHtml() . GetFilterForm() . $q->end_div();
1914   }
1915   PrintFooter($id) if $standalone;
1916 }
1917
1918 sub RcTextItem {
1919   my ($name, $value) = @_;
1920   $value =~ s/\n+$//;
1921   $value =~ s/\n+/\n /;
1922   return $value ? $name . ': ' . $value . "\n" : '';
1923 }
1924
1925 sub RcTextRevision {
1926   my($id, $ts, $host, $username, $summary, $minor, $revision,
1927      $languages, $cluster, $last) = @_;
1928   my $link = $ScriptName
1929     . (GetParam('all', 0) && ! $last
1930        ? '?' . GetPageParameters('browse', $id, $revision, $cluster, $last)
1931        : ($UsePathInfo ? '/' : '?') . UrlEncode($id));
1932   print "\n", RcTextItem('title', NormalToFree($id)),
1933     RcTextItem('description', $summary),
1934     RcTextItem('generator', $username
1935          ? $username . ' ' . Ts('from %s', $host) : $host),
1936     RcTextItem('language', join(', ', @{$languages})), RcTextItem('link', $link),
1937     RcTextItem('last-modified', TimeToW3($ts)),
1938       RcTextItem('revision', $revision);
1939 }
1940
1941 sub PrintRcText { # print text rss header and call ProcessRcLines
1942   local $RecentLink = 0;
1943   print RcTextItem('title', $SiteName),
1944     RcTextItem('description', $SiteDescription), RcTextItem('link', $ScriptName),
1945     RcTextItem('generator', 'Oddmuse'), RcTextItem('rights', $RssRights);
1946   ProcessRcLines(sub {}, \&RcTextRevision);
1947 }
1948
1949 sub GetRcRss {
1950   my $date = TimeToRFC822($LastUpdate);
1951   my %excluded = ();
1952   if (GetParam("exclude", 1)) {
1953     foreach (split(/\n/, GetPageContent($RssExclude))) {
1954       if (/^ ([^ ]+)[ \t]*$/) { # only read lines with one word after one space
1955   $excluded{$1} = 1;
1956       }
1957     }
1958   }
1959   my $rss = qq{<?xml version="1.0" encoding="UTF-8"?>\n};
1960   if ($RssStyleSheet =~ /\.(xslt?|xml)$/) {
1961     $rss .= qq{<?xml-stylesheet type="text/xml" href="$RssStyleSheet" ?>\n};
1962   } elsif ($RssStyleSheet) {
1963     $rss .= qq{<?xml-stylesheet type="text/css" href="$RssStyleSheet" ?>\n};
1964   }
1965   $rss .= qq{<rss version="2.0"
1966     xmlns:wiki="http://purl.org/rss/1.0/modules/wiki/"
1967     xmlns:dc="http://purl.org/dc/elements/1.1/"
1968     xmlns:cc="http://web.resource.org/cc/"
1969     xmlns:atom="http://www.w3.org/2005/Atom">
1970 <channel>
1971 <docs>http://blogs.law.harvard.edu/tech/rss</docs>
1972 };
1973   my $title = QuoteHtml($SiteName) . ': '
1974     . GetParam('title', QuoteHtml(NormalToFree($HomePage)));
1975   $rss .= "<title>$title</title>\n";
1976   $rss .= "<link>" . ScriptUrl($HomePage) . "</link>\n";
1977   $rss .= qq{<atom:link href="} . GetScriptUrlWithRcParameters()
1978     . qq{" rel="self" type="application/rss+xml" />\n};
1979   $rss .= "<description>" . QuoteHtml($SiteDescription) . "</description>\n"
1980     if $SiteDescription;
1981   $rss .= "<pubDate>$date</pubDate>\n";
1982   $rss .= "<lastBuildDate>$date</lastBuildDate>\n";
1983   $rss .= "<generator>Oddmuse</generator>\n";
1984   $rss .= "<copyright>$RssRights</copyright>\n" if $RssRights;
1985   $rss .= join('', map {"<cc:license>" . QuoteHtml($_) . "</cc:license>\n"}
1986          (ref $RssLicense eq 'ARRAY' ? @$RssLicense : $RssLicense))
1987     if $RssLicense;
1988   $rss .= "<wiki:interwiki>$InterWikiMoniker</wiki:interwiki>\n"
1989     if $InterWikiMoniker;
1990   if ($RssImageUrl) {
1991     $rss .= "<image>\n";
1992     $rss .= "<url>$RssImageUrl</url>\n";
1993     $rss .= "<title>$title</title>\n";    # the same as the channel
1994     $rss .= "<link>$ScriptName</link>\n"; # the same as the channel
1995     $rss .= "</image>\n";
1996   }
1997   my $limit = GetParam("rsslimit", 15); # Only take the first 15 entries
1998   my $count = 0;
1999   ProcessRcLines(sub {}, sub {
2000        my $id = shift;
2001        return if $excluded{$id}
2002          or ($limit ne 'all' and $count++ >= $limit);
2003        $rss .= "\n" . RssItem($id, @_);
2004      });
2005   $rss .= "</channel>\n</rss>\n";
2006   return $rss;
2007 }
2008
2009 sub RssItem {
2010   my ($id, $ts, $host, $username, $summary, $minor, $revision,
2011       $languages, $cluster, $last) = @_;
2012   my $name = ItemName($id);
2013   $summary = PageHtml($id, 50*1024, T('This page is too big to send over RSS.'))
2014     if (GetParam('full', 0)); # full page means summary is not shown
2015   my $date = TimeToRFC822($ts);
2016   $username = QuoteHtml($username);
2017   $username = $host unless $username;
2018   my $rss = "<item>\n";
2019   $rss .= "<title>$name</title>\n";
2020   my $link = ScriptUrl(GetParam('all', $cluster)
2021              ? GetPageParameters('browse', $id, $revision, $cluster, $last)
2022              : UrlEncode($id));
2023   $rss .= "<link>$link</link>\n<guid>$link</guid>\n";
2024   $rss .= "<description>" . QuoteHtml($summary) . "</description>\n" if $summary;
2025   $rss .= "<pubDate>" . $date . "</pubDate>\n";
2026   $rss .= "<comments>" . ScriptUrl($CommentsPrefix . UrlEncode($id))
2027     . "</comments>\n" if $CommentsPrefix and $id !~ /^$CommentsPrefix/o;
2028   $rss .= "<dc:contributor>" . $username . "</dc:contributor>\n" if $username;
2029   $rss .= "<wiki:status>" . (1 == $revision ? 'new' : 'updated')
2030     . "</wiki:status>\n";
2031   $rss .= "<wiki:importance>" . ($minor ? 'minor' : 'major')
2032     . "</wiki:importance>\n";
2033   $rss .= "<wiki:version>" . $revision . "</wiki:version>\n";
2034   $rss .= "<wiki:history>" . ScriptUrl("action=history;id=" . UrlEncode($id))
2035     . "</wiki:history>\n";
2036   $rss .= "<wiki:diff>" . ScriptUrl("action=browse;diff=1;id=" . UrlEncode($id))
2037     . "</wiki:diff>\n" if $UseDiff and GetParam('diffrclink', 1);
2038   return $rss . "</item>\n";
2039 }
2040
2041 sub DoRss {
2042   print GetHttpHeader('application/xml');
2043   print GetRcRss();
2044 }
2045
2046 sub DoHistory {
2047   my $id = shift;
2048   ValidIdOrDie($id);
2049   OpenPage($id);
2050   if (GetParam('raw', 0)) {
2051     print GetHttpHeader('text/plain'),
2052       RcTextItem('title', Ts('History of %s', NormalToFree($OpenPageName))),
2053       RcTextItem('date', TimeToText($Now)),
2054       RcTextItem('link', ScriptUrl("action=history;id=$OpenPageName;raw=1")),
2055       RcTextItem('generator', 'Oddmuse');
2056     SetParam('all', 1);
2057     my @languages = split(/,/, $Page{languages});
2058     RcTextRevision($id, $Page{ts}, $Page{host}, $Page{username}, $Page{summary},
2059        $Page{minor}, $Page{revision}, \@languages, undef, 1);
2060     foreach my $revision (GetKeepRevisions($OpenPageName)) {
2061       my %keep = GetKeptRevision($revision);
2062       @languages = split(/,/, $keep{languages});
2063       RcTextRevision($id, $keep{ts}, $keep{host}, $keep{username},
2064          $keep{summary}, $keep{minor}, $keep{revision}, \@languages);
2065     }
2066   } else {
2067     print GetHeader('', Ts('History of %s', NormalToFree($id)),
2068                     undef, undef, undef, GetFooterLinks($id, 'history'));
2069     my $row = 0;
2070     my $rollback = UserCanEdit($id, 0) && (GetParam('username', '')
2071              or UserIsEditor());
2072     my $date = CalcDay($Page{ts});
2073     my @html = (GetHistoryLine($id, \%Page, $row++, $rollback, $date, 1));
2074     foreach my $revision (GetKeepRevisions($OpenPageName)) {
2075       my %keep = GetKeptRevision($revision);
2076       my $new = CalcDay($keep{ts});
2077       push(@html, GetHistoryLine($id, \%keep, $row++, $rollback,
2078                                  $new, $new ne $date));
2079       $date = $new;
2080     }
2081     @html = (GetFormStart(undef, 'get', 'history'),
2082        $q->p($q->submit({-name=>T('Compare')}),
2083        # don't use $q->hidden here!
2084        $q->input({-type=>'hidden',-name=>'action',-value=>'browse'}),
2085        $q->input({-type=>'hidden', -name=>'diff', -value=>'1'}),
2086        $q->input({-type=>'hidden', -name=>'id', -value=>$id})),
2087        $q->table({-class=>'history'}, @html),
2088        $q->p($q->submit({-name=>T('Compare')})),
2089        $q->end_form()) if $UseDiff;
2090     push(@html, $q->p(ScriptLink('title=' . UrlEncode($id) . ';text='
2091          . UrlEncode($DeletedPage) . ';summary='
2092          . UrlEncode(T('Deleted')),
2093          T('Mark this page for deletion'))))
2094       if $KeepDays and $rollback and $Page{revision};
2095     print $q->div({-class=>'content history'}, @html);
2096     PrintFooter($id, 'history');
2097   }
2098 }
2099
2100 sub GetHistoryLine {
2101   my ($id, $dataref, $row, $rollback, $date, $newday) = @_;
2102   my %data = %$dataref;
2103   my $revision = $data{revision};
2104   return $q->p(T('No other revisions available')) unless $revision;
2105   my $html = CalcTime($data{ts});
2106   if (0 == $row) {    # current revision
2107     $html .= ' (' . T('current') . ')' if $rollback;
2108     $html .= ' ' . GetPageLink($id, Ts('Revision %s', $revision));
2109   } else {
2110     $html .= ' ' . $q->submit("rollback-$data{ts}", T('rollback')) if $rollback;
2111     $html .= ' ' . GetOldPageLink('browse', $id, $revision,
2112           Ts('Revision %s', $revision));
2113   }
2114   my $host = $data{host};
2115   $host = $data{ip} unless $host;
2116   $html .= T(' . . . . ') . GetAuthorLink($host, $data{username});
2117   $html .= $q->span({class=>'dash'}, ' &#8211; ')
2118     . $q->strong(QuoteHtml($data{summary})) if $data{summary};
2119   $html .= ' ' . $q->em({class=>'type'}, T('(minor)')) . ' ' if $data{minor};
2120   if ($UseDiff) {
2121     my %attr1 = (-type=>'radio', -name=>'diffrevision', -value=>$revision);
2122     $attr1{-checked} = 'checked' if 1==$row;
2123     my %attr2 = (-type=>'radio', -name=>'revision', -value=> $row ? $revision : '');
2124     $attr2{-checked} = 'checked' if 0==$row; # first row is special
2125     $html = $q->Tr($q->td($q->input(\%attr1)), $q->td($q->input(\%attr2)),
2126        $q->td($html));
2127     $html = $q->Tr($q->td({-colspan=>3}, $q->strong($date))) . $html if $newday;
2128   } else {
2129     $html .= $q->br();
2130     $html = $q->strong($date) . $q->br() . $html if $newday;
2131   }
2132   return $html;
2133 }
2134
2135 sub DoContributors {
2136   my $id = shift;
2137   SetParam('rcidonly', $id);
2138   SetParam('all', 1);
2139   print GetHeader('', Ts('Contributors to %s', NormalToFree($id || $SiteName)));
2140   my %contrib = ();
2141   for my $line (GetRcLines(1)) {
2142     my ($ts, $pagename, $minor, $summary, $host, $username) = @$line;
2143     $contrib{$username}++ if $username;
2144   }
2145   print $q->div({-class=>'content contrib'},
2146     $q->p(map { GetPageLink($_) } sort(keys %contrib)));
2147   PrintFooter();
2148 }
2149
2150 sub RollbackPossible {
2151   my $ts = shift; # there can be no rollback to the most recent change(s) made (1s resolution!)
2152   return $ts != $LastUpdate && ($Now - $ts) < $KeepDays * 86400; # 24*60*60
2153 }
2154
2155 sub DoRollback {
2156   my $page = shift;
2157   my $to = GetParam('to', 0);
2158   ReportError(T('Missing target for rollback.'), '400 BAD REQUEST') unless $to;
2159   ReportError(T('Target for rollback is too far back.'), '400 BAD REQUEST') unless $page or RollbackPossible($to);
2160   ReportError(T('A username is required for ordinary users.'), '403 FORBIDDEN') unless GetParam('username', '') or UserIsEditor();
2161   my @ids = ();
2162   if (not $page) {   # cannot just use list length because of ('')
2163     return unless UserIsAdminOrError(); # only admins can do mass changes
2164     SetParam('showedit', 1); # make GetRcLines return minor edits as well
2165     SetParam('all', 1);      # prevent LatestChanges from interfering
2166     SetParam('rollback', 1); # prevent StripRollbacks from interfering
2167     my %ids = map { my ($ts, $id) = @$_; $id => 1; } # make unique via hash
2168       GetRcLines($Now - $KeepDays * 86400); # 24*60*60
2169     @ids = keys %ids;
2170   } else {
2171     @ids = ($page);
2172   }
2173   RequestLockOrError();
2174   print GetHeader('', T('Rolling back changes'),
2175                   undef, undef, undef, GetFooterLinks($page)),
2176                     $q->start_div({-class=>'content rollback'}), $q->start_p();
2177   foreach my $id (@ids) {
2178     OpenPage($id);
2179     my ($text, $minor, $ts) = GetTextAtTime($to);
2180     if ($Page{text} eq $text) {
2181       print T("The two revisions are the same."), $q->br() if $page; # no message when doing mass revert
2182     } elsif (!UserCanEdit($id, 1)) {
2183       print Ts('Editing not allowed for %s.', $id), $q->br();
2184     } elsif (not UserIsEditor() and my $rule = BannedContent($text)) {
2185       print Ts('Rollback of %s would restore banned content.', $id), $rule, $q->br();
2186     } else {
2187       Save($id, $text, Ts('Rollback to %s', TimeToText($to)), $minor, ($Page{ip} ne $ENV{REMOTE_ADDR}));
2188       print Ts('%s rolled back', GetPageLink($id)), ($ts ? ' ' . Ts('to %s', TimeToText($to)) : ''), $q->br();
2189     }
2190   }
2191   WriteRcLog('[[rollback]]', $page, $to); # leave marker
2192   print $q->end_p() . $q->end_div();
2193   ReleaseLock();
2194   PrintFooter($page);
2195 }
2196
2197 sub DoAdminPage {
2198   my ($id, @rest) = @_;
2199   my @menu = ();
2200   push(@menu, ScriptLink('action=index',
2201                          T('Index of all pages'), 'index'))
2202     if $Action{index};
2203   push(@menu, ScriptLink('action=version',
2204                          T('Wiki Version'), 'version'))
2205     if $Action{version};
2206   push(@menu, ScriptLink('action=unlock',
2207                          T('Unlock Wiki'), 'unlock'))
2208     if $Action{unlock};
2209   push(@menu, ScriptLink('action=password',
2210                          T('Password'), 'password'))
2211     if $Action{password};
2212   push(@menu, ScriptLink('action=maintain',
2213                          T('Run maintenance'), 'maintain'))
2214     if $Action{maintain};
2215   if (UserIsAdmin()) {
2216     push(@menu, ScriptLink('action=clear',
2217                            T('Clear Cache'), 'clear'))
2218       if $Action{clear};
2219     if ($Action{editlock}) {
2220       if (-f "$DataDir/noedit") {
2221         push(@menu, ScriptLink('action=editlock;set=0',
2222                               T('Unlock site'), 'editlock 0'));
2223       } else {
2224         push(@menu, ScriptLink('action=editlock;set=1',
2225                                T('Lock site'), 'editlock 1'));
2226       }
2227     }
2228     if ($id and $Action{pagelock}) {
2229       my $title = NormalToFree($id);
2230       if (-f GetLockedPageFile($id)) {
2231         push(@menu, ScriptLink('action=pagelock;set=0;id='
2232                                . UrlEncode($id),
2233                                Ts('Unlock %s', $title),
2234                                'pagelock 0'));
2235       } else {
2236         push(@menu, ScriptLink('action=pagelock;set=1;id='
2237                                . UrlEncode($id),
2238                                Ts('Lock %s', $title),
2239                                'pagelock 1'));
2240       }
2241     }
2242   }
2243   foreach my $sub (@MyAdminCode) {
2244     &$sub($id, \@menu, \@rest);
2245     $Message .= $q->p($@) if $@; # since this happens before GetHeader is called, the message will be shown
2246   }
2247   print GetHeader('', T('Administration')),
2248     $q->div({-class=>'content admin'}, $q->p(T('Actions:')), $q->ul($q->li(\@menu)),
2249       $q->p(T('Important pages:')) . $q->ul(map { $q->li(GetPageOrEditLink($_, NormalToFree($_))) if $_;
2250                   } sort keys %AdminPages),
2251       $q->p(Ts('To mark a page for deletion, put <strong>%s</strong> on the first line.',
2252          $DeletedPage)), @rest);
2253   PrintFooter();
2254 }
2255
2256 sub GetPageParameters {
2257   my ($action, $id, $revision, $cluster, $last) = @_;
2258   $id = FreeToNormal($id);
2259   my $link = "action=$action;id=" . UrlEncode($id);
2260   $link .= ";revision=$revision" if $revision and not $last;
2261   $link .= ';rcclusteronly=' . UrlEncode($cluster) if $cluster;
2262   return $link;
2263 }
2264
2265 sub GetOldPageLink {
2266   my ($action, $id, $revision, $name, $cluster, $last) = @_;
2267   return ScriptLink(GetPageParameters($action, $id, $revision, $cluster, $last),
2268                     NormalToFree($name), 'revision');
2269 }
2270
2271 sub GetSearchLink {
2272   my ($text, $class, $name, $title) = @_;
2273   my $id = UrlEncode(QuoteRegexp('"' . $text . '"'));
2274   $name = UrlEncode($name);
2275   $text = NormalToFree($text);
2276   $id =~ s/_/+/g;   # Search for url-escaped spaces
2277   return ScriptLink('search=' . $id, $text, $class, $name, $title);
2278 }
2279
2280 sub ScriptLinkDiff {
2281   my ($diff, $id, $text, $new, $old) = @_;
2282   my $action = 'action=browse;diff=' . $diff . ';id=' . UrlEncode($id);
2283   $action .= ";diffrevision=$old"  if ($old and $old ne '');
2284   $action .= ";revision=$new"  if ($new and $new ne '');
2285   return ScriptLink($action, $text, 'diff');
2286 }
2287
2288 sub GetAuthorLink {
2289   my ($host, $username) = @_;
2290   $username = FreeToNormal($username);
2291   my $name = NormalToFree($username);
2292   if (ValidId($username) ne '') { # ValidId() returns error string
2293     $username = '';     # Just pretend it isn't there.
2294   }
2295   if ($username and $RecentLink) {
2296     return ScriptLink(UrlEncode($username), $name, 'author', undef, Ts('from %s', $host));
2297   } elsif ($username) {
2298     return $q->span({-class=>'author'}, $name) . ' ' . Ts('from %s', $host);
2299   }
2300   return $host;
2301 }
2302
2303 sub GetHistoryLink {
2304   my ($id, $text) = @_;
2305   my $action = 'action=history;id=' . UrlEncode(FreeToNormal($id));
2306   return ScriptLink($action, $text, 'history');
2307 }
2308
2309 sub GetRCLink {
2310   my ($id, $text) = @_;
2311   return ScriptLink('action=rc;all=1;from=1;showedit=1;rcidonly=' . UrlEncode(FreeToNormal($id)), $text, 'rc');
2312 }
2313
2314 sub GetTitle {
2315   my ($id, $title) = @_;
2316   return $q->h1(GetSearchLink($id, '', '', T('Click to search for references to this page')))
2317     if ($id ne '');
2318
2319   return $q->h1($title);
2320 }
2321
2322 sub GetLogoUrl {
2323   return if (!$LogoUrl);
2324   my $alt = T('[Home]');
2325   my $url = $IndexHash{$LogoUrl} ? GetDownloadLink($LogoUrl, 2) : $LogoUrl;
2326   return ScriptLink(UrlEncode($HomePage),
2327                     $q->img({-src=>$url, -alt=>$alt, -class=>'logo'}), 'logo');
2328 }
2329
2330 sub GetMotd {
2331   my $day = CalcDay($Now);
2332   my $month_and_day =  substr($day, 5);
2333   my $message = $SpecialDays{$month_and_day};
2334
2335   return '' unless $message;
2336   return $q->div({-class=>'motd'},
2337                  $q->span({-class=>'specialdays'}, $message))
2338 }
2339
2340 sub GetHeader {
2341   my ($id, $title, $oldId, $nocache, $status, $editLinks) = @_;
2342   my $embed = GetParam('embed', $EmbedWiki);
2343   my $result = GetHttpHeader('text/html', $nocache, $status);
2344   if ($oldId) {
2345     $Message .= $q->p('(' . Ts('redirected from %s', GetEditLink($oldId, $oldId)) . ')');
2346   }
2347   $result .= GetHtmlHeader(Ts('%s: ', $SiteName) . UnWiki($title), $id);
2348   if ($embed) {
2349     $result .= $q->div({-class=>'header'}, $q->div({-class=>'message'}, $Message))  if $Message;
2350     return $result;
2351   }
2352   $result .= $q->start_div({-class=>'header'});
2353   $result .= GetLogoUrl();
2354
2355   $result .= GetLoginLinks($id);
2356
2357   my $topLinkBar = GetParam('toplinkbar', $TopLinkBar);
2358   my $gotoBar = $topLinkBar & 1; # bit0
2359   my $editBar = $topLinkBar & 2; # bit1
2360
2361   $result .= GetGotoBar($id) if $gotoBar;
2362   $result .= GetExploreGotoBar() if $gotoBar;
2363   $result .= GetEditorGotoBar() if $gotoBar;
2364   $result .= GetMotd() if $topLinkBar;
2365   $result .= $editLinks if $editBar && UserIsEditor();
2366
2367   $result .= $q->div({-class=>'message'}, $Message)  if $Message;
2368   $result .= GetTitle($id, $title);
2369   return $result . $q->end_div() . $q->start_div({-class=>'wrapper'});
2370 }
2371
2372 sub GetHttpHeader {
2373   return if $PrintedHeader;
2374   $PrintedHeader = 1;
2375   my ($type, $ts, $status, $encoding) = @_; # $ts is undef, a ts, or 'nocache'
2376   $q->charset($type =~ m!^(text/|application/xml)! ? 'utf-8' : ''); # text/plain, text/html, application/xml: UTF-8
2377   my %headers = (-cache_control=>($UseCache < 0 ? 'no-cache' : 'max-age=10'));
2378   $headers{-etag} = $ts || PageEtag() if GetParam('cache', $UseCache) >= 2;
2379   $headers{'-last-modified'} = TimeToRFC822($ts) if $ts and $ts ne 'nocache'; # RFC 2616 section 13.3.4
2380   $headers{-type} = GetParam('mime-type', $type);
2381   $headers{-status} = $status if $status;
2382   $headers{-Content_Encoding} = $encoding if $encoding;
2383   my $cookie = Cookie();
2384   $headers{-cookie} = $cookie  if $cookie;
2385   if ($q->request_method() eq 'HEAD') {
2386     print $q->header(%headers), "\n\n"; # add newlines for FCGI because of exit()
2387     exit; # total shortcut -- HEAD never expects anything other than the header!
2388   }
2389   return $q->header(%headers);
2390 }
2391
2392 sub CookieData {
2393   my ($changed, $visible, %params);
2394   foreach my $key (keys %CookieParameters) {
2395     my $default = $CookieParameters{$key};
2396     my $value = GetParam($key, $default);
2397     $params{$key} = $value  if $value ne $default;
2398     # The cookie is considered to have changed under the following
2399     # condition: If the value was already set, and the new value is
2400     # not the same as the old value, or if there was no old value, and
2401     # the new value is not the default.
2402     my $change = (defined $OldCookie{$key} ? ($value ne $OldCookie{$key}) : ($value ne $default));
2403     $visible = 1 if $change and not $InvisibleCookieParameters{$key};
2404     $changed = 1 if $change; # note if any parameter changed and needs storing
2405   }
2406   return $changed, $visible, %params;
2407 }
2408
2409 sub Cookie {
2410   my ($changed, $visible, %params) = CookieData(); # params are URL encoded
2411   if ($changed) {
2412     my $cookie = join(UrlEncode($FS), %params); # no CTL in field values
2413     my $result = $q->cookie(-name=>$CookieName, -value=>$cookie,
2414                             -expires=>'+2y');
2415     $Message .= $q->p(T('Cookie: ') . $CookieName . ', '
2416                       . join(', ', map {$_ . '=' . $params{$_}}
2417                              keys(%params))) if $visible;
2418     return $result;
2419   }
2420   return '';
2421 }
2422
2423 sub GetHtmlHeader {   # always HTML!
2424   my ($title, $id) = @_;
2425   my $base = $SiteBase ? $q->base({-href=>$SiteBase}) : '';
2426   $base .= '<link rel="alternate" type="application/wiki" title="'
2427     . T('Edit this page') . '" href="'
2428     . ScriptUrl('action=edit;id=' . UrlEncode(GetId())) . '" />' if $id;
2429   return $DocumentHeader
2430     . $q->head($q->title($title) . $base
2431       . GetCss() . GetRobots() . GetFeeds() . GetFavicon() . $HtmlHeaders
2432       . '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />')
2433       . '<body class="' . GetParam('theme', $ScriptName) . '">';
2434 }
2435
2436 sub GetRobots { # NOINDEX for non-browse pages.
2437   if (GetParam('action', 'browse') eq 'browse'
2438       and not GetParam('revision', '')) {
2439     return '<meta name="robots" content="INDEX,FOLLOW" />';
2440   } else {
2441     return '<meta name="robots" content="NOINDEX,FOLLOW" />';
2442   }
2443 }
2444
2445 sub GetFeeds {      # default for $HtmlHeaders
2446   my $html = '<link rel="alternate" type="application/rss+xml" title="'
2447     . QuoteHtml($SiteName) . '" href="' . $ScriptName . '?action=rss" />';
2448   my $id = GetId(); # runs during Init, not during DoBrowseRequest
2449   $html .= '<link rel="alternate" type="application/rss+xml" title="'
2450     . QuoteHtml("$SiteName: $id") . '" href="' . $ScriptName
2451     . '?action=rss;rcidonly=' . UrlEncode(FreeToNormal($id)) . '" />' if $id;
2452   my $username = GetParam('username', '');
2453   $html .= '<link rel="alternate" type="application/rss+xml" '
2454     . 'title="Follow-ups for ' . NormalToFree($username) . '" '
2455     . 'href="' . ScriptUrl('action=rss;followup=' . UrlEncode($username))
2456     . '" />' if $username;
2457   return $html;
2458 }
2459
2460 sub GetCss {      # prevent javascript injection
2461   my @css = map { s/\".*//; $_; } split(/\s+/, GetParam('css', ''));
2462   push (@css, $StyleSheet) if $StyleSheet and not @css;
2463   push (@css, "$ScriptName?action=browse;id=" . UrlEncode($StyleSheetPage) . ";raw=1;mime-type=text/css")
2464     if $IndexHash{$StyleSheetPage} and not @css;
2465   push (@css, 'http://www.oddmuse.org/default.css') unless @css;
2466   return join('', map { qq(<link type="text/css" rel="stylesheet" href="$_" />) } @css);
2467 }
2468
2469 sub GetFavicon {
2470   if ($Favicon) {
2471     my $url = $IndexHash{$Favicon} ? GetDownloadLink($Favicon, 2) : $Favicon;
2472     return qq(<link rel="shortcut icon" href="$url" />);
2473   }
2474
2475   return '';
2476 }
2477
2478 sub PrintPageContent {
2479   my ($text, $revision, $comment) = @_;
2480   print $q->start_div({-class=>'content browse'});
2481   if ($revision eq '' and $Page{blocks} and GetParam('cache', $UseCache) > 0) {
2482     PrintCache();
2483   } else {
2484     my $savecache = ($Page{revision} > 0 and $revision eq ''); # new page not cached
2485     PrintWikiToHTML($text, $savecache, $revision); # unlocked, with anchors, unlocked
2486   }
2487   if ($comment) {
2488     print $q->start_div({-class=>'preview'}), $q->hr();
2489     print $q->h2(T('Preview:'));
2490     # no caching, current revision, unlocked
2491     PrintWikiToHTML(AddComment('', $comment));
2492     print $q->hr(), $q->h2(T('Preview only, not yet saved')), $q->end_div();
2493   } print $q->end_div();
2494 }
2495
2496 sub PrintFooter {
2497   my ($id, $rev, $comment) = @_;
2498   if (GetParam('embed', $EmbedWiki)) {
2499     print $q->end_html, "\n";
2500     return;
2501   }
2502   print GetCommentForm($id, $rev, $comment),
2503     $q->start_div({-class=>'wrapper close'}), $q->end_div(), $q->end_div(),
2504       $q->start_div({-class=>'footer'}), $q->hr(), GetGotoBar($id),
2505   GetFooterLinks($id, $rev), GetFooterTimestamp($id, $rev);
2506   if ($DataDir =~ m|/tmp/|) {
2507     print $q->p($q->strong(T('Warning') . ': ')
2508     . Ts('Database is stored in temporary directory %s', $DataDir));
2509   }
2510   print T($FooterNote) if $FooterNote;
2511   print $q->p(GetValidatorLink()) if GetParam('validate', $ValidatorLink);
2512   print $q->p(Ts('%s seconds', (time - $Now))) if GetParam('timing',0);
2513   print $q->end_div();
2514   PrintMyContent($id) if defined(&PrintMyContent);
2515   foreach my $sub (@MyFooters) {
2516     print &$sub(@_);
2517   }
2518   print $q->end_html, "\n";
2519 }
2520
2521 sub GetFooterTimestamp {
2522   my ($id, $rev) = @_;
2523   if ($id and $rev ne 'history' and $rev ne 'edit' and $Page{revision}) {
2524     my @elements = ($q->br(), ($rev eq '' ? T('Last edited') : T('Edited')), TimeToText($Page{ts}),
2525         Ts('by %s', GetAuthorLink($Page{host}, $Page{username})));
2526     push(@elements, ScriptLinkDiff(2, $id, T('(diff)'), $rev)) if $UseDiff and $Page{revision} > 1;
2527     return $q->span({-class=>'time'}, @elements);
2528   }
2529   return '';
2530 }
2531
2532 sub GetAdminLink {
2533   my ($id) = @_;
2534   return '' unless ($Action{admin} and GetParam('action', '') ne 'admin');
2535
2536   my $action = 'action=admin';
2537   $action .= ';id=' . UrlEncode($id) if $id;
2538   return ScriptLink($action, T('Administration'), 'admin');
2539 }
2540
2541 sub GetLoginLinks {
2542   my ($id) = @_;
2543   my @elements;
2544
2545   my $adminLink = GetAdminLink($id) if UserIsAdmin();
2546   push(@elements, $adminLink) if $adminLink;
2547
2548   push(@elements, ScriptLink('action=password', T('Password'), 'password'))
2549     if $Action{password};
2550
2551   return @elements ? $q->span({-class=>'login bar'}, $q->br(), @elements) : '';
2552 }
2553
2554 sub GetFooterLinks {
2555   my ($id, $rev) = @_;
2556   my @elements;
2557   if ($id and $rev ne 'history' and $rev ne 'edit') {
2558     if ($CommentsPrefix) {
2559       if ($id =~ /^$CommentsPrefix(.*)/o) {
2560         push(@elements, GetPageLink($1, undef, 'original', T('a')));
2561       } else {
2562         push(@elements, GetPageLink($CommentsPrefix . $id, undef, 'comment', T('c')));
2563       }
2564     }
2565     if (UserCanEdit($id, 0)) {
2566       if ($rev) {               # showing old revision
2567         push(@elements, GetOldPageLink('edit', $id, $rev, Ts('Edit revision %s of this page', $rev)));
2568       } else {                  # showing current revision
2569         push(@elements, GetEditLink($id, T('Edit this page'), undef, T('e')));
2570       }
2571     } else {                    # no permission or generated page
2572       push(@elements, ScriptLink('action=password', T('This page is read-only'), 'password'));
2573     }
2574   }
2575   push(@elements, GetHistoryLink($id, T('View other revisions'))) if $Action{history} and $id and $rev ne 'history';
2576   push(@elements, GetPageLink($id, T('View current revision')),
2577        GetRCLink($id, T('View all changes'))) if $Action{history} and $rev ne '';
2578   push(@elements, ScriptLink("action=contrib;id=" . UrlEncode($id), T('View contributors'), 'contrib'))
2579     if $Action{contrib} and $id and $rev eq 'history';
2580
2581   push(@elements, GetRawLink($id, T('Raw'), T('r')));
2582
2583   return @elements ? $q->span({-class=>'edit bar'}, $q->br(), @elements) : '';
2584 }
2585
2586 sub GetCommentForm {
2587   my ($id, $rev, $comment) = @_;
2588   if ($CommentsPrefix ne '' and $id and $rev ne 'history' and $rev ne 'edit'
2589       and $id =~ /^$CommentsPrefix/o and UserCanEdit($id, 0, 1)) {
2590     return $q->div({-class=>'comment'}, GetFormStart(undef, undef, 'comment'), # protected by questionasker
2591        $q->p(GetHiddenValue('title', $id),
2592        GetTextArea('aftertext', $comment ? $comment : $NewComment, 10)), $EditNote,
2593        $q->p($q->span({-class=>'username'},
2594                       $q->label({-for=>'username'}, T('Username:')), ' ',
2595                       $q->textfield(-name=>'username', -id=>'username',
2596                                     -default=>GetParam('username', ''),
2597                                     -override=>1, -size=>20, -maxlength=>50)),
2598              $q->span({-class=>'homepage'},
2599                       $q->label({-for=>'homepage'}, T('Homepage URL:')), ' ',
2600                       $q->textfield(-name=>'homepage', -id=>'homepage',
2601                                     -default=>GetParam('homepage', ''),
2602                                     -override=>1, -size=>40, -maxlength=>100))),
2603        $q->p($q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save')), ' ',
2604        $q->submit(-name=>'Preview', -accesskey=>T('p'), -value=>T('Preview'))),
2605        $q->endform());
2606   }
2607   return '';
2608 }
2609
2610 sub GetFormStart {
2611   my ($ignore, $method, $class) = @_;
2612   $method ||= 'post';
2613   $class  ||= 'form';
2614   return $q->start_multipart_form(-method=>$method, -action=>$FullUrl,
2615                                   -accept_charset=>'utf-8', -class=>$class);
2616 }
2617
2618 sub GetSearchForm {
2619   my $form = # $q->label({-for=>'search'}, T('Search:')) . ' '
2620     ''
2621     . $q->textfield(-name=>'search', -id=>'search', -size=>15, -placeholder=>"Search",
2622                     -accesskey=>T('f')) . ' ';
2623   if ($ReplaceForm) {
2624     $form .= $q->label({-for=>'replace'}, T('Replace:')) . ' '
2625       . $q->textfield(-name=>'replace', -id=>'replace', -size=>20) . ' '
2626         . $q->checkbox(-name=>'delete', -label=>T('Delete')) . ' ';
2627   }
2628   if (%Languages) {
2629     $form .= $q->label({-for=>'searchlang'}, T('Language:')) . ' '
2630       . $q->textfield(-name=>'lang', -id=>'searchlang', -size=>10,
2631                       -default=>GetParam('lang', '')) . ' ';
2632   }
2633   return GetFormStart(undef, 'get', 'search')
2634     . $q->p($form . $q->submit('dosearch', T('Go!'))) . $q->endform;
2635 }
2636
2637 sub GetValidatorLink {
2638   return $q->a({-href => 'http://validator.w3.org/check/referer'}, T('Validate HTML'))
2639     . ' ' . $q->a({-href=>'http://jigsaw.w3.org/css-validator/check/referer'}, T('Validate CSS'));
2640 }
2641
2642 sub GetGotoBar {    # ignore $id parameter
2643   return $q->span({-class=>'gotobar bar'}, $q->br(), (map { GetPageLink($_) }
2644               @UserGotoBarPages), $UserGotoBar);
2645 }
2646
2647 sub GetEditorGotoBar {
2648   return !UserIsEditor() ? '' :
2649     $q->span({-class=>'editorgotobar bar'}, $q->br(),
2650              (map { GetPageLink($_) } @EditorGotoBarPages), $EditorGotoBar);
2651 }
2652
2653 sub GetExploreGotoBar {
2654   return $q->span({-class=>'explorebar bar'}, $q->br(), (map { GetPageLink($_) }
2655               @ExploreGotoBarPages), GetSearchForm());
2656 }
2657
2658 sub PrintHtmlDiff {
2659   my ($type, $old, $new, $text, $summary) = @_;
2660   my $intro = T('Last edit');
2661   my $diff = GetCacheDiff($type == 1 ? 'major' : 'minor');
2662   # compute old revision if cache is disabled or no cached diff is available
2663   if (not $old and (not $diff or GetParam('cache', $UseCache) < 1)) {
2664     if ($type == 1) {
2665       $old = $Page{lastmajor} - 1;
2666       ($text, $new, $summary) = GetTextRevision($Page{lastmajor}, 1)
2667         unless $new or $Page{lastmajor} == $Page{revision};
2668     } elsif ($new) {
2669       $old = $new - 1;
2670     } else {
2671       $old = $Page{revision} - 1;
2672     }
2673   }
2674   $summary = $Page{summary} if not $summary and not $new;
2675   $summary = $q->p({-class=>'summary'}, T('Summary:') . ' ' . $summary) if $summary;
2676   if ($old > 0) { # generate diff if the computed old revision makes sense
2677     $diff = GetKeptDiff($text, $old);
2678     $intro = Tss('Difference between revision %1 and %2', $old,
2679      $new ? Ts('revision %s', $new) : T('current revision'));
2680   } elsif ($type == 1 and $Page{lastmajor} != $Page{revision}) {
2681     $intro = Ts('Last major edit (%s)', ScriptLinkDiff(1, $OpenPageName, T('later minor edits'),
2682                    undef, $Page{lastmajor}||1));
2683   }
2684   $diff =~ s!<p><strong>(.*?)</strong></p>!'<p><strong>' . T($1) . '</strong></p>'!ge;
2685   $diff = T('No diff available.') unless $diff;
2686   print $q->div({-class=>'diff'}, $q->p($q->b($intro)), $summary, $diff);
2687 }
2688
2689 sub GetCacheDiff {
2690   my $type = shift;
2691   my $diff = $Page{"diff-$type"};
2692   $diff = $Page{"diff-minor"} if ($diff eq '1'); # if major eq minor diff
2693   return $diff;
2694 }
2695
2696 sub GetKeptDiff {
2697   my ($new, $revision) = @_;
2698   $revision = 1 unless $revision;
2699   my ($old, $rev) = GetTextRevision($revision, 1);
2700   return '' unless $rev;
2701   return T("The two revisions are the same.") if $old eq $new;
2702   return GetDiff($old, $new, $rev);
2703 }
2704
2705 sub DoDiff {      # Actualy call the diff program
2706   CreateDir($TempDir);
2707   my $oldName = "$TempDir/old";
2708   my $newName = "$TempDir/new";
2709   RequestLockDir('diff') or return '';
2710   WriteStringToFile($oldName, $_[0]);
2711   WriteStringToFile($newName, $_[1]);
2712   my $diff_out = `diff $oldName $newName`;
2713   utf8::decode($diff_out); # needs decoding
2714   $diff_out =~ s/\\ No newline.*\n//g; # Get rid of common complaint.
2715   ReleaseLockDir('diff');
2716   # No need to unlink temp files--next diff will just overwrite.
2717   return $diff_out;
2718 }
2719
2720 sub GetDiff {
2721   my ($old, $new, $revision) = @_;
2722   my $old_is_file = (TextIsFile($old))[0] || '';
2723   my $old_is_image = ($old_is_file =~ /^image\//);
2724   my $new_is_file = TextIsFile($new);
2725   if ($old_is_file or $new_is_file) {
2726     return $q->p($q->strong(T('Old revision:')))
2727       . $q->div({-class=>'old'}, # don't pring new revision, because that's the one that gets shown!
2728     $q->p($old_is_file ? GetDownloadLink($OpenPageName, $old_is_image, $revision) : $old))
2729     }
2730   $old =~ s/[\r\n]+/\n/g;
2731   $new =~ s/[\r\n]+/\n/g;
2732   return ImproveDiff(DoDiff($old, $new));
2733 }
2734
2735 sub ImproveDiff {      # NO NEED TO BE called within a diff lock
2736   my $diff = QuoteHtml(shift);
2737   $diff =~ tr/\r//d;
2738   my @hunks = split (/^(\d+,?\d*[adc]\d+,?\d*\n)/m, $diff);
2739   my $result = shift (@hunks);  # intro
2740   while ($#hunks > 0)           # at least one header and a real hunk
2741     {
2742       my $header = shift (@hunks);
2743       $header =~ s|^(\d+.*c.*)|<p><strong>Changed:</strong></p>| # T('Changed:')
2744         or $header =~ s|^(\d+.*d.*)|<p><strong>Deleted:</strong></p>| # T('Deleted:')
2745         or $header =~ s|^(\d+.*a.*)|<p><strong>Added:</strong></p>|; # T('Added:')
2746       $result .= $header;
2747       my $chunk = shift (@hunks);
2748       my ($old, $new) = split (/\n---\n/, $chunk, 2);
2749       if ($old and $new) {
2750   ($old, $new) = DiffMarkWords($old, $new);
2751   $result .= "$old<p><strong>to</strong></p>\n$new"; # T('to')
2752       } else {
2753         if (substr($chunk,0,2) eq '&g') {
2754           $result .= DiffAddPrefix(DiffStripPrefix($chunk), '&gt; ', 'new');
2755         } else {
2756           $result .= DiffAddPrefix(DiffStripPrefix($chunk), '&lt; ', 'old');
2757         }
2758       }
2759     }
2760   return $result;
2761 }
2762
2763 sub DiffMarkWords {
2764   my ($old, $new) = map { DiffStripPrefix($_) } @_;
2765   my @diffs = grep(/^\d/, split(/\n/, DoDiff(join("\n",split(/\s+|\b/,$old)) . "\n",
2766                join("\n",split(/\s+|\b/,$new)) . "\n")));
2767   foreach my $diff (reverse @diffs) { # so that new html tags don't confuse word counts
2768     my ($start1,$end1,$type,$start2,$end2) = $diff =~ /^(\d+),?(\d*)([adc])(\d+),?(\d*)$/mg;
2769     if ($type eq 'd' or $type eq 'c') {
2770       $end1 = $start1 unless $end1;
2771       $old = DiffHtmlMarkWords($old,$start1,$end1);
2772     }
2773     if ($type eq 'a' or $type eq 'c') {
2774       $end2 = $start2 unless $end2;
2775       $new = DiffHtmlMarkWords($new,$start2,$end2);
2776     }
2777   }
2778   return (DiffAddPrefix($old, '&lt; ', 'old'),
2779     DiffAddPrefix($new, '&gt; ', 'new'));
2780 }
2781
2782 sub DiffHtmlMarkWords {
2783   my ($text,$start,$end) = @_;
2784   my @fragments = split(/(\s+|\b)/, $text);
2785   splice(@fragments, 2 * ($start - 1), 0, '<strong class="changes">');
2786   splice(@fragments, 2 * $end, 0, '</strong>');
2787   my $result = join('', @fragments);
2788   $result =~ s!&<(/?)strong([^>]*)>(amp|[gl]t);!<$1strong$2>&$3;!g;
2789   $result =~ s!&(amp|[gl]t)<(/?)strong([^>]*)>;!&$1;<$2strong$3>!g;
2790   return $result;
2791 }
2792
2793 sub DiffStripPrefix {
2794   my $str = shift;
2795   $str =~ s/^&[lg]t; //gm;
2796   return $str;
2797 }
2798
2799 sub DiffAddPrefix {
2800   my ($str, $prefix, $class) = @_;
2801   my @lines = split(/\n/,$str);
2802   for my $line (@lines) {
2803     $line = $prefix . $line;
2804   }
2805   return $q->div({-class=>$class},$q->p(join($q->br(), @lines)));
2806 }
2807
2808 sub ParseData {      # called a lot during search, so it was optimized
2809   my $data = shift;   # by eliminating non-trivial regular expressions
2810   my %result;
2811   my $end = index($data, ': ');
2812   my $key = substr($data, 0, $end);
2813   my $start = $end += 2;           # skip ': '
2814   while ($end = index($data, "\n", $end) + 1) { # include \n
2815     next if substr($data, $end, 1) eq "\t";     # continue after \n\t
2816     $result{$key} = substr($data, $start, $end - $start - 1); # strip last \n
2817     $start = index($data, ': ', $end); # starting at $end begins the new key
2818     last if $start == -1;
2819     $key = substr($data, $end, $start - $end);
2820     $end = $start += 2;   # skip ': '
2821   }
2822   $result{$key} .= substr($data, $end, -1); # strip last \n
2823   foreach (keys %result) {
2824     $result{$_} =~ s/\n\t/\n/g;
2825   }
2826   return %result;
2827 }
2828
2829 sub OpenPage {      # Sets global variables
2830   my $id = shift;
2831   if ($OpenPageName eq $id) {
2832     return;
2833   }
2834   if ($IndexHash{$id}) {
2835     %Page = ParseData(ReadFileOrDie(GetPageFile($id)));
2836   } else {
2837     %Page = ();
2838     $Page{ts} = $Now;
2839     $Page{revision} = 0;
2840     if ($id eq $HomePage
2841         and (open(F, '<:utf8', $ReadMe)
2842              or open(F, '<:utf8', 'README'))) {
2843       local $/ = undef;
2844       $Page{text} = <F>;
2845       close F;
2846     } elsif ($CommentsPrefix and $id =~ /^$CommentsPrefix(.*)/o) { # do nothing
2847     }
2848   }
2849   $OpenPageName = $id;
2850 }
2851
2852 sub GetTextAtTime { # call with opened page, return $minor if all pages between now and $ts are minor!
2853   my $ts = shift;
2854   my $minor = $Page{minor};
2855   return ($Page{text}, $minor, 0) if $Page{ts} <= $ts; # current page is old enough
2856   return ($DeletedPage, $minor, 0) if $Page{revision} == 1 and $Page{ts} > $ts; # created after $ts
2857   my %keep = ();    # info may be needed after the loop
2858   foreach my $revision (GetKeepRevisions($OpenPageName)) {
2859     %keep = GetKeptRevision($revision);
2860     $minor = 0 if not $keep{minor} and $keep{ts} >= $ts; # ignore keep{minor} if keep{ts} is too old
2861     return ($keep{text}, $minor, 0) if $keep{ts} <= $ts;
2862   }
2863   return ($DeletedPage, $minor, 0) if $keep{revision} == 1; # then the page was created after $ts!
2864   return ($keep{text}, $minor, $keep{ts}); # the oldest revision available is not old enough
2865 }
2866
2867 sub GetTextRevision {
2868   my ($revision, $quiet) = @_;
2869   $revision =~ s/\D//g;   # Remove non-numeric chars
2870   return ($Page{text}, $revision, $Page{summary}) unless $revision and $revision ne $Page{revision};
2871   my %keep = GetKeptRevision($revision);
2872   if (not %keep) {
2873     $Message .= $q->p(Ts('Revision %s not available', $revision)
2874           . ' (' . T('showing current revision instead') . ')') unless $quiet;
2875     return ($Page{text}, '', '');
2876   }
2877   $Message .= $q->p(Ts('Showing revision %s', $revision)) unless $quiet;
2878   return ($keep{text}, $revision, $keep{summary});
2879 }
2880
2881 sub GetPageContent {
2882   my $id = shift;
2883   if ($IndexHash{$id}) {
2884     my %data = ParseData(ReadFileOrDie(GetPageFile($id)));
2885     return $data{text};
2886   }
2887   return '';
2888 }
2889
2890 sub GetKeptRevision {   # Call after OpenPage
2891   my ($status, $data) = ReadFile(GetKeepFile($OpenPageName, (shift)));
2892   return () unless $status;
2893   return ParseData($data);
2894 }
2895
2896 sub GetPageFile {
2897   my ($id) = @_;
2898   return $PageDir . '/' . GetPageDirectory($id) . "/$id.pg";
2899 }
2900
2901 sub GetKeepFile {
2902   my ($id, $revision) = @_; die "No revision for $id" unless $revision; #FIXME
2903   return $KeepDir . '/' . GetPageDirectory($id) . "/$id/$revision.kp";
2904 }
2905
2906 sub GetKeepDir {
2907   my $id = shift; die 'No id' unless $id; #FIXME
2908   return $KeepDir . '/' . GetPageDirectory($id) . '/' . $id;
2909 }
2910
2911 sub GetKeepFiles {
2912   return bsd_glob(GetKeepDir(shift) . '/*.kp'); # files such as 1.kp, 2.kp, etc.
2913 }
2914
2915 sub GetKeepRevisions {
2916   return sort {$b <=> $a} map { m/([0-9]+)\.kp$/; $1; } GetKeepFiles(shift);
2917 }
2918
2919 sub GetPageDirectory {
2920   my $id = shift;
2921   if ($id =~ /^([a-zA-Z])/) {
2922     return uc($1);
2923   }
2924   return 'other';
2925 }
2926
2927 # Always call SavePage within a lock.
2928 sub SavePage { # updating the cache will not change timestamp and revision!
2929   ReportError(T('Cannot save a nameless page.'), '400 BAD REQUEST', 1) unless $OpenPageName;
2930   ReportError(T('Cannot save a page without revision.'), '400 BAD REQUEST', 1) unless $Page{revision};
2931   CreatePageDir($PageDir, $OpenPageName);
2932   WriteStringToFile(GetPageFile($OpenPageName), EncodePage(%Page));
2933 }
2934
2935 sub SaveKeepFile {
2936   return if ($Page{revision} < 1); # Don't keep 'empty' revision
2937   delete $Page{blocks};      # delete some info from the page
2938   delete $Page{flags};
2939   delete $Page{'diff-major'};
2940   delete $Page{'diff-minor'};
2941   $Page{'keep-ts'} = $Now;  # expire only $KeepDays from $Now!
2942   CreateKeepDir($KeepDir, $OpenPageName);
2943   WriteStringToFile(GetKeepFile($OpenPageName, $Page{revision}), EncodePage(%Page));
2944 }
2945
2946 sub EncodePage {
2947   my @data = @_;
2948   my $result = '';
2949   $result .= (shift @data) . ': ' . EscapeNewlines(shift @data) . "\n" while (@data);
2950   return $result;
2951 }
2952
2953 sub EscapeNewlines {
2954   $_[0] =~ s/\n/\n\t/g;   # modify original instead of copying
2955   return $_[0];
2956 }
2957
2958 sub ExpireKeepFiles {   # call with opened page
2959   return unless $KeepDays;
2960   my $expirets = $Now - ($KeepDays * 86400); # 24*60*60
2961   foreach my $revision (GetKeepRevisions($OpenPageName)) {
2962     my %keep = GetKeptRevision($revision);
2963     next if $keep{'keep-ts'} >= $expirets;
2964     next if $KeepMajor and $keep{revision} == $Page{lastmajor};
2965     unlink GetKeepFile($OpenPageName, $revision);
2966   }
2967 }
2968
2969 sub ReadFile {
2970   my $file = shift;
2971   utf8::encode($file); # filenames are bytes!
2972   if (open(IN, '<:utf8', $file)) {
2973     local $/ = undef;   # Read complete files
2974     my $data=<IN>;
2975     close IN;
2976     return (1, $data);
2977   }
2978   return (0, '');
2979 }
2980
2981 sub ReadFileOrDie {
2982   my ($file) = @_;
2983   my ($status, $data);
2984   ($status, $data) = ReadFile($file);
2985   if (!$status) {
2986     ReportError(Ts('Cannot open %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
2987   }
2988   return $data;
2989 }
2990
2991 sub WriteStringToFile {
2992   my ($file, $string) = @_;
2993   utf8::encode($file);
2994   open(OUT, '>:encoding(UTF-8)', $file)
2995     or ReportError(Ts('Cannot write %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
2996   print OUT  $string;
2997   close(OUT);
2998 }
2999
3000 sub AppendStringToFile {
3001   my ($file, $string) = @_;
3002   utf8::encode($file);
3003   open(OUT, '>>:encoding(UTF-8)', $file)
3004     or ReportError(Ts('Cannot write %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
3005   print OUT  $string;
3006   close(OUT);
3007 }
3008
3009 sub CreateDir {
3010   my ($newdir) = @_;
3011   utf8::encode($newdir);
3012   return if -d $newdir;
3013   mkdir($newdir, 0775)
3014     or ReportError(Ts('Cannot create %s', $newdir) . ": $!", '500 INTERNAL SERVER ERROR');
3015 }
3016
3017 sub CreatePageDir {
3018   my ($dir, $id) = @_;
3019   CreateDir($dir);
3020   CreateDir($dir . '/' . GetPageDirectory($id));
3021 }
3022
3023 sub CreateKeepDir {
3024   my ($dir, $id) = @_;
3025   CreatePageDir($dir, $id);
3026   CreateDir($dir . '/' . GetPageDirectory($id) . '/' . $id);
3027 }
3028
3029 sub GetLockedPageFile {
3030   my $id = shift;
3031   return $PageDir . '/' . GetPageDirectory($id) . "/$id.lck";
3032 }
3033
3034 sub RequestLockDir {
3035   my ($name, $tries, $wait, $error, $retried) = @_;
3036   $tries = 4 unless $tries;
3037   $wait = 2 unless $wait;
3038   CreateDir($TempDir);
3039   my $lock = $LockDir . $name;
3040   my $n = 0;
3041   while (mkdir($lock, 0555) == 0) {
3042     if ($n++ >= $tries) {
3043       my $ts = (stat($lock))[9];
3044       if ($Now - $ts > $LockExpiration and $LockExpires{$name}
3045           and not $retried) {
3046         ReleaseLockDir($name); # try to expire lock (no checking)
3047         return 1 if RequestLockDir($name, undef, undef, undef, 1);
3048       }
3049       return 0 unless $error;
3050       ReportError(Ts('Could not get %s lock', $name) . ": $!. "
3051       . Ts('The lock was created %s.', CalcTimeSince($Now - $ts))
3052       . ($retried ? ' ' . T('Maybe the user running this script is no longer allowed to remove the lock directory?') : ''),
3053       '503 SERVICE UNAVAILABLE');
3054     }
3055     sleep($wait);
3056   }
3057   $Locks{$name} = 1;
3058   return 1;
3059 }
3060
3061 sub ReleaseLockDir {
3062   my $name = shift;        # We don't check whether we succeeded.
3063   rmdir($LockDir . $name); # Before fixing, make sure we only call this
3064   delete $Locks{$name};    # when we know the lock exists.
3065 }
3066
3067 sub RequestLockOrError {
3068   # 10 tries, 3 second wait, die on error
3069   return RequestLockDir('main', 10, 3, 1);
3070 }
3071
3072 sub ReleaseLock {
3073   ReleaseLockDir('main');
3074 }
3075
3076 sub ForceReleaseLock {
3077   my $pattern = shift;
3078   my $forced;
3079   foreach my $name (bsd_glob $pattern) {
3080     # First try to obtain lock (in case of normal edit lock)
3081     $forced = 1 if !RequestLockDir($name, 5, 3, 0);
3082     ReleaseLockDir($name); # Release the lock, even if we didn't get it.
3083   }
3084   return $forced;
3085 }
3086
3087 sub DoUnlock {
3088   my $message = '';
3089   print GetHeader('', T('Unlock Wiki'), undef, 'nocache');
3090   print $q->p(T('This operation may take several seconds...'));
3091   for my $lock (@KnownLocks) {
3092     if (ForceReleaseLock($lock)) {
3093       $message .= $q->p(Ts('Forced unlock of %s lock.', $lock));
3094     }
3095   }
3096   if ($message) {
3097     print $message;
3098   } else {
3099     print $q->p(T('No unlock required.'));
3100   }
3101   PrintFooter();
3102 }
3103
3104 sub CalcDay {
3105   my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift);
3106   return sprintf('%4d-%02d-%02d', $year+1900, $mon+1, $mday);
3107 }
3108
3109 sub CalcTime {
3110   my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift);
3111   return sprintf('%02d:%02d UTC', $hour, $min);
3112 }
3113
3114 sub CalcTimeSince {
3115   my $total = shift;
3116   if ($total >= 7200) {
3117     return Ts('%s hours ago',int($total/3600));
3118   } elsif ($total >= 3600) {
3119     return T('1 hour ago');
3120   } elsif ($total >= 120) {
3121     return Ts('%s minutes ago',int($total/60));
3122   } elsif ($total >= 60) {
3123     return T('1 minute ago');
3124   } elsif ($total >= 2) {
3125     return Ts('%s seconds ago',int($total));
3126   } elsif ($total == 1) {
3127     return T('1 second ago');
3128   } else {
3129     return T('just now');
3130   }
3131 }
3132
3133 sub TimeToText {
3134   my $t = shift;
3135   return CalcDay($t) . ' ' . CalcTime($t);
3136 }
3137
3138 sub TimeToW3 { # Complete date plus hours and minutes: YYYY-MM-DDThh:mmTZD (eg 1997-07-16T19:20+01:00)
3139   my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift); # use special UTC designator ("Z")
3140   return sprintf('%4d-%02d-%02dT%02d:%02dZ', $year+1900, $mon+1, $mday, $hour, $min);
3141 }
3142
3143 sub TimeToRFC822 {
3144   my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime(shift); # Sat, 07 Sep 2002 00:00:01 GMT
3145   return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", qw(Sun Mon Tue Wed Thu Fri Sat)[$wday], $mday,
3146      qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon], $year+1900, $hour, $min, $sec);
3147 }
3148
3149 sub GetHiddenValue {
3150   my ($name, $value) = @_;
3151   $q->param($name, $value);
3152   return $q->input({-type=>"hidden", -name=>$name, -value=>$value});
3153 }
3154
3155 sub GetRemoteHost { # when testing, these variables are undefined.
3156   my $rhost = $ENV{REMOTE_HOST}; # tests are written to avoid -w warnings.
3157   if (not $rhost and $UseLookup and $ENV{REMOTE_ADDR}) {
3158     # Catch errors (including bad input) without aborting the script
3159     eval 'use Socket; my $iaddr = inet_aton($ENV{REMOTE_ADDR});'
3160       . '$rhost = gethostbyaddr($iaddr, AF_INET) if $iaddr;';
3161   }
3162   if (not $rhost) {
3163     $rhost = $ENV{REMOTE_ADDR};
3164   }
3165   return $rhost;
3166 }
3167
3168 sub FreeToNormal {    # trim all spaces and convert them to underlines
3169   my $id = shift;
3170   return '' unless $id;
3171   $id =~ s/ /_/g;
3172   if (index($id, '_') > -1) {  # Quick check for any space/underscores
3173     $id =~ s/__+/_/g;
3174     $id =~ s/^_//;
3175     $id =~ s/_$//;
3176   }
3177   return UnquoteHtml($id);
3178 }
3179
3180 sub ItemName {
3181   my $id = shift; # id
3182   return NormalToFree($id) unless GetParam('short', 1) and $RssStrip;
3183   my $comment = $id =~ s/^($CommentsPrefix)//o; # strip first so that ^ works
3184   $id =~ s/^$RssStrip//o;
3185   $id = $CommentsPrefix . $id if $comment;
3186   return NormalToFree($id);
3187 }
3188
3189 sub NormalToFree { # returns HTML quoted title with spaces
3190   my $title = shift;
3191   $title =~ s/_/ /g;
3192   return QuoteHtml($title);
3193 }
3194
3195 sub UnWiki {
3196   my $str = shift;
3197   return $str unless $WikiLinks and $str =~ /^$LinkPattern$/;
3198   $str =~ s/([[:lower:]])([[:upper:]])/$1 $2/g;
3199   return $str;
3200 }
3201
3202 sub DoEdit {
3203   my ($id, $newText, $preview) = @_;
3204   ValidIdOrDie($id);
3205   my $upload = GetParam('upload', undef);
3206   if (!UserCanEdit($id, 1)) {
3207     my $rule = UserIsBanned();
3208     if ($rule) {
3209       ReportError(T('Edit Denied'), '403 FORBIDDEN', undef,
3210       $q->p(T('Editing not allowed: user, ip, or network is blocked.')),
3211       $q->p(T('Contact the wiki administrator for more information.')),
3212       $q->p(Ts('The rule %s matched for you.', $rule) . ' '
3213       . Ts('See %s for more information.', GetPageLink($BannedHosts))));
3214     } else {
3215       ReportError(T('Edit Denied'), '403 FORBIDDEN', undef,
3216       $q->p(Ts('Editing not allowed: %s is read-only.', NormalToFree($id))));
3217     }
3218   } elsif ($upload and not $UploadAllowed and not UserIsAdmin()) {
3219     ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
3220   }
3221   OpenPage($id);
3222   my ($text, $revision) = GetTextRevision(GetParam('revision', ''), 1); # maybe revision reset!
3223   my $oldText = $preview ? $newText : $text;
3224   my $isFile = TextIsFile($oldText);
3225   $upload = $isFile if not defined $upload;
3226   if ($upload and not $UploadAllowed and not UserIsAdmin()) {
3227     ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
3228   }
3229   if ($upload) {    # shortcut lots of code
3230     $revision = '';
3231     $preview = 0;
3232   } elsif ($isFile and not $upload) {
3233     $oldText = '';
3234   }
3235   my $header;
3236   if ($revision and not $upload) {
3237     $header = Ts('Editing revision %s of', $revision) . ' ' . NormalToFree($id);
3238   } else {
3239     $header = Ts('Editing %s', NormalToFree($id));
3240   }
3241   print GetHeader('', $header, undef, undef, undef, GetFooterLinks($id, 'edit')),
3242     $q->start_div({-class=>'content edit'});
3243   if ($preview and not $upload) {
3244     print $q->start_div({-class=>'preview'});
3245     print $q->h2(T('Preview:'));
3246     PrintWikiToHTML($oldText); # no caching, current revision, unlocked
3247     print $q->hr(), $q->h2(T('Preview only, not yet saved')), $q->end_div();
3248   }
3249   if ($revision) {
3250     print $q->strong(Ts('Editing old revision %s.', $revision) . '  '
3251          . T('Saving this page will replace the latest revision with this text.'))
3252   }
3253   print GetEditForm($id, $upload, $oldText, $revision), $q->end_div();
3254   PrintFooter($id, 'edit');
3255 }
3256
3257 sub GetEditForm {
3258   my ($page_name, $upload, $oldText, $revision) = @_;
3259   my $html = GetFormStart(undef, undef, $upload ? 'edit upload' : 'edit text') # protected by questionasker
3260     .$q->p(GetHiddenValue("title", $page_name), ($revision ? GetHiddenValue('revision', $revision) : ''),
3261            GetHiddenValue('oldtime', $Page{ts}), ($upload ? GetUpload() : GetTextArea('text', $oldText)));
3262   my $summary = UnquoteHtml(GetParam('summary', ''))
3263     || ($Now - $Page{ts} < ($SummaryHours * 3600) ? $Page{summary} : '');
3264   $html .= $q->p(T('Summary:').$q->br().GetTextArea('summary', $summary, 2))
3265     .$q->p($q->checkbox(-name=>'recent_edit', -checked=>(GetParam('recent_edit', '') eq 'on'),
3266                         -label=>T('This change is a minor edit.')));
3267   $html .= T($EditNote) if $EditNote; # Allow translation
3268   my $username = GetParam('username', '');
3269   $html .= $q->p($q->label({-for=>'username'}, T('Username:')).' '
3270     .$q->textfield(-name=>'username', -id=>'username', -default=>$username,
3271                    -override=>1, -size=>20, -maxlength=>50))
3272     .$q->p($q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save')),
3273            ($upload ? '' : ' ' . $q->submit(-name=>'Preview', -accesskey=>T('p'), -value=>T('Preview'))).
3274            ' '.$q->submit(-name=>'Cancel', -value=>T('Cancel')));
3275   if ($upload) {
3276     $html .= $q->p(ScriptLink('action=edit;upload=0;id='.UrlEncode($page_name), T('Replace this file with text'),   'upload'));
3277   }
3278   elsif ($UploadAllowed or UserIsAdmin()) {
3279     $html .= $q->p(ScriptLink('action=edit;upload=1;id='.UrlEncode($page_name), T('Replace this text with a file'), 'upload'));
3280   }
3281   $html .= $q->endform();
3282   return $html;
3283 }
3284
3285 sub GetTextArea {
3286   my ($name, $text, $rows) = @_;
3287   return $q->textarea(-id=>$name, -name=>$name, -default=>$text, -rows=>$rows||25, -columns=>78, -override=>1);
3288 }
3289
3290 sub GetUpload {
3291   return T('File to upload: ') . $q->filefield(-name=>'file', -size=>50, -maxlength=>100);
3292 }
3293
3294 sub DoDownload {
3295   my $id = shift;
3296   OpenPage($id) if ValidIdOrDie($id);
3297   print $q->header(-status=>'304 NOT MODIFIED') and return if FileFresh(); # FileFresh needs an OpenPage!
3298   my ($text, $revision) = GetTextRevision(GetParam('revision', '')); # maybe revision reset!
3299   my $ts = $Page{ts};
3300   if (my ($type, $encoding) = TextIsFile($text)) {
3301     my ($data) = $text =~ /^[^\n]*\n(.*)/s;
3302     my %allowed = map {$_ => 1} @UploadTypes;
3303     ReportError(Ts('Files of type %s are not allowed.', $type), '415 UNSUPPORTED MEDIA TYPE')
3304       if @UploadTypes and not $allowed{$type};
3305     print GetHttpHeader($type, $ts, undef, $encoding);
3306     require MIME::Base64;
3307     binmode(STDOUT, ":pop:raw"); # need to pop utf8 for Windows users!?
3308     print MIME::Base64::decode($data);
3309   } else {
3310     print GetHttpHeader('text/plain', $ts);
3311     print $text;
3312   }
3313 }
3314
3315 sub DoPassword {
3316   print GetHeader('',T('Password')), $q->start_div({-class=>'content password'});
3317   print $q->p(T('Your password is saved in a cookie, if you have cookies enabled. Cookies may get lost if you connect from another machine, from another account, or using another software.'));
3318   if (UserIsAdmin()) {
3319     print $q->p(T('You are currently an administrator on this site.'));
3320   } elsif (UserIsEditor()) {
3321     print $q->p(T('You are currently an editor on this site.'));
3322   } else {
3323     print $q->p(T('You are a normal user on this site.'));
3324     if ($AdminPass or $EditPass) {
3325       print $q->p(T('Your password does not match any of the  administrator or editor passwords.'));
3326     }
3327   }
3328   if ($AdminPass or $EditPass) {
3329     print GetFormStart(undef, undef, 'password'),
3330       $q->p(GetHiddenValue('action', 'password'), T('Password:'), ' ',
3331       $q->password_field(-name=>'pwd', -size=>20, -maxlength=>50),
3332       $q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save'))), $q->endform;
3333   } else {
3334     print $q->p(T('This site does not use admin or editor passwords.'));
3335   }
3336   print $q->end_div();
3337   PrintFooter();
3338 }
3339
3340 sub UserIsEditorOrError {
3341   UserIsEditor()
3342     or ReportError(T('This operation is restricted to site editors only...'), '403 FORBIDDEN');
3343   return 1;
3344 }
3345
3346 sub UserIsAdminOrError {
3347   UserIsAdmin()
3348     or ReportError(T('This operation is restricted to administrators only...'), '403 FORBIDDEN');
3349   return 1;
3350 }
3351
3352 sub UserCanEdit {
3353   my ($id, $editing, $comment) = @_;
3354   return 0 if $id eq 'SampleUndefinedPage' or $id eq T('SampleUndefinedPage')
3355     or $id eq 'Sample_Undefined_Page' or $id eq T('Sample_Undefined_Page');
3356   return 1 if UserIsAdmin();
3357   return 0 if $id ne '' and -f GetLockedPageFile($id);
3358   return 0 if $LockOnCreation{$id} and not -f GetPageFile($id); # new page
3359   return 1 if UserIsEditor();
3360   return 0 if !$EditAllowed or -f $NoEditFile;
3361   return 0 if $editing and UserIsBanned(); # this call is more expensive
3362   return 0 if $EditAllowed >= 2 and (not $CommentsPrefix or $id !~ /^$CommentsPrefix/o);
3363   return 1 if $EditAllowed >= 3 and ($comment or (GetParam('aftertext', '') and not GetParam('text', '')));
3364   return 0 if $EditAllowed >= 3;
3365   return 1;
3366 }
3367
3368 sub UserIsBanned {
3369   return 0 if GetParam('action', '') eq 'password'; # login is always ok
3370   my ($host, $ip);
3371   $ip = $ENV{'REMOTE_ADDR'};
3372   $host = GetRemoteHost();
3373   foreach (split(/\n/, GetPageContent($BannedHosts))) {
3374     if (/^\s*([^#]\S+)/) { # all lines except empty lines and comments, trim whitespace
3375       my $regexp = $1;
3376       return $regexp  if ($ip   =~ /$regexp/i);
3377       return $regexp  if ($host =~ /$regexp/i);
3378     }
3379   }
3380   return 0;
3381 }
3382
3383 sub UserIsAdmin {
3384   return 0 if $AdminPass eq '';
3385   my $pwd = GetParam('pwd', '');
3386   foreach (split(/\s+/, $AdminPass)) {
3387     return 1 if $pwd eq $_;
3388   }
3389   return 0;
3390 }
3391
3392 sub UserIsEditor {
3393   return 1 if UserIsAdmin();  # Admin includes editor
3394   return 0 if $EditPass eq '';
3395   my $pwd = GetParam('pwd', ''); # Used for both passwords
3396   foreach (split(/\s+/, $EditPass)) {
3397     return 1 if $pwd eq $_;
3398   }
3399   return 0;
3400 }
3401
3402 sub BannedContent {
3403   my $str = shift;
3404   my @urls = $str =~ /$FullUrlPattern/go;
3405   foreach (split(/\n/, GetPageContent($BannedContent))) {
3406     next unless m/^\s*([^#]+?)\s*(#\s*(\d\d\d\d-\d\d-\d\d\s*)?(.*))?$/;
3407     my ($regexp, $comment, $re) = ($1, $4, undef);
3408     foreach my $url (@urls) {
3409       eval { $re = qr/$regexp/i; };
3410       if (defined($re) && $url =~ $re) {
3411         return Tss('Rule "%1" matched "%2" on this page.', $regexp, $url) . ' '
3412           . ($comment ? Ts('Reason: %s.', $comment) : T('Reason unknown.')) . ' '
3413           . Ts('See %s for more information.', GetPageLink($BannedContent));
3414       }
3415     }
3416   }
3417   return 0;
3418 }
3419
3420 sub DoIndex {
3421   my $raw = GetParam('raw', 0);
3422   my $match = GetParam('match', '');
3423   my @pages = ();
3424   my @menu = ($q->label({-for=>'indexmatch'}, T('Filter:')) . ' '
3425         . $q->textfield(-name=>'match', -id=>'indexmatch', -size=>20));
3426   foreach my $data (@IndexOptions) {
3427     my ($option, $text, $default, $sub) = @$data;
3428     my $value = GetParam($option, $default); # HTML checkbox warning!
3429     $value = 0 if GetParam('manual', 0) and $value ne 'on';
3430     push(@pages, &$sub) if $value;
3431     push(@menu, $q->checkbox(-name=>$option, -checked=>$value, -label=>$text));
3432   }
3433   @pages = grep /$match/i, @pages if $match;
3434   @pages = sort @pages;
3435   if ($raw) {
3436     print GetHttpHeader('text/plain'); # and ignore @menu
3437   } else {
3438     print GetHeader('', T('Index of all pages'));
3439     push(@menu, GetHiddenValue('manual', 1) . $q->submit(-value=>T('Go!')));
3440     push(@menu, $q->b(Ts('(for %s)', GetParam('lang', '')))) if GetParam('lang', '');
3441     print $q->start_div({-class=>'content index'}),
3442       GetFormStart(undef, 'get', 'index'), GetHiddenValue('action', 'index'),
3443       $q->p(join($q->br(), @menu)), $q->end_form(),
3444       $q->h2(Ts('%s pages found.', ($#pages + 1))), $q->start_p();
3445   }
3446   foreach (@pages) {
3447     PrintPage($_);
3448   }
3449   print $q->end_p(), $q->end_div() unless $raw;
3450   PrintFooter() unless $raw;
3451 }
3452
3453 sub PrintPage {
3454   my $id = shift;
3455   my $lang = GetParam('lang', 0);
3456   if ($lang) {
3457     OpenPage($id);
3458     my @languages = split(/,/, $Page{languages});
3459     next if (@languages and not grep(/$lang/, @languages));
3460   }
3461   if (GetParam('raw', 0)) {
3462     if (GetParam('search', '') and GetParam('context',1)) {
3463       print "title: $id\n\n"; # for near links without full search
3464     } else {
3465       print $id, "\n";
3466     }
3467   } else {
3468     print GetPageOrEditLink($id, NormalToFree($id)), $q->br();
3469   }
3470 }
3471
3472 sub AllPagesList {
3473   my $refresh = GetParam('refresh', 0);
3474   return @IndexList if @IndexList and not $refresh;
3475   SetParam('refresh', 0) if $refresh;
3476   if (not $refresh and -f $IndexFile) {
3477     my ($status, $rawIndex) = ReadFile($IndexFile); # not fatal
3478     if ($status) {
3479       %IndexHash = split(/\s+/, $rawIndex);
3480       @IndexList = sort(keys %IndexHash);
3481       return @IndexList;
3482     }
3483     # If open fails just refresh the index
3484   }
3485   @IndexList = ();
3486   %IndexHash = ();
3487   # If file exists and cannot be changed, error!
3488   my $locked = RequestLockDir('index', undef, undef, -f $IndexFile);
3489   foreach (bsd_glob("$PageDir/*/*.pg"), bsd_glob("$PageDir/*/.*.pg")) {
3490     next unless m|/.*/(.+)\.pg$|;
3491     my $id = $1;
3492     utf8::decode($id);
3493     push(@IndexList, $id);
3494     $IndexHash{$id} = 1;
3495   }
3496   WriteStringToFile($IndexFile, join(' ', %IndexHash)) if $locked;
3497   ReleaseLockDir('index') if $locked;
3498   return @IndexList;
3499 }
3500
3501 sub DoSearch {
3502   my $string = shift;
3503   return DoIndex() if $string eq '';
3504   eval { qr/$string/ }
3505     or $@ and ReportError(Ts('Malformed regular expression in %s', $string),
3506                           '400 BAD REQUEST');
3507   my $replacement = GetParam('replace',undef);
3508   my $raw = GetParam('raw','');
3509   my @results;
3510   if ($replacement or GetParam('delete', 0)) {
3511     return unless UserIsAdminOrError();
3512     print GetHeader('', Ts('Replaced: %s', $string . " &#x2192; " . $replacement)),
3513       $q->start_div({-class=>'content replacement'});
3514     @results = Replace($string,$replacement);
3515     foreach (@results) {
3516       PrintSearchResult($_, SearchRegexp($replacement||$string));
3517     }
3518   } else {
3519     if ($raw) {
3520       print GetHttpHeader('text/plain');
3521       print RcTextItem('title', Ts('Search for: %s', $string)), RcTextItem('date', TimeToText($Now)),
3522         RcTextItem('link', $q->url(-path_info=>1, -query=>1)), "\n" if GetParam('context', 1);
3523     } else {
3524       print GetHeader('', Ts('Search for: %s', $string)), $q->start_div({-class=>'content search'});
3525       $ReplaceForm = UserIsAdmin();
3526       print $q->p({-class=>'links'}, SearchMenu($string));
3527     }
3528     @results = SearchTitleAndBody($string, \&PrintSearchResult, SearchRegexp($string));
3529   }
3530   print SearchResultCount($#results + 1), $q->end_div() unless $raw;
3531   PrintFooter() unless $raw;
3532 }
3533
3534 sub SearchMenu {
3535   return ScriptLink('action=rc;rcfilteronly=' . UrlEncode(shift),
3536                     T('View changes for these pages'));
3537 }
3538
3539 sub SearchResultCount { $q->p({-class=>'result'}, Ts('%s pages found.', (shift))); }
3540
3541 sub PageIsUploadedFile {
3542   my $id = shift;
3543   return undef if $OpenPageName eq $id;
3544   if ($IndexHash{$id}) {
3545     my $file = GetPageFile($id);
3546     utf8::encode($file); # filenames are bytes!
3547     open(FILE, '<:utf8', $file)
3548       or ReportError(Ts('Cannot open %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
3549     while (defined($_ = <FILE>) and $_ !~ /^text: /) {
3550     }          # read lines until we get to the text key
3551     close FILE;
3552     return TextIsFile(substr($_,6)); # pass "#FILE image/png\n" to the test
3553   }
3554 }
3555
3556 sub SearchTitleAndBody { # expects search string to be HTML quoted and will unquote it
3557   my ($string, $func, @args) = @_;
3558   $string = UnquoteHtml($string);
3559   my @found;
3560   my $lang = GetParam('lang', '');
3561   foreach my $id (GrepFiltered($string, AllPagesList())) {
3562     my $name = NormalToFree($id);
3563     my ($text) = PageIsUploadedFile($id); # set to mime-type if this is an uploaded file
3564     if (not $text) { # not uploaded file, therefore allow searching of page body
3565       local ($OpenPageName, %Page); # this is local!
3566       OpenPage($id); # this opens a page twice if it is not uploaded, but that's ok
3567       if ($lang) {
3568         my @languages = split(/,/, $Page{languages});
3569         next if (@languages and not grep(/$lang/, @languages));
3570       }
3571       $text = $Page{text};
3572     }
3573     if (SearchString($string, $name . "\n" . $text)) { # the real search code
3574       push(@found, $id);
3575       &$func($id, @args) if $func;
3576     }
3577   }
3578   return @found;
3579 }
3580
3581 sub GrepFiltered { # grep is so much faster!!
3582   my ($string, @pages) = @_;
3583   my $regexp = SearchRegexp($string);
3584   return @pages unless GetParam('grep', $UseGrep) and $regexp;
3585   my @result = grep(/$regexp/i, @pages);
3586   my %found = map {$_ => 1} @result;
3587   $regexp =~ s/\\n(\)*)$/\$$1/g; # sometimes \n can be replaced with $
3588   $regexp =~ s/([?+{|()])/\\$1/g; # basic regular expressions from man grep
3589   # if we know of any remaining grep incompatibilities we should
3590   # return @pages here!
3591   $regexp = quotemeta($regexp);
3592   open(F, '-|:encoding(UTF-8)', "grep -rli $regexp '$PageDir' 2>/dev/null");
3593   while (<F>) {
3594     push(@result, $1) if m/.*\/(.*)\.pg/ and not $found{$1};
3595   }
3596   close(F);
3597   return sort @result;
3598 }
3599
3600 sub SearchString {
3601   my ($string, $data) = @_;
3602   my @strings = grep /./, $string =~ /\"([^\"]+)\"|(\S+)/g; # skip null entries
3603   foreach my $str (@strings) {
3604     return 0 unless ($data =~ /$str/i);
3605   }
3606   return 1;
3607 }
3608
3609 sub SearchRegexp {
3610   my $regexp = join '|', map { index($_,'|') == -1 ? $_ : "($_)" }
3611     grep /./, shift =~ /\"([^\"]+)\"|(\S+)/g; # this acts as OR
3612   $regexp =~ s/\\s/[[:space:]]/g;
3613   return $regexp;
3614 }
3615
3616 sub PrintSearchResult {
3617   my ($name, $regex) = @_;
3618   return PrintPage($name) if not GetParam('context',1);
3619   my $raw = GetParam('raw', 0);
3620   OpenPage($name);     # should be open already, just making sure!
3621   my $text = $Page{text};
3622   my ($type) = TextIsFile($text); # MIME type if an uploaded file
3623   my %entry;
3624   #  get the page, filter it, remove all tags
3625   $text =~ s/$FS//go;   # Remove separators (paranoia)
3626   $text =~ s/[\s]+/ /g;   #  Shrink whitespace
3627   $text =~ s/([-_=\\*\\.]){10,}/$1$1$1$1$1/g ; # e.g. shrink "----------"
3628   $entry{title} = $name;
3629   $entry{description} =  $type || SearchExtract(QuoteHtml($text), $regex);
3630   $entry{size} = int((length($text)/1024)+1) . 'K';
3631   $entry{'last-modified'} = TimeToText($Page{ts});
3632   $entry{username} = $Page{username};
3633   $entry{host} = $Page{host};
3634   PrintSearchResultEntry(\%entry, $regex);
3635 }
3636
3637 sub PrintSearchResultEntry {
3638   my %entry = %{(shift)}; # get value from reference
3639   my $regex = shift;
3640   if (GetParam('raw', 0)) {
3641     $entry{generator} = $entry{username} . ' ' if $entry{username};
3642     $entry{generator} .= Ts('from %s', $entry{host}) if $entry{host};
3643     foreach my $key (qw(title description size last-modified generator username host)) {
3644       print RcTextItem($key, $entry{$key});
3645     }
3646     print RcTextItem('link', "$ScriptName?$entry{title}"), "\n";
3647   } else {
3648     my $author = GetAuthorLink($entry{host}, $entry{username});
3649     $author = $entry{generator} unless $author;
3650     my $id = $entry{title};
3651     my ($class, $resolved, $title, $exists) = ResolveId($id);
3652     my $text = NormalToFree($id);
3653     my $result = $q->span({-class=>'result'}, ScriptLink(UrlEncode($resolved), $text, $class, undef, $title));
3654     my $description = $entry{description};
3655     $description = $q->br() . SearchHighlight($description, $regex) if $description;
3656     my $info = $entry{size};
3657     $info .= ' - ' if $info;
3658     $info .= T('last updated') . ' ' . $entry{'last-modified'} if $entry{'last-modified'};
3659     $info .= ' ' . T('by') . ' ' . $author if $author;
3660     $info = $q->br() . $q->span({-class=>'info'}, $info) if $info;
3661     print $q->p($result, $description, $info);
3662   }
3663 }
3664
3665 sub SearchHighlight {
3666   my ($data, $regex) = @_;
3667   $data =~ s/($regex)/<strong>$1<\/strong>/gi;
3668   return $data;
3669 }
3670
3671 sub SearchExtract {
3672   my ($data, $string) = @_;
3673   my ($snippetlen, $maxsnippets) = (100, 4) ; #  these seem nice.
3674   # show a snippet from the beginning of the document
3675   my $j = index($data, ' ', $snippetlen); # end on word boundary
3676   my $t = substr($data, 0, $j);
3677   my $result = $t . ' . . .';
3678   $data = substr($data, $j);  # to avoid rematching
3679   my $jsnippet = 0 ;
3680   while ($jsnippet < $maxsnippets && $data =~ m/($string)/i) {
3681     $jsnippet++;
3682     if (($j = index($data, $1)) > -1 ) {
3683       # get substr containing (start of) match, ending on word boundaries
3684       my $start = index($data, ' ', $j-($snippetlen/2));
3685       $start = 0 if ($start == -1);
3686       my $end = index($data, ' ', $j+($snippetlen/2));
3687       $end = length($data ) if ($end == -1);
3688       $t = substr($data, $start, $end-$start);
3689       $result .= $t . ' . . .';
3690       # truncate text to avoid rematching the same string.
3691       $data = substr($data, $end);
3692     }
3693   }
3694   return $result;
3695 }
3696
3697 sub Replace {
3698   my ($from, $to) = @_;
3699   my $lang = GetParam('lang', '');
3700   my @result;
3701   RequestLockOrError();   # fatal
3702   foreach my $id (AllPagesList()) {
3703     OpenPage($id);
3704     if ($lang) {
3705       my @languages = split(/,/, $Page{languages});
3706       next if (@languages and not grep(/$lang/, @languages));
3707     }
3708     $_ = $Page{text};
3709     if (eval "s{$from}{$to}gi") { # allows use of backreferences
3710       push (@result, $id);
3711       Save($id, $_, $from . ' -> ' . $to, 1,
3712      ($Page{ip} ne $ENV{REMOTE_ADDR}));
3713     }
3714   }
3715   ReleaseLock();
3716   return @result;
3717 }
3718
3719 sub DoPost {
3720   my $id = FreeToNormal(shift);
3721   ValidIdOrDie($id);
3722   ReportError(Ts('Editing not allowed for %s.', $id), '403 FORBIDDEN') unless UserCanEdit($id, 1);
3723   # Lock before getting old page to prevent races
3724   RequestLockOrError();         # fatal
3725   OpenPage($id);
3726   my $old = $Page{text};
3727   my $string = UnquoteHtml(GetParam('text', undef));
3728   $string =~ s/(\r|$FS)//go;
3729   my ($type) = TextIsFile($string); # MIME type if an uploaded file
3730   my $filename = GetParam('file', undef);
3731   if (($filename or $type) and not $UploadAllowed and not UserIsAdmin()) {
3732     ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
3733   }
3734   my $comment = UnquoteHtml(GetParam('aftertext', undef));
3735   $comment =~ s/(\r|$FS)//go;
3736   if (defined($comment) and (not $comment or $comment eq $NewComment)) {
3737     ReleaseLock();
3738     ReBrowsePage($id);
3739   }
3740   if ($filename) {              # upload file
3741     my $file = $q->upload('file');
3742     if (not $file and $q->cgi_error) {
3743       ReportError(Ts('Transfer Error: %s', $q->cgi_error), '500 INTERNAL SERVER ERROR');
3744     }
3745     ReportError(T('Browser reports no file info.'), '500 INTERNAL SERVER ERROR')
3746       unless $q->uploadInfo($filename);
3747     $type = $q->uploadInfo($filename)->{'Content-Type'};
3748     ReportError(T('Browser reports no file type.'), '415 UNSUPPORTED MEDIA TYPE') unless $type;
3749     local $/ = undef;           # Read complete files
3750     my $content = <$file>; # Apparently we cannot count on <$file> to always work within the eval!?
3751     my $encoding = 'gzip' if substr($content,0,2) eq "\x1f\x8b";
3752     eval { require MIME::Base64; $_ = MIME::Base64::encode($content) };
3753     $string = "#FILE $type $encoding\n" . $_;
3754   } else {                      # ordinary text edit
3755     $string = AddComment($old, $comment) if $comment;
3756     $string = substr($string, length($DeletedPage)) # undelete pages when adding a comment
3757       if $comment and substr($string, 0, length($DeletedPage)) eq $DeletedPage; # no regexp!
3758     $string .= "\n"  if ($string !~ /\n$/); # add trailing newline
3759     $string = RunMyMacros($string); # run macros on text pages only
3760   }
3761   my %allowed = map {$_ => 1} @UploadTypes;
3762   ReportError(Ts('Files of type %s are not allowed.', $type), '415 UNSUPPORTED MEDIA TYPE')
3763     if @UploadTypes and $type and not $allowed{$type};
3764   # Banned Content
3765   my $summary = GetSummary();
3766   if (not UserIsEditor()) {
3767     my $rule = BannedContent($string) || BannedContent($summary);
3768     ReportError(T('Edit Denied'), '403 FORBIDDEN', undef, $q->p(T('The page contains banned text.')),
3769                 $q->p(T('Contact the wiki administrator for more information.')), $q->p($rule)) if $rule;
3770   }
3771   # rebrowse if no changes
3772   my $oldrev = $Page{revision};
3773   if (GetParam('Preview', '')) { # Preview button was used
3774     ReleaseLock();
3775     if ($comment) {
3776       BrowsePage($id, 0, RunMyMacros($comment)); # show macros in preview
3777     } else {
3778       DoEdit($id, $string, 1);
3779     }
3780     return;
3781   } elsif ($old eq $string) {
3782     ReleaseLock();       # No changes -- just show the same page again
3783     return ReBrowsePage($id);
3784   } elsif ($oldrev == 0 and ($string eq $NewText or $string eq "\n")) {
3785     ReportError(T('No changes to be saved.'), '400 BAD REQUEST'); # don't fake page creation because of webdav
3786   }
3787   my $newAuthor = 0;
3788   if ($oldrev) { # the first author (no old revision) is not considered to be "new"
3789     # prefer usernames for potential new author detection
3790     $newAuthor = 1 if not $Page{username} or $Page{username} ne GetParam('username', '');
3791     $newAuthor = 1 if not $ENV{REMOTE_ADDR} or not $Page{ip} or $ENV{REMOTE_ADDR} ne $Page{ip};
3792   }
3793   my $oldtime = $Page{ts};
3794   my $myoldtime = GetParam('oldtime', ''); # maybe empty!
3795   # Handle raw edits with the meta info on the first line
3796   if (GetParam('raw', 0) == 2 and $string =~ /^([0-9]+).*\n((.*\n)*.*)/) {
3797     $myoldtime = $1;
3798     $string = $2;
3799   }
3800   my $generalwarning = 0;
3801   if ($newAuthor and $oldtime ne $myoldtime and not $comment) {
3802     if ($myoldtime) {
3803       my ($ancestor) = GetTextAtTime($myoldtime);
3804       if ($ancestor and $old ne $ancestor) {
3805         my $new = MergeRevisions($string, $ancestor, $old);
3806         if ($new) {
3807           $string = $new;
3808           if ($new =~ /^<<<<<<</m and $new =~ /^>>>>>>>/m) {
3809             SetParam('msg', Ts('This page was changed by somebody else %s.',
3810                                CalcTimeSince($Now - $Page{ts}))
3811                      . ' ' . T('The changes conflict.  Please check the page again.'));
3812           }                     # else no conflict
3813         } else {
3814           $generalwarning = 1;
3815         }  # else merge revision didn't work
3816       }    # else nobody changed the page in the mean time (same text)
3817     } else {
3818       $generalwarning = 1;
3819     }                   # no way to be sure since myoldtime is missing
3820   } # same author or nobody changed the page in the mean time (same timestamp)
3821   if ($generalwarning and ($Now - $Page{ts}) < 600) {
3822     SetParam('msg', Ts('This page was changed by somebody else %s.',
3823                        CalcTimeSince($Now - $Page{ts}))
3824              . ' ' . T('Please check whether you overwrote those changes.'));
3825   }
3826   Save($id, $string, $summary, (GetParam('recent_edit', '') eq 'on'), $filename);
3827   ReleaseLock();
3828   ReBrowsePage($id);
3829 }
3830
3831 sub GetSummary {
3832   my $text = GetParam('aftertext',  '') || ($Page{revision} > 0 ? '' : GetParam('text', ''));
3833   if ($SummaryDefaultLength and length($text) > $SummaryDefaultLength) {
3834     $text = substr($text, 0, $SummaryDefaultLength);
3835     $text =~ s/\s*\S*$/ . . ./;
3836   }
3837   my $summary = GetParam('summary', '') || $text; # not GetParam('summary', $text) work because '' is defined
3838   $summary =~ s/$FS|[\r\n]+/ /go; # remove linebreaks and separator characters
3839   $summary =~ s/\[$FullUrlPattern\s+(.*?)\]/$2/go; # fix common annoyance when copying text to summary
3840   $summary =~ s/\[$FullUrlPattern\]//go;
3841   $summary =~ s/\[\[$FreeLinkPattern\]\]/$1/go;
3842   return UnquoteHtml($summary);
3843 }
3844
3845 sub AddComment {
3846   my ($string, $comment) = @_;
3847   $comment =~ s/\r//g;    # Remove "\r"-s (0x0d) from the string
3848   $comment =~ s/\s+$//g;  # Remove whitespace at the end
3849   return $string unless $comment;
3850   my $isCommentPage = $CommentsPrefix and (GetParam('title') =~ /^$CommentsPrefix/o);
3851   return $string . $comment
3852     unless $isCommentPage;      # Regular page.
3853   if ($comment ne $NewComment) {
3854     # Page is a comments page.  Store username, homepage, timestamp
3855     # along with the comment.
3856     my $author = GetParam('username', T('Anonymous'));
3857     my $homepage = GetParam('homepage', '');
3858     $homepage = 'http://' . $homepage
3859       if $homepage and not substr($homepage,0,7) eq 'http://';
3860     $author = "[$homepage $author]" if $homepage;
3861     $string .= "\n----\n\n" if $string and $string ne "\n";
3862     $string .= $comment . "\n\n"
3863       . '-- ' . $author . ' ' . TimeToText($Now) . "\n\n";
3864   }
3865   return $string;
3866 }
3867
3868 sub Save {      # call within lock, with opened page
3869   my ($id, $new, $summary, $minor, $upload) = @_;
3870   my $user = GetParam('username', '');
3871   my $host = GetRemoteHost();
3872   my $revision = $Page{revision} + 1;
3873   my $old = $Page{text};
3874   my $olddiff = $Page{'diff-major'} == '1' ? $Page{'diff-minor'} : $Page{'diff-major'};
3875   if ($revision == 1 and -e $IndexFile and not unlink($IndexFile)) { # regenerate index on next request
3876     SetParam('msg', Ts('Cannot delete the index file %s.', $IndexFile)
3877        . ' ' . T('Please check the directory permissions.')
3878        . ' ' . T('Your changes were not saved.'));
3879     return 0;
3880   }
3881   ReInit($id);
3882   TouchIndexFile();
3883   SaveKeepFile(); # deletes blocks, flags, diff-major, and diff-minor, and sets keep-ts
3884   ExpireKeepFiles();
3885   $Page{ts} = $Now;
3886   $Page{lastmajor} = $revision unless $minor;
3887   $Page{revision} = $revision;
3888   $Page{summary} = $summary;
3889   $Page{username} = $user;
3890   $Page{ip} = $ENV{REMOTE_ADDR};
3891   $Page{host} = $host;
3892   $Page{minor} = $minor;
3893   $Page{text} = $new;
3894   if ($UseDiff and $UseCache > 1 and $revision > 1 and not $upload and not TextIsFile($old)) {
3895     UpdateDiffs($old, $new, $olddiff); # sets diff-major and diff-minor
3896   }
3897   my $languages;
3898   $languages = GetLanguages($new) unless $upload;
3899   $Page{languages} = $languages;
3900   SavePage();
3901   if ($revision == 1 and $LockOnCreation{$id}) {
3902     WriteStringToFile(GetLockedPageFile($id), 'LockOnCreation');
3903   }
3904   WriteRcLog($id, $summary, $minor, $revision, $user, $host, $languages, GetCluster($new));
3905   if ($revision == 1) {
3906     $IndexHash{$id} = 1;
3907     @IndexList = sort(keys %IndexHash);
3908     WriteStringToFile($IndexFile, join(' ', %IndexHash));
3909   }
3910 }
3911
3912 sub TouchIndexFile {
3913   my $ts = time;
3914   utime $ts, $ts, $IndexFile;
3915   $LastUpdate = $Now = $ts;
3916 }
3917
3918 sub GetLanguages {
3919   my $text = shift;
3920   my @result;
3921   for my $lang (sort keys %Languages) {
3922     my @matches = $text =~ /$Languages{$lang}/ig;
3923     push(@result, $lang) if $#matches >= $LanguageLimit;
3924   }
3925   return join(',', @result);
3926 }
3927
3928 sub GetCluster {
3929   $_ = shift;
3930   return '' unless $PageCluster;
3931   return $1 if ($WikiLinks && /^$LinkPattern\n/o)
3932     or ($FreeLinks && /^\[\[$FreeLinkPattern\]\]\n/o);
3933 }
3934
3935 sub MergeRevisions {   # merge change from file2 to file3 into file1
3936   my ($file1, $file2, $file3) = @_;
3937   my ($name1, $name2, $name3) = ("$TempDir/file1", "$TempDir/file2", "$TempDir/file3");
3938   CreateDir($TempDir);
3939   RequestLockDir('merge') or return T('Could not get a lock to merge!');
3940   WriteStringToFile($name1, $file1);
3941   WriteStringToFile($name2, $file2);
3942   WriteStringToFile($name3, $file3);
3943   my ($you,$ancestor,$other) = (T('you'), T('ancestor'), T('other'));
3944   my $output = `diff3 -m -L "$you" -L "$ancestor" -L "$other" $name1 $name2 $name3`;
3945   ReleaseLockDir('merge'); # don't unlink temp files--next merge will just overwrite.
3946   return $output;
3947 }
3948
3949 # Note: all diff and recent-list operations should be done within locks.
3950 sub WriteRcLog {
3951   my ($id, $summary, $minor, $revision, $username, $host, $languages, $cluster) = @_;
3952   my $rc_line = join($FS, $Now, $id, $minor, $summary, $host,
3953          $username, $revision, $languages, $cluster);
3954   AppendStringToFile($RcFile, $rc_line . "\n");
3955 }
3956
3957 sub UpdateDiffs { # this could be optimized, but isn't frequent enough
3958   my ($old, $new, $olddiff) = @_;
3959   $Page{'diff-minor'} = GetDiff($old, $new); # create new diff-minor
3960   # 1 is a special value for GetCacheDiff telling it to use diff-minor
3961   $Page{'diff-major'} = $Page{lastmajor} == $Page{revision} ? 1 : $olddiff;
3962 }
3963
3964 sub DoMaintain {
3965   print GetHeader('', T('Run Maintenance')), $q->start_div({-class=>'content maintain'});
3966   my $fname = "$DataDir/maintain";
3967   if (!UserIsAdmin()) {
3968     if ((-f $fname) && ((-M $fname) < 0.5)) {
3969       print $q->p(T('Maintenance not done.') . ' ' . T('(Maintenance can only be done once every 12 hours.)')
3970       . ' ', T('Remove the "maintain" file or wait.')), $q->end_div();
3971       PrintFooter();
3972       return;
3973     }
3974   }
3975   print '<p>', T('Expiring keep files and deleting pages marked for deletion');
3976   # Expire all keep files
3977   foreach my $name (AllPagesList()) {
3978     print $q->br(), GetPageLink($name);
3979     OpenPage($name);
3980     my $delete = PageDeletable();
3981     if ($delete) {
3982       my $status = DeletePage($OpenPageName);
3983       print ' ' . ($status ? T('not deleted: ') . $status : T('deleted'));
3984     } else {
3985       ExpireKeepFiles();
3986     }
3987   }
3988   print '</p>';
3989   RequestLockOrError();
3990   print $q->p(T('Main lock obtained.'));
3991   print $q->p(Ts('Moving part of the %s log file.', $RCName));
3992   # Determine the number of days to go back
3993   my $days = 0;
3994   foreach (@RcDays) {
3995     $days = $_ if $_ > $days;
3996   }
3997   my $starttime = $Now - $days * 86400; # 24*60*60
3998   # Read the current file
3999   my ($status, $data) = ReadFile($RcFile);
4000   if (!$status) {
4001     print $q->p($q->strong(Ts('Could not open %s log file', $RCName) . ':') . ' '. $RcFile),
4002       $q->p(T('Error was') . ':'), $q->pre($!), $q->p(T('Note: This error is normal if no changes have been made.'));
4003   }
4004   # Move the old stuff from rc to temp
4005   my @rc = split(/\n/, $data);
4006   my $i;
4007   for ($i = 0; $i < @rc ; $i++) {
4008     my ($ts) = split(/$FS/o, $rc[$i]);
4009     last if ($ts >= $starttime);
4010   }
4011   print $q->p(Ts('Moving %s log entries.', $i));
4012   if ($i) {
4013     my @temp = splice(@rc, 0, $i);
4014     # Write new files, and backups
4015     AppendStringToFile($RcOldFile, join("\n",@temp) . "\n");
4016     WriteStringToFile($RcFile . '.old', $data);
4017     WriteStringToFile($RcFile, @rc ? join("\n",@rc) . "\n" : '');
4018   }
4019   if (opendir(DIR, $RssDir)) {  # cleanup if they should expire anyway
4020     foreach (readdir(DIR)) {
4021       unlink "$RssDir/$_" if $Now - (stat($_))[9] > $RssCacheHours * 3600;
4022     }
4023     closedir DIR;
4024   }
4025   foreach my $sub (@MyMaintenance) {
4026     &$sub;
4027   }
4028   WriteStringToFile($fname, 'Maintenance done at ' . TimeToText($Now));
4029   ReleaseLock();
4030   print $q->p(T('Main lock released.')), $q->end_div();
4031   PrintFooter();
4032 }
4033
4034 sub PageDeletable {
4035   return unless $KeepDays;
4036   my $expirets = $Now - ($KeepDays * 86400); # 24*60*60
4037   return 0 unless $Page{ts} < $expirets;
4038   return PageMarkedForDeletion();
4039 }
4040
4041 sub PageMarkedForDeletion {
4042   return 1 if $Page{text} =~ /^\s*$/; # only whitespace is also to be deleted
4043   return $DeletedPage && substr($Page{text}, 0, length($DeletedPage)) eq $DeletedPage; # no regexp!
4044 }
4045
4046 sub DeletePage {    # Delete must be done inside locks.
4047   my $id = shift;
4048   ValidIdOrDie($id);
4049   foreach my $name (GetPageFile($id), GetKeepFiles($id), GetKeepDir($id), GetLockedPageFile($id), $IndexFile) {
4050     unlink $name if -f $name;
4051     rmdir $name if -d $name;
4052   }
4053   ReInit($id);
4054   delete $IndexHash{$id};
4055   @IndexList = sort(keys %IndexHash);
4056   return '';      # no error
4057 }
4058
4059 sub DoEditLock {
4060   return unless UserIsAdminOrError();
4061   print GetHeader('', T('Set or Remove global edit lock'));
4062   my $fname = "$NoEditFile";
4063   if (GetParam("set", 1)) {
4064     WriteStringToFile($fname, 'editing locked.');
4065   } else {
4066     unlink($fname);
4067   }
4068   utime time, time, $IndexFile; # touch index file
4069   print $q->p(-f $fname ? T('Edit lock created.') : T('Edit lock removed.'));
4070   PrintFooter();
4071 }
4072
4073 sub DoPageLock {
4074   return unless UserIsAdminOrError();
4075   print GetHeader('', T('Set or Remove page edit lock'));
4076   my $id = GetParam('id', '');
4077   my $fname = GetLockedPageFile($id) if ValidIdOrDie($id);
4078   if (GetParam('set', 1)) {
4079     WriteStringToFile($fname, 'editing locked.');
4080   } else {
4081     unlink($fname);
4082   }
4083   utime time, time, $IndexFile; # touch index file
4084   print $q->p(-f $fname ? Ts('Lock for %s created.', GetPageLink($id))
4085         : Ts('Lock for %s removed.', GetPageLink($id)));
4086   PrintFooter();
4087 }
4088
4089 sub DoShowVersion {
4090   print GetHeader('', T('Displaying Wiki Version')), $q->start_div({-class=>'content version'});
4091   print $WikiDescription, $q->p($q->server_software()),
4092     $q->p(sprintf('Perl v%vd', $^V)),
4093       $q->p($ENV{MOD_PERL} ? $ENV{MOD_PERL} : "no mod_perl"), $q->p('CGI: ', $CGI::VERSION),
4094   $q->p('LWP::UserAgent ', eval { local $SIG{__DIE__}; require LWP::UserAgent; $LWP::UserAgent::VERSION; }),
4095     $q->p('XML::RSS: ', eval { local $SIG{__DIE__}; require XML::RSS; $XML::RSS::VERSION; }),
4096       $q->p('XML::Parser: ', eval { local $SIG{__DIE__}; $XML::Parser::VERSION; });
4097   print $q->p('diff: ' . (`diff --version` || $!)), $q->p('diff3: ' . (`diff3 --version` || $!)) if $UseDiff;
4098   print $q->p('grep: ' . (`grep --version` || $!)) if $UseGrep;
4099   print $q->end_div();
4100   PrintFooter();
4101 }
4102
4103 sub DoDebug {
4104   print GetHeader('', T('Debugging Information')),
4105     $q->start_div({-class=>'content debug'});
4106   foreach my $sub (@Debugging) { &$sub }
4107   print $q->end_div();
4108   PrintFooter();
4109 }
4110
4111 sub DoSurgeProtection {
4112   return unless $SurgeProtection;
4113   my $name = GetParam('username','');
4114   $name = $ENV{'REMOTE_ADDR'} if not $name and $SurgeProtection;
4115   return unless $name;
4116   ReadRecentVisitors();
4117   AddRecentVisitor($name);
4118   if (RequestLockDir('visitors')) { # not fatal
4119     WriteRecentVisitors();
4120     ReleaseLockDir('visitors');
4121     if (DelayRequired($name)) {
4122       ReportError(Ts('Too many connections by %s',$name)
4123       . ': ' . Tss('Please do not fetch more than %1 pages in %2 seconds.',
4124              $SurgeProtectionViews, $SurgeProtectionTime),
4125       '503 SERVICE UNAVAILABLE');
4126     }
4127   } elsif (GetParam('action', '') ne 'unlock') {
4128     ReportError(Ts('Could not get %s lock', 'visitors') . ': ' . Ts('Check whether the web server can create the directory %s and whether it can create files in it.', $TempDir), '503 SERVICE UNAVAILABLE');
4129   }
4130 }
4131
4132 sub DelayRequired {
4133   my $name = shift;
4134   my @entries = @{$RecentVisitors{$name}};
4135   my $ts = $entries[$SurgeProtectionViews];
4136   return ($Now - $ts) < $SurgeProtectionTime;
4137 }
4138
4139 sub AddRecentVisitor {
4140   my $name = shift;
4141   my $value = $RecentVisitors{$name};
4142   my @entries = ($Now);
4143   push(@entries, @{$value}) if $value;
4144   $RecentVisitors{$name} = \@entries;
4145 }
4146
4147 sub ReadRecentVisitors {
4148   my ($status, $data) = ReadFile($VisitorFile);
4149   %RecentVisitors = ();
4150   return  unless $status;
4151   foreach (split(/\n/,$data)) {
4152     my @entries = split /$FS/o;
4153     my $name = shift(@entries);
4154     $RecentVisitors{$name} = \@entries if $name;
4155   }
4156 }
4157
4158 sub WriteRecentVisitors {
4159   my $data = '';
4160   my $limit = $Now - $SurgeProtectionTime;
4161   foreach my $name (keys %RecentVisitors) {
4162     my @entries = @{$RecentVisitors{$name}};
4163     if ($entries[0] >= $limit) { # if the most recent one is too old, do not keep
4164       $data .=  join($FS, $name, @entries[0 .. $SurgeProtectionViews - 1]) . "\n";
4165     }
4166   }
4167   WriteStringToFile($VisitorFile, $data);
4168 }
4169
4170 sub TextIsFile { $_[0] =~ /^#FILE (\S+) ?(\S+)?\n/ }
4171
4172 DoWikiRequest() if $RunCGI and not exists $ENV{MOD_PERL}; # Do everything.
4173 1; # In case we are loaded from elsewhere