forked from github/kensanata.oddmuse
eaf97602ff
When serving recent changes, we know the username and host of the person making the edit. We use GetAuthorLink to show either the name linked to the username, or "Anonymous", or a colour coded bogus hash of their host (that's the four octal digits, hopefully colourized by your CSS). When serving raw changes, we used to serve just the username or "Anonymous". In order to help use cases such as the Gemini wiki running on gemini://alexschroeder.ch:1965 which consumes raw changes to present a view that is compatible with Gemini Wiki, we'd like those bogus hashes as well. This comit does that by splitting ColorCode into Code and ColorCode such that we can use Code when serving raw changes.
4161 lines
160 KiB
Perl
Executable File
4161 lines
160 KiB
Perl
Executable File
#! /usr/bin/env perl
|
|
# Copyright (C) 2001-2019
|
|
# Alex Schroeder <alex@gnu.org>
|
|
# Copyright (C) 2014-2015
|
|
# Alex Jakimenko <alex.jakimenko@gmail.com>
|
|
# Copyleft 2008 Brian Curry <http://www.raiazome.com>
|
|
# ... including lots of patches from the UseModWiki site
|
|
# Copyright (C) 2001, 2002 various authors
|
|
# ... which was based on UseModWiki version 0.92 (April 21, 2001)
|
|
# Copyright (C) 2000, 2001 Clifford A. Adams
|
|
# <caadams@frontiernet.net> or <usemod@usemod.com>
|
|
# ... which was based on the GPLed AtisWiki 0.3
|
|
# Copyright (C) 1998 Markus Denker <marcus@ira.uka.de>
|
|
# ... which was based on the LGPLed CVWiki CVS-patches
|
|
# Copyright (C) 1997 Peter Merel
|
|
# ... and The Original WikiWikiWeb
|
|
# Copyright (C) 1996, 1997 Ward Cunningham <ward@c2.com>
|
|
# (code reused with permission)
|
|
|
|
# This program is free software: you can redistribute it and/or modify it under
|
|
# the terms of the GNU General Public License as published by the Free Software
|
|
# Foundation, either version 3 of the License, or (at your option) any later
|
|
# version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful, but WITHOUT
|
|
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
|
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License along with
|
|
# this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
package OddMuse;
|
|
use strict;
|
|
use warnings;
|
|
no warnings 'numeric';
|
|
no warnings 'uninitialized';
|
|
use utf8; # in case anybody ever adds UTF8 characters to the source
|
|
use B;
|
|
use CGI qw/-utf8/;
|
|
use CGI::Carp qw(fatalsToBrowser);
|
|
use File::Glob ':glob';
|
|
use Encode qw(encode_utf8 decode_utf8);
|
|
use sigtrap 'handler' => \&HandleSignals, 'normal-signals', 'error-signals';
|
|
local $| = 1; # Do not buffer output (localized for mod_perl)
|
|
|
|
# Options:
|
|
our ($ScriptName, $FullUrl, $PageDir, $TempDir, $LockDir, $KeepDir, $RssDir,
|
|
$RcFile, $RcOldFile, $IndexFile, $NoEditFile, $VisitorFile, $DeleteFile, $RssLicense,
|
|
$FreeLinkPattern, $LinkPattern, $FreeInterLinkPattern, $InterLinkPattern,
|
|
$UrlPattern, $FullUrlPattern, $InterSitePattern,
|
|
$UrlProtocols, $ImageExtensions, $LastUpdate,
|
|
%LockOnCreation, %PlainTextPages, %AdminPages,
|
|
@MyAdminCode, @MyFormChanges, @MyInitVariables, @MyMacros, @MyMaintenance,
|
|
$DocumentHeader, %HtmlEnvironmentContainers, $FS, $Counter, @Debugging);
|
|
|
|
# Internal variables:
|
|
our ($q, $bol, $OpenPageName, %Page, %Translate, %IndexHash, @IndexList,
|
|
@HtmlStack, @HtmlAttrStack, @Blocks, @Flags,
|
|
%Includes, $FootnoteNumber, $CollectingJournal, $HeaderIsPrinted,
|
|
%Locks, $Fragment, $Today, $ModulesDescription, %RssInterwikiTranslate,
|
|
$Message, $Now, %RecentVisitors, %MyInc, $WikiDescription, %InterSite, %OldCookie);
|
|
|
|
# Can be set outside the script: $DataDir, $UseConfig, $ConfigFile, $ModuleDir,
|
|
# $ConfigPage, $AdminPass, $EditPass, $ScriptName, $FullUrl, $RunCGI.
|
|
|
|
# 1 = load config file in the data directory
|
|
our $UseConfig //= 1;
|
|
|
|
# Main wiki directory
|
|
our $DataDir;
|
|
$DataDir ||= decode_utf8($ENV{WikiDataDir}) if $UseConfig;
|
|
$DataDir ||= '/tmp/oddmuse'; # FIXME: /var/opt/oddmuse/wiki ?
|
|
$DataDir = "./$DataDir" unless $DataDir =~ m!^(/|\./)!;
|
|
|
|
our $ConfigFile;
|
|
$ConfigFile ||= $ENV{WikiConfigFile} if $UseConfig;
|
|
our $ModuleDir;
|
|
$ModuleDir ||= $ENV{WikiModuleDir} if $UseConfig;
|
|
|
|
our $ConfigPage ||= '';
|
|
|
|
# 1 = Run script as CGI instead of loading as module
|
|
our $RunCGI //= 1;
|
|
|
|
# 1 = allow page views using wiki.pl/PageName
|
|
our $UsePathInfo = 1;
|
|
|
|
# -1 = disabled, 0 = 10s; 1 = partial HTML cache; 2 = HTTP/1.1 caching
|
|
our $UseCache = 2;
|
|
|
|
our $SiteName = 'Wiki'; # Name of site (used for titles)
|
|
our $HomePage = 'HomePage'; # Home page
|
|
our $CookieName = 'Wiki'; # Name for this wiki (for multi-wiki sites)
|
|
|
|
our $MaxPost = 1024 * 210; # Maximum 210K posts (about 200K for pages)
|
|
our $StyleSheet = ''; # URL for CSS stylesheet (like '/wiki.css')
|
|
our $StyleSheetPage = ''; # Page for CSS sheet
|
|
our $LogoUrl = ''; # URL for site logo ('' for no logo)
|
|
our $NotFoundPg = ''; # Page for not-found links ('' for blank pg)
|
|
|
|
our $EditAllowed = 1; # 0 = no, 1 = yes, 2 = comments pages only, 3 = comments only
|
|
our $AdminPass //= ''; # Whitespace separated passwords.
|
|
our $EditPass //= ''; # Whitespace separated passwords.
|
|
our $PassHashFunction //= ''; # Name of the function to create hashes
|
|
our $PassSalt //= ''; # Salt will be added to any password before hashing
|
|
|
|
our $BannedHosts = 'BannedHosts'; # Page for banned hosts
|
|
our $BannedCanRead = 1; # 1 = banned cannot edit, 0 = banned cannot read
|
|
our $BannedContent = 'BannedContent'; # Page for banned content (usually for link-ban)
|
|
our $WikiLinks = ''; # 1 = LinkPattern is a link
|
|
our $FreeLinks = 1; # 1 = [[some text]] is a link
|
|
our $UseQuestionmark = 1; # 1 = append questionmark to links to nonexisting pages
|
|
our $BracketText = 1; # 1 = [URL desc] uses a description for the URL
|
|
our $BracketWiki = 1; # 1 = [WikiLink desc] uses a desc for the local link
|
|
our $NetworkFile = 1; # 1 = file: is a valid protocol for URLs
|
|
our $AllNetworkFiles = 0; # 1 = file:///foo is allowed -- the default allows only file://foo
|
|
our $InterMap = 'InterMap'; # name of the intermap page, '' = disable
|
|
our $RssInterwikiTranslate = 'RssInterwikiTranslate'; # name of RSS interwiki translation page, '' = disable
|
|
$ENV{PATH} = '/bin:/usr/bin'; # Path used to find 'diff' and 'grep'
|
|
our $UseDiff = 1; # 1 = use diff
|
|
our $SurgeProtection = 1; # 1 = protect against leeches
|
|
our $SurgeProtectionTime = 20; # Size of the protected window in seconds
|
|
our $SurgeProtectionViews = 20; # How many page views to allow in this window
|
|
our $DeletedPage = 'DeletedPage'; # Pages starting with this can be deleted
|
|
our $RCName = 'RecentChanges'; # Name of changes page
|
|
our @RcDays = qw(1 3 7 30 90); # Days for links on RecentChanges
|
|
our $RcDefault = 30; # Default number of RecentChanges days
|
|
our $KeepHostDays = 4; # Days to keep IP numbers for
|
|
our $KeepDays = 0; # Days to keep old revisions (0 means keep forever)
|
|
our $KeepMajor = 1; # 1 = keep at least one major rev when expiring pages
|
|
our $SummaryHours = 4; # Hours to offer the old subject when editing a page
|
|
our $SummaryDefaultLength = 150; # Length of default text for summary (0 to disable)
|
|
our $ShowEdits = 0; # 1 = major and show minor edits in recent changes
|
|
our $ShowAll = 0; # 1 = show multiple edits per page in recent changes
|
|
our $ShowRollbacks = 0; # 1 = show rollbacks in recent changes
|
|
our $RecentLink = 1; # 1 = link to usernames
|
|
our $PageCluster = ''; # name of cluster page, eg. 'Cluster' to enable
|
|
our $InterWikiMoniker = ''; # InterWiki prefix for this wiki for RSS
|
|
our $SiteDescription = ''; # RSS Description of this wiki
|
|
our $RssStrip = '^\d\d\d\d-\d\d-\d\d_'; # Regexp to strip from feed item titles
|
|
our $RssImageUrl = $LogoUrl; # URL to image to associate with your RSS feed
|
|
our $RssRights = ''; # Copyright notice for RSS, usually an URL to the appropriate text
|
|
our $RssExclude = 'RssExclude'; # name of the page that lists pages to be excluded from the feed
|
|
our $RssCacheHours = 1; # How many hours to cache remote RSS files
|
|
our $RssStyleSheet = ''; # External style sheet for RSS files
|
|
our $UploadAllowed = 0; # 1 = yes, 0 = administrators only
|
|
our @UploadTypes = ('image/jpeg', 'image/png'); # MIME types allowed, all allowed if empty list
|
|
our $EmbedWiki = 0; # 1 = no headers/footers
|
|
our $FooterNote = ''; # HTML for bottom of every page
|
|
our $EditNote = ''; # HTML notice above buttons on edit page
|
|
our $TopLinkBar = 1; # 0 = goto bar both at the top and bottom; 1 = top, 2 = bottom
|
|
our $TopSearchForm = 1; # 0 = search form both at the top and bottom; 1 = top, 2 = bottom
|
|
our $MatchingPages = 0; # 1 = search page content and page titles
|
|
our @UserGotoBarPages = (); # List of pagenames
|
|
our $UserGotoBar = ''; # HTML added to end of goto bar
|
|
our $CommentsPrefix = ''; # prefix for comment pages, eg. 'Comments_on_' to enable
|
|
our $CommentsPattern = undef; # regex used to match comment pages
|
|
our $HtmlHeaders = ''; # Additional stuff to put in the HTML <head> section
|
|
our $IndentLimit = 20; # Maximum depth of nested lists
|
|
our $CurrentLanguage = 'en'; # Language of error messages etc
|
|
our $LanguageLimit = 3; # Number of matches req. for each language
|
|
our $JournalLimit = 200; # how many pages can be collected in one go?
|
|
our $PageNameLimit = 120; # max length of page name in bytes
|
|
$DocumentHeader = qq(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN")
|
|
. qq( "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">\n)
|
|
. qq(<html xmlns="http://www.w3.org/1999/xhtml">);
|
|
our @MyFooters = (\&GetCommentForm, \&WrapperEnd, \&DefaultFooter);
|
|
# Checkboxes at the end of the index.
|
|
our @IndexOptions = ();
|
|
# Display short comments below the GotoBar for special days
|
|
# Example: %SpecialDays = ('1-1' => 'New Year', '1-2' => 'Next Day');
|
|
our %SpecialDays = ();
|
|
# Replace regular expressions with inlined images
|
|
# Example: %Smilies = (":-?D(?=\\W)" => '/pics/grin.png');
|
|
our %Smilies = ();
|
|
# Detect page languages when saving edits
|
|
# Example: %Languages = ('de' => '\b(der|die|das|und|oder)\b');
|
|
our %Languages = ();
|
|
our @KnownLocks = qw(main diff index merge visitors); # locks to remove
|
|
our $LockExpiration = 60; # How long before expirable locks are expired
|
|
our %LockExpires = (diff=>1, index=>1, merge=>1, visitors=>1); # locks to expire after some time
|
|
our %LockCleaners = (); # What to do if a job under a lock gets a signal like SIGINT. e.g. 'diff' => \&CleanDiff
|
|
our %CookieParameters = (username=>'', pwd=>'', homepage=>'', theme=>'', css=>'', msg=>'', lang=>'', embed=>$EmbedWiki,
|
|
toplinkbar=>$TopLinkBar, topsearchform=>$TopSearchForm, matchingpages=>$MatchingPages, );
|
|
our %Action = (rc => \&BrowseRc, rollback => \&DoRollback,
|
|
browse => \&BrowseResolvedPage, maintain => \&DoMaintain,
|
|
random => \&DoRandom, pagelock => \&DoPageLock,
|
|
history => \&DoHistory, editlock => \&DoEditLock,
|
|
edit => \&DoEdit, version => \&DoShowVersion,
|
|
download => \&DoDownload, rss => \&DoRss,
|
|
unlock => \&DoUnlock, password => \&DoPassword,
|
|
index => \&DoIndex, admin => \&DoAdminPage,
|
|
clear => \&DoClearCache, debug => \&DoDebug,
|
|
contrib => \&DoContributors, more => \&DoJournal);
|
|
our @MyRules = (\&LinkRules, \&ListRule); # don't set this variable, add to it!
|
|
our %RuleOrder = (\&LinkRules => 0, \&ListRule => 0);
|
|
|
|
# The 'main' program, called at the end of this script file (aka. as handler)
|
|
sub DoWikiRequest {
|
|
Init();
|
|
DoSurgeProtection();
|
|
if (not $BannedCanRead and UserIsBanned() and not UserIsEditor()) {
|
|
ReportError(T('Reading not allowed: user, ip, or network is blocked.'), '403 FORBIDDEN',
|
|
0, $q->p(ScriptLink('action=password', T('Login'), 'password')));
|
|
}
|
|
DoBrowseRequest();
|
|
}
|
|
|
|
sub ReportError { # fatal!
|
|
my ($errmsg, $status, $log, @html) = @_;
|
|
InitRequest(); # make sure we can report errors before InitRequest
|
|
print GetHttpHeader('text/html', 'nocache', $status), GetHtmlHeader(T('Error')),
|
|
$q->start_div({class=>"error"}), $q->h1(QuoteHtml($errmsg)), @html, $q->end_div,
|
|
$q->end_html, "\n\n"; # newlines for FCGI because of exit()
|
|
WriteStringToFile("$TempDir/error", '<body>' . $q->h1("$status $errmsg") . $q->Dump) if $log;
|
|
map { ReleaseLockDir($_); } keys %Locks;
|
|
exit 2;
|
|
}
|
|
|
|
sub Init {
|
|
binmode(STDOUT, ':encoding(UTF-8)'); # this is where the HTML gets printed
|
|
binmode(STDERR, ':encoding(UTF-8)'); # just in case somebody prints debug info to stderr
|
|
InitDirConfig();
|
|
$FS = "\x1e"; # The FS character is the RECORD SEPARATOR control char in ASCII
|
|
$Message = ''; # Warnings and non-fatal errors.
|
|
InitLinkPatterns(); # Link pattern can be changed in config files
|
|
InitModules(); # Modules come first so that users can change module variables in config
|
|
InitConfig(); # Config comes as early as possible; remember $q is not available here
|
|
InitRequest(); # get $q with $MaxPost; set these in the config file
|
|
InitCookie(); # After InitRequest, because $q is used
|
|
InitVariables(); # After config, to change variables, after InitCookie for GetParam
|
|
}
|
|
|
|
sub InitModules {
|
|
if ($UseConfig and $ModuleDir and IsDir($ModuleDir)) {
|
|
foreach my $lib (Glob("$ModuleDir/*.p[ml]")) {
|
|
if (not $MyInc{$lib}) {
|
|
$MyInc{$lib} = 1; # Cannot use %INC in mod_perl settings
|
|
my $file = encode_utf8($lib);
|
|
do $file;
|
|
$Message .= CGI::p("$lib: $@") if $@; # no $q exists, yet
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub InitConfig {
|
|
if ($UseConfig and $ConfigFile and not $INC{$ConfigFile} and IsFile($ConfigFile)) {
|
|
do $ConfigFile; # these options must be set in a wrapper script or via the environment
|
|
$Message .= CGI::p("$ConfigFile: $@") if $@; # remember, no $q exists, yet
|
|
}
|
|
if ($ConfigPage) { # $FS and $MaxPost must be set in config file!
|
|
my ($status, $data) = ReadFile(GetPageFile(FreeToNormal($ConfigPage)));
|
|
my $page = ParseData($data); # before InitVariables so GetPageContent won't work
|
|
eval $page->{text} if $page->{text}; # perlcritic dislikes the use of eval here but we really mean it
|
|
$Message .= CGI::p("$ConfigPage: $@") if $@;
|
|
}
|
|
}
|
|
|
|
sub InitDirConfig {
|
|
$PageDir = "$DataDir/page"; # Stores page data
|
|
$KeepDir = "$DataDir/keep"; # Stores kept (old) page data
|
|
$TempDir = "$DataDir/temp"; # Temporary files and locks
|
|
$LockDir = "$TempDir/lock"; # DB is locked if this exists
|
|
$NoEditFile = "$DataDir/noedit"; # Indicates that the site is read-only
|
|
$RcFile = "$DataDir/rc.log"; # New RecentChanges logfile
|
|
$RcOldFile = "$DataDir/oldrc.log"; # Old RecentChanges logfile
|
|
$IndexFile = "$DataDir/pageidx"; # List of all pages
|
|
$VisitorFile = "$DataDir/visitors.log"; # List of recent visitors
|
|
$DeleteFile = "$DataDir/delete.log"; # Deletion logfile
|
|
$RssDir = "$DataDir/rss"; # For rss feed cache
|
|
$ConfigFile ||= "$DataDir/config"; # Config file with Perl code to execute
|
|
$ModuleDir ||= "$DataDir/modules"; # For extensions (ending in .pm or .pl)
|
|
}
|
|
|
|
sub InitRequest { # set up $q
|
|
$CGI::POST_MAX = $MaxPost;
|
|
$q ||= new CGI;
|
|
}
|
|
|
|
sub InitVariables { # Init global session variables for mod_perl!
|
|
$WikiDescription = $q->p($q->a({-href=>'https://www.oddmuse.org/'}, 'Oddmuse'),
|
|
$Counter++ > 0 ? Ts('%s calls', $Counter) : '');
|
|
$WikiDescription .= $ModulesDescription if $ModulesDescription;
|
|
$HeaderIsPrinted = 0; # print HTTP headers only once
|
|
$ScriptName //= $q->url(); # URL used in links
|
|
$FullUrl ||= $ScriptName; # URL used in forms
|
|
%Locks = ();
|
|
@Blocks = ();
|
|
@Flags = ();
|
|
$Fragment = '';
|
|
%RecentVisitors = ();
|
|
$OpenPageName = ''; # Currently open page
|
|
my $add_space = $CommentsPrefix =~ /[ \t_]$/;
|
|
$$_ = FreeToNormal($$_) for # convert spaces to underscores on all configurable pagenames
|
|
(\$HomePage, \$RCName, \$BannedHosts, \$InterMap, \$StyleSheetPage, \$CommentsPrefix,
|
|
\$ConfigPage, \$NotFoundPg, \$RssInterwikiTranslate, \$BannedContent, \$RssExclude, );
|
|
$CommentsPrefix .= '_' if $add_space;
|
|
$CommentsPattern = "^$CommentsPrefix(.*)" unless defined $CommentsPattern or not $CommentsPrefix;
|
|
@UserGotoBarPages = ($HomePage, $RCName) unless @UserGotoBarPages;
|
|
my @pages = sort($BannedHosts, $StyleSheetPage, $ConfigPage, $InterMap,
|
|
$RssInterwikiTranslate, $BannedContent);
|
|
%AdminPages = map { $_ => 1} @pages, $RssExclude unless %AdminPages;
|
|
%LockOnCreation = map { $_ => 1} @pages unless %LockOnCreation;
|
|
%PlainTextPages = ($BannedHosts => 1, $BannedContent => 1,
|
|
$StyleSheetPage => 1, $ConfigPage => 1) unless %PlainTextPages;
|
|
delete $PlainTextPages{''}; # $ConfigPage and others might be empty.
|
|
CreateDir($DataDir); # Create directory if it doesn't exist
|
|
$Now = time; # Reset in case script is persistent
|
|
my $ts = Modified($IndexFile); # always stat for multiple server processes
|
|
ReInit() if not $ts or $LastUpdate != $ts; # reinit if another process changed files (requires $DataDir)
|
|
$LastUpdate = $ts;
|
|
unshift(@MyRules, \&MyRules) if defined(&MyRules) && (not @MyRules or $MyRules[0] != \&MyRules);
|
|
@MyRules = sort {$RuleOrder{$a} <=> $RuleOrder{$b}} @MyRules; # default is 0
|
|
ReportError(Ts('Cannot create %s', $DataDir) . ": $!", '500 INTERNAL SERVER ERROR') unless IsDir($DataDir);
|
|
@IndexOptions = (['pages', T('Include normal pages'), 1, \&AllPagesList]);
|
|
foreach my $sub (@MyInitVariables) {
|
|
my $result = $sub->();
|
|
$Message .= $q->p($@) if $@;
|
|
}
|
|
}
|
|
|
|
sub ReInit { # init everything we need if we want to link to stuff
|
|
my $id = shift; # when saving a page, what to do depends on the page being saved
|
|
AllPagesList() unless $id;
|
|
InterInit() if $InterMap and (not $id or $id eq $InterMap);
|
|
%RssInterwikiTranslate = () if not $id or $id eq $RssInterwikiTranslate; # special since rarely used
|
|
}
|
|
|
|
sub InitCookie {
|
|
undef $q->{'.cookies'}; # Clear cache if it exists (for SpeedyCGI)
|
|
my $cookie = $q->cookie($CookieName);
|
|
%OldCookie = split(/$FS/, UrlDecode($cookie));
|
|
my %provided = map { $_ => 1 } $q->param;
|
|
for my $key (keys %OldCookie) {
|
|
SetParam($key, $OldCookie{$key}) unless $provided{$key};
|
|
}
|
|
CookieUsernameFix();
|
|
CookieRollbackFix();
|
|
}
|
|
|
|
sub CookieUsernameFix {
|
|
# Only valid usernames get stored in the new cookie.
|
|
my $name = GetParam('username', '');
|
|
$q->delete('username');
|
|
if (not $name) {
|
|
# do nothing
|
|
} elsif ($WikiLinks and not $FreeLinks and $name !~ /^$LinkPattern$/) {
|
|
$Message .= $q->p(Ts('Invalid UserName %s: not saved.', $name));
|
|
} elsif ($FreeLinks and $name !~ /^$FreeLinkPattern$/) {
|
|
$Message .= $q->p(Ts('Invalid UserName %s: not saved.', $name));
|
|
} elsif (length($name) > 50) { # Too long
|
|
$Message .= $q->p(T('UserName must be 50 characters or less: not saved'));
|
|
} else {
|
|
SetParam('username', $name);
|
|
}
|
|
}
|
|
|
|
sub CookieRollbackFix {
|
|
my @rollback = grep(/rollback-(\d+)/, $q->param);
|
|
if (@rollback and $rollback[0] =~ /(\d+)/) {
|
|
SetParam('to', $1);
|
|
$q->delete('action');
|
|
SetParam('action', 'rollback');
|
|
}
|
|
}
|
|
|
|
sub GetParam {
|
|
my ($name, $default) = @_;
|
|
my $result = $q->param(encode_utf8($name));
|
|
$result //= $default;
|
|
return QuoteHtml($result); # you need to unquote anything that can have <tags>
|
|
}
|
|
|
|
sub SetParam {
|
|
my ($name, $val) = @_;
|
|
$q->param($name, $val);
|
|
}
|
|
|
|
sub InitLinkPatterns {
|
|
my ($WikiWord, $QDelim);
|
|
$QDelim = '(?:"")?'; # Optional quote delimiter (removed from the output)
|
|
$WikiWord = '\p{Uppercase}+\p{Lowercase}+\p{Uppercase}\p{Alphabetic}*';
|
|
$LinkPattern = "($WikiWord)$QDelim";
|
|
$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 >)
|
|
# Intersites must start with uppercase letter to avoid confusion with URLs.
|
|
$InterSitePattern = '[A-Z\x{0080}-\x{fffd}]+[A-Za-z\x{0080}-\x{fffd}]+';
|
|
$InterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,]*[-a-zA-Z0-9\x{0080}-\x{fffd}_=#\$\@~`\%&*+\\/])$QDelim";
|
|
$FreeInterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,()' ]+)"; # plus space and other characters, and no restrictions on the end of the pattern
|
|
$UrlProtocols = 'https?|ftp|afs|news|nntp|mid|cid|mailto|wais|prospero|telnet|gophers?|irc|feed';
|
|
$UrlProtocols .= '|file' if $NetworkFile;
|
|
my $UrlChars = '[-a-zA-Z0-9/@=+$_~*.,;:?!\'"()&#%]'; # see RFC 2396
|
|
my $EndChars = '[-a-zA-Z0-9/@=+$_~*]'; # no punctuation at the end of the url.
|
|
$UrlPattern = "((?:$UrlProtocols):$UrlChars+$EndChars)";
|
|
$FullUrlPattern="((?:$UrlProtocols):$UrlChars+)"; # when used in square brackets
|
|
$ImageExtensions = '(gif|jpg|jpeg|png|bmp|svg)';
|
|
}
|
|
|
|
sub Clean {
|
|
my $block = shift;
|
|
return 0 unless defined($block); # "0" must print
|
|
return 1 if $block eq ''; # '' is the result of a dirty rule
|
|
$Fragment .= $block;
|
|
return 1;
|
|
}
|
|
|
|
sub Dirty { # arg 1 is the raw text; the real output must be printed instead
|
|
if ($Fragment ne '') {
|
|
$Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end of ApplyRules)
|
|
print $Fragment;
|
|
push(@Blocks, $Fragment);
|
|
push(@Flags, 0);
|
|
}
|
|
push(@Blocks, shift);
|
|
push(@Flags, 1);
|
|
$Fragment = '';
|
|
}
|
|
|
|
sub ApplyRules {
|
|
# locallinks: apply rules that create links depending on local config (incl. interlink!)
|
|
my ($text, $locallinks, $withanchors, $revision, @tags) = @_; # $revision is used for images
|
|
$text =~ s/\r\n/\n/g; # DOS to Unix
|
|
$text =~ s/\n+$//g; # No trailing paragraphs
|
|
return if $text eq ''; # allow the text '0'
|
|
local $Fragment = ''; # the clean HTML fragment not yet on @Blocks
|
|
local @Blocks = (); # the list of cached HTML blocks
|
|
local @Flags = (); # a list for each block, 1 = dirty, 0 = clean
|
|
Clean(join('', map { AddHtmlEnvironment($_) } @tags));
|
|
if ($OpenPageName and $PlainTextPages{$OpenPageName}) { # there should be no $PlainTextPages{''}
|
|
Clean(CloseHtmlEnvironments() . $q->pre($text));
|
|
} elsif (my ($type) = TextIsFile($text)) { # TODO? $type defined here??
|
|
Clean(CloseHtmlEnvironments() . $q->p(T('This page contains an uploaded file:'))
|
|
. $q->p(GetDownloadLink($OpenPageName, (substr($type, 0, 6) eq 'image/'), $revision))
|
|
. (length $Page{summary} > 0 ? $q->blockquote(QuoteHtml($Page{summary})) : $q->p(T('No summary was provided for this file.'))));
|
|
} else {
|
|
my $smileyregex = join "|", keys %Smilies;
|
|
$smileyregex = qr/(?=$smileyregex)/;
|
|
local $_ = $text;
|
|
local $bol = 1;
|
|
while (1) {
|
|
# Block level elements should eat trailing empty lines to prevent empty p elements.
|
|
if ($bol and m/\G(\s*\n)+/cg) {
|
|
Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p'));
|
|
} elsif ($bol and m/\G(\<include(\s+(text|with-anchors))?\s+"(.*)"\>[ \t]*\n?)/cgi) {
|
|
# <include "uri..."> includes the text of the given URI verbatim
|
|
Clean(CloseHtmlEnvironments());
|
|
Dirty($1);
|
|
my ($oldpos, $old_, $type, $uri) = ((pos), $_, $3, UnquoteHtml($4)); # remember, page content is quoted!
|
|
if ($uri =~ /^($UrlProtocols):/) {
|
|
if ($type eq 'text') {
|
|
print $q->pre({class=>"include $uri"}, QuoteHtml(GetRaw($uri)));
|
|
} else { # never use local links for remote pages, with a starting tag
|
|
print $q->start_div({class=>"include"});
|
|
ApplyRules(QuoteHtml(GetRaw($uri)), 0, ($type eq 'with-anchors'), undef, 'p');
|
|
print $q->end_div();
|
|
}
|
|
} else {
|
|
$Includes{$OpenPageName} = 1;
|
|
local $OpenPageName = FreeToNormal($uri);
|
|
if ($type eq 'text') {
|
|
print $q->pre({class=>"include $OpenPageName"}, QuoteHtml(GetPageContent($OpenPageName)));
|
|
} elsif (not $Includes{$OpenPageName}) { # with a starting tag, watch out for recursion
|
|
print $q->start_div({class=>"include $OpenPageName"});
|
|
ApplyRules(QuoteHtml(GetPageContent($OpenPageName)), $locallinks, $withanchors, undef, 'p');
|
|
print $q->end_div();
|
|
delete $Includes{$OpenPageName};
|
|
} else {
|
|
print $q->p({-class=>'error'}, $q->strong(Ts('Recursive include of %s!', $OpenPageName)));
|
|
}
|
|
}
|
|
Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
|
|
($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
|
|
} elsif ($bol and m/\G(\<(journal|titles):?(\d*)((\s+|:)(\d*),?(\d*))?(\s+"(.*?)")?(\s+(reverse|past|future))?(\s+search\s+(.*))?\>[ \t]*\n?)/cgi) {
|
|
# <journal 10 "regexp"> includes 10 pages matching regexp
|
|
Clean(CloseHtmlEnvironments());
|
|
Dirty($1);
|
|
my ($oldpos, $old_) = (pos, $_); # remember these because of the call to PrintJournal()
|
|
PrintJournal($6, $7, $9, $11, $3, $13, $2);
|
|
Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
|
|
($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
|
|
} elsif ($bol and m/\G(\<rss(\s+(\d*))?\s+(.*?)\>[ \t]*\n?)/cgis) {
|
|
# <rss "uri..."> stores the parsed RSS of the given URI
|
|
Clean(CloseHtmlEnvironments());
|
|
Dirty($1);
|
|
my ($oldpos, $old_) = (pos, $_); # remember these because of the call to RSS()
|
|
print RSS($3 || 15, split(/\s+/, UnquoteHtml($4)));
|
|
Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
|
|
($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
|
|
} elsif (/\G(<search (.*?)>)/cgis) {
|
|
# <search regexp>
|
|
Clean(CloseHtmlEnvironments());
|
|
Dirty($1);
|
|
my ($oldpos, $old_) = (pos, $_);
|
|
print $q->start_div({-class=>'search'});
|
|
SearchTitleAndBody($2, \&PrintSearchResult, SearchRegexp($2));
|
|
print $q->end_div;
|
|
Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
|
|
($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
|
|
} elsif ($bol and m/\G(<<<<<<< )/cg) {
|
|
my ($str, $count, $limit, $oldpos) = ($1, 0, 100, pos);
|
|
while (m/\G(.*\n)/cg and $count++ < $limit) {
|
|
$str .= $1;
|
|
last if (substr($1, 0, 29) eq '>>>>>>> ');
|
|
}
|
|
if ($count >= $limit) {
|
|
pos = $oldpos; # reset because we did not find a match
|
|
Clean('<<<<<<< ');
|
|
} else {
|
|
Clean(CloseHtmlEnvironments() . $q->pre({-class=>'conflict'}, $str) . AddHtmlEnvironment('p'));
|
|
}
|
|
} elsif ($bol and m/\G#REDIRECT/cg) {
|
|
Clean('#REDIRECT');
|
|
} elsif (%Smilies and m/\G$smileyregex/cg and Clean(SmileyReplace())) {
|
|
} elsif (Clean(RunMyRules($locallinks, $withanchors))) {
|
|
} elsif (m/\G\s*\n(\s*\n)+/cg) { # paragraphs: at least two newlines
|
|
Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p')); # another one like this further up
|
|
} elsif (m/\G&([A-Za-z]+|#[0-9]+|#x[A-Za-f0-9]+);/cg) { # entity references
|
|
Clean("&$1;");
|
|
} elsif (m/\G\s+/cg) {
|
|
Clean(' ');
|
|
} elsif (m/\G([A-Za-z\x{0080}-\x{fffd}]+([ \t]+[a-z\x{0080}-\x{fffd}]+)*[ \t]+)/cg
|
|
or m/\G([A-Za-z\x{0080}-\x{fffd}]+)/cg or m/\G(\S)/cg) {
|
|
Clean($1); # multiple words but do not match http://foo
|
|
} else {
|
|
last;
|
|
}
|
|
$bol = (substr($_, pos() - 1, 1) eq "\n");
|
|
}
|
|
}
|
|
pos = length $_; # notify module functions we've completed rule handling
|
|
Clean(CloseHtmlEnvironments()); # last block -- close it, cache it
|
|
if ($Fragment ne '') {
|
|
$Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end Dirty())
|
|
print $Fragment;
|
|
push(@Blocks, $Fragment);
|
|
push(@Flags, 0);
|
|
}
|
|
# this can be stored in the page cache -- see PrintCache
|
|
return (join($FS, @Blocks), join($FS, @Flags));
|
|
}
|
|
|
|
sub ListRule {
|
|
if ($bol && m/\G(\s*\n)*(\*+)[ \t]+/cg
|
|
or InElement('li') && m/\G(\s*\n)+(\*+)[ \t]+/cg) {
|
|
return CloseHtmlEnvironmentUntil('li')
|
|
. OpenHtmlEnvironment('ul', length($2)) . AddHtmlEnvironment('li');
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub LinkRules {
|
|
my ($locallinks, $withanchors) = @_;
|
|
if ($locallinks
|
|
and ($BracketText && m/\G(\[$InterLinkPattern\s+([^\]]+?)\])/cg
|
|
or $BracketText && m/\G(\[\[$FreeInterLinkPattern\|([^\]]+?)\]\])/cg
|
|
or m/\G(\[$InterLinkPattern\])/cg or m/\G(\[\[\[$FreeInterLinkPattern\]\]\])/cg
|
|
or m/\G($InterLinkPattern)/cg or m/\G(\[\[$FreeInterLinkPattern\]\])/cg)) {
|
|
# [InterWiki:FooBar text] or [InterWiki:FooBar] or
|
|
# InterWiki:FooBar or [[InterWiki:foo bar|text]] or
|
|
# [[InterWiki:foo bar]] or [[[InterWiki:foo bar]]]-- Interlinks
|
|
# can change when the intermap changes (local config, therefore
|
|
# depend on $locallinks). The intermap is only read if
|
|
# necessary, so if this not an interlink, we have to backtrack a
|
|
# bit.
|
|
my $bracket = (substr($1, 0, 1) eq '[') # but \[\[$FreeInterLinkPattern\]\] it not bracket!
|
|
&& !((substr($1, 0, 2) eq '[[') && (substr($1, 2, 1) ne '[') && index($1, '|') < 0);
|
|
my $quote = (substr($1, 0, 2) eq '[[');
|
|
my ($oldmatch, $output) = ($1, GetInterLink($2, $3, $bracket, $quote)); # $3 may be empty
|
|
if ($oldmatch eq $output) { # no interlink
|
|
my ($site, $rest) = split(/:/, $oldmatch, 2);
|
|
Clean($site);
|
|
pos = (pos) - length($rest) - 1; # skip site, but reparse rest
|
|
} else {
|
|
Dirty($oldmatch);
|
|
print $output; # this is an interlink
|
|
}
|
|
} elsif ($BracketText && m/\G(\[$FullUrlPattern[|[:space:]]([^\]]+?)\])/cg
|
|
or $BracketText && m/\G(\[\[$FullUrlPattern[|[:space:]]([^\]]+?)\]\])/cg
|
|
or m/\G(\[$FullUrlPattern\])/cg or m/\G($UrlPattern)/cg) {
|
|
# [URL text] makes [text] link to URL, [URL] makes footnotes [1]
|
|
my ($str, $url, $text, $bracket, $rest) = ($1, $2, $3, (substr($1, 0, 1) eq '['), '');
|
|
if ($url =~ /(<|>|&)$/) { # remove trailing partial named entitites and add them as
|
|
$rest = $1; # back again at the end as trailing text.
|
|
$url =~ s/&(lt|gt|amp)$//;
|
|
}
|
|
if ($bracket and not defined $text) { # [URL] is dirty because the number may change
|
|
Dirty($str);
|
|
print GetUrl($url, $text, $bracket), $rest;
|
|
} else {
|
|
Clean(GetUrl($url, $text, $bracket, not $bracket) . $rest); # $text may be empty, no images in brackets
|
|
}
|
|
} elsif ($WikiLinks && m/\G!$LinkPattern/cg) {
|
|
Clean($1); # ! gets eaten
|
|
} elsif ($WikiLinks && $locallinks
|
|
&& ($BracketWiki && m/\G(\[$LinkPattern\s+([^\]]+?)\])/cg
|
|
or m/\G(\[$LinkPattern\])/cg or m/\G($LinkPattern)/cg)) {
|
|
# [LocalPage text], [LocalPage], LocalPage
|
|
Dirty($1);
|
|
my $bracket = (substr($1, 0, 1) eq '[' and not $3);
|
|
print GetPageOrEditLink($2, $3, $bracket);
|
|
} elsif ($locallinks && $FreeLinks && (m/\G(\[\[image:$FreeLinkPattern\]\])/cg
|
|
or m/\G(\[\[image:$FreeLinkPattern\|([^]|]+)\]\])/cg)) {
|
|
# [[image:Free Link]], [[image:Free Link|alt text]]
|
|
Dirty($1);
|
|
print GetDownloadLink(FreeToNormal($2), 1, undef, UnquoteHtml($3));
|
|
} elsif ($FreeLinks && $locallinks
|
|
&& ($BracketWiki && m/\G(\[\[$FreeLinkPattern\|([^\]]+)\]\])/cg
|
|
or m/\G(\[\[\[$FreeLinkPattern\]\]\])/cg
|
|
or m/\G(\[\[$FreeLinkPattern\]\])/cg)) {
|
|
# [[Free Link|text]], [[[Free Link]]], [[Free Link]]
|
|
Dirty($1);
|
|
my $bracket = (substr($1, 0, 3) eq '[[[');
|
|
print GetPageOrEditLink($2, $3, $bracket, 1); # $3 may be empty
|
|
} else {
|
|
return; # nothing matched
|
|
}
|
|
return ''; # one of the dirty rules matched (and they all are)
|
|
}
|
|
|
|
sub SetHtmlEnvironmentContainer {
|
|
my ($html_tag, $html_tag_attr) = @_;
|
|
$HtmlEnvironmentContainers{$html_tag} = defined $html_tag_attr ? (
|
|
$HtmlEnvironmentContainers{$html_tag} ? '|' . $HtmlEnvironmentContainers{$html_tag} : '')
|
|
. $html_tag_attr : '';
|
|
}
|
|
|
|
sub InElement { # is $html_tag in @HtmlStack?
|
|
my ($html_tag, $html_tag_attr) = @_;
|
|
my $i = 0;
|
|
foreach my $html_tag_current (@HtmlStack) {
|
|
return 1 if $html_tag_current eq $html_tag and
|
|
($html_tag_attr ? $HtmlAttrStack[$i] =~ m/$html_tag_attr/ : 1);
|
|
$i++;
|
|
} return '';
|
|
}
|
|
|
|
sub AddOrCloseHtmlEnvironment { # add $html_tag, if not already added; close, otherwise
|
|
my ($html_tag, $html_tag_attr) = @_;
|
|
return InElement ($html_tag, '^' . $html_tag_attr . '$')
|
|
? CloseHtmlEnvironment($html_tag, '^' . $html_tag_attr . '$')
|
|
: AddHtmlEnvironment ($html_tag, $html_tag_attr);
|
|
}
|
|
|
|
sub AddHtmlEnvironment { # add a new $html_tag
|
|
my ($html_tag, $html_tag_attr) = @_;
|
|
$html_tag_attr //= '';
|
|
if ($html_tag and not (@HtmlStack and $HtmlStack[0] eq $html_tag and
|
|
($html_tag_attr ? $HtmlAttrStack[0] =~ m/$html_tag_attr/ : 1))) {
|
|
unshift(@HtmlStack, $html_tag);
|
|
unshift(@HtmlAttrStack, $html_tag_attr);
|
|
return '<' . $html_tag . ($html_tag_attr ? ' ' . $html_tag_attr : '') . '>';
|
|
} return ''; # always return something
|
|
}
|
|
|
|
sub OpenHtmlEnvironment { # close the previous $html_tag and open a new one
|
|
my ($html_tag, $depth, $html_tag_attr, $tag_regex) = @_;
|
|
my ($html, $found, @stack) = ('', 0); # always return something
|
|
while (@HtmlStack and $found < $depth) { # determine new stack
|
|
my $tag = pop(@HtmlStack);
|
|
$found++ if ($tag_regex ? $tag =~ $tag_regex : $tag eq $html_tag);
|
|
unshift(@stack, $tag);
|
|
}
|
|
unshift(@stack, pop(@HtmlStack)) if @HtmlStack and $found < $depth; # nested sublist coming up, keep list item
|
|
@HtmlStack = @stack unless $found; # if starting a new list
|
|
$html .= CloseHtmlEnvironments(); # close remaining elements (or all elements if a new list)
|
|
@HtmlStack = @stack if $found; # if not starting a new list
|
|
$depth = $IndentLimit if $depth > $IndentLimit; # requested depth 0 makes no sense
|
|
$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.
|
|
if $html_tag_attr and $html_tag_attr !~ m/^\s*[[:alpha:]]@@+\s*=\s*('|").+\1/;
|
|
splice(@HtmlAttrStack, 0, @HtmlAttrStack - @HtmlStack); # truncate to size of @HtmlStack
|
|
foreach ($found .. $depth - 1) {
|
|
unshift(@HtmlStack, $html_tag);
|
|
unshift(@HtmlAttrStack, $html_tag_attr);
|
|
$html .= $html_tag_attr ? "<$html_tag $html_tag_attr>" : "<$html_tag>";
|
|
}
|
|
return $html;
|
|
}
|
|
|
|
sub CloseHtmlEnvironments { # close all -- remember to use AddHtmlEnvironment('p') if required!
|
|
return CloseHtmlEnvironmentUntil() if pos($_) == length($_); # close all HTML environments if we're are at the end of this page
|
|
my $html = '';
|
|
while (@HtmlStack) {
|
|
defined $HtmlEnvironmentContainers{$HtmlStack[0]} and # avoid closing block level elements
|
|
($HtmlEnvironmentContainers{$HtmlStack[0]} ? $HtmlAttrStack[0] =~
|
|
m/$HtmlEnvironmentContainers{$HtmlStack[0]}/ : 1) and return $html;
|
|
shift(@HtmlAttrStack);
|
|
$html .= '</' . shift(@HtmlStack) . '>';
|
|
}
|
|
return $html;
|
|
}
|
|
|
|
sub CloseHtmlEnvironment { # close environments up to and including $html_tag
|
|
my $html = (@_ and InElement(@_)) ? CloseHtmlEnvironmentUntil(@_) : undef;
|
|
if (@HtmlStack and (not(@_) or defined $html)) {
|
|
shift(@HtmlAttrStack);
|
|
$html .= '</' . shift(@HtmlStack) . '>';
|
|
}
|
|
return $html || ''; # avoid returning undefined
|
|
}
|
|
|
|
sub CloseHtmlEnvironmentUntil { # close environments up to but not including $html_tag
|
|
my ($html_tag, $html_tag_attr) = @_;
|
|
my $html = '';
|
|
while (@HtmlStack && (pos($_) == length($_) || # while there is an HTML tag-stack and we are at the end of this page or...
|
|
!($html_tag ? $HtmlStack[0] eq $html_tag && # the top tag is not the desired tag and...
|
|
($html_tag_attr ? $HtmlAttrStack[0] =~ # its attributes do not match,
|
|
m/$html_tag_attr/ : 1) : ''))) { # then...
|
|
shift(@HtmlAttrStack); # shift off the top tag and
|
|
$html .= '</' . shift(@HtmlStack) . '>'; # append it to our HTML string.
|
|
}
|
|
return $html;
|
|
}
|
|
|
|
sub SmileyReplace {
|
|
foreach my $regexp (keys %Smilies) {
|
|
if (m/\G($regexp)/cg) {
|
|
return $q->img({-src=>$Smilies{$regexp}, -alt=>UnquoteHtml($1), -class=>'smiley'});
|
|
}
|
|
}
|
|
}
|
|
|
|
sub RunMyRules {
|
|
my ($locallinks, $withanchors) = @_;
|
|
foreach my $sub (@MyRules) {
|
|
my $result = $sub->($locallinks, $withanchors);
|
|
SetParam('msg', $@) if $@;
|
|
return $result if defined($result);
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub RunMyMacros {
|
|
$_ = shift;
|
|
foreach my $macro (@MyMacros) { $macro->() };
|
|
return $_;
|
|
}
|
|
|
|
sub PrintWikiToHTML {
|
|
my ($markup, $is_saving_cache, $revision, $is_locked) = @_;
|
|
my ($blocks, $flags);
|
|
$FootnoteNumber = 0;
|
|
$markup =~ s/$FS//g if $markup; # Remove separators (paranoia)
|
|
$markup = QuoteHtml($markup);
|
|
($blocks, $flags) = ApplyRules($markup, 1, $is_saving_cache, $revision, 'p');
|
|
if ($is_saving_cache and not $revision and $Page{revision} # don't save revision 0 pages
|
|
and $Page{blocks} ne $blocks and $Page{flags} ne $flags) {
|
|
$Page{blocks} = $blocks;
|
|
$Page{flags} = $flags;
|
|
if ($is_locked or RequestLockDir('main')) { # not fatal!
|
|
SavePage();
|
|
ReleaseLock() unless $is_locked;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub DoClearCache {
|
|
return unless UserIsAdminOrError();
|
|
RequestLockOrError();
|
|
print GetHeader('', T('Clear Cache')), $q->start_div({-class=>'content clear'}),
|
|
$q->p(T('Main lock obtained.')), '<p>';
|
|
foreach my $id (AllPagesList()) {
|
|
OpenPage($id);
|
|
delete @Page{qw(blocks flags languages)};
|
|
$Page{languages} = GetLanguages($Page{blocks}) unless TextIsFile($Page{blocks});
|
|
SavePage();
|
|
print $q->br(), GetPageLink($id);
|
|
}
|
|
print '</p>', $q->p(T('Main lock released.')), $q->end_div();
|
|
utime time, time, $IndexFile; # touch index file
|
|
ReleaseLock();
|
|
PrintFooter();
|
|
}
|
|
|
|
sub QuoteHtml {
|
|
my $html = shift;
|
|
$html =~ s/&/&/g;
|
|
$html =~ s/</</g;
|
|
$html =~ s/>/>/g;
|
|
$html =~ s/[\x00-\x08\x0b\x0c\x0e-\x1f]/ /g; # legal xml: #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
|
|
return $html;
|
|
}
|
|
|
|
sub UnquoteHtml {
|
|
my $html = shift;
|
|
$html =~ s/</</g;
|
|
$html =~ s/>/>/g;
|
|
$html =~ s/&/&/g;
|
|
$html =~ s/%26/&/g;
|
|
return $html;
|
|
}
|
|
|
|
sub UrlEncode {
|
|
my $str = shift;
|
|
return '' unless $str;
|
|
my @letters = split(//, encode_utf8($str));
|
|
my %safe = map {$_ => 1} ('a' .. 'z', 'A' .. 'Z', '0' .. '9', '-', '_', '.', '!', '~', '*', "'", '(', ')', '#');
|
|
foreach my $letter (@letters) {
|
|
$letter = sprintf("%%%02x", ord($letter)) unless $safe{$letter};
|
|
}
|
|
return join('', @letters);
|
|
}
|
|
|
|
sub UrlDecode {
|
|
my $str = shift;
|
|
return decode_utf8($str) if $str =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/eig;
|
|
return $str;
|
|
}
|
|
|
|
sub QuoteRegexp {
|
|
my $re = shift;
|
|
$re =~ s/([\\\[\]\$()^.])/\\$1/g;
|
|
return $re;
|
|
}
|
|
|
|
sub GetRaw {
|
|
my $uri = shift;
|
|
return unless eval { require LWP::UserAgent; };
|
|
my $ua = LWP::UserAgent->new;
|
|
my $response = $ua->get($uri);
|
|
return $response->decoded_content if $response->is_success;
|
|
}
|
|
|
|
sub DoJournal {
|
|
print GetHeader(undef, T('Journal'));
|
|
print $q->start_div({-class=>'content journal'});
|
|
PrintJournal(map { GetParam($_, ''); } qw(num num regexp mode offset search variation));
|
|
print $q->end_div();
|
|
PrintFooter();
|
|
}
|
|
|
|
sub JournalSort { $b cmp $a }
|
|
|
|
sub PrintJournal {
|
|
return if $CollectingJournal; # avoid infinite loops
|
|
local $CollectingJournal = 1;
|
|
my ($num, $numMore, $regexp, $mode, $offset, $search, $variation) = @_;
|
|
$variation ||= 'journal';
|
|
$regexp ||= '^\d\d\d\d-\d\d-\d\d';
|
|
$num ||= 10;
|
|
$numMore = $num unless $numMore ne '';
|
|
$offset ||= 0;
|
|
# FIXME: Should pass filtered list of pages to SearchTitleAndBody to save time?
|
|
my @pages = sort JournalSort (grep(/$regexp/, $search ? SearchTitleAndBody($search) : AllPagesList()));
|
|
@pages = reverse @pages if $mode eq 'reverse' or $mode eq 'future';
|
|
$b = $Today // CalcDay($Now);
|
|
if ($mode eq 'future' || $mode eq 'past') {
|
|
my $compare = $mode eq 'future' ? -1 : 1;
|
|
for (my $i = 0; $i < @pages; $i++) {
|
|
$a = $pages[$i];
|
|
if (JournalSort() == $compare) {
|
|
@pages = @pages[$i .. $#pages];
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
return unless $pages[$offset];
|
|
print $q->start_div({-class=>'journal h-feed'});
|
|
my $next = $offset + PrintAllPages(1, 1, $num, $variation, @pages[$offset .. $#pages]);
|
|
print $q->end_div();
|
|
$regexp = UrlEncode($regexp);
|
|
$search = UrlEncode($search);
|
|
if ($pages[$next] and $numMore != 0) {
|
|
print $q->p({-class=>'more'}, ScriptLink("action=more;num=$numMore;regexp=$regexp;search=$search;mode=$mode;offset=$next;variation=$variation", T('More...'), 'more'));
|
|
}
|
|
}
|
|
|
|
sub PrintAllPages {
|
|
my ($links, $comments, $num, $variation, @pages) = @_;
|
|
my $lang = GetParam('lang', 0);
|
|
my ($i, $n) = 0;
|
|
for my $id (@pages) {
|
|
last if $n >= $JournalLimit and not UserIsAdmin() or $num and $n >= $num;
|
|
$i++; # pages looked at
|
|
local ($OpenPageName, %Page); # this is local!
|
|
OpenPage($id);
|
|
my @languages = split(/,/, $Page{languages});
|
|
next if $lang and @languages and not grep(/$lang/, @languages);
|
|
next if PageMarkedForDeletion();
|
|
next if substr($Page{text}, 0, 10) eq '#REDIRECT ';
|
|
print $q->start_div({-class=>'page h-entry'}),
|
|
$q->h1({-class => 'entry-title'},
|
|
$links ? GetPageLink($id) : $q->a({-name=>$id}, UrlEncode(FreeToNormal($id))));
|
|
if ($variation ne 'titles') {
|
|
my $lang = (split /,/, $Page{languages})[0] || $CurrentLanguage;
|
|
print $q->start_div({-class=>'entry-content', -lang=>$lang});
|
|
PrintPageHtml();
|
|
print $q->end_div();
|
|
PrintPageCommentsLink($id, $comments);
|
|
}
|
|
print $q->end_div();
|
|
$n++; # pages actually printed
|
|
}
|
|
return $i;
|
|
}
|
|
|
|
sub PrintPageCommentsLink {
|
|
my ($id, $comments) = @_;
|
|
if ($comments and $CommentsPattern and $id !~ /$CommentsPattern/) {
|
|
print $q->p({-class=>'comment'},
|
|
GetPageLink($CommentsPrefix . $id, T('Comments on this page')));
|
|
}
|
|
}
|
|
|
|
sub RSS {
|
|
return if $CollectingJournal; # avoid infinite loops when using full=1
|
|
local $CollectingJournal = 1;
|
|
my $maxitems = shift;
|
|
my @uris = @_;
|
|
my %lines;
|
|
if (not eval { require XML::RSS; }) {
|
|
my $err = $@;
|
|
return $q->div({-class=>'rss'}, $q->p({-class=>'error'}, $q->strong(T('XML::RSS is not available on this system.')), $err));
|
|
}
|
|
# All strings that are concatenated with strings returned by the RSS
|
|
# feed must be decoded. Without this decoding, 'diff' and 'history'
|
|
# translations will be double encoded when printing the result.
|
|
my $tDiff = T('diff');
|
|
my $tHistory = T('history');
|
|
my $wikins = 'http://purl.org/rss/1.0/modules/wiki/';
|
|
my $rdfns = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#';
|
|
@uris = map { my $x = $_; $x =~ s/^"?(.*?)"?$/$1/; $x; } @uris; # strip quotes of uris
|
|
my ($str, %data) = GetRss(@uris);
|
|
foreach my $uri (keys %data) {
|
|
my $data = $data{$uri};
|
|
if (not $data) {
|
|
$str .= $q->p({-class=>'error'}, $q->strong(Ts('%s returned no data, or LWP::UserAgent is not available.',
|
|
$q->a({-href=>$uri}, $uri))));
|
|
} else {
|
|
my $rss = new XML::RSS;
|
|
eval { local $SIG{__DIE__}; $rss->parse($data); };
|
|
if ($@) {
|
|
$str .= $q->p({-class=>'error'}, $q->strong(Ts('RSS parsing failed for %s', $q->a({-href=>$uri}, $uri)) . ': ' . $@));
|
|
} else {
|
|
my $interwiki;
|
|
if (@uris > 1) {
|
|
RssInterwikiTranslateInit(); # not needed anywhere else thus init only now and not in ReInit
|
|
$interwiki = $rss->{channel}->{$wikins}->{interwiki};
|
|
$interwiki =~ s/^\s+//; # when RDF is used, sometimes whitespace remains,
|
|
$interwiki =~ s/\s+$//; # which breaks the test for an existing $interwiki below
|
|
$interwiki ||= $rss->{channel}->{$rdfns}->{value};
|
|
$interwiki = $RssInterwikiTranslate{$interwiki} if $RssInterwikiTranslate{$interwiki};
|
|
$interwiki ||= $RssInterwikiTranslate{$uri};
|
|
}
|
|
my $num = 999;
|
|
$str .= $q->p({-class=>'error'}, $q->strong(Ts('No items found in %s.', $q->a({-href=>$uri}, $uri))))
|
|
unless @{$rss->{items}};
|
|
foreach my $i (@{$rss->{items}}) {
|
|
my $line;
|
|
my $date = $i->{dc}->{date};
|
|
if (not $date and $i->{pubDate}) {
|
|
$date = $i->{pubDate};
|
|
my %mon = (Jan=>1, Feb=>2, Mar=>3, Apr=>4, May=>5, Jun=>6,
|
|
Jul=>7, Aug=>8, Sep=>9, Oct=>10, Nov=>11, Dec=>12);
|
|
$date =~ s/^(?:[A-Z][a-z][a-z], )?(\d\d?) ([A-Z][a-z][a-z]) (\d\d(?:\d\d)?)/ # pubDate uses RFC 822
|
|
sprintf('%04d-%02d-%02d', ($3 < 100 ? 1900 + $3 : $3), $mon{$2}, $1)/e;
|
|
}
|
|
$date ||= sprintf("%03d", $num--); # for RSS 0.91 feeds without date, descending
|
|
my $title = $i->{title};
|
|
my $description = $i->{description};
|
|
if (not $title and $description) { # title may be missing in RSS 2.00
|
|
$title = $description;
|
|
$description = '';
|
|
}
|
|
$title = $i->{link} if not $title and $i->{link}; # if description and title are missing
|
|
$line .= ' (' . $q->a({-href=>$i->{$wikins}->{diff}}, $tDiff) . ')' if $i->{$wikins}->{diff};
|
|
$line .= ' (' . $q->a({-href=>$i->{$wikins}->{history}}, $tHistory) . ')' if $i->{$wikins}->{history};
|
|
if ($title) {
|
|
if ($i->{link}) {
|
|
$line .= ' ' . $q->a({-href=>$i->{link}, -title=>$date},
|
|
($interwiki ? $interwiki . ':' : '') . $title);
|
|
} else {
|
|
$line .= ' ' . $title;
|
|
}
|
|
}
|
|
my $contributor = $i->{dc}->{contributor};
|
|
$contributor ||= $i->{$wikins}->{username};
|
|
$contributor =~ s/^\s+//;
|
|
$contributor =~ s/\s+$//;
|
|
$contributor ||= $i->{$rdfns}->{value};
|
|
$line .= $q->span({-class=>'contributor'}, $q->span(T(' . . . .') . ' ') . $contributor) if $contributor;
|
|
if ($description) {
|
|
if ($description =~ /</) {
|
|
$line .= $q->div({-class=>'description'}, $description);
|
|
} else {
|
|
$line .= $q->span({class=>'dash'}, ' – ') . $q->strong({-class=>'description'}, $description);
|
|
}
|
|
}
|
|
$date .= ' ' while ($lines{$date}); # make sure this is unique
|
|
$lines{$date} = $line;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
my @lines = sort { $b cmp $a } keys %lines;
|
|
@lines = @lines[0 .. $maxitems-1] if $maxitems and $#lines > $maxitems;
|
|
my $date = '';
|
|
foreach my $key (@lines) {
|
|
my $line = $lines{$key};
|
|
if ($key =~ /(\d\d\d\d(?:-\d?\d)?(?:-\d?\d)?)(?:[T ](\d?\d:\d\d))?/) {
|
|
my ($day, $time) = ($1, $2);
|
|
if ($day ne $date) {
|
|
$str .= '</ul>' if $date; # close ul except for the first time where no open ul exists
|
|
$date = $day;
|
|
$str .= $q->p($q->strong($day)) . '<ul>';
|
|
}
|
|
$line = $q->span({-class=>'time'}, $time . ' UTC ') . $line if $time;
|
|
} elsif (not $date) {
|
|
$str .= '<ul>'; # if the feed doesn't have any dates we need to start the list anyhow
|
|
$date = $Now; # to ensure the list starts only once
|
|
}
|
|
$str .= $q->li($line);
|
|
}
|
|
$str .= '</ul>' if $date;
|
|
return $q->div({-class=>'rss'}, $str);
|
|
}
|
|
|
|
sub GetRss {
|
|
my %todo = map {$_, GetRssFile($_)} @_;
|
|
my %data = ();
|
|
my $str = '';
|
|
if (GetParam('cache', $UseCache) > 0) {
|
|
foreach my $uri (keys %todo) { # read cached rss files if possible
|
|
if ($Now - Modified($todo{$uri}) < $RssCacheHours * 3600) {
|
|
$data{$uri} = ReadFile($todo{$uri});
|
|
delete($todo{$uri}); # no need to fetch them below
|
|
}
|
|
}
|
|
}
|
|
my @need_cache = keys %todo;
|
|
if (keys %todo > 1) { # try parallel access if available
|
|
eval { # see code example in LWP::Parallel, not LWP::Parallel::UserAgent (no callbacks here)
|
|
require LWP::Parallel::UserAgent;
|
|
my $pua = LWP::Parallel::UserAgent->new();
|
|
foreach my $uri (keys %todo) {
|
|
if (my $res = $pua->register(HTTP::Request->new('GET', $uri))) {
|
|
$str .= $res->error_as_HTML;
|
|
}
|
|
}
|
|
%todo = (); # because the uris in the response may have changed due to redirects
|
|
my $entries = $pua->wait();
|
|
foreach (keys %$entries) {
|
|
my $uri = $entries->{$_}->request->uri;
|
|
$data{$uri} = $entries->{$_}->response->decoded_content;
|
|
}
|
|
}
|
|
}
|
|
foreach my $uri (keys %todo) { # default operation: synchronous fetching
|
|
$data{$uri} = GetRaw($uri);
|
|
}
|
|
if (GetParam('cache', $UseCache) > 0) {
|
|
CreateDir($RssDir);
|
|
foreach my $uri (@need_cache) {
|
|
my $data = $data{$uri};
|
|
# possibly a Latin-1 file without encoding attribute will cause a problem?
|
|
$data =~ s/encoding="[^"]*"/encoding="UTF-8"/; # content was converted
|
|
WriteStringToFile(GetRssFile($uri), $data) if $data;
|
|
}
|
|
}
|
|
return $str, %data;
|
|
}
|
|
|
|
sub GetRssFile {
|
|
return $RssDir . '/' . UrlEncode(shift);
|
|
}
|
|
|
|
sub RssInterwikiTranslateInit {
|
|
return unless $RssInterwikiTranslate;
|
|
%RssInterwikiTranslate = ();
|
|
foreach (split(/\n/, GetPageContent($RssInterwikiTranslate))) {
|
|
if (/^ ([^ ]+)[ \t]+([^ ]+)$/) {
|
|
$RssInterwikiTranslate{$1} = $2;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub GetInterSiteUrl {
|
|
my ($site, $page, $quote) = @_;
|
|
return unless $page;
|
|
$page = join('/', map { UrlEncode($_) } split(/\//, $page)) if $quote; # Foo:bar+baz is not quoted, [[Foo:bar baz]] is.
|
|
my $url = $InterSite{$site} or return;
|
|
$url =~ s/\%s/$page/g or $url .= $page;
|
|
return $url;
|
|
}
|
|
|
|
sub BracketLink { # brackets can be removed via CSS
|
|
return $q->span($q->span({class=>'bracket'}, '[') . (shift) . $q->span({class=>'bracket'}, ']'));
|
|
}
|
|
|
|
sub GetInterLink {
|
|
my ($id, $text, $bracket, $quote) = @_;
|
|
my ($site, $page) = split(/:/, $id, 2);
|
|
$page =~ s/&/&/g; # Unquote common URL HTML
|
|
my $url = GetInterSiteUrl($site, $page, $quote);
|
|
my $class = 'inter ' . $site;
|
|
return "[$id $text]" if $text and $bracket and not $url;
|
|
return "[$id]" if $bracket and not $url;
|
|
return $id if not $url;
|
|
if ($bracket and not $text) {
|
|
$text = BracketLink(++$FootnoteNumber);
|
|
$class .= ' number';
|
|
} elsif (not $text) {
|
|
$text = $q->span({-class=>'site'}, $site)
|
|
. $q->span({-class=>'separator'}, ':')
|
|
. $q->span({-class=>'interpage'}, $page);
|
|
} elsif ($bracket) { # and $text is set
|
|
$class .= ' outside';
|
|
}
|
|
return $q->a({-href=>$url, -class=>$class}, $text);
|
|
}
|
|
|
|
sub InterInit {
|
|
%InterSite = ();
|
|
foreach (split(/\n/, GetPageContent($InterMap))) {
|
|
if (/^ ($InterSitePattern)[ \t]+([^ ]+)$/) {
|
|
$InterSite{$1} = $2;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub GetUrl {
|
|
my ($url, $text, $bracket, $images) = @_;
|
|
$url =~ /^($UrlProtocols)/;
|
|
my $class = "url $1";
|
|
if ($NetworkFile && $url =~ m|^file:///| && !$AllNetworkFiles
|
|
or !$NetworkFile && $url =~ m|^file:|) {
|
|
# Only do remote file:// links. No file:///c|/windows.
|
|
return $url;
|
|
} elsif ($bracket and not defined $text) {
|
|
$text = BracketLink(++$FootnoteNumber);
|
|
$class .= ' number';
|
|
} elsif (not defined $text) {
|
|
$text = $url;
|
|
} elsif ($bracket) { # and $text is set
|
|
$class .= ' outside';
|
|
}
|
|
$url = UnquoteHtml($url); # links should be unquoted again
|
|
if ($images and $url =~ /^(http:|https:|ftp:).+\.$ImageExtensions$/i) {
|
|
return $q->img({-src=>$url, -alt=>$url, -class=>$class});
|
|
} else {
|
|
return $q->a({-href=>$url, -class=>$class}, $text);
|
|
}
|
|
}
|
|
|
|
sub GetPageOrEditLink { # use GetPageLink and GetEditLink if you know the result!
|
|
my ($id, $text, $bracket, $free) = @_;
|
|
$id = FreeToNormal($id);
|
|
my ($class, $resolved, $title, $exists) = ResolveId($id);
|
|
if (not $text and $resolved and $bracket) {
|
|
$text = BracketLink(++$FootnoteNumber);
|
|
$class .= ' number';
|
|
$title = NormalToFree($id);
|
|
}
|
|
my $link = $text || NormalToFree($id);
|
|
if ($resolved) { # anchors don't exist as pages, therefore do not use $exists
|
|
return ScriptLink(UrlEncode($resolved), $link, $class, undef, $title);
|
|
} else { # reproduce markup if $UseQuestionmark
|
|
return GetEditLink($id, UnquoteHtml($bracket ? "[$link]" : $link)) unless $UseQuestionmark;
|
|
$link = QuoteHtml($id) . GetEditLink($id, '?');
|
|
$link .= ($free ? '|' : ' ') . $text if $text and FreeToNormal($text) ne $id;
|
|
$link = "[[$link]]" if $free;
|
|
$link = "[$link]" if $bracket or not $free and $text;
|
|
return $link;
|
|
}
|
|
}
|
|
|
|
sub GetPageLink { # use if you want to force a link to local pages, whether it exists or not
|
|
my ($id, $name, $class, $accesskey) = @_;
|
|
$id = FreeToNormal($id);
|
|
$name ||= $id;
|
|
$class .= ' ' if $class;
|
|
return ScriptLink(UrlEncode($id), NormalToFree($name), $class . 'local',
|
|
undef, undef, $accesskey);
|
|
}
|
|
|
|
sub GetEditLink { # shortcut
|
|
my ($id, $name, $upload, $accesskey) = @_;
|
|
$id = FreeToNormal($id);
|
|
my $action = 'action=edit;id=' . UrlEncode($id);
|
|
$action .= ';upload=1' if $upload;
|
|
return ScriptLink($action, NormalToFree($name), 'edit', undef, T('Click to edit this page'), $accesskey);
|
|
}
|
|
|
|
sub ScriptUrl {
|
|
my $action = shift;
|
|
if ($action =~ /^($UrlProtocols)\%3a/ or $action =~ /^\%2f/) { # nearlinks and other URLs
|
|
$action =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/eg; # undo urlencode
|
|
# do nothing
|
|
} else {
|
|
$action = $ScriptName . (($UsePathInfo and index($action, '=') == -1) ? '/' : '?') . $action;
|
|
}
|
|
return $action unless wantarray;
|
|
return ($action, index($action, '=') != -1);
|
|
}
|
|
|
|
sub ScriptLink {
|
|
my ($action, $text, $class, $name, $title, $accesskey) = @_;
|
|
my ($url, $nofollow) = ScriptUrl($action);
|
|
my %params;
|
|
$params{-href} = $url;
|
|
$params{'-rel'} = 'nofollow' if $nofollow;
|
|
$params{'-class'} = $class if $class;
|
|
$params{'-name'} = $name if $name;
|
|
$params{'-title'} = $title if $title;
|
|
$params{'-accesskey'} = $accesskey if $accesskey;
|
|
return $q->a(\%params, $text);
|
|
}
|
|
|
|
sub GetDownloadLink {
|
|
my ($id, $image, $revision, $alt) = @_;
|
|
$alt ||= NormalToFree($id);
|
|
# if the page does not exist
|
|
return '[[' . ($image ? 'image' : 'download') . ':'
|
|
. ($UseQuestionmark ? QuoteHtml($id) . GetEditLink($id, '?', 1)
|
|
: GetEditLink($id, $id, 1)) . ']]'
|
|
unless $IndexHash{$id};
|
|
my $action;
|
|
if ($revision) {
|
|
$action = "action=download;id=" . UrlEncode($id) . ";revision=$revision";
|
|
} elsif ($UsePathInfo) {
|
|
$action = "download/" . UrlEncode($id);
|
|
} else {
|
|
$action = "action=download;id=" . UrlEncode($id);
|
|
}
|
|
if ($image) {
|
|
$action = $ScriptName . (($UsePathInfo and not $revision) ? '/' : '?') . $action;
|
|
return $action if $image == 2;
|
|
my $result = $q->img({-src=>$action, -alt=>UnquoteHtml($alt), -title=>UnquoteHtml($alt), -class=>'upload'});
|
|
$result = ScriptLink(UrlEncode($id), $result, 'image') unless $id eq $OpenPageName;
|
|
return $result;
|
|
} else {
|
|
return ScriptLink($action, $alt, 'upload');
|
|
}
|
|
}
|
|
|
|
sub PrintCache { # Use after OpenPage!
|
|
my @blocks = split($FS, $Page{blocks});
|
|
my @flags = split($FS, $Page{flags});
|
|
$FootnoteNumber = 0;
|
|
foreach my $block (@blocks) {
|
|
if (shift(@flags)) {
|
|
ApplyRules($block, 1, 1); # local links, anchors, current revision, no start tag
|
|
} else {
|
|
print $block;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub PrintPageHtml { # print an open page
|
|
return unless GetParam('page', 1);
|
|
if ($Page{blocks} and defined $Page{flags} and GetParam('cache', $UseCache) > 0) {
|
|
PrintCache();
|
|
} else {
|
|
PrintWikiToHTML($Page{text}, 1); # save cache, current revision, no main lock
|
|
}
|
|
}
|
|
|
|
sub PrintPageDiff { # print diff for open page
|
|
my $diff = GetParam('diff', 0);
|
|
if ($UseDiff and $diff) {
|
|
PrintHtmlDiff($diff);
|
|
print $q->hr() if GetParam('page', 1);
|
|
}
|
|
}
|
|
|
|
sub ToString {
|
|
my $sub_ref = shift;
|
|
my $output;
|
|
open(my $outputFH, '>:encoding(UTF-8)', \$output) or die "Can't open memory file: $!";
|
|
my $oldFH = select $outputFH;
|
|
$sub_ref->(@_);
|
|
select $oldFH;
|
|
close $outputFH;
|
|
return decode_utf8($output);
|
|
}
|
|
|
|
sub PageHtml {
|
|
my ($id, $limit, $error) = @_;
|
|
OpenPage($id);
|
|
my $diff = ToString \&PrintPageDiff;
|
|
return $error if $limit and length($diff) > $limit;
|
|
my $lang = (split /,/, $Page{languages})[0] // $CurrentLanguage;
|
|
my $page .= ToString \&PrintPageHtml;
|
|
$page = qq{<div class="page" lang="$lang">$page</div>} if $page;
|
|
return $diff . $q->p($error) if $limit and length($diff . $page) > $limit;
|
|
return $diff . $page;
|
|
}
|
|
|
|
sub T {
|
|
my $text = shift;
|
|
return $Translate{$text} || $text;
|
|
}
|
|
|
|
sub Ts {
|
|
my ($text, $string) = @_;
|
|
$text = T($text);
|
|
$text =~ s/\%s/$string/ if defined($string);
|
|
return $text;
|
|
}
|
|
|
|
sub Tss {
|
|
my $text = $_[0];
|
|
$text = T($text);
|
|
$text =~ s/\%([1-9])/$_[$1]/eg;
|
|
return $text;
|
|
}
|
|
|
|
sub GetId {
|
|
my $id = UnquoteHtml(GetParam('id', GetParam('title', ''))); # id=x or title=x -> x
|
|
if (not $id and $q->keywords) {
|
|
$id = decode_utf8(join('_', $q->keywords)); # script?p+q -> p_q
|
|
}
|
|
if ($UsePathInfo and $q->path_info) {
|
|
my @path = map { decode_utf8($_) } split(/\//, $q->path_info);
|
|
$id ||= pop(@path); # script/p/q -> q
|
|
foreach my $p (@path) {
|
|
SetParam($p, 1); # script/p/q -> p=1
|
|
}
|
|
}
|
|
return $id;
|
|
}
|
|
|
|
sub DoBrowseRequest {
|
|
# We can use the error message as the HTTP error code
|
|
ReportError(Ts('CGI Internal error: %s', $q->cgi_error), $q->cgi_error) if $q->cgi_error;
|
|
print $q->header(-status=>'304 NOT MODIFIED') and return if PageFresh(); # return value is ignored
|
|
my $id = GetId();
|
|
my $action = lc(GetParam('action', '')); # script?action=foo;id=bar
|
|
$action = 'download' if GetParam('download', '') and not $action; # script/download/id
|
|
if ($Action{$action}) {
|
|
&{$Action{$action}}($id);
|
|
} elsif ($action and defined &MyActions) {
|
|
eval { local $SIG{__DIE__}; MyActions(); };
|
|
} elsif ($action) {
|
|
ReportError(Ts('Invalid action parameter %s', $action), '501 NOT IMPLEMENTED');
|
|
} elsif (GetParam('search', '') ne '') { # allow search for "0"
|
|
SetParam('action', 'search'); # make sure this gets a NOINDEX
|
|
DoSearch();
|
|
} elsif (GetParam('match', '') ne '') {
|
|
SetParam('action', 'index'); # make sure this gets a NOINDEX
|
|
DoIndex();
|
|
} elsif (GetParam('title', '') and not GetParam('Cancel', '')) {
|
|
DoPost(GetParam('title', ''));
|
|
} else {
|
|
BrowseResolvedPage($id || $HomePage); # default action!
|
|
}
|
|
}
|
|
|
|
sub ValidId { # hack alert: returns error message if invalid, and unfortunately the empty string if valid!
|
|
my $id = FreeToNormal(shift);
|
|
return T('Page name is missing') unless $id;
|
|
require bytes;
|
|
return Ts('Page name is too long: %s', $id) if bytes::length($id) > $PageNameLimit;
|
|
return Ts('Invalid Page %s (must not end with .db)', $id) if $id =~ m|\.db$|;
|
|
return Ts('Invalid Page %s (must not end with .lck)', $id) if $id =~ m|\.lck$|;
|
|
return Ts('Invalid Page %s', $id) if $FreeLinks ? $id !~ m|^$FreeLinkPattern$| : $id !~ m|^$LinkPattern$|;
|
|
}
|
|
|
|
sub ValidIdOrDie {
|
|
my $id = shift;
|
|
my $error = ValidId($id);
|
|
ReportError($error, '400 BAD REQUEST') if $error;
|
|
return 1;
|
|
}
|
|
|
|
sub ResolveId { # return css class, resolved id, title (eg. for popups), exist-or-not
|
|
my $id = shift;
|
|
return ('local', $id, '', 1) if $IndexHash{$id};
|
|
return ('', '', '', '');
|
|
}
|
|
|
|
sub BrowseResolvedPage {
|
|
my $id = FreeToNormal(shift);
|
|
my ($class, $resolved, $title, $exists) = ResolveId($id);
|
|
if ($class and $class eq 'near' and not GetParam('rcclusteronly', 0)) { # nearlink (is url)
|
|
print $q->redirect({-uri=>$resolved});
|
|
} elsif ($class and $class eq 'alias') { # an anchor was found instead of a page
|
|
ReBrowsePage($resolved);
|
|
} elsif (not $resolved and $NotFoundPg and $id !~ /$CommentsPattern/) { # custom page-not-found message
|
|
BrowsePage($NotFoundPg);
|
|
} elsif ($resolved or $id =~ /$CommentsPattern/ and $1 and $IndexHash{$1}) { # an existing page
|
|
BrowsePage(($resolved or $id), GetParam('raw', 0));
|
|
} else { # new page!
|
|
BrowsePage($id, GetParam('raw', 0), undef, '404 NOT FOUND') if ValidIdOrDie($id);
|
|
}
|
|
}
|
|
|
|
sub NewText { # only if no revision is available
|
|
my $id = shift;
|
|
if ($CommentsPrefix and $id =~ /^($CommentsPrefix)/) {
|
|
return T('There are no comments, yet. Be the first to leave a comment!');
|
|
} elsif ($id eq $HomePage) {
|
|
return T('Welcome!');
|
|
} else {
|
|
return Ts('This page does not exist, but you can %s.',
|
|
'[' . ScriptUrl('action=edit;id=' . UrlEncode($id)) . ' '
|
|
. T('create it now') . ']');
|
|
}
|
|
}
|
|
|
|
sub BrowsePage {
|
|
my ($id, $raw, $comment, $status) = @_;
|
|
OpenPage($id);
|
|
my ($revisionPage, $revision) = GetTextRevision(GetParam('revision', ''));
|
|
my $text = $revisionPage->{text};
|
|
$text = NewText($id) unless $revision or $Page{revision} or $comment; # new text for new pages
|
|
# handle a single-level redirect
|
|
my $oldId = GetParam('oldid', '');
|
|
if ((substr($text, 0, 10) eq '#REDIRECT ')) {
|
|
if ($oldId) {
|
|
$Message .= $q->p(T('Too many redirections'));
|
|
} elsif ($revision) {
|
|
$Message .= $q->p(T('No redirection for old revisions'));
|
|
} elsif (($FreeLinks and $text =~ /^\#REDIRECT\s+\[\[$FreeLinkPattern\]\]/)
|
|
or ($WikiLinks and $text =~ /^\#REDIRECT\s+$LinkPattern/)) {
|
|
return ReBrowsePage(FreeToNormal($1), $id);
|
|
} else {
|
|
$Message .= $q->p(T('Invalid link pattern for #REDIRECT'));
|
|
}
|
|
}
|
|
# shortcut if we only need the raw text: no caching, no diffs, no html.
|
|
if ($raw) {
|
|
print GetHttpHeader('text/plain', $Page{ts}, $IndexHash{$id} ? undef : '404 NOT FOUND');
|
|
print $Page{ts} . " # Do not delete this line when editing!\n" if $raw == 2;
|
|
print $text;
|
|
return;
|
|
}
|
|
# normal page view
|
|
my $msg = GetParam('msg', '');
|
|
$Message .= $q->p($msg) if $msg; # show message if the page is shown
|
|
SetParam('msg', '');
|
|
print GetHeader($id, NormalToFree($id), $oldId, undef, $status);
|
|
my $showDiff = GetParam('diff', 0);
|
|
if ($UseDiff and $showDiff) {
|
|
PrintHtmlDiff($showDiff, GetParam('diffrevision'), $revisionPage, $Page{revision});
|
|
print $q->hr();
|
|
}
|
|
PrintPageContent($text, $revision, $comment);
|
|
SetParam('rcclusteronly', $id) if FreeToNormal(GetCluster($text)) eq $id; # automatically filter by cluster
|
|
PrintRcHtml($id);
|
|
PrintFooter($id, $revision, $comment, $revisionPage);
|
|
}
|
|
|
|
sub ReBrowsePage {
|
|
my ($id, $oldId) = map { UrlEncode($_); } @_; # encode before printing URL
|
|
if ($oldId) { # Target of #REDIRECT (loop breaking)
|
|
print GetRedirectPage("action=browse;oldid=$oldId;id=$id", $id);
|
|
} else {
|
|
print GetRedirectPage($id, $id);
|
|
}
|
|
}
|
|
|
|
sub GetRedirectPage {
|
|
my ($action, $name) = @_;
|
|
my ($url, $html);
|
|
if (GetParam('raw', 0)) {
|
|
$html = GetHttpHeader('text/plain');
|
|
$html .= Ts('Please go on to %s.', $action); # no redirect
|
|
return $html;
|
|
}
|
|
$url = $ScriptName . (($UsePathInfo and $action !~ /=/) ? '/' : '?') . $action;
|
|
my $nameLink = $q->a({-href=>$url}, $name);
|
|
my %headers = (-uri=>$url);
|
|
my $cookie = Cookie();
|
|
$headers{-cookie} = $cookie if $cookie;
|
|
return $q->redirect(%headers);
|
|
}
|
|
|
|
sub DoRandom {
|
|
my @pages = AllPagesList();
|
|
ReBrowsePage($pages[int(rand($#pages + 1))]);
|
|
}
|
|
|
|
sub PageFresh { # pages can depend on other pages (ie. last update), admin status, and css
|
|
return 1 if $q->http('HTTP_IF_NONE_MATCH') and GetParam('cache', $UseCache) >= 2
|
|
and $q->http('HTTP_IF_NONE_MATCH') eq PageEtag();
|
|
}
|
|
|
|
sub PageEtag {
|
|
my ($changed, %params) = CookieData();
|
|
return UrlEncode(join($FS, $LastUpdate||$Now, sort(values %params))); # no CTL in field values
|
|
}
|
|
|
|
sub FileFresh { # old files are never stale, current files are stale when the page was modified
|
|
return 1 if $q->http('HTTP_IF_NONE_MATCH') and GetParam('cache', $UseCache) >= 2
|
|
and (GetParam('revision', 0) or $q->http('HTTP_IF_NONE_MATCH') eq $Page{ts});
|
|
}
|
|
|
|
sub BrowseRc {
|
|
my $id = shift;
|
|
if (GetParam('raw', 0)) {
|
|
print GetHttpHeader('text/plain');
|
|
PrintRcText();
|
|
} else {
|
|
PrintRcHtml($id || $RCName, 1);
|
|
}
|
|
}
|
|
|
|
sub GetRcLines { # starttime, hash of seen pages to use as a second return value
|
|
my $starttime = shift || GetParam('from', 0) ||
|
|
$Now - GetParam('days', $RcDefault) * 86400; # 24*60*60
|
|
my $filterOnly = GetParam('rcfilteronly', '');
|
|
# these variables apply accross logfiles
|
|
my %match = $filterOnly ? map { $_ => 1 } SearchTitleAndBody($filterOnly) : ();
|
|
my %following = ();
|
|
my @result = ();
|
|
my $ts;
|
|
# check the first timestamp in the default file, maybe read old log file
|
|
if (open(my $F, '<:encoding(UTF-8)', encode_utf8($RcFile))) {
|
|
my $line = <$F>;
|
|
($ts) = split(/$FS/, $line); # the first timestamp in the regular rc file
|
|
}
|
|
if (not $ts or $ts > $starttime) { # we need to read the old rc file, too
|
|
push(@result, GetRcLinesFor($RcOldFile, $starttime, \%match, \%following));
|
|
}
|
|
push(@result, GetRcLinesFor($RcFile, $starttime, \%match, \%following));
|
|
# GetRcLinesFor is trying to save memory space, but some operations
|
|
# can only happen once we have all the data.
|
|
return LatestChanges(StripRollbacks(@result));
|
|
}
|
|
|
|
sub LatestChanges {
|
|
my $all = GetParam('all', $ShowAll);
|
|
my @result = @_;
|
|
my %seen = ();
|
|
for (my $i = $#result; $i >= 0; $i--) {
|
|
my $id = $result[$i][1];
|
|
if ($all) {
|
|
$result[$i][9] = 1 unless $seen{$id}; # mark latest edit
|
|
} else {
|
|
splice(@result, $i, 1) if $seen{$id}; # remove older edits
|
|
}
|
|
$seen{$id} = 1;
|
|
}
|
|
my $to = GetParam('upto', 0);
|
|
if ($to) {
|
|
for (my $i = 0; $i < $#result; $i++) {
|
|
if ($result[$i][0] > $to) {
|
|
splice(@result, $i);
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
return reverse @result;
|
|
}
|
|
|
|
sub StripRollbacks {
|
|
my @result = @_;
|
|
if (not (GetParam('all', $ShowAll) or GetParam('rollback', $ShowRollbacks))) { # strip rollbacks
|
|
my (%rollback);
|
|
for (my $i = $#result; $i >= 0; $i--) {
|
|
# some fields have a different meaning if looking at rollbacks
|
|
my ($ts, $id, $target_ts, $target_id) = @{$result[$i]};
|
|
if ($id eq '[[rollback]]') {
|
|
if ($target_id) {
|
|
$rollback{$target_id} = $target_ts; # single page rollback
|
|
splice(@result, $i, 1); # strip marker
|
|
} else {
|
|
my $end = $i;
|
|
while ($ts > $target_ts and $i > 0) {
|
|
$i--; # quickly skip all these lines
|
|
$ts = $result[$i][0];
|
|
}
|
|
splice(@result, $i + 1, $end - $i);
|
|
$i++; # compensate $i-- in for loop
|
|
}
|
|
} elsif ($rollback{$id} and $ts > $rollback{$id}) {
|
|
splice(@result, $i, 1); # strip rolled back single pages
|
|
}
|
|
}
|
|
} else { # just strip the marker left by DoRollback()
|
|
for (my $i = $#result; $i >= 0; $i--) {
|
|
splice(@result, $i, 1) if $result[$i][1] eq '[[rollback]]'; # id
|
|
}
|
|
}
|
|
return @result;
|
|
}
|
|
|
|
sub GetRcLinesFor {
|
|
my $file = shift;
|
|
my $starttime = shift;
|
|
my %match = %{$_[0]}; # deref
|
|
my %following = %{$_[1]}; # deref
|
|
# parameters
|
|
my $showminoredit = GetParam('showedit', $ShowEdits); # show minor edits
|
|
my $all = GetParam('all', $ShowAll);
|
|
my ($idOnly, $userOnly, $hostOnly, $clusterOnly, $filterOnly, $match, $lang,
|
|
$followup) = map { UnquoteHtml(GetParam($_, '')); }
|
|
qw(rcidonly rcuseronly rchostonly
|
|
rcclusteronly rcfilteronly match lang followup);
|
|
# parsing and filtering
|
|
my @result = ();
|
|
open(my $F, '<:encoding(UTF-8)', encode_utf8($file)) or return ();
|
|
while (my $line = <$F>) {
|
|
chomp($line);
|
|
my ($ts, $id, $minor, $summary, $host, $username, $revision,
|
|
$languages, $cluster) = split(/$FS/, $line);
|
|
next if $ts < $starttime;
|
|
$following{$id} = $ts if $followup and $followup eq $username;
|
|
next if $followup and (not $following{$id} or $ts <= $following{$id});
|
|
next if $idOnly and $idOnly ne $id;
|
|
next if $filterOnly and not $match{$id};
|
|
next if ($userOnly and $userOnly ne $username);
|
|
next if $minor == 1 and not $showminoredit; # skip minor edits (if [[rollback]] this is bogus)
|
|
next if not $minor and $showminoredit == 2; # skip major edits
|
|
next if $match and $id !~ /$match/i;
|
|
next if $hostOnly and $host !~ /$hostOnly/i;
|
|
my @languages = split(/,/, $languages);
|
|
next if $lang and @languages and not grep(/$lang/, @languages);
|
|
if ($PageCluster) {
|
|
($cluster, $summary) = ($1, $2) if $summary =~ /^\[\[$FreeLinkPattern\]\] ?: *(.*)/
|
|
or $summary =~ /^$LinkPattern ?: *(.*)/;
|
|
next if ($clusterOnly and $clusterOnly ne $cluster);
|
|
$cluster = '' if $clusterOnly; # don't show cluster if $clusterOnly eq $cluster
|
|
if ($all < 2 and not $clusterOnly and $cluster) {
|
|
$summary = "$id: $summary"; # print the cluster instead of the page
|
|
$id = $cluster;
|
|
$revision = '';
|
|
}
|
|
} else {
|
|
$cluster = '';
|
|
}
|
|
$following{$id} = $ts if $followup and $followup eq $username;
|
|
push(@result, [$ts, $id, $minor, $summary, $host, $username, $revision,
|
|
\@languages, $cluster]);
|
|
}
|
|
return @result;
|
|
}
|
|
|
|
sub ProcessRcLines {
|
|
my ($printDailyTear, $printRCLine) = @_; # code references
|
|
# needed for output
|
|
my $date = '';
|
|
for my $line (GetRcLines()) {
|
|
my ($ts, $id, $minor, $summary, $host, $username, $revision, $languageref,
|
|
$cluster, $last) = @$line;
|
|
if ($date ne CalcDay($ts)) {
|
|
$date = CalcDay($ts);
|
|
$printDailyTear->($date);
|
|
}
|
|
$printRCLine->($id, $ts, $host, $username, $summary, $minor, $revision,
|
|
$languageref, $cluster, $last);
|
|
}
|
|
}
|
|
|
|
sub RcHeader {
|
|
my ($from, $upto, $html) = (GetParam('from', 0), GetParam('upto', 0), '');
|
|
my $days = GetParam('days') + 0 || $RcDefault; # force numeric $days
|
|
my $all = GetParam('all', $ShowAll);
|
|
my $edits = GetParam('showedit', $ShowEdits);
|
|
my $rollback = GetParam('rollback', $ShowRollbacks);
|
|
if ($from) {
|
|
$html .= $q->h2(Ts('Updates since %s', TimeToText(GetParam('from', 0))) . ' '
|
|
. ($upto ? Ts('up to %s', TimeToText($upto)) : ''));
|
|
} else {
|
|
$html .= $q->h2((GetParam('days', $RcDefault) != 1)
|
|
? Ts('Updates in the last %s days', $days)
|
|
: Ts('Updates in the last day'));
|
|
}
|
|
my $action = '';
|
|
my ($idOnly, $userOnly, $hostOnly, $clusterOnly, $filterOnly,
|
|
$match, $lang, $followup) =
|
|
map {
|
|
my $val = GetParam($_, '');
|
|
$html .= $q->p($q->b('(' . Ts('for %s only', $val) . ')')) if $val;
|
|
$action .= ";$_=$val" if $val; # remember these parameters later!
|
|
$val;
|
|
} qw(rcidonly rcuseronly rchostonly rcclusteronly rcfilteronly
|
|
match lang followup);
|
|
my $rss = "action=rss$action;days=$days;all=$all;showedit=$edits";
|
|
if ($clusterOnly) {
|
|
$action = GetPageParameters('browse', $clusterOnly) . $action;
|
|
} else {
|
|
$action = "action=rc$action";
|
|
}
|
|
my @menu;
|
|
if ($all) {
|
|
push(@menu, ScriptLink("$action;days=$days;all=0;showedit=$edits",
|
|
T('List latest change per page only')));
|
|
} else {
|
|
push(@menu, ScriptLink("$action;days=$days;all=1;showedit=$edits",
|
|
T('List all changes')));
|
|
if ($rollback) {
|
|
push(@menu, ScriptLink("$action;days=$days;all=0;rollback=0;"
|
|
. "showedit=$edits", T('Skip rollbacks')));
|
|
} else {
|
|
push(@menu, ScriptLink("$action;days=$days;all=0;rollback=1;"
|
|
. "showedit=$edits", T('Include rollbacks')));
|
|
}
|
|
}
|
|
if ($edits) {
|
|
push(@menu, ScriptLink("$action;days=$days;all=$all;showedit=0",
|
|
T('List only major changes')));
|
|
} else {
|
|
push(@menu, ScriptLink("$action;days=$days;all=$all;showedit=1",
|
|
T('Include minor changes')));
|
|
}
|
|
$html .= $q->p(join(' | ', (map { ScriptLink("$action;days=$_;all=$all;showedit=$edits", $_); } @RcDays)),
|
|
T('days'), $q->br(), @menu, $q->br(),
|
|
ScriptLink($action . ';from=' . ($LastUpdate + 1)
|
|
. ";all=$all;showedit=$edits", T('List later changes')),
|
|
ScriptLink($rss, T('RSS'), 'rss nopages nodiff'),
|
|
ScriptLink("$rss;full=1", T('RSS with pages'), 'rss pages nodiff'),
|
|
ScriptLink("$rss;full=1;diff=1", T('RSS with pages and diff'),
|
|
'rss pages diff'));
|
|
$html .= $q->p({-class => 'documentation'}, T('Using the ｢rollback｣ button on this page will reset the wiki to that particular point in time, undoing any later changes to all of the pages.')) if UserIsAdmin() and GetParam('all', $ShowAll);
|
|
return $html;
|
|
}
|
|
|
|
sub RcOtherParameters {
|
|
my $more = '';
|
|
foreach (@_, qw(page diff full all showedit rollback rcidonly rcuseronly rchostonly rcclusteronly rcfilteronly match lang followup)) {
|
|
my $val = GetParam($_, '');
|
|
$more .= ";$_=" . UrlEncode($val) if $val;
|
|
}
|
|
return $more;
|
|
}
|
|
|
|
sub RcSelfAction {
|
|
my $action = GetParam('action', 'rc');
|
|
return "action=$action" . RcOtherParameters(qw(from upto days));
|
|
}
|
|
|
|
sub RcPreviousAction {
|
|
my $action = GetParam('action', 'rc');
|
|
my $interval = GetParam('days', $RcDefault) * 86400;
|
|
# use delta between from and upto, or use days, whichever is available
|
|
my $to = GetParam('from', GetParam('upto', $Now - $interval));
|
|
my $from = $to - (GetParam('upto') ? GetParam('upto') - GetParam('from') : $interval);
|
|
return "action=$action;from=$from;upto=$to" . RcOtherParameters();
|
|
}
|
|
|
|
sub RcLastAction {
|
|
my $action = GetParam('action', 'rc');
|
|
my $more = "action=$action";
|
|
my $days = GetParam('days', $RcDefault);
|
|
$more .= ";days=$days" if $days != $RcDefault;
|
|
return $more . RcOtherParameters();
|
|
}
|
|
|
|
sub GetFilterForm {
|
|
my $form = $q->strong(T('Filters'));
|
|
$form .= $q->input({-type=>'hidden', -name=>'action', -value=>'rc'});
|
|
$form .= $q->input({-type=>'hidden', -name=>'all', -value=>1}) if (GetParam('all', $ShowAll));
|
|
$form .= $q->input({-type=>'hidden', -name=>'showedit', -value=>1}) if (GetParam('showedit', $ShowEdits));
|
|
if (GetParam('days', $RcDefault) != $RcDefault) {
|
|
$form .= $q->input({-type=>'hidden', -name=>'days', -value=>GetParam('days', $RcDefault)});
|
|
}
|
|
my $table = '';
|
|
foreach my $h (['match' => T('Title:')],
|
|
['rcfilteronly' => T('Title and Body:')],
|
|
['rcuseronly' => T('Username:')], ['rchostonly' => T('Host:')],
|
|
['followup' => T('Follow up to:')]) {
|
|
$table .= $q->Tr($q->td($q->label({-for=>$h->[0]}, $h->[1])),
|
|
$q->td($q->textfield(-name=>$h->[0], -id=>$h->[0], -size=>20)));
|
|
}
|
|
if (%Languages) {
|
|
$table .= $q->Tr($q->td($q->label({-for=>'rclang'}, T('Language:')))
|
|
. $q->td($q->textfield(-name=>'lang', -id=>'rclang', -size=>10,
|
|
-default=>GetParam('lang', ''))));
|
|
}
|
|
return GetFormStart(undef, 'get', 'filter') . $q->p($form) . $q->table($table)
|
|
. $q->p($q->submit('dofilter', T('Go!'))) . $q->end_form;
|
|
}
|
|
|
|
sub RcHtml {
|
|
my ($html, $inlist) = ('', 0);
|
|
# Optimize param fetches and translations out of main loop
|
|
my $all = GetParam('all', $ShowAll);
|
|
my $admin = UserIsAdmin();
|
|
my $rollback_was_possible = 0;
|
|
my $printDailyTear = sub {
|
|
my $date = shift;
|
|
if ($inlist) {
|
|
$html .= '</ul>';
|
|
$inlist = 0;
|
|
}
|
|
$html .= $q->p($q->strong($date));
|
|
if (not $inlist) {
|
|
$html .= '<ul>';
|
|
$inlist = 1;
|
|
}
|
|
};
|
|
my $printRCLine = sub {
|
|
my($id, $ts, $host, $username, $summary, $minor, $revision,
|
|
$languages, $cluster, $last) = @_;
|
|
my $all_revision = $last ? undef : $revision; # no revision for the last one
|
|
$host = QuoteHtml($host);
|
|
my $author = GetAuthorLink($username, $host);
|
|
my $sum = $summary ? $q->span({class=>'dash'}, ' – ')
|
|
. $q->strong(QuoteHtml($summary)) : '';
|
|
my $edit = $minor ? $q->em({class=>'type'}, T('(minor)')) : '';
|
|
my $lang = @{$languages}
|
|
? $q->span({class=>'lang'}, '[' . join(', ', @{$languages}) . ']') : '';
|
|
my ($pagelink, $history, $diff, $rollback) = ('', '', '', '');
|
|
if ($all) {
|
|
$pagelink = GetOldPageLink('browse', $id, $all_revision, $id, $cluster);
|
|
my $rollback_is_possible = RollbackPossible($ts);
|
|
if ($admin and ($rollback_is_possible or $rollback_was_possible)) {
|
|
$rollback = $q->submit("rollback-$ts", T('rollback'));
|
|
$rollback_was_possible = $rollback_is_possible;
|
|
} else {
|
|
$rollback_was_possible = 0;
|
|
}
|
|
} elsif ($cluster) {
|
|
$pagelink = GetOldPageLink('browse', $id, $revision, $id, $cluster);
|
|
} else {
|
|
$pagelink = GetPageLink($id, $cluster);
|
|
$history = '(' . GetHistoryLink($id, T('history')) . ')';
|
|
}
|
|
if ($cluster and $PageCluster) {
|
|
$diff .= GetPageLink($PageCluster) . ':';
|
|
} elsif ($UseDiff and GetParam('diffrclink', 1)) {
|
|
if ($revision == 1) {
|
|
$diff .= '(' . $q->span({-class=>'new'}, T('new')) . ')';
|
|
} elsif ($all) {
|
|
$diff .= '(' . ScriptLinkDiff(2, $id, T('diff'), $all_revision) .')';
|
|
} else {
|
|
$diff .= '(' . ScriptLinkDiff($minor ? 2 : 1, $id, T('diff')) . ')';
|
|
}
|
|
}
|
|
$html .= $q->li($q->span({-class=>'time'}, CalcTime($ts)), $diff, $history,
|
|
$rollback, $pagelink, T(' . . . .'), $author, $sum, $lang,
|
|
$edit);
|
|
};
|
|
ProcessRcLines($printDailyTear, $printRCLine);
|
|
$html .= '</ul>' if $inlist;
|
|
$html .= $q->p({-class=>'more'}, ScriptLink(RcPreviousAction(), T('More...'), 'more'));
|
|
return GetFormStart(undef, 'get', 'rc') . $html . $q->end_form;
|
|
}
|
|
|
|
sub PrintRcHtml { # to append RC to existing page, or action=rc directly
|
|
my ($id, $standalone) = @_;
|
|
my $rc = ($id eq $RCName or $id eq T($RCName) or T($id) eq $RCName);
|
|
if ($standalone) {
|
|
print GetHeader('', $rc ? NormalToFree($id) : Ts('All changes for %s', NormalToFree($id)));
|
|
}
|
|
if ($standalone or $rc or GetParam('rcclusteronly', '')) {
|
|
print $q->start_div({-class=>'rc'});
|
|
print $q->hr() unless $standalone or GetParam('embed', $EmbedWiki);
|
|
print RcHeader() . RcHtml() . GetFilterForm() . $q->end_div();
|
|
}
|
|
PrintFooter($id) if $standalone;
|
|
}
|
|
|
|
sub RcTextItem {
|
|
my ($name, $value) = @_;
|
|
$value = UnquoteHtml($value);
|
|
$value =~ s/\n+$//;
|
|
$value =~ s/\n+/\n /g;
|
|
return $value ? $name . ': ' . $value . "\n" : '';
|
|
}
|
|
|
|
sub RcTextRevision {
|
|
my($id, $ts, $host, $username, $summary, $minor, $revision,
|
|
$languages, $cluster, $last) = @_;
|
|
my $link = $ScriptName
|
|
. (GetParam('all', $ShowAll) && ! $last
|
|
? '?' . GetPageParameters('browse', $id, $revision, $cluster, $last)
|
|
: ($UsePathInfo ? '/' : '?') . UrlEncode($id));
|
|
$summary = GetPageContent($id) if GetParam('full', 0);
|
|
print "\n", RcTextItem('title', NormalToFree($id)),
|
|
RcTextItem('description', $summary),
|
|
RcTextItem('generator', GetAuthor($username, $host)),
|
|
RcTextItem('language', join(', ', @{$languages})), RcTextItem('link', $link),
|
|
RcTextItem('last-modified', TimeToW3($ts)),
|
|
RcTextItem('revision', $revision),
|
|
RcTextItem('minor', $minor);
|
|
}
|
|
|
|
sub PrintRcText { # print text rss header and call ProcessRcLines
|
|
local $RecentLink = 0;
|
|
print RcTextItem('title', $SiteName),
|
|
RcTextItem('description', $SiteDescription), RcTextItem('link', $ScriptName),
|
|
RcTextItem('generator', 'Oddmuse'), RcTextItem('rights', $RssRights);
|
|
ProcessRcLines(sub {}, \&RcTextRevision);
|
|
}
|
|
|
|
sub GetRcRss {
|
|
my $date = TimeToRFC822($LastUpdate);
|
|
my %excluded = ();
|
|
if (GetParam("exclude", 1)) {
|
|
foreach (split(/\n/, GetPageContent($RssExclude))) {
|
|
if (/^ ([^ ]+)[ \t]*$/) { # only read lines with one word after one space
|
|
$excluded{$1} = 1;
|
|
}
|
|
}
|
|
}
|
|
my $rss = qq{<?xml version="1.0" encoding="UTF-8"?>\n};
|
|
if ($RssStyleSheet =~ /\.(xslt?|xml)$/) {
|
|
$rss .= qq{<?xml-stylesheet type="text/xml" href="$RssStyleSheet" ?>\n};
|
|
} elsif ($RssStyleSheet) {
|
|
$rss .= qq{<?xml-stylesheet type="text/css" href="$RssStyleSheet" ?>\n};
|
|
}
|
|
$rss .= qq{<rss version="2.0"
|
|
xmlns:wiki="http://purl.org/rss/1.0/modules/wiki/"
|
|
xmlns:dc="http://purl.org/dc/elements/1.1/"
|
|
xmlns:cc="http://web.resource.org/cc/"
|
|
xmlns:atom="http://www.w3.org/2005/Atom">
|
|
<channel>
|
|
<docs>http://blogs.law.harvard.edu/tech/rss</docs>
|
|
};
|
|
my $title = QuoteHtml($SiteName) . ': ' . GetParam('title', QuoteHtml(NormalToFree($HomePage)));
|
|
$rss .= "<title>$title</title>\n";
|
|
$rss .= "<link>$ScriptName?" . RcSelfAction() . "</link>\n";
|
|
$rss .= qq{<atom:link href="$ScriptName?} . RcSelfAction() . qq{" rel="self" type="application/rss+xml" />\n};
|
|
$rss .= qq{<atom:link href="$ScriptName?} . RcPreviousAction() . qq{" rel="previous" type="application/rss+xml" />\n};
|
|
$rss .= qq{<atom:link href="$ScriptName?} . RcLastAction() . qq{" rel="last" type="application/rss+xml" />\n};
|
|
if ($SiteDescription) {
|
|
$rss .= "<description>" . QuoteHtml($SiteDescription) . "</description>\n"
|
|
}
|
|
$rss .= "<pubDate>$date</pubDate>\n";
|
|
$rss .= "<lastBuildDate>$date</lastBuildDate>\n";
|
|
$rss .= "<generator>Oddmuse</generator>\n";
|
|
$rss .= "<copyright>$RssRights</copyright>\n" if $RssRights;
|
|
if ($RssLicense) {
|
|
$rss .= join('', map {"<cc:license>" . QuoteHtml($_) . "</cc:license>\n"}
|
|
(ref $RssLicense eq 'ARRAY' ? @$RssLicense : $RssLicense))
|
|
}
|
|
$rss .= "<wiki:interwiki>$InterWikiMoniker</wiki:interwiki>\n" if $InterWikiMoniker;
|
|
if ($RssImageUrl) {
|
|
$rss .= "<image>\n";
|
|
$rss .= "<url>$RssImageUrl</url>\n";
|
|
$rss .= "<title>$title</title>\n"; # the same as the channel
|
|
$rss .= "<link>$ScriptName?" . RcSelfAction() . "</link>\n"; # the same as the channel
|
|
$rss .= "</image>\n";
|
|
}
|
|
my $limit = GetParam("rsslimit", 15); # Only take the first 15 entries
|
|
my $count = 0;
|
|
ProcessRcLines(sub {}, sub {
|
|
my $id = shift;
|
|
return if $excluded{$id} or ($limit ne 'all' and $count++ >= $limit);
|
|
$rss .= "\n" . RssItem($id, @_);
|
|
});
|
|
$rss .= "</channel>\n</rss>\n";
|
|
return $rss;
|
|
}
|
|
|
|
sub RssItem {
|
|
my ($id, $ts, $host, $username, $summary, $minor, $revision,
|
|
$languages, $cluster, $last) = @_;
|
|
my $name = ItemName($id);
|
|
if (GetParam('full', 0)) { # full page means summary is not shown
|
|
$summary = PageHtml($id, 50 * 1024, T('This page is too big to send over RSS.'));
|
|
} else {
|
|
$summary = QuoteHtml($summary); # page summary must be quoted
|
|
}
|
|
my $date = TimeToRFC822($ts);
|
|
$username = QuoteHtml($username);
|
|
my $rss = "<item>\n";
|
|
$rss .= "<title>$name</title>\n";
|
|
my $link = ScriptUrl(GetParam('all', $cluster)
|
|
? GetPageParameters('browse', $id, $revision, $cluster, $last)
|
|
: UrlEncode($id));
|
|
$rss .= "<link>$link</link>\n<guid>$link</guid>\n";
|
|
$rss .= "<description>" . QuoteHtml($summary) . "</description>\n" if $summary;
|
|
$rss .= "<pubDate>" . $date . "</pubDate>\n";
|
|
$rss .= "<comments>" . ScriptUrl($CommentsPrefix . UrlEncode($id))
|
|
. "</comments>\n" if $CommentsPattern and $id !~ /$CommentsPattern/;
|
|
$rss .= "<dc:contributor>" . $username . "</dc:contributor>\n" if $username;
|
|
$rss .= "<wiki:status>" . (1 == $revision ? 'new' : 'updated') . "</wiki:status>\n";
|
|
$rss .= "<wiki:importance>" . ($minor ? 'minor' : 'major') . "</wiki:importance>\n";
|
|
$rss .= "<wiki:version>" . $revision . "</wiki:version>\n";
|
|
$rss .= "<wiki:history>" . ScriptUrl("action=history;id=" . UrlEncode($id))
|
|
. "</wiki:history>\n";
|
|
$rss .= "<wiki:diff>" . ScriptUrl("action=browse;diff=1;id=" . UrlEncode($id))
|
|
. "</wiki:diff>\n" if $UseDiff and GetParam('diffrclink', 1);
|
|
return $rss . "</item>\n";
|
|
}
|
|
|
|
sub DoRss {
|
|
print GetHttpHeader('application/xml');
|
|
print GetRcRss();
|
|
}
|
|
|
|
sub DoHistory {
|
|
my $id = shift;
|
|
ValidIdOrDie($id);
|
|
OpenPage($id);
|
|
if (GetParam('raw', 0)) {
|
|
DoRawHistory($id);
|
|
} else {
|
|
DoHtmlHistory($id);
|
|
}
|
|
}
|
|
|
|
sub DoRawHistory {
|
|
my ($id) = @_;
|
|
print GetHttpHeader('text/plain'),
|
|
RcTextItem('title', Ts('History of %s', NormalToFree($OpenPageName))),
|
|
RcTextItem('date', TimeToText($Now)),
|
|
RcTextItem('link', ScriptUrl("action=history;id=$OpenPageName;raw=1")),
|
|
RcTextItem('generator', 'Oddmuse');
|
|
SetParam('all', 1);
|
|
my @languages = split(/,/, $Page{languages});
|
|
RcTextRevision($id, $Page{ts}, $Page{host}, $Page{username}, $Page{summary},
|
|
$Page{minor}, $Page{revision}, \@languages, undef, 1);
|
|
foreach my $revision (GetKeepRevisions($OpenPageName)) {
|
|
my $keep = GetKeptRevision($revision);
|
|
@languages = split(/,/, $keep->{languages});
|
|
RcTextRevision($id, $keep->{ts}, $keep->{host}, $keep->{username},
|
|
$keep->{summary}, $keep->{minor}, $keep->{revision}, \@languages);
|
|
}
|
|
}
|
|
|
|
sub DoHtmlHistory {
|
|
my ($id) = @_;
|
|
print GetHeader('', Ts('History of %s', NormalToFree($id)));
|
|
my $row = 0;
|
|
my $rollback = UserCanEdit($id, 0) && (GetParam('username', '') or UserIsEditor());
|
|
my $date = CalcDay($Page{ts});
|
|
my @html = (GetFormStart(undef, 'get', 'history'));
|
|
push(@html, $q->p({-class => 'documentation'}, T('Using the ｢rollback｣ button on this page will reset the page to that particular point in time, undoing any later changes to this page.'))) if $rollback;
|
|
push(@html, $q->p(# don't use $q->hidden here!
|
|
$q->input({-type=>'hidden', -name=>'action', -value=>'browse'}),
|
|
$q->input({-type=>'hidden', -name=>'diff', -value=>'1'}),
|
|
$q->input({-type=>'hidden', -name=>'id', -value=>$id})));
|
|
# list of rows with revisions, starting with current revision
|
|
push(@html, $q->p($q->submit({-name=>T('Compare')}))) if $UseDiff;
|
|
my @rows = (GetHistoryLine($id, \%Page, $row++, $rollback, $date, 1));
|
|
foreach my $revision (GetKeepRevisions($OpenPageName)) {
|
|
my $keep = GetKeptRevision($revision);
|
|
my $new = CalcDay($keep->{ts});
|
|
push(@rows, GetHistoryLine($id, $keep, $row++, $rollback, $new, $new ne $date));
|
|
$date = $new;
|
|
}
|
|
# if we can use diff, add radio-buttons and compare buttons if $UseDiff
|
|
if ($UseDiff) {
|
|
push(@html, $q->table({-class=>'history'}, @rows),
|
|
$q->p($q->submit({-name=>T('Compare')})), $q->end_form());
|
|
} else {
|
|
push(@html, @rows);
|
|
}
|
|
if ($KeepDays and $rollback and $Page{revision}) {
|
|
push(@html, $q->p(ScriptLink('title=' . UrlEncode($id) . ';text='
|
|
. UrlEncode($DeletedPage) . ';summary='
|
|
. UrlEncode(T('Deleted')),
|
|
T('Mark this page for deletion'))));
|
|
}
|
|
print $q->div({-class=>'content history'}, @html);
|
|
PrintFooter($id, 'history');
|
|
}
|
|
|
|
sub GetHistoryLine {
|
|
my ($id, $dataref, $row, $rollback, $date, $newday) = @_;
|
|
my %data = %$dataref;
|
|
my $revision = $data{revision};
|
|
return $q->p(T('No other revisions available')) unless $revision;
|
|
my $html = CalcTime($data{ts});
|
|
if ($row == 0) { # current revision
|
|
$html .= ' (' . T('current') . ')' if $rollback;
|
|
$html .= ' ' . GetPageLink($id, Ts('Revision %s', $revision));
|
|
} else {
|
|
$html .= ' ' . $q->submit("rollback-$data{ts}", T('rollback')) if $rollback;
|
|
$html .= ' ' . GetOldPageLink('browse', $id, $revision,
|
|
Ts('Revision %s', $revision));
|
|
}
|
|
$html .= T(' . . . .') . ' ' . GetAuthorLink($data{username});
|
|
$html .= $q->span({class=>'dash'}, ' – ')
|
|
. $q->strong(QuoteHtml($data{summary})) if $data{summary};
|
|
$html .= ' ' . $q->em({class=>'type'}, T('(minor)')) . ' ' if $data{minor};
|
|
if ($UseDiff) {
|
|
my %attr1 = (-type=>'radio', -name=>'diffrevision', -value=>$revision);
|
|
$attr1{-checked} = 'checked' if $row == 1;
|
|
my %attr2 = (-type=>'radio', -name=>'revision', -value=> $row ? $revision : '');
|
|
$attr2{-checked} = 'checked' if $row == 0; # first row is special
|
|
$html = $q->Tr($q->td($q->input(\%attr1)), $q->td($q->input(\%attr2)), $q->td($html));
|
|
$html = $q->Tr($q->td({-colspan=>3}, $q->strong($date))) . $html if $newday;
|
|
} else {
|
|
$html .= $q->br();
|
|
$html = $q->strong($date) . $q->br() . $html if $newday;
|
|
}
|
|
return $html;
|
|
}
|
|
|
|
sub DoContributors {
|
|
my $id = shift;
|
|
SetParam('rcidonly', $id);
|
|
SetParam('all', 1);
|
|
print GetHeader('', Ts('Contributors to %s', NormalToFree($id || $SiteName)));
|
|
my %contrib = ();
|
|
for my $line (GetRcLines(1)) {
|
|
my ($ts, $pagename, $minor, $summary, $host, $username) = @$line;
|
|
$contrib{$username}++ if $username;
|
|
}
|
|
print $q->div({-class=>'content contrib'},
|
|
$q->p(map { GetPageLink($_) } sort(keys %contrib)));
|
|
PrintFooter();
|
|
}
|
|
|
|
sub RollbackPossible {
|
|
my $ts = shift; # there can be no rollback to the most recent change(s) made (1s resolution!)
|
|
return $ts != $LastUpdate && (!$KeepDays || ($Now - $ts) < $KeepDays * 86400); # 24*60*60
|
|
}
|
|
|
|
sub DoRollback {
|
|
my $page = shift;
|
|
my $to = GetParam('to', 0);
|
|
ReportError(T('Missing target for rollback.'), '400 BAD REQUEST') unless $to;
|
|
ReportError(T('Target for rollback is too far back.'), '400 BAD REQUEST') unless $page or RollbackPossible($to);
|
|
ReportError(T('A username is required for ordinary users.'), '403 FORBIDDEN') unless GetParam('username', '') or UserIsEditor();
|
|
my @ids = ();
|
|
if (not $page) { # cannot just use list length because of ('')
|
|
return unless UserIsAdminOrError(); # only admins can do mass changes
|
|
SetParam('showedit', 1); # make GetRcLines return minor edits as well
|
|
SetParam('all', 1); # prevent LatestChanges from interfering
|
|
SetParam('rollback', 1); # prevent StripRollbacks from interfering
|
|
my %ids = map { my ($ts, $id) = @$_; $id => 1; } # make unique via hash
|
|
GetRcLines($to); # list all the pages edited since $to
|
|
@ids = keys %ids;
|
|
} else {
|
|
@ids = ($page);
|
|
}
|
|
RequestLockOrError();
|
|
print GetHeader('', T('Rolling back changes')),
|
|
$q->start_div({-class=>'content rollback'}), $q->start_p();
|
|
foreach my $id (@ids) {
|
|
OpenPage($id);
|
|
my ($text, $minor, $ts) = GetTextAtTime($to);
|
|
if ($Page{text} eq $text) {
|
|
print T("The two revisions are the same."), $q->br() if $page; # no message when doing mass revert
|
|
} elsif (not UserCanEdit($id, 1)) {
|
|
print Ts('Editing not allowed: %s is read-only.', $id), $q->br();
|
|
} elsif (not UserIsEditor() and my $rule = BannedContent($text)) {
|
|
print Ts('Rollback of %s would restore banned content.', $id), $rule, $q->br();
|
|
} else {
|
|
Save($id, $text, Ts('Rollback to %s', TimeToText($to)), $minor, ($Page{host} ne $q->remote_addr()));
|
|
print Ts('%s rolled back', GetPageLink($id)), ($ts ? ' ' . Ts('to %s', TimeToText($to)) : ''), $q->br();
|
|
}
|
|
}
|
|
WriteRcLog('[[rollback]]', $page, $to); # leave marker
|
|
print $q->end_p() . $q->end_div();
|
|
ReleaseLock();
|
|
PrintFooter($page, 'edit');
|
|
}
|
|
|
|
sub DoAdminPage {
|
|
my ($id, @rest) = @_;
|
|
my @menu = ();
|
|
push(@menu, ScriptLink('action=index', T('Index of all pages'), 'index')) if $Action{index};
|
|
push(@menu, ScriptLink('action=version', T('Wiki Version'), 'version')) if $Action{version};
|
|
push(@menu, ScriptLink('action=password', T('Password'), 'password')) if $Action{password};
|
|
push(@menu, ScriptLink('action=maintain', T('Run maintenance'), 'maintain')) if $Action{maintain};
|
|
my @locks;
|
|
for my $pattern (@KnownLocks) {
|
|
for my $name (Glob($pattern)) {
|
|
if (IsDir($LockDir . $name)) {
|
|
push(@locks, $name);
|
|
}
|
|
}
|
|
}
|
|
if (@locks and $Action{unlock}) {
|
|
push(@menu, ScriptLink('action=unlock', T('Unlock Wiki'), 'unlock') . ' (' . join(', ', @locks) . ')');
|
|
};
|
|
if (UserIsAdmin()) {
|
|
if ($Action{editlock}) {
|
|
if (IsFile("$DataDir/noedit")) {
|
|
push(@menu, ScriptLink('action=editlock;set=0', T('Unlock site'), 'editlock 0'));
|
|
} else {
|
|
push(@menu, ScriptLink('action=editlock;set=1', T('Lock site'), 'editlock 1'));
|
|
}
|
|
}
|
|
if ($id and $Action{pagelock}) {
|
|
my $title = NormalToFree($id);
|
|
if (IsFile(GetLockedPageFile($id))) {
|
|
push(@menu, ScriptLink('action=pagelock;set=0;id=' . UrlEncode($id),
|
|
Ts('Unlock %s', $title), 'pagelock 0'));
|
|
} else {
|
|
push(@menu, ScriptLink('action=pagelock;set=1;id=' . UrlEncode($id),
|
|
Ts('Lock %s', $title), 'pagelock 1'));
|
|
}
|
|
}
|
|
push(@menu, ScriptLink('action=clear', T('Clear Cache'), 'clear')) if $Action{clear};
|
|
}
|
|
foreach my $sub (@MyAdminCode) {
|
|
$sub->($id, \@menu, \@rest);
|
|
$Message .= $q->p($@) if $@; # since this happens before GetHeader is called, the message will be shown
|
|
}
|
|
print GetHeader('', T('Administration')),
|
|
$q->div({-class=>'content admin'}, $q->p(T('Actions:')), $q->ul($q->li(\@menu)),
|
|
$q->p(T('Important pages:')) . $q->ul(map { $q->li(GetPageOrEditLink($_, NormalToFree($_))) if $_;
|
|
} sort keys %AdminPages),
|
|
$q->p(Ts('To mark a page for deletion, put <strong>%s</strong> on the first line.',
|
|
$DeletedPage)), @rest);
|
|
PrintFooter();
|
|
}
|
|
|
|
sub GetPageParameters {
|
|
my ($action, $id, $revision, $cluster, $last) = @_;
|
|
$id = FreeToNormal($id);
|
|
my $link = "action=$action;id=" . UrlEncode($id);
|
|
$link .= ";revision=$revision" if $revision and not $last;
|
|
$link .= ';rcclusteronly=' . UrlEncode($cluster) if $cluster;
|
|
return $link;
|
|
}
|
|
|
|
sub GetOldPageLink {
|
|
my ($action, $id, $revision, $name, $cluster, $last) = @_;
|
|
return ScriptLink(GetPageParameters($action, $id, $revision, $cluster, $last),
|
|
NormalToFree($name), 'revision');
|
|
}
|
|
|
|
sub GetSearchLink {
|
|
my ($text, $class, $name, $title) = @_;
|
|
my $id = UrlEncode(QuoteRegexp('"' . $text . '"'));
|
|
$name = UrlEncode($name);
|
|
$text = NormalToFree($text);
|
|
$id =~ s/_/+/g; # Search for url-escaped spaces
|
|
return ScriptLink('search=' . $id, $text, $class, $name, $title);
|
|
}
|
|
|
|
sub ScriptLinkDiff {
|
|
my ($diff, $id, $text, $new, $old) = @_;
|
|
my $action = 'action=browse;diff=' . $diff . ';id=' . UrlEncode($id);
|
|
$action .= ";diffrevision=$old" if $old;
|
|
$action .= ";revision=$new" if $new;
|
|
return ScriptLink($action, $text, 'diff');
|
|
}
|
|
|
|
sub Code {
|
|
my ($str) = @_;
|
|
my $num = unpack("L",B::hash($str)); # 32-bit integer
|
|
my $code = sprintf("%o", $num); # octal is 0-7
|
|
return substr($code, 0, 4); # four numbers
|
|
}
|
|
|
|
sub ColorCode {
|
|
my $code = Code(@_);
|
|
my @indexes = split(//, $code); # four numbers
|
|
my @colors = qw/red orange yellow green blue indigo violet white/;
|
|
return $q->span({-class => 'ip-code', -title => T('Anonymous')},
|
|
join('', map { $q->span({-class => $colors[$_]}, $_) }
|
|
@indexes));
|
|
}
|
|
|
|
sub GetAuthor {
|
|
my ($username, $host) = @_;
|
|
return $username if $username;
|
|
return T('Anonymous') if $host eq 'Anonymous';
|
|
return Code($host);
|
|
}
|
|
|
|
sub GetAuthorLink {
|
|
my ($username, $host) = @_;
|
|
$username = FreeToNormal($username);
|
|
my $name = NormalToFree($username);
|
|
if (ValidId($username) ne '') { # ValidId() returns error string
|
|
$username = ''; # Just pretend it isn't there.
|
|
}
|
|
if ($username and $RecentLink) {
|
|
return ScriptLink(UrlEncode($username), $name, 'author');
|
|
} elsif ($username) {
|
|
return $q->span({-class=>'author'}, $name);
|
|
}
|
|
return T('Anonymous') if $host eq 'Anonymous';
|
|
return ColorCode($host);
|
|
}
|
|
|
|
sub GetHistoryLink {
|
|
my ($id, $text) = @_;
|
|
my $action = 'action=history;id=' . UrlEncode(FreeToNormal($id));
|
|
return ScriptLink($action, $text, 'history');
|
|
}
|
|
|
|
sub GetRCLink {
|
|
my ($id, $text) = @_;
|
|
return ScriptLink('action=rc;all=1;from=1;showedit=1;rcidonly='
|
|
. UrlEncode(FreeToNormal($id)), $text, 'rc');
|
|
}
|
|
|
|
sub GetHeader {
|
|
my ($id, $title, $oldId, $nocache, $status) = @_;
|
|
my $embed = GetParam('embed', $EmbedWiki);
|
|
my $result = GetHttpHeader('text/html', $nocache, $status);
|
|
if ($oldId) {
|
|
$Message .= $q->p('(' . Ts('redirected from %s', GetEditLink($oldId, $oldId)) . ')');
|
|
}
|
|
$result .= GetHtmlHeader(Ts('%s:', $SiteName) . ' ' . UnWiki($title), $id);
|
|
if ($embed) {
|
|
$result .= $q->div({-class=>'header'}, $q->div({-class=>'message'}, $Message)) if $Message;
|
|
return $result;
|
|
}
|
|
$result .= GetHeaderDiv($id, $title, $oldId, $embed);
|
|
return $result . $q->start_div({-class=>'wrapper'});
|
|
}
|
|
|
|
sub GetHeaderDiv {
|
|
my ($id, $title, $oldId, $embed) = @_;
|
|
my $result .= $q->start_div({-class=>'header'});
|
|
if (not $embed and $LogoUrl) {
|
|
my $url = $IndexHash{$LogoUrl} ? GetDownloadLink($LogoUrl, 2) : $LogoUrl;
|
|
$result .= ScriptLink(UrlEncode($HomePage), $q->img({-src=>$url, -alt=>T('[Home]'), -class=>'logo'}), 'logo');
|
|
}
|
|
$result .= $q->start_div({-class=>'menu'});
|
|
if (GetParam('toplinkbar', $TopLinkBar) != 2) {
|
|
$result .= GetGotoBar($id);
|
|
if (%SpecialDays) {
|
|
my ($sec, $min, $hour, $mday, $mon, $year) = gmtime($Now);
|
|
if ($SpecialDays{($mon + 1) . '-' . $mday}) {
|
|
$result .= $q->br() . $q->span({-class=>'specialdays'},
|
|
$SpecialDays{($mon + 1) . '-' . $mday});
|
|
}
|
|
}
|
|
}
|
|
$result .= GetSearchForm() if GetParam('topsearchform', $TopSearchForm) != 2;
|
|
$result .= $q->end_div();
|
|
$result .= $q->div({-class=>'message'}, $Message) if $Message;
|
|
$result .= GetHeaderTitle($id, $title, $oldId);
|
|
$result .= $q->end_div();
|
|
return $result;
|
|
}
|
|
|
|
sub GetHeaderTitle {
|
|
my ($id, $title, $oldId) = @_;
|
|
return $q->h1($title) if $id eq '';
|
|
return $q->h1(GetSearchLink($id, '', '', T('Click to search for references to this page')));
|
|
}
|
|
|
|
sub GetHttpHeader {
|
|
return if $HeaderIsPrinted; # When calling ReportError, we don't know whether HTTP headers have
|
|
$HeaderIsPrinted = 1; # already been printed. We want them printed just once.
|
|
my ($type, $ts, $status, $encoding) = @_;
|
|
$q->charset($type =~ m!^(text/|application/xml)! ? 'utf-8' : ''); # text/plain, text/html, application/xml: UTF-8
|
|
my %headers = (-cache_control=>($UseCache < 0 ? 'no-cache' : 'max-age=10'));
|
|
# Set $ts when serving raw content that cannot be modified by cookie
|
|
# parameters; or 'nocache'; or undef. If you provide a $ts, the last-modified
|
|
# header generated will by used by HTTP/1.0 clients. If you provide no $ts,
|
|
# the etag header generated will be used by HTTP/1.1 clients. In this
|
|
# situation, cookie parameters can influence the look of the page and we
|
|
# cannot rely on $LastUpdate. HTTP/1.0 clients will ignore etags. See RFC 2616
|
|
# section 13.3.4.
|
|
if (GetParam('cache', $UseCache) >= 2 and $ts ne 'nocache') {
|
|
$headers{'-last-modified'} = TimeToRFC822($ts) if $ts;
|
|
$headers{-etag} = PageEtag();
|
|
}
|
|
$headers{-type} = GetParam('mime-type', $type);
|
|
$headers{-status} = $status if $status;
|
|
$headers{-Content_Encoding} = $encoding if $encoding;
|
|
my $cookie = Cookie();
|
|
$headers{-cookie} = $cookie if $cookie;
|
|
if ($q->request_method() eq 'HEAD') {
|
|
print $q->header(%headers), "\n\n"; # add newlines for FCGI because of exit()
|
|
exit; # total shortcut -- HEAD never expects anything other than the header!
|
|
}
|
|
return $q->header(%headers);
|
|
}
|
|
|
|
sub CookieData {
|
|
my ($changed, %params);
|
|
foreach my $key (keys %CookieParameters) {
|
|
my $default = $CookieParameters{$key};
|
|
my $value = GetParam($key, $default);
|
|
$params{$key} = $value if $value ne $default;
|
|
# The cookie is considered to have changed under the following
|
|
# condition: If the value was already set, and the new value is
|
|
# not the same as the old value, or if there was no old value, and
|
|
# the new value is not the default.
|
|
my $change = (defined $OldCookie{$key} ? ($value ne $OldCookie{$key}) : ($value ne $default));
|
|
$changed = 1 if $change; # note if any parameter changed and needs storing
|
|
}
|
|
return $changed, %params;
|
|
}
|
|
|
|
sub Cookie {
|
|
my ($changed, %params) = CookieData(); # params are URL encoded
|
|
if ($changed) {
|
|
my $cookie = join(UrlEncode($FS), %params); # no CTL in field values
|
|
return $q->cookie(-name=>$CookieName, -value=>$cookie, -expires=>'+2y', secure=>$ENV{'HTTPS'}, httponly=>1);
|
|
}
|
|
return '';
|
|
}
|
|
|
|
sub GetHtmlHeader { # always HTML!
|
|
my ($title, $id) = @_;
|
|
my $edit_link = $id ? '<link rel="alternate" type="application/wiki" title="'
|
|
. T('Edit this page') . '" href="' . ScriptUrl('action=edit;id=' . UrlEncode($id)) . '" />' : '';
|
|
my $theme = GetParam('theme', 'default');
|
|
return $DocumentHeader
|
|
. $q->head($q->title($title) . $edit_link
|
|
. GetCss() . GetRobots() . GetFeeds() . $HtmlHeaders
|
|
. '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />')
|
|
. qq{<body class="$theme" lang="$CurrentLanguage">};
|
|
}
|
|
|
|
sub GetRobots { # NOINDEX for non-browse pages.
|
|
if (GetParam('action', 'browse') eq 'browse' and not GetParam('revision', '')) {
|
|
return '<meta name="robots" content="INDEX,FOLLOW" />';
|
|
} else {
|
|
return '<meta name="robots" content="NOINDEX,FOLLOW" />';
|
|
}
|
|
}
|
|
|
|
sub GetFeeds { # default for $HtmlHeaders
|
|
my $html = '<link rel="alternate" type="application/rss+xml" title="'
|
|
. QuoteHtml($SiteName) . '" href="' . $ScriptName . '?action=rss" />';
|
|
my $id = GetId(); # runs during Init, not during DoBrowseRequest
|
|
$html .= '<link rel="alternate" type="application/rss+xml" title="'
|
|
. QuoteHtml("$SiteName: $id") . '" href="' . $ScriptName
|
|
. '?action=rss;rcidonly=' . UrlEncode(FreeToNormal($id)) . '" />' if $id;
|
|
my $username = GetParam('username', '');
|
|
$html .= '<link rel="alternate" type="application/rss+xml" '
|
|
. 'title="Follow-ups for ' . NormalToFree($username) . '" '
|
|
. 'href="' . ScriptUrl('action=rss;followup=' . UrlEncode($username))
|
|
. '" />' if $username;
|
|
return $html;
|
|
}
|
|
|
|
sub GetCss { # prevent javascript injection
|
|
my @css = map { my $x = $_; $x =~ s/\".*//; $x; } split(/\s+/, GetParam('css', ''));
|
|
push (@css, ref $StyleSheet ? @$StyleSheet : $StyleSheet) if $StyleSheet and not @css;
|
|
if ($IndexHash{$StyleSheetPage} and not @css) {
|
|
push (@css, "$ScriptName?action=browse;id=" . UrlEncode($StyleSheetPage) . ";raw=1;mime-type=text/css")
|
|
}
|
|
push (@css, 'https://oddmuse.org/default.css') unless @css;
|
|
return join('', map { qq(<link type="text/css" rel="stylesheet" href="$_" />) } @css);
|
|
}
|
|
|
|
sub PrintPageContent {
|
|
my ($text, $revision, $comment) = @_;
|
|
print $q->start_div({-class=>'content browse', -lang=>GetLanguage($text)});
|
|
# This is a lot like PrintPageHtml except that it also works for older revisions
|
|
if ($revision eq '' and $Page{blocks} and GetParam('cache', $UseCache) > 0) {
|
|
PrintCache();
|
|
} else {
|
|
my $savecache = ($Page{revision} > 0 and $revision eq ''); # new page not cached
|
|
PrintWikiToHTML($text, $savecache, $revision); # unlocked, with anchors, unlocked
|
|
}
|
|
if ($comment) {
|
|
print $q->start_div({-class=>'preview'}), $q->hr();
|
|
print $q->h2(T('Preview:'));
|
|
# no caching, current revision, unlocked
|
|
PrintWikiToHTML(AddComment('', $comment));
|
|
print $q->hr(), $q->h2(T('Preview only, not yet saved')), $q->end_div();
|
|
}
|
|
print $q->end_div();
|
|
}
|
|
|
|
sub PrintFooter {
|
|
my ($id, $rev, $comment, $page) = @_;
|
|
if (GetParam('embed', $EmbedWiki)) {
|
|
print $q->end_html, "\n";
|
|
return;
|
|
}
|
|
PrintMyContent($id) if defined(&PrintMyContent);
|
|
foreach my $sub (@MyFooters) {
|
|
print $sub->(@_);
|
|
}
|
|
print $q->end_html, "\n";
|
|
}
|
|
|
|
sub WrapperEnd { # called via @MyFooters
|
|
return $q->start_div({-class=>'wrapper close'}) . $q->end_div() . $q->end_div(); # closes content
|
|
}
|
|
|
|
sub DefaultFooter { # called via @MyFooters
|
|
my ($id, $rev, $comment, $page) = @_;
|
|
my $html = $q->start_div({-class=>'footer'}) . $q->hr();
|
|
$html .= GetGotoBar($id) if GetParam('toplinkbar', $TopLinkBar) != 1;
|
|
$html .= GetFooterLinks($id, $rev);
|
|
$html .= GetFooterTimestamp($id, $rev, $page);
|
|
$html .= GetSearchForm() if GetParam('topsearchform', $TopSearchForm) != 1;
|
|
if ($DataDir =~ m|/tmp/|) {
|
|
$html .= $q->p($q->strong(T('Warning') . ': ')
|
|
. Ts('Database is stored in temporary directory %s', $DataDir));
|
|
}
|
|
$html .= T($FooterNote) if $FooterNote;
|
|
$html .= $q->p(Ts('%s seconds', (time - $Now))) if GetParam('timing', 0);
|
|
$html .= $q->end_div();
|
|
return $html;
|
|
}
|
|
|
|
sub GetFooterTimestamp {
|
|
my ($id, $rev, $page) = @_;
|
|
$page //= \%Page;
|
|
if ($id and $rev ne 'history' and $rev ne 'edit' and $page->{revision}) {
|
|
my @elements = (($rev eq '' ? T('Last edited') : T('Edited')), TimeToText($page->{ts}),
|
|
Ts('by %s', GetAuthorLink($page->{username})));
|
|
push(@elements, ScriptLinkDiff(2, $id, T('(diff)'), $rev)) if $UseDiff and $page->{revision} > 1;
|
|
return $q->div({-class=>'time'}, @elements);
|
|
}
|
|
return '';
|
|
}
|
|
|
|
sub GetFooterLinks {
|
|
my ($id, $rev) = @_;
|
|
my @elements;
|
|
if ($id and $rev ne 'history' and $rev ne 'edit') {
|
|
if ($CommentsPattern) {
|
|
if ($id =~ /$CommentsPattern/) {
|
|
push(@elements, GetPageLink($1, undef, 'original', T('a'))) if $1;
|
|
} else {
|
|
push(@elements, GetPageLink($CommentsPrefix . $id, undef, 'comment', T('c')));
|
|
}
|
|
}
|
|
if (UserCanEdit($id, 0)) {
|
|
if ($rev) { # showing old revision
|
|
push(@elements, GetOldPageLink('edit', $id, $rev, Ts('Edit revision %s of this page', $rev)));
|
|
} else { # showing current revision
|
|
push(@elements, GetEditLink($id, T('Edit this page'), undef, T('e')));
|
|
}
|
|
} else { # no permission or generated page
|
|
push(@elements, ScriptLink('action=password', T('This page is read-only'), 'password'));
|
|
}
|
|
}
|
|
push(@elements, GetHistoryLink($id, T('View other revisions'))) if $Action{history} and $id and $rev ne 'history';
|
|
push(@elements, GetPageLink($id, T('View current revision')),
|
|
GetRCLink($id, T('View all changes'))) if $Action{history} and $rev ne '';
|
|
if ($Action{contrib} and $id and $rev eq 'history') {
|
|
push(@elements, ScriptLink("action=contrib;id=" . UrlEncode($id), T('View contributors'), 'contrib'));
|
|
}
|
|
if ($Action{admin} and GetParam('action', '') ne 'admin') {
|
|
my $action = 'action=admin';
|
|
$action .= ';id=' . UrlEncode($id) if $id;
|
|
push(@elements, ScriptLink($action, T('Administration'), 'admin'));
|
|
}
|
|
return @elements ? $q->div({-class=>'edit bar'}, @elements) : '';
|
|
}
|
|
|
|
sub GetCommentForm {
|
|
my ($id, $rev, $comment) = @_;
|
|
if ($CommentsPattern ne '' and $id and $rev ne 'history' and $rev ne 'edit'
|
|
and $id =~ /$CommentsPattern/ and UserCanEdit($id, 0, 1)) {
|
|
my $html = $q->div({-class=>'comment'},
|
|
GetFormStart(undef, undef, 'comment'),
|
|
$q->p(GetHiddenValue('title', $id),
|
|
$q->label({-for=>'aftertext', -accesskey=>T('c')},
|
|
T('Add your comment here:')), $q->br(),
|
|
GetTextArea('aftertext', $comment, 10)),
|
|
$EditNote,
|
|
$q->p($q->span({-class=>'username'},
|
|
$q->label({-for=>'username'}, T('Username:')), ' ',
|
|
$q->textfield(-name=>'username', -id=>'username',
|
|
-default=>GetParam('username', ''),
|
|
-override=>1, -size=>20, -maxlength=>50)),
|
|
$q->span({-class=>'homepage'},
|
|
$q->label({-for=>'homepage'}, T('Homepage URL:')), ' ',
|
|
$q->textfield(-name=>'homepage', -id=>'homepage',
|
|
-default=>GetParam('homepage', ''),
|
|
-override=>1, -size=>40, -maxlength=>100))),
|
|
$q->p($q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save')), ' ',
|
|
$q->submit(-name=>'Preview', -accesskey=>T('p'), -value=>T('Preview'))),
|
|
$q->end_form());
|
|
foreach my $sub (@MyFormChanges) {
|
|
$html = $sub->($html, 'comment');
|
|
}
|
|
return $html;
|
|
}
|
|
return '';
|
|
}
|
|
|
|
sub GetFormStart {
|
|
my ($ignore, $method, $class) = @_;
|
|
$method ||= 'post';
|
|
$class ||= 'form';
|
|
return $q->start_multipart_form(-method=>$method, -action=>$FullUrl,
|
|
-accept_charset=>'utf-8', -class=>$class);
|
|
}
|
|
|
|
sub GetSearchForm {
|
|
my $html = GetFormStart(undef, 'get', 'search') . $q->start_p;
|
|
$html .= $q->label({-for=>'search'}, T('Search:')) . ' '
|
|
. $q->textfield(-name=>'search', -id=>'search', -size=>15, -accesskey=>T('f')) . ' ';
|
|
if (GetParam('search') ne '' and UserIsAdmin()) { # see DoBrowseRequest
|
|
$html .= $q->label({-for=>'replace'}, T('Replace:')) . ' '
|
|
. $q->textfield(-name=>'replace', -id=>'replace', -size=>20) . ' '
|
|
. $q->label({-for=>'delete', -title=>'If you want to replace matches with the empty string'}, T('Delete')) . ' '
|
|
. $q->input({-type=>'checkbox', -name=>'delete'})
|
|
. $q->submit('preview', T('Preview'));
|
|
}
|
|
if (GetParam('matchingpages', $MatchingPages)) {
|
|
$html .= $q->label({-for=>'matchingpage'}, T('Filter:')) . ' '
|
|
. $q->textfield(-name=>'match', -id=>'matchingpage', -size=>15) . ' ';
|
|
}
|
|
if (%Languages) {
|
|
$html .= $q->label({-for=>'searchlang'}, T('Language:')) . ' '
|
|
. $q->textfield(-name=>'lang', -id=>'searchlang', -size=>5, -default=>GetParam('lang', '')) . ' ';
|
|
}
|
|
$html .= $q->submit('dosearch', T('Go!')) . $q->end_p . $q->end_form;
|
|
return $html;
|
|
}
|
|
|
|
sub GetGotoBar { # ignore $id parameter
|
|
return $q->span({-class=>'gotobar bar'}, (map { GetPageLink($_) }
|
|
@UserGotoBarPages), $UserGotoBar);
|
|
}
|
|
|
|
# return list of summaries between two revisions, assuming the open page is the upper one
|
|
sub DiffSummary {
|
|
my ($current, $from, $to) = @_;
|
|
my @summaries = ($current); # the current summary is not in a kept file
|
|
unshift(@summaries, map { GetKeptRevision($_)->{summary} } ($from + 1 .. $to - 1)) if $from and $to;
|
|
my ($last, @result);
|
|
for my $summary (@summaries) {
|
|
$summary =~ s/^\s+//; # squish leading whitespace
|
|
next unless $summary; # not empty
|
|
next if $summary eq $last; # not a repeat
|
|
push(@result, QuoteHtml($summary));
|
|
$last = $summary;
|
|
}
|
|
return '' unless @result;
|
|
return $q->p({-class=>'summary'}, T('Summary:'), $result[0]) if @result == 1;
|
|
return $q->div({-class=>'summary'}, $q->p(T('Summary:')), $q->ul($q->li(\@result)));
|
|
}
|
|
|
|
sub PrintHtmlDiff {
|
|
my ($type, $old, $page, $current) = @_;
|
|
$page //= \%Page;
|
|
$current //= $page->{revision};
|
|
$type = 2 if $old or $page->{revision} != $current; # explicit revisions means minor diffs!
|
|
$old //= $page->{$type == 1 ? 'lastmajor' : 'revision'} - 1; # default diff revision if none given
|
|
my ($diff, $summary);
|
|
my $intro = T('Last edit');
|
|
# use the cached diff and summary if possible
|
|
if ($old == $page->{$type == 1 ? 'lastmajor' : 'revision'} - 1) {
|
|
$diff = GetCacheDiff($type == 1 ? 'major' : 'minor', $page);
|
|
# just add the last diff in the right format
|
|
$summary = DiffSummary($page->{$type == 1 ? 'lastmajorsummary' : 'summary'});
|
|
}
|
|
# if there was no cached diff: compute it, and new intro
|
|
if (not $diff and $old > 0) {
|
|
($diff, my $keptPage) = GetKeptDiff($page->{text}, $old);
|
|
my $to = $page->{revision} != $current ? Ts('revision %s', $page->{revision}) : T('current revision');
|
|
$intro = Tss('Difference between revision %1 and %2', $old, $to);
|
|
$summary = DiffSummary($page->{summary}, $old, $page->{revision});
|
|
}
|
|
# if this is the last major diff and there are minor diffs to look at, and we
|
|
# didn't request a particular old revision
|
|
if ($type == 1 and $page->{lastmajor} and $page->{lastmajor} != $current) {
|
|
$intro = Ts('Last major edit (%s)', ScriptLinkDiff(2, $OpenPageName, T('later minor edits'),
|
|
undef, $page->{lastmajor} || 1));
|
|
}
|
|
$diff =~ s!<p><strong>(.*?)</strong></p>!'<p><strong>' . T($1) . '</strong></p>'!eg;
|
|
$diff ||= T('No diff available.');
|
|
print $q->div({-class=>'diff'}, $q->p($q->b($intro)), $summary, $diff);
|
|
}
|
|
|
|
sub GetCacheDiff {
|
|
my ($type, $page) = @_;
|
|
my $diff = $page->{"diff-$type"};
|
|
$diff = $page->{"diff-minor"} if $diff eq '1'; # if major eq minor diff
|
|
return $diff;
|
|
}
|
|
|
|
sub GetKeptDiff {
|
|
my ($new, $revision) = @_;
|
|
$revision ||= 1;
|
|
my ($revisionPage, $rev) = GetTextRevision($revision, 1);
|
|
return '', $revisionPage unless $rev;
|
|
return T("The two revisions are the same."), $revisionPage if $revisionPage->{text} eq $new;
|
|
return GetDiff($revisionPage->{text}, $new, $rev), $revisionPage;
|
|
}
|
|
|
|
sub DoDiff { # Actualy call the diff program
|
|
CreateDir($TempDir);
|
|
my $oldName = "$TempDir/old";
|
|
my $newName = "$TempDir/new";
|
|
RequestLockDir('diff') or return '';
|
|
WriteStringToFile($oldName, $_[0]);
|
|
WriteStringToFile($newName, $_[1]);
|
|
my $command = encode_utf8("diff -- \Q$oldName\E \Q$newName\E");
|
|
my $diff_out = decode_utf8(qx($command));
|
|
ReleaseLockDir('diff');
|
|
$diff_out =~ s/\n\K\\ No newline.*\n//g; # Get rid of common complaint.
|
|
# No need to unlink temp files--next diff will just overwrite.
|
|
return $diff_out;
|
|
}
|
|
|
|
sub GetDiff {
|
|
my ($old, $new, $revision) = @_;
|
|
my $old_is_file = (TextIsFile($old))[0] || '';
|
|
my $old_is_image = ($old_is_file =~ /^image\//);
|
|
my $new_is_file = TextIsFile($new);
|
|
if ($old_is_file or $new_is_file) {
|
|
return $q->p($q->strong(T('Old revision:')))
|
|
. $q->div({-class=>'old'}, # don't pring new revision, because that's the one that gets shown!
|
|
$q->p($old_is_file ? GetDownloadLink($OpenPageName, $old_is_image, $revision) : $old))
|
|
}
|
|
$old =~ s/[\r\n]+/\n/g;
|
|
$new =~ s/[\r\n]+/\n/g;
|
|
return ImproveDiff(DoDiff($old, $new));
|
|
}
|
|
|
|
sub ImproveDiff { # NO NEED TO BE called within a diff lock
|
|
my $diff = QuoteHtml(shift);
|
|
$diff =~ tr/\r//d;
|
|
my @hunks = split (/^(\d+,?\d*[adc]\d+,?\d*\n)/m, $diff);
|
|
my $result = shift (@hunks); # intro
|
|
while ($#hunks > 0) { # at least one header and a real hunk
|
|
my $header = shift (@hunks);
|
|
$header =~ s|^(\d+.*c.*)|<p><strong>Changed:</strong></p>| # T('Changed:')
|
|
or $header =~ s|^(\d+.*d.*)|<p><strong>Deleted:</strong></p>| # T('Deleted:')
|
|
or $header =~ s|^(\d+.*a.*)|<p><strong>Added:</strong></p>|; # T('Added:')
|
|
$result .= $header;
|
|
my $chunk = shift (@hunks);
|
|
my ($old, $new) = split (/\n---\n/, $chunk, 2);
|
|
if ($old and $new) {
|
|
($old, $new) = DiffMarkWords($old, $new);
|
|
$result .= "$old<p><strong>to</strong></p>\n$new"; # T('to')
|
|
} else {
|
|
if (substr($chunk, 0, 2) eq '&g') {
|
|
$result .= DiffAddPrefix(DiffStripPrefix($chunk), '> ', 'new');
|
|
} else {
|
|
$result .= DiffAddPrefix(DiffStripPrefix($chunk), '< ', 'old');
|
|
}
|
|
}
|
|
}
|
|
return $result;
|
|
}
|
|
|
|
sub DiffMarkWords {
|
|
my ($old, $new) = map { DiffStripPrefix($_) } @_;
|
|
my @diffs = grep(/^\d/, split(/\n/, DoDiff(join("\n", split(/\s+|\b/, $old)) . "\n",
|
|
join("\n", split(/\s+|\b/, $new)) . "\n")));
|
|
foreach my $diff (reverse @diffs) { # so that new html tags don't confuse word counts
|
|
my ($start1, $end1, $type, $start2, $end2) = $diff =~ /^(\d+),?(\d*)([adc])(\d+),?(\d*)$/gm;
|
|
if ($type eq 'd' or $type eq 'c') {
|
|
$end1 ||= $start1;
|
|
$old = DiffHtmlMarkWords($old, $start1, $end1);
|
|
}
|
|
if ($type eq 'a' or $type eq 'c') {
|
|
$end2 ||= $start2;
|
|
$new = DiffHtmlMarkWords($new, $start2, $end2);
|
|
}
|
|
}
|
|
return (DiffAddPrefix($old, '< ', 'old'),
|
|
DiffAddPrefix($new, '> ', 'new'));
|
|
}
|
|
|
|
sub DiffHtmlMarkWords {
|
|
my ($text, $start, $end) = @_;
|
|
my @fragments = split(/(\s+|\b)/, $text);
|
|
splice(@fragments, 2 * ($start - 1), 0, '<strong class="changes">');
|
|
splice(@fragments, 2 * $end, 0, '</strong>');
|
|
my $result = join('', @fragments);
|
|
$result =~ s!&<(/?)strong([^>]*)>(amp|[gl]t);!<$1strong$2>&$3;!g;
|
|
$result =~ s!&(amp|[gl]t)<(/?)strong([^>]*)>;!&$1;<$2strong$3>!g;
|
|
return $result;
|
|
}
|
|
|
|
sub DiffStripPrefix {
|
|
my $str = shift;
|
|
$str =~ s/^&[lg]t; //gm;
|
|
return $str;
|
|
}
|
|
|
|
sub DiffAddPrefix {
|
|
my ($str, $prefix, $class) = @_;
|
|
my @lines = split(/\n/, $str);
|
|
for my $line (@lines) {
|
|
$line = $prefix . $line;
|
|
}
|
|
return $q->div({-class=>$class}, $q->p(join($q->br(), @lines)));
|
|
}
|
|
|
|
sub ParseData {
|
|
my $data = shift;
|
|
my %result;
|
|
while ($data =~ /(\S+?): (.*?)(?=\n[^ \t]|\Z)/gs) {
|
|
my ($key, $value) = ($1, $2);
|
|
$value =~ s/\n\t/\n/g;
|
|
$result{$key} = $value;
|
|
}
|
|
# return unless %result; # undef instead of empty hash # TODO should we do that?
|
|
return wantarray ? %result : \%result; # return list sometimes for compatibility
|
|
}
|
|
|
|
sub OpenPage { # Sets global variables
|
|
my $id = shift;
|
|
return if $OpenPageName eq $id;
|
|
if ($IndexHash{$id}) {
|
|
%Page = %{ParseData(ReadFileOrDie(GetPageFile($id)))};
|
|
} else {
|
|
%Page = ();
|
|
$Page{ts} = $Now;
|
|
$Page{revision} = 0;
|
|
}
|
|
$OpenPageName = $id;
|
|
}
|
|
|
|
sub GetTextAtTime { # call with opened page, return $minor if all pages between now and $ts are minor!
|
|
my $ts = shift;
|
|
my $minor = $Page{minor};
|
|
return ($Page{text}, $minor, 0) if $Page{ts} <= $ts; # current page is old enough
|
|
return ($DeletedPage, $minor, 0) if $Page{revision} == 1 and $Page{ts} > $ts; # created after $ts
|
|
my $keep = {}; # info may be needed after the loop
|
|
foreach my $revision (GetKeepRevisions($OpenPageName)) {
|
|
$keep = GetKeptRevision($revision);
|
|
# $minor = 0 unless defined $keep; # TODO?
|
|
$minor = 0 if not $keep->{minor} and $keep->{ts} >= $ts; # ignore keep{minor} if keep{ts} is too old
|
|
return ($keep->{text}, $minor, 0) if $keep->{ts} <= $ts;
|
|
}
|
|
return ($DeletedPage, $minor, 0) if $keep->{revision} == 1; # then the page was created after $ts!
|
|
return ($keep->{text}, $minor, $keep->{ts}); # the oldest revision available is not old enough
|
|
}
|
|
|
|
sub GetTextRevision {
|
|
my ($revision, $quiet) = @_;
|
|
$revision =~ s/\D//g; # Remove non-numeric chars
|
|
return wantarray ? (\%Page, $revision) : \%Page unless $revision and $revision ne $Page{revision};
|
|
my $keep = GetKeptRevision($revision);
|
|
if (not defined $keep) {
|
|
$Message .= $q->p(Ts('Revision %s not available', $revision)
|
|
. ' (' . T('showing current revision instead') . ')') unless $quiet;
|
|
return wantarray ? (\%Page, '') : \%Page;
|
|
}
|
|
$Message .= $q->p(Ts('Showing revision %s', $revision)) unless $quiet;
|
|
return wantarray ? ($keep, $revision) : $keep;
|
|
}
|
|
|
|
sub GetPageContent {
|
|
my $id = shift;
|
|
return ParseData(ReadFileOrDie(GetPageFile($id)))->{text} if $IndexHash{$id};
|
|
return '';
|
|
}
|
|
|
|
sub GetKeptRevision { # Call after OpenPage
|
|
my ($status, $data) = ReadFile(GetKeepFile($OpenPageName, (shift)));
|
|
return unless $status;
|
|
return ParseData($data);
|
|
}
|
|
|
|
sub GetPageFile {
|
|
my ($id) = @_;
|
|
return "$PageDir/$id.pg";
|
|
}
|
|
|
|
sub GetKeepFile {
|
|
my ($id, $revision) = @_; die "No revision for $id" unless $revision; #FIXME
|
|
return GetKeepDir($id) . "/$revision.kp";
|
|
}
|
|
|
|
sub GetKeepDir {
|
|
my $id = shift; die 'No id' unless $id; #FIXME
|
|
return "$KeepDir/$id";
|
|
}
|
|
|
|
sub GetKeepFiles {
|
|
return Glob(GetKeepDir(shift) . '/*.kp'); # files such as 1.kp, 2.kp, etc.
|
|
}
|
|
|
|
sub GetKeepRevisions {
|
|
my @result = sort {$b <=> $a} map { m/([0-9]+)\.kp$/; $1; } GetKeepFiles(shift);
|
|
return @result;
|
|
}
|
|
|
|
# Always call SavePage within a lock.
|
|
sub SavePage { # updating the cache will not change timestamp and revision!
|
|
ReportError(T('Cannot save a nameless page.'), '400 BAD REQUEST', 1) unless $OpenPageName;
|
|
ReportError(T('Cannot save a page without revision.'), '400 BAD REQUEST', 1) unless $Page{revision};
|
|
CreateDir($PageDir);
|
|
WriteStringToFile(GetPageFile($OpenPageName), EncodePage(%Page));
|
|
}
|
|
|
|
sub SaveKeepFile {
|
|
return if ($Page{revision} < 1); # Don't keep 'empty' revision
|
|
delete $Page{blocks}; # delete some info from the page
|
|
delete $Page{flags};
|
|
delete $Page{'diff-major'};
|
|
delete $Page{'diff-minor'};
|
|
$Page{'keep-ts'} = $Now; # expire only $KeepDays from $Now!
|
|
CreateDir($KeepDir);
|
|
CreateDir(GetKeepDir($OpenPageName));
|
|
WriteStringToFile(GetKeepFile($OpenPageName, $Page{revision}), EncodePage(%Page));
|
|
}
|
|
|
|
sub EncodePage {
|
|
my @data = @_;
|
|
my $result = '';
|
|
$result .= (shift @data) . ': ' . EscapeNewlines(shift @data) . "\n" while (@data);
|
|
return $result;
|
|
}
|
|
|
|
sub EscapeNewlines {
|
|
$_[0] =~ s/\n/\n\t/g; # modify original instead of copying
|
|
return $_[0];
|
|
}
|
|
|
|
sub ExpireAllKeepFiles {
|
|
foreach my $name (AllPagesList()) {
|
|
print $q->br(), GetPageLink($name);
|
|
OpenPage($name);
|
|
my $delete = PageDeletable();
|
|
if ($delete) {
|
|
my $status = DeletePage($OpenPageName);
|
|
print ' ', ($status ? T('not deleted:') . ' ' . $status : T('deleted'));
|
|
} else {
|
|
ExpireKeepFiles();
|
|
}
|
|
}
|
|
}
|
|
|
|
sub ExpireKeepFiles { # call with opened page
|
|
return unless $KeepDays;
|
|
my $expirets = $Now - ($KeepDays * 86400); # 24*60*60
|
|
foreach my $revision (GetKeepRevisions($OpenPageName)) {
|
|
my $keep = GetKeptRevision($revision);
|
|
next if $keep->{'keep-ts'} >= $expirets;
|
|
next if $KeepMajor and $keep->{revision} == $Page{lastmajor};
|
|
Unlink(GetKeepFile($OpenPageName, $revision));
|
|
}
|
|
}
|
|
|
|
sub ReadFile {
|
|
if (open(my $IN, '<:encoding(UTF-8)', encode_utf8(shift))) {
|
|
local $/ = undef; # Read complete files
|
|
my $data=<$IN>;
|
|
close $IN;
|
|
return (1, $data);
|
|
}
|
|
return (0, '');
|
|
}
|
|
|
|
sub ReadFileOrDie {
|
|
my ($file) = @_;
|
|
my ($status, $data);
|
|
($status, $data) = ReadFile($file);
|
|
if (not $status) {
|
|
ReportError(Ts('Cannot open %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
|
|
}
|
|
return $data;
|
|
}
|
|
|
|
sub WriteStringToFile {
|
|
my ($file, $string) = @_;
|
|
open(my $OUT, '>:encoding(UTF-8)', encode_utf8($file))
|
|
or ReportError(Ts('Cannot write %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
|
|
print $OUT $string;
|
|
close($OUT);
|
|
}
|
|
|
|
sub AppendStringToFile {
|
|
my ($file, $string) = @_;
|
|
open(my $OUT, '>>:encoding(UTF-8)', encode_utf8($file))
|
|
or ReportError(Ts('Cannot write %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
|
|
print $OUT $string;
|
|
close($OUT);
|
|
}
|
|
|
|
sub IsFile { return -f encode_utf8(shift); }
|
|
sub IsDir { return -d encode_utf8(shift); }
|
|
sub ZeroSize { return -z encode_utf8(shift); }
|
|
sub Unlink { return unlink(map { encode_utf8($_) } @_); }
|
|
sub Modified { return (stat(encode_utf8(shift)))[9]; }
|
|
sub Glob { return map { decode_utf8($_) } bsd_glob(encode_utf8(shift)); }
|
|
sub ChangeMod { return chmod(shift, map { encode_utf8($_) } @_); }
|
|
sub Rename { return rename(encode_utf8($_[0]), encode_utf8($_[1])); }
|
|
sub RemoveDir { return rmdir(encode_utf8(shift)); }
|
|
sub ChangeDir { return chdir(encode_utf8(shift)); }
|
|
|
|
sub CreateDir {
|
|
my ($newdir) = @_;
|
|
return if IsDir($newdir);
|
|
mkdir(encode_utf8($newdir), 0775)
|
|
or ReportError(Ts('Cannot create %s', $newdir) . ": $!", '500 INTERNAL SERVER ERROR');
|
|
}
|
|
|
|
sub GetLockedPageFile {
|
|
my $id = shift;
|
|
return "$PageDir/$id.lck";
|
|
}
|
|
|
|
sub RequestLockDir {
|
|
my ($name, $tries, $wait, $error, $retried) = @_;
|
|
$tries ||= 4;
|
|
$wait ||= 2;
|
|
CreateDir($TempDir);
|
|
my $lock = $LockDir . $name;
|
|
my $n = 0;
|
|
# Cannot use CreateDir because we don't want to skip mkdir if the directory
|
|
# already exists.
|
|
while (mkdir(encode_utf8($lock), 0555) == 0) {
|
|
if ($n++ >= $tries) {
|
|
my $ts = Modified($lock);
|
|
if ($Now - $ts > $LockExpiration and $LockExpires{$name} and not $retried) { # XXX should we remove this now?
|
|
ReleaseLockDir($name); # try to expire lock (no checking)
|
|
return 1 if RequestLockDir($name, undef, undef, undef, 1);
|
|
}
|
|
return 0 unless $error;
|
|
ReportError(Ts('Could not get %s lock', $name) . ": $!. ",
|
|
'503 SERVICE UNAVAILABLE', undef,
|
|
Ts('The lock was created %s.', CalcTimeSince($Now - $ts))
|
|
. ($retried && ' ' . T('Maybe the user running this script is no longer allowed to remove the lock directory?'))
|
|
. ' ' . T('Sometimes locks are left behind if a job crashes.') . ' '
|
|
. ($Now - $ts < 600 ? T('After ten minutes, you could try to unlock the wiki.')
|
|
: ScriptLink('action=unlock', T('Unlock Wiki'), 'unlock')));
|
|
}
|
|
sleep($wait);
|
|
}
|
|
$Locks{$name} = 1;
|
|
return 1;
|
|
}
|
|
|
|
sub HandleSignals {
|
|
my ($signal) = @_; # TODO should we pass it to CleanLock?
|
|
CleanLock($_) foreach keys %Locks;
|
|
exit; # let's count it as graceful exit
|
|
}
|
|
|
|
sub CleanLock {
|
|
my ($name) = @_;
|
|
$LockCleaners{$name}->() if exists $LockCleaners{$name};
|
|
ReleaseLockDir($name); # TODO should we log this?
|
|
}
|
|
|
|
sub ReleaseLockDir {
|
|
my $name = shift; # We don't check whether we succeeded.
|
|
RemoveDir($LockDir . $name); # Before fixing, make sure we only call this
|
|
delete $Locks{$name}; # when we know the lock exists.
|
|
}
|
|
|
|
sub RequestLockOrError {
|
|
return RequestLockDir('main', 10, 3, 1); # 10 tries, 3 second wait, die on error
|
|
}
|
|
|
|
sub ReleaseLock {
|
|
ReleaseLockDir('main');
|
|
}
|
|
|
|
sub ForceReleaseLock {
|
|
my $pattern = shift;
|
|
my $forced;
|
|
foreach my $name (Glob($pattern)) {
|
|
# First try to obtain lock (in case of normal edit lock)
|
|
$forced = 1 unless RequestLockDir($name, 5, 3, 0);
|
|
ReleaseLockDir($name); # Release the lock, even if we didn't get it. This should not happen.
|
|
}
|
|
return $forced;
|
|
}
|
|
|
|
sub DoUnlock {
|
|
my $message = '';
|
|
print GetHeader('', T('Unlock Wiki'), undef, 'nocache');
|
|
print $q->p(T('This operation may take several seconds...'));
|
|
for my $lock (@KnownLocks) {
|
|
if (ForceReleaseLock($lock)) {
|
|
$message .= $q->p(Ts('Forced unlock of %s lock.', $lock));
|
|
}
|
|
}
|
|
print $message || $q->p(T('No unlock required.'));
|
|
PrintFooter();
|
|
}
|
|
|
|
sub CalcDay {
|
|
my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift);
|
|
return sprintf('%4d-%02d-%02d', $year + 1900, $mon + 1, $mday);
|
|
}
|
|
|
|
sub CalcTime {
|
|
my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift);
|
|
return sprintf('%02d:%02d UTC', $hour, $min);
|
|
}
|
|
|
|
sub CalcTimeSince {
|
|
my $total = shift;
|
|
return Ts('%s hours ago', int($total/3600)) if ($total >= 7200);
|
|
return T('1 hour ago') if ($total >= 3600);
|
|
return Ts('%s minutes ago', int($total/60)) if ($total >= 120);
|
|
return T('1 minute ago') if ($total >= 60);
|
|
return Ts('%s seconds ago', int($total)) if ($total >= 2);
|
|
return T('1 second ago') if ($total == 1);
|
|
return T('just now');
|
|
}
|
|
|
|
sub TimeToText {
|
|
my $t = shift;
|
|
return CalcDay($t) . ' ' . CalcTime($t);
|
|
}
|
|
|
|
sub TimeToW3 { # Complete date plus hours and minutes: YYYY-MM-DDThh:mmTZD (eg 1997-07-16T19:20+01:00)
|
|
my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift); # use special UTC designator ("Z")
|
|
return sprintf('%4d-%02d-%02dT%02d:%02dZ', $year + 1900, $mon + 1, $mday, $hour, $min);
|
|
}
|
|
|
|
sub TimeToRFC822 {
|
|
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime(shift); # Sat, 07 Sep 2002 00:00:01 GMT
|
|
return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", qw(Sun Mon Tue Wed Thu Fri Sat)[$wday], $mday,
|
|
qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon], $year + 1900, $hour, $min, $sec);
|
|
}
|
|
|
|
sub GetHiddenValue {
|
|
my ($name, $value) = @_;
|
|
return $q->input({-type=>"hidden", -name=>$name, -value=>$value});
|
|
}
|
|
|
|
sub FreeToNormal { # trim all spaces and convert them to underlines
|
|
my $id = shift;
|
|
return '' unless $id;
|
|
$id =~ s/ /_/g;
|
|
$id =~ s/__+/_/g;
|
|
$id =~ s/^_//;
|
|
$id =~ s/_$//;
|
|
return UnquoteHtml($id);
|
|
}
|
|
|
|
sub ItemName {
|
|
my $id = shift; # id
|
|
return NormalToFree($id) unless GetParam('short', 1) and $RssStrip;
|
|
my $comment = $id =~ s/^($CommentsPrefix)//; # strip first so that ^ works
|
|
$id =~ s/^$RssStrip//;
|
|
$id = $CommentsPrefix . $id if $comment;
|
|
return NormalToFree($id);
|
|
}
|
|
|
|
sub NormalToFree { # returns HTML quoted title with spaces
|
|
my $title = shift;
|
|
$title =~ s/_/ /g;
|
|
return QuoteHtml($title);
|
|
}
|
|
|
|
sub UnWiki {
|
|
my $str = shift;
|
|
return $str unless $WikiLinks and $str =~ /^$LinkPattern$/;
|
|
$str =~ s/([[:lower:]])([[:upper:]])/$1 $2/g;
|
|
return $str;
|
|
}
|
|
|
|
sub DoEdit {
|
|
my ($id, $newText, $preview) = @_;
|
|
UserCanEditOrDie($id);
|
|
my $upload = GetParam('upload', undef);
|
|
if ($upload and not $UploadAllowed and not UserIsAdmin()) {
|
|
ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
|
|
}
|
|
OpenPage($id);
|
|
my ($revisionPage, $revision) = GetTextRevision(GetParam('revision', ''), 1); # maybe revision reset!
|
|
my $oldText = $preview ? $newText : $revisionPage->{text};
|
|
my $isFile = TextIsFile($oldText);
|
|
$upload //= $isFile;
|
|
if ($upload and not $UploadAllowed and not UserIsAdmin()) {
|
|
ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
|
|
}
|
|
if ($upload) { # shortcut lots of code
|
|
$revision = '';
|
|
$preview = 0;
|
|
} elsif ($isFile) {
|
|
$oldText = '';
|
|
}
|
|
my $header;
|
|
if ($revision and not $upload) {
|
|
$header = Ts('Editing revision %s of', $revision) . ' ' . NormalToFree($id);
|
|
} else {
|
|
$header = Ts('Editing %s', NormalToFree($id));
|
|
}
|
|
print GetHeader('', $header), $q->start_div({-class=>'content edit'});
|
|
if ($preview and not $upload) {
|
|
print $q->start_div({-class=>'preview'});
|
|
print $q->h2(T('Preview:'));
|
|
PrintWikiToHTML($oldText); # no caching, current revision, unlocked
|
|
print $q->hr(), $q->h2(T('Preview only, not yet saved')), $q->end_div();
|
|
}
|
|
if ($revision) {
|
|
print $q->strong(Ts('Editing old revision %s.', $revision) . ' '
|
|
. T('Saving this page will replace the latest revision with this text.'))
|
|
}
|
|
print GetEditForm($id, $upload, $oldText, $revision), $q->end_div();
|
|
PrintFooter($id, 'edit');
|
|
}
|
|
|
|
sub GetEditForm {
|
|
my ($page_name, $upload, $oldText, $revision) = @_;
|
|
my $html = GetFormStart(undef, undef, $upload ? 'edit upload' : 'edit text') # protected by questionasker
|
|
.$q->p(GetHiddenValue("title", $page_name),
|
|
($revision ? GetHiddenValue('revision', $revision) : ''),
|
|
GetHiddenValue('oldtime', GetParam('oldtime', $Page{ts})), # prefer parameter over actual timestamp
|
|
($upload ? GetUpload() : GetTextArea('text', $oldText)));
|
|
my $summary = UnquoteHtml(GetParam('summary', ''))
|
|
|| ($Now - $Page{ts} < ($SummaryHours * 3600) ? $Page{summary} : '');
|
|
$html .= $q->p(T('Summary:').$q->br().GetTextArea('summary', $summary, 2))
|
|
.$q->p($q->checkbox(-name=>'recent_edit', -checked=>(GetParam('recent_edit', '') eq 'on'),
|
|
-label=>T('This change is a minor edit.')));
|
|
$html .= T($EditNote) if $EditNote; # Allow translation
|
|
my $username = GetParam('username', '');
|
|
$html .= $q->p($q->label({-for=>'username'}, T('Username:')).' '
|
|
.$q->textfield(-name=>'username', -id=>'username', -default=>$username,
|
|
-override=>1, -size=>20, -maxlength=>50))
|
|
.$q->p($q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save')),
|
|
($upload ? '' : ' ' . $q->submit(-name=>'Preview', -accesskey=>T('p'), -value=>T('Preview'))).
|
|
' '.$q->submit(-name=>'Cancel', -value=>T('Cancel')));
|
|
if ($upload) {
|
|
$html .= $q->p(ScriptLink('action=edit;upload=0;id=' . UrlEncode($page_name), T('Replace this file with text'), 'upload'));
|
|
} elsif ($UploadAllowed or UserIsAdmin()) {
|
|
$html .= $q->p(ScriptLink('action=edit;upload=1;id=' . UrlEncode($page_name), T('Replace this text with a file'), 'upload'));
|
|
}
|
|
$html .= $q->end_form();
|
|
foreach my $sub (@MyFormChanges) {
|
|
$html = $sub->($html, 'edit', $upload);
|
|
}
|
|
return $html;
|
|
}
|
|
|
|
sub GetTextArea {
|
|
my ($name, $text, $rows) = @_;
|
|
return $q->textarea(-id=>$name, -name=>$name, -default=>$text, -rows=>$rows || 25, -columns=>78, -override=>1);
|
|
}
|
|
|
|
sub GetUpload {
|
|
return T('File to upload:') . ' ' . $q->filefield(-name=>'file', -size=>50, -maxlength=>100);
|
|
}
|
|
|
|
sub DoDownload {
|
|
my $id = shift;
|
|
OpenPage($id) if ValidIdOrDie($id);
|
|
print $q->header(-status=>'304 NOT MODIFIED') and return if FileFresh(); # FileFresh needs an OpenPage!
|
|
my ($revisionPage, $revision) = GetTextRevision(GetParam('revision', '')); # maybe revision reset!
|
|
my $text = $revisionPage->{text};
|
|
if (my ($type, $encoding) = TextIsFile($text)) {
|
|
my ($data) = $text =~ /^[^\n]*\n(.*)/s;
|
|
my %allowed = map {$_ => 1} @UploadTypes;
|
|
if (@UploadTypes and not $allowed{$type}) {
|
|
ReportError(Ts('Files of type %s are not allowed.', $type), '415 UNSUPPORTED MEDIA TYPE');
|
|
}
|
|
print GetHttpHeader($type, $Page{ts}, undef, $encoding);
|
|
require MIME::Base64;
|
|
binmode(STDOUT, ":pop:raw"); # need to pop utf8 for Windows users!?
|
|
print MIME::Base64::decode($data);
|
|
} else {
|
|
print GetHttpHeader('text/plain', $Page{ts});
|
|
print $text;
|
|
}
|
|
}
|
|
|
|
sub DoPassword {
|
|
my $id = shift;
|
|
print GetHeader('', T('Password')), $q->start_div({-class=>'content password'});
|
|
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.'));
|
|
if (not $AdminPass and not $EditPass) {
|
|
print $q->p(T('This site does not use admin or editor passwords.'));
|
|
} else {
|
|
if (UserIsAdmin()) {
|
|
print $q->p(T('You are currently an administrator on this site.'));
|
|
} elsif (UserIsEditor()) {
|
|
print $q->p(T('You are currently an editor on this site.'));
|
|
} else {
|
|
print $q->p(T('You are a normal user on this site.'));
|
|
if (not GetParam('pwd')) {
|
|
print $q->p(T('You do not have a password set.'));
|
|
} else {
|
|
print $q->p(T('Your password does not match any of the administrator or editor passwords.'));
|
|
}
|
|
}
|
|
print GetFormStart(undef, undef, 'password'),
|
|
$q->p(GetHiddenValue('action', 'password'), T('Password:'), ' ',
|
|
$q->password_field(-name=>'pwd', -size=>20, -maxlength=>64),
|
|
$q->hidden(-name=>'id', -value=>$id),
|
|
$q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save'))),
|
|
$q->end_form;
|
|
}
|
|
if ($id) {
|
|
print $q->p(ScriptLink('action=browse;id=' . UrlEncode($id) . ';time=' . time,
|
|
Ts('Return to %s', NormalToFree($id))));
|
|
}
|
|
print $q->end_div();
|
|
PrintFooter();
|
|
}
|
|
|
|
sub UserIsEditorOrError {
|
|
UserIsEditor()
|
|
or ReportError(T('This operation is restricted to site editors only...'), '403 FORBIDDEN');
|
|
return 1;
|
|
}
|
|
|
|
sub UserIsAdminOrError {
|
|
UserIsAdmin()
|
|
or ReportError(T('This operation is restricted to administrators only...'), '403 FORBIDDEN');
|
|
return 1;
|
|
}
|
|
|
|
sub UserCanEditOrDie {
|
|
my $id = shift;
|
|
ValidIdOrDie($id);
|
|
if (not UserCanEdit($id, 1)) {
|
|
my $rule = UserIsBanned();
|
|
if ($rule) {
|
|
ReportError(T('Edit Denied'), '403 FORBIDDEN', undef,
|
|
$q->p(T('Editing not allowed: user, ip, or network is blocked.')),
|
|
$q->p(T('Contact the wiki administrator for more information.')),
|
|
$q->p(Ts('The rule %s matched for you.', $rule) . ' '
|
|
. Ts('See %s for more information.', GetPageLink($BannedHosts))));
|
|
} else {
|
|
ReportError(T('Edit Denied'), '403 FORBIDDEN', undef,
|
|
$q->p(Ts('Editing not allowed: %s is read-only.', NormalToFree($id))));
|
|
}
|
|
}
|
|
}
|
|
|
|
sub UserCanEdit {
|
|
my ($id, $editing, $comment) = @_;
|
|
return 0 if $id eq 'SampleUndefinedPage' or $id eq T('SampleUndefinedPage')
|
|
or $id eq 'Sample_Undefined_Page' or $id eq T('Sample_Undefined_Page');
|
|
return 1 if UserIsAdmin();
|
|
return 0 if $id ne '' and IsFile(GetLockedPageFile($id));
|
|
return 0 if $LockOnCreation{$id} and not IsFile(GetPageFile($id)); # new page
|
|
return 1 if UserIsEditor();
|
|
return 0 if not $EditAllowed or IsFile($NoEditFile);
|
|
return 0 if $editing and UserIsBanned(); # this call is more expensive
|
|
return 0 if $EditAllowed >= 2 and (not $CommentsPattern or $id !~ /$CommentsPattern/);
|
|
return 1 if $EditAllowed >= 3 and GetParam('recent_edit', '') ne 'on' # disallow minor comments
|
|
and ($comment or (GetParam('aftertext', '') and not GetParam('text', '')));
|
|
return 0 if $EditAllowed >= 3;
|
|
return 1;
|
|
}
|
|
|
|
sub UserIsBanned {
|
|
return 0 if GetParam('action', '') eq 'password'; # login is always ok
|
|
my $host = $q->remote_addr();
|
|
foreach (split(/\n/, GetPageContent($BannedHosts))) {
|
|
if (/^\s*([^#]\S+)/) { # all lines except empty lines and comments, trim whitespace
|
|
my $regexp = $1;
|
|
return $regexp if ($host =~ /$regexp/i);
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub UserIsAdmin {
|
|
return UserHasPassword(GetParam('pwd', ''), $AdminPass);
|
|
}
|
|
|
|
sub UserIsEditor {
|
|
return 1 if UserIsAdmin(); # Admin includes editor
|
|
return UserHasPassword(GetParam('pwd', ''), $EditPass);
|
|
}
|
|
|
|
sub UserHasPassword {
|
|
my ($pwd, $pass) = @_;
|
|
return 0 unless $pass;
|
|
if ($PassHashFunction ne '') {
|
|
no strict 'refs'; # TODO this is kept for compatibility. Feel free to remove it later (comment written on 2015-07-14)
|
|
$pwd = $PassHashFunction->($pwd . $PassSalt);
|
|
}
|
|
foreach (split(/\s+/, $pass)) {
|
|
return 1 if $pwd eq $_;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub BannedContent {
|
|
my $str = shift;
|
|
my @urls = $str =~ /$FullUrlPattern/g;
|
|
foreach (split(/\n/, GetPageContent($BannedContent))) {
|
|
next unless m/^\s*([^#]+?)\s*(#\s*(\d\d\d\d-\d\d-\d\d\s*)?(.*))?$/;
|
|
my ($regexp, $comment, $re) = ($1, $4, undef);
|
|
foreach my $url (@urls) {
|
|
eval { $re = qr/$regexp/i; };
|
|
if (defined($re) and $url =~ $re) {
|
|
return Tss('Rule "%1" matched "%2" on this page.', $regexp, $url) . ' '
|
|
. ($comment ? Ts('Reason: %s.', $comment) : T('Reason unknown.')) . ' '
|
|
. Ts('See %s for more information.', GetPageLink($BannedContent));
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub SortIndex {
|
|
my ($A, $B) = ($a, $b);
|
|
my $aIsComment = $A =~ s/^$CommentsPrefix//;
|
|
$B =~ s/^$CommentsPrefix//;
|
|
return $aIsComment ? 1 : -1 if $A eq $B;
|
|
$A cmp $B;
|
|
}
|
|
|
|
sub DoIndex {
|
|
my $raw = GetParam('raw', 0);
|
|
my $match = GetParam('match', '');
|
|
my $limit = GetParam('n', '');
|
|
my @pages = ();
|
|
my @menu = ($q->label({-for=>'indexmatch'}, T('Filter:')) . ' '
|
|
. $q->textfield(-name=>'match', -id=>'indexmatch', -size=>20));
|
|
foreach my $data (@IndexOptions) {
|
|
my ($option, $text, $default, $sub) = @$data;
|
|
my $value = GetParam($option, $default); # HTML checkbox warning!
|
|
$value = 0 if GetParam('manual', 0) and $value ne 'on';
|
|
push(@pages, $sub->()) if $value;
|
|
push(@menu, $q->checkbox(-name=>$option, -checked=>$value, -label=>$text));
|
|
}
|
|
@pages = grep /$match/i, @pages if $match;
|
|
@pages = sort SortIndex @pages;
|
|
@pages = @pages[0 .. $limit - 1] if $limit;
|
|
if ($raw) {
|
|
print GetHttpHeader('text/plain'); # and ignore @menu
|
|
} else {
|
|
print GetHeader('', T('Index of all pages'));
|
|
push(@menu, GetHiddenValue('manual', 1) . $q->submit(-value=>T('Go!')));
|
|
push(@menu, $q->b(Ts('(for %s)', GetParam('lang', '')))) if GetParam('lang', '');
|
|
print $q->start_div({-class=>'content index'}),
|
|
GetFormStart(undef, 'get', 'index'), GetHiddenValue('action', 'index'),
|
|
$q->p(join($q->br(), @menu)), $q->end_form(),
|
|
$q->h2(Ts('%s pages found.', ($#pages + 1))), $q->start_p();
|
|
}
|
|
PrintPage($_) foreach (@pages);
|
|
print $q->end_p(), $q->end_div() unless $raw;
|
|
PrintFooter() unless $raw;
|
|
}
|
|
|
|
sub PrintPage {
|
|
my $id = shift;
|
|
my $lang = GetParam('lang', 0);
|
|
if ($lang) {
|
|
OpenPage($id);
|
|
my @languages = split(/,/, $Page{languages});
|
|
next if (@languages and not grep(/$lang/, @languages));
|
|
}
|
|
if (GetParam('raw', 0)) {
|
|
if (GetParam('search', '') and GetParam('context', 1)) {
|
|
print "title: $id\n\n"; # for near links without full search
|
|
} else {
|
|
print $id, "\n";
|
|
}
|
|
} else {
|
|
print GetPageOrEditLink($id, NormalToFree($id)), $q->br();
|
|
}
|
|
}
|
|
|
|
sub AllPagesList {
|
|
my $refresh = GetParam('refresh', 0);
|
|
return @IndexList if @IndexList and not $refresh;
|
|
SetParam('refresh', 0) if $refresh;
|
|
return @IndexList if not $refresh and IsFile($IndexFile) and ReadIndex();
|
|
# If open fails just refresh the index
|
|
RefreshIndex();
|
|
return @IndexList;
|
|
}
|
|
|
|
sub ReadIndex {
|
|
my ($status, $rawIndex) = ReadFile($IndexFile); # not fatal
|
|
if ($status) {
|
|
@IndexList = split(/ /, $rawIndex);
|
|
%IndexHash = map {$_ => 1} @IndexList;
|
|
return @IndexList;
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub WriteIndex {
|
|
WriteStringToFile($IndexFile, join(' ', @IndexList));
|
|
}
|
|
|
|
sub RefreshIndex {
|
|
@IndexList = ();
|
|
%IndexHash = ();
|
|
# If file exists and cannot be changed, error!
|
|
my $locked = RequestLockDir('index', undef, undef, IsFile($IndexFile));
|
|
foreach (Glob("$PageDir/*.pg"), Glob("$PageDir/.*.pg")) {
|
|
next unless m|/.*/(.+)\.pg$|;
|
|
my $id = $1;
|
|
push(@IndexList, $id);
|
|
$IndexHash{$id} = 1;
|
|
}
|
|
WriteIndex() if $locked;
|
|
ReleaseLockDir('index') if $locked;
|
|
}
|
|
|
|
sub AddToIndex {
|
|
my ($id) = @_;
|
|
$IndexHash{$id} = 1;
|
|
@IndexList = sort(keys %IndexHash);
|
|
WriteIndex();
|
|
}
|
|
|
|
sub DoSearch {
|
|
my $string = shift || GetParam('search', '');
|
|
my $re = UnquoteHtml($string);
|
|
return DoIndex() if $string eq '';
|
|
eval { qr/$re/ } or $re = quotemeta($re);
|
|
my $replacement = GetParam('replace', undef);
|
|
my $raw = GetParam('raw', '');
|
|
my @results;
|
|
if ($replacement or GetParam('delete', 0)) {
|
|
return unless UserIsAdminOrError();
|
|
if (GetParam('preview', '')) { # Preview button was used
|
|
print GetHeader('', Ts('Preview: %s', $string . " → " . $replacement));
|
|
print $q->start_div({-class=>'content replacement'});
|
|
print GetFormStart(undef, 'post', 'replace');
|
|
print GetHiddenValue('search', $string);
|
|
print GetHiddenValue('replace', $replacement);
|
|
print GetHiddenValue('delete', GetParam('delete', 0));
|
|
print $q->submit(-value=>T('Go!')) . $q->end_form();
|
|
@results = ReplaceAndDiff($re, UnquoteHtml($replacement));
|
|
} else {
|
|
print GetHeader('', Ts('Replaced: %s', $string . " → " . $replacement));
|
|
print $q->start_div({-class=>'content replacement'});
|
|
@results = ReplaceAndSave($re, UnquoteHtml($replacement));
|
|
foreach (@results) {
|
|
PrintSearchResult($_, quotemeta($replacement || $re)); # the replacement is not a valid regex
|
|
}
|
|
}
|
|
} else {
|
|
if ($raw) {
|
|
print GetHttpHeader('text/plain');
|
|
print RcTextItem('title', Ts('Search for: %s', $string)), RcTextItem('date', TimeToText($Now)),
|
|
RcTextItem('link', $q->url(-path_info=>1, -query=>1)), "\n" if GetParam('context', 1);
|
|
} else {
|
|
print GetHeader('', Ts('Search for: %s', $string)), $q->start_div({-class=>'content search'});
|
|
print $q->p({-class=>'links'}, SearchMenu($string));
|
|
}
|
|
@results = SearchTitleAndBody($re, \&PrintSearchResult, SearchRegexp($re));
|
|
}
|
|
print SearchResultCount($#results + 1), $q->end_div() unless $raw;
|
|
PrintFooter() unless $raw;
|
|
}
|
|
|
|
sub SearchMenu {
|
|
return ScriptLink('action=rc;rcfilteronly=' . UrlEncode(shift),
|
|
T('View changes for these pages'));
|
|
}
|
|
|
|
sub SearchResultCount { $q->p({-class=>'result'}, Ts('%s pages found.', (shift))); }
|
|
|
|
sub PageIsUploadedFile {
|
|
my $id = shift;
|
|
return if $OpenPageName eq $id;
|
|
if ($IndexHash{$id}) {
|
|
my $file = GetPageFile($id);
|
|
open(my $FILE, '<:encoding(UTF-8)', encode_utf8($file))
|
|
or ReportError(Ts('Cannot open %s', GetPageFile($id))
|
|
. ": $!", '500 INTERNAL SERVER ERROR');
|
|
while (defined($_ = <$FILE>) and $_ !~ /^text: /) {
|
|
} # read lines until we get to the text key
|
|
close $FILE;
|
|
return unless length($_) > 6;
|
|
return TextIsFile(substr($_, 6)); # pass "#FILE image/png\n" to the test
|
|
}
|
|
}
|
|
|
|
sub SearchTitleAndBody {
|
|
my ($regex, $func, @args) = @_;
|
|
my @found;
|
|
my $lang = GetParam('lang', '');
|
|
foreach my $id (Filtered($regex, AllPagesList())) {
|
|
my $name = NormalToFree($id);
|
|
my ($text) = PageIsUploadedFile($id); # set to mime-type if this is an uploaded file
|
|
local ($OpenPageName, %Page); # this is local!
|
|
if (not $text) { # not uploaded file, therefore allow searching of page body
|
|
OpenPage($id); # this opens a page twice if it is not uploaded, but that's ok
|
|
if ($lang) {
|
|
my @languages = split(/,/, $Page{languages});
|
|
next if (@languages and not grep(/$lang/, @languages));
|
|
}
|
|
$text = $Page{text};
|
|
}
|
|
if (SearchString($regex, $name . "\n" . $text)) { # the real search code
|
|
push(@found, $id);
|
|
$func->($id, @args) if $func;
|
|
}
|
|
}
|
|
return @found;
|
|
}
|
|
|
|
sub Filtered { # this is overwriten in extensions such as tags.pl
|
|
my ($string, @pages) = @_;
|
|
my $match = GetParam('match', '');
|
|
@pages = grep /$match/i, @pages if $match;
|
|
return @pages;
|
|
}
|
|
|
|
sub SearchString {
|
|
my ($string, $data) = @_;
|
|
my @strings = grep /./, $string =~ /\"([^\"]+)\"|(\S+)/g; # skip null entries
|
|
foreach my $str (@strings) {
|
|
return 0 unless ($data =~ /$str/i);
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub SearchRegexp {
|
|
my $regexp = join '|', map { index($_, '|') == -1 ? $_ : "($_)" }
|
|
grep /./, shift =~ /\"([^\"]+)\"|(\S+)/g; # this acts as OR
|
|
$regexp =~ s/\\s/[[:space:]]/g;
|
|
return $regexp;
|
|
}
|
|
|
|
sub PrintSearchResult {
|
|
my ($name, $regex) = @_;
|
|
return PrintPage($name) if not GetParam('context', 1);
|
|
OpenPage($name); # should be open already, just making sure!
|
|
my $text = $Page{text};
|
|
my ($type) = TextIsFile($text); # MIME type if an uploaded file
|
|
my %entry;
|
|
# get the page, filter it, remove all tags
|
|
$text =~ s/$FS//g; # Remove separators (paranoia)
|
|
$text =~ s/[\s]+/ /g; # Shrink whitespace
|
|
$text =~ s/([-_=\\*\\.]){10,}/$1$1$1$1$1/g ; # e.g. shrink "----------"
|
|
$entry{title} = $name;
|
|
$entry{description} = $type || SearchHighlight(QuoteHtml(SearchExtract($text, $regex)), QuoteHtml($regex));
|
|
$entry{size} = int((length($text) / 1024) + 1) . 'K';
|
|
$entry{'last-modified'} = TimeToText($Page{ts});
|
|
$entry{username} = $Page{username};
|
|
PrintSearchResultEntry(\%entry);
|
|
}
|
|
|
|
sub PrintSearchResultEntry {
|
|
my %entry = %{(shift)}; # get value from reference
|
|
if (GetParam('raw', 0)) {
|
|
$entry{generator} = GetAuthor($entry{username});
|
|
foreach my $key (qw(title description size last-modified generator username)) {
|
|
print RcTextItem($key, $entry{$key});
|
|
}
|
|
print RcTextItem('link', "$ScriptName?$entry{title}"), "\n";
|
|
} else {
|
|
my $author = GetAuthorLink($entry{username});
|
|
$author ||= $entry{generator};
|
|
my $id = $entry{title};
|
|
my ($class, $resolved, $title, $exists) = ResolveId($id);
|
|
my $text = NormalToFree($id);
|
|
my $result = $q->span({-class=>'result'}, ScriptLink(UrlEncode($resolved), $text, $class, undef, $title));
|
|
my $description = $entry{description};
|
|
$description = $q->br() . $description if $description;
|
|
my $info = $entry{size};
|
|
$info .= ' - ' if $info;
|
|
$info .= T('last updated') . ' ' . $entry{'last-modified'} if $entry{'last-modified'};
|
|
$info .= ' ' . T('by') . ' ' . $author if $author;
|
|
$info = $q->br() . $q->span({-class=>'info'}, $info) if $info;
|
|
print $q->p($result, $description, $info);
|
|
}
|
|
}
|
|
|
|
sub SearchHighlight {
|
|
my ($data, $regex) = @_;
|
|
$data =~ s/($regex)/<strong>$1<\/strong>/gi unless GetParam('raw');
|
|
return $data;
|
|
}
|
|
|
|
sub SearchExtract {
|
|
my ($data, $regex) = @_;
|
|
my ($snippetlen, $maxsnippets) = (100, 4); # these seem nice.
|
|
# show a snippet from the beginning of the document
|
|
my $j = index($data, ' ', $snippetlen); # end on word boundary
|
|
my $t = substr($data, 0, $j);
|
|
my $result = $t . ' . . .';
|
|
$data = substr($data, $j); # to avoid rematching
|
|
my $jsnippet = 0 ;
|
|
while ($jsnippet < $maxsnippets and $data =~ m/($regex)/i) {
|
|
$jsnippet++;
|
|
if (($j = index($data, $1)) > -1 ) {
|
|
# get substr containing (start of) match, ending on word boundaries
|
|
my $start = index($data, ' ', $j - $snippetlen / 2);
|
|
$start = 0 if $start == -1;
|
|
my $end = index($data, ' ', $j + $snippetlen / 2);
|
|
$end = length($data) if $end == -1;
|
|
$t = substr($data, $start, $end - $start);
|
|
$result .= $t . ' . . .';
|
|
# truncate text to avoid rematching the same string.
|
|
$data = substr($data, $end);
|
|
}
|
|
}
|
|
return $result;
|
|
}
|
|
|
|
sub ReplaceAndSave {
|
|
my ($from, $to) = @_;
|
|
RequestLockOrError(); # fatal
|
|
my @result = Replace($from, $to, 1, sub {
|
|
my ($id, $new) = @_;
|
|
Save($id, $new, $from . ' → ' . $to, 1);
|
|
});
|
|
ReleaseLock();
|
|
return @result;
|
|
}
|
|
|
|
sub ReplaceAndDiff {
|
|
my ($from, $to) = @_;
|
|
my @found = Replace($from, $to, 0, sub {
|
|
my ($id, $new) = @_;
|
|
print $q->h2(GetPageLink($id)), $q->div({-class=>'diff'}, ImproveDiff(DoDiff($Page{text}, $new)));
|
|
});
|
|
if (@found > GetParam('offset', 0) + GetParam('num', 10)) {
|
|
my $more = "search=" . UrlEncode($from) . ";preview=1"
|
|
. ";offset=" . (GetParam('num', 10) + GetParam('offset', 0))
|
|
. ";num=" . GetParam('num', 10);
|
|
$more .= ";replace=" . UrlEncode($to) if $to;
|
|
$more .= ";delete=1" unless $to;
|
|
print $q->p({-class=>'more'}, ScriptLink($more, T('More...'), 'more'));
|
|
}
|
|
return @found;
|
|
}
|
|
|
|
sub Replace {
|
|
my ($from, $to, $all, $func) = @_; # $func takes $id and $new text
|
|
my $lang = GetParam('lang', '');
|
|
my $num = GetParam('num', 10);
|
|
my $offset = GetParam('offset', 0);
|
|
my @result;
|
|
foreach my $id (AllPagesList()) {
|
|
OpenPage($id);
|
|
if ($lang) {
|
|
my @languages = split(/,/, $Page{languages});
|
|
next if (@languages and not grep(/$lang/, @languages));
|
|
}
|
|
$_ = $Page{text};
|
|
my $replacement = sub {
|
|
my ($o1, $o2, $o3, $o4, $o5, $o6, $o7, $o8, $o9) = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
|
|
my $str = $to;
|
|
$str =~ s/\$([1-9])/'$o' . $1/eeg;
|
|
$str
|
|
};
|
|
if (s/$from/$replacement->()/egi) { # allows use of backreferences
|
|
push (@result, $id);
|
|
$func->($id, $_) if $all or @result > $offset and @result <= $offset + $num;
|
|
}
|
|
}
|
|
return @result;
|
|
}
|
|
|
|
sub DoPost {
|
|
my $id = FreeToNormal(shift);
|
|
UserCanEditOrDie($id);
|
|
# Lock before getting old page to prevent races
|
|
RequestLockOrError(); # fatal
|
|
OpenPage($id);
|
|
my $old = $Page{text};
|
|
my $string = UnquoteHtml(GetParam('text', undef));
|
|
$string =~ s/(\r|$FS)//g;
|
|
my ($type) = TextIsFile($string); # MIME type if an uploaded file
|
|
my $filename = GetParam('file', undef);
|
|
if (($filename or $type) and not $UploadAllowed and not UserIsAdmin()) {
|
|
ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
|
|
}
|
|
my $comment = UnquoteHtml(GetParam('aftertext', undef));
|
|
$comment =~ s/(\r|$FS)//g;
|
|
if (defined $comment and $comment eq '') {
|
|
ReleaseLock();
|
|
return ReBrowsePage($id);
|
|
}
|
|
if ($filename) { # upload file
|
|
my $file = $q->upload('file');
|
|
if (not $file and $q->cgi_error) {
|
|
ReportError(Ts('Transfer Error: %s', $q->cgi_error), '500 INTERNAL SERVER ERROR');
|
|
}
|
|
ReportError(T('Browser reports no file info.'), '500 INTERNAL SERVER ERROR') unless $q->uploadInfo($filename);
|
|
$type = $q->uploadInfo($filename)->{'Content-Type'};
|
|
ReportError(T('Browser reports no file type.'), '415 UNSUPPORTED MEDIA TYPE') unless $type;
|
|
local $/ = undef; # Read complete files
|
|
my $content = <$file>; # Apparently we cannot count on <$file> to always work within the eval!?
|
|
my $encoding = substr($content, 0, 2) eq "\x1f\x8b" ? 'gzip' : '';
|
|
eval { require MIME::Base64; $_ = MIME::Base64::encode($content) };
|
|
$string = "#FILE $type $encoding\n" . $_;
|
|
} else { # ordinary text edit
|
|
$string = AddComment($old, $comment) if defined $comment;
|
|
if ($comment and substr($string, 0, length($DeletedPage)) eq $DeletedPage) { # look ma, no regexp!
|
|
$string = substr($string, length($DeletedPage)); # undelete pages when adding a comment
|
|
}
|
|
$string .= "\n" if ($string !~ /\n$/); # add trailing newline
|
|
$string = RunMyMacros($string); # run macros on text pages only
|
|
}
|
|
my %allowed = map {$_ => 1} @UploadTypes;
|
|
if (@UploadTypes and $type and not $allowed{$type}) {
|
|
ReportError(Ts('Files of type %s are not allowed.', $type), '415 UNSUPPORTED MEDIA TYPE');
|
|
}
|
|
# Banned Content
|
|
my $summary = GetSummary();
|
|
if (not UserIsEditor()) {
|
|
my $rule = BannedContent(NormalToFree($id)) || BannedContent($string) || BannedContent($summary);
|
|
ReportError(T('Edit Denied'), '403 FORBIDDEN', undef, $q->p(T('The page contains banned text.')),
|
|
$q->p(T('Contact the wiki administrator for more information.')), $q->p($rule)) if $rule;
|
|
}
|
|
# rebrowse if no changes
|
|
my $oldrev = $Page{revision};
|
|
if (GetParam('Preview', '')) { # Preview button was used
|
|
ReleaseLock();
|
|
if (defined $comment) {
|
|
BrowsePage($id, 0, RunMyMacros($comment)); # show macros in preview
|
|
} else {
|
|
DoEdit($id, $string, 1);
|
|
}
|
|
return;
|
|
} elsif ($old eq $string) {
|
|
ReleaseLock(); # No changes -- just show the same page again
|
|
return ReBrowsePage($id);
|
|
} elsif ($oldrev == 0 and $string eq "\n") {
|
|
ReportError(T('No changes to be saved.'), '400 BAD REQUEST'); # don't fake page creation because of webdav
|
|
}
|
|
my $newAuthor = 0;
|
|
if ($oldrev) { # the first author (no old revision) is not considered to be "new"
|
|
$newAuthor = 1 if not $Page{username} or $Page{username} ne GetParam('username', '');
|
|
}
|
|
my $oldtime = $Page{ts};
|
|
my $myoldtime = GetParam('oldtime', ''); # maybe empty!
|
|
# Handle raw edits with the meta info on the first line
|
|
if (GetParam('raw', 0) == 2 and $string =~ /^([0-9]+).*\n((.*\n)*.*)/) {
|
|
$myoldtime = $1;
|
|
$string = $2;
|
|
}
|
|
my $generalwarning = 0;
|
|
if ($newAuthor and $oldtime ne $myoldtime and not defined $comment) {
|
|
if ($myoldtime) {
|
|
my ($ancestor) = GetTextAtTime($myoldtime);
|
|
if ($ancestor and $old ne $ancestor) {
|
|
my $new = MergeRevisions($string, $ancestor, $old);
|
|
if ($new) {
|
|
$string = $new;
|
|
if ($new =~ /^<<<<<<</m and $new =~ /^>>>>>>>/m) {
|
|
SetParam('msg', Ts('This page was changed by somebody else %s.',
|
|
CalcTimeSince($Now - $Page{ts}))
|
|
. ' ' . T('The changes conflict. Please check the page again.'));
|
|
} # else no conflict
|
|
} else {
|
|
$generalwarning = 1;
|
|
} # else merge revision didn't work
|
|
} # else nobody changed the page in the mean time (same text)
|
|
} else {
|
|
$generalwarning = 1;
|
|
} # no way to be sure since myoldtime is missing
|
|
} # same author or nobody changed the page in the mean time (same timestamp)
|
|
if ($generalwarning and ($Now - $Page{ts}) < 600) {
|
|
SetParam('msg', Ts('This page was changed by somebody else %s.',
|
|
CalcTimeSince($Now - $Page{ts}))
|
|
. ' ' . T('Please check whether you overwrote those changes.'));
|
|
}
|
|
Save($id, $string, $summary, (GetParam('recent_edit', '') eq 'on'), $filename);
|
|
ReleaseLock();
|
|
ReBrowsePage($id);
|
|
}
|
|
|
|
sub GetSummary {
|
|
my $text = GetParam('aftertext', '') || ($Page{revision} > 0 ? '' : GetParam('text', ''));
|
|
return '' if $text =~ /^#FILE /;
|
|
if ($SummaryDefaultLength and length($text) > $SummaryDefaultLength) {
|
|
$text = substr($text, 0, $SummaryDefaultLength);
|
|
$text =~ s/\s*\S*$/ . . ./;
|
|
}
|
|
my $summary = GetParam('summary', '') || $text; # not GetParam('summary', $text) work because '' is defined
|
|
$summary =~ s/$FS|[\r\n]+/ /g; # remove linebreaks and separator characters
|
|
$summary =~ s/\[$FullUrlPattern\s+(.*?)\]/$2/g; # fix common annoyance when copying text to summary
|
|
$summary =~ s/\[$FullUrlPattern\]//g;
|
|
$summary =~ s/\[\[$FreeLinkPattern\]\]/$1/g;
|
|
return UnquoteHtml($summary);
|
|
}
|
|
|
|
sub AddComment {
|
|
my ($string, $comment) = @_;
|
|
$comment =~ s/\r//g; # Remove "\r"-s (0x0d) from the string
|
|
$comment =~ s/\s+$//g; # Remove whitespace at the end
|
|
if ($comment ne '') {
|
|
my $author = GetParam('username', T('Anonymous'));
|
|
my $homepage = GetParam('homepage', '');
|
|
$homepage = 'http://' . $homepage if $homepage and $homepage !~ /^($UrlProtocols):/;
|
|
$author = "[$homepage $author]" if $homepage;
|
|
$string .= "\n----\n\n" if $string and $string ne "\n";
|
|
$string .= $comment . "\n\n"
|
|
. '-- ' . $author . ' ' . TimeToText($Now) . "\n\n";
|
|
}
|
|
return $string;
|
|
}
|
|
|
|
sub Save { # call within lock, with opened page
|
|
my ($id, $new, $summary, $minor, $upload) = @_;
|
|
my $user = GetParam('username', '');
|
|
my $revision = $Page{revision} + 1;
|
|
my $old = $Page{text};
|
|
my $olddiff = $Page{'diff-major'} == '1' ? $Page{'diff-minor'} : $Page{'diff-major'};
|
|
if ($revision == 1 and IsFile($IndexFile) and not Unlink($IndexFile)) { # regenerate index on next request
|
|
SetParam('msg', Ts('Cannot delete the index file %s.', $IndexFile)
|
|
. ' ' . T('Please check the directory permissions.')
|
|
. ' ' . T('Your changes were not saved.'));
|
|
return 0;
|
|
}
|
|
ReInit($id);
|
|
TouchIndexFile();
|
|
SaveKeepFile(); # deletes blocks, flags, diff-major, and diff-minor, and sets keep-ts
|
|
ExpireKeepFiles();
|
|
$Page{lastmajor} = $revision unless $minor;
|
|
$Page{lastmajorsummary} = $summary unless $minor;
|
|
@Page{qw(ts revision summary username minor text)} =
|
|
($Now, $revision, $summary, $user, $minor, $new);
|
|
if ($UseDiff and $UseCache > 1 and $revision > 1 and not $upload and not TextIsFile($old)) {
|
|
UpdateDiffs($old, $new, $olddiff); # sets diff-major and diff-minor
|
|
}
|
|
my $languages;
|
|
$languages = GetLanguages($new) unless $upload;
|
|
$Page{languages} = $languages;
|
|
SavePage();
|
|
if ($revision == 1 and $LockOnCreation{$id}) {
|
|
WriteStringToFile(GetLockedPageFile($id), 'LockOnCreation');
|
|
}
|
|
my $host = $q->remote_addr();
|
|
WriteRcLog($id, $summary, $minor, $revision, $user, $host, $languages, GetCluster($new));
|
|
AddToIndex($id) if ($revision == 1);
|
|
}
|
|
|
|
sub TouchIndexFile {
|
|
my $ts = time;
|
|
utime $ts, $ts, $IndexFile;
|
|
$LastUpdate = $Now = $ts;
|
|
}
|
|
|
|
sub GetLanguages {
|
|
my $text = shift;
|
|
my %result;
|
|
for my $lang (keys %Languages) {
|
|
my @matches = $text =~ /$Languages{$lang}/gi;
|
|
$result{$lang} = @matches if @matches >= $LanguageLimit;
|
|
}
|
|
return join(',', sort { $result{$b} <=> $result{$a} } keys %result);
|
|
}
|
|
|
|
sub GetLanguage { # the first language, or the default language
|
|
return ((split /,/, GetLanguages(@_))[0] or $CurrentLanguage);
|
|
}
|
|
|
|
sub GetCluster {
|
|
$_ = shift;
|
|
return '' unless $PageCluster;
|
|
return $1 if ($WikiLinks && /^$LinkPattern\n/)
|
|
or ($FreeLinks && /^\[\[$FreeLinkPattern\]\]\n/);
|
|
}
|
|
|
|
sub MergeRevisions { # merge change from file2 to file3 into file1
|
|
my ($file1, $file2, $file3) = @_;
|
|
my ($name1, $name2, $name3) = ("$TempDir/file1", "$TempDir/file2", "$TempDir/file3");
|
|
CreateDir($TempDir);
|
|
RequestLockDir('merge') or return T('Could not get a lock to merge!');
|
|
WriteStringToFile($name1, $file1);
|
|
WriteStringToFile($name2, $file2);
|
|
WriteStringToFile($name3, $file3);
|
|
my ($you, $ancestor, $other) = (T('you'), T('ancestor'), T('other'));
|
|
my $output = decode_utf8(`diff3 -m -L \Q$you\E -L \Q$ancestor\E -L \Q$other\E -- \Q$name1\E \Q$name2\E \Q$name3\E`);
|
|
ReleaseLockDir('merge'); # don't unlink temp files--next merge will just overwrite.
|
|
return $output;
|
|
}
|
|
|
|
# Note: all diff and recent-list operations should be done within locks.
|
|
sub WriteRcLog {
|
|
my ($id, $summary, $minor, $revision, $username, $host, $languages, $cluster) = @_;
|
|
my $line = join($FS, $Now, $id, $minor, $summary, $host,
|
|
$username, $revision, $languages, $cluster);
|
|
AppendStringToFile($RcFile, $line . "\n");
|
|
}
|
|
|
|
sub UpdateDiffs { # this could be optimized, but isn't frequent enough
|
|
my ($old, $new, $olddiff) = @_;
|
|
$Page{'diff-minor'} = GetDiff($old, $new); # create new diff-minor
|
|
# 1 is a special value for GetCacheDiff telling it to use diff-minor
|
|
$Page{'diff-major'} = $Page{lastmajor} == $Page{revision} ? 1 : $olddiff;
|
|
}
|
|
|
|
sub DoMaintain {
|
|
print GetHeader('', T('Run Maintenance')), $q->start_div({-class=>'content maintain'});
|
|
my $fname = "$DataDir/maintain";
|
|
if (not UserIsAdmin()) {
|
|
if (IsFile($fname) and $Now - Modified($fname) < 12 * 60 * 60) {
|
|
print $q->p(T('Maintenance not done.') . ' ' . T('(Maintenance can only be done once every 12 hours.)')
|
|
. ' ', T('Remove the "maintain" file or wait.')), $q->end_div();
|
|
PrintFooter();
|
|
return;
|
|
}
|
|
}
|
|
print '<p>', T('Expiring keep files and deleting pages marked for deletion');
|
|
ExpireAllKeepFiles();
|
|
print '</p>';
|
|
RequestLockOrError();
|
|
print $q->p(T('Main lock obtained.'));
|
|
print $q->p(Ts('Moving part of the %s log file.', $RCName));
|
|
# Determine the number of days to go back, default is largest of @RcDays
|
|
my $days = 0;
|
|
foreach (@RcDays) {
|
|
$days = $_ if $_ > $days;
|
|
}
|
|
my $starttime = $Now - $days * 86400; # 24*60*60
|
|
# Read the current file
|
|
my ($status, $data) = ReadFile($RcFile);
|
|
if (not $status) {
|
|
print $q->p($q->strong(Ts('Could not open %s log file', $RCName) . ':') . ' ' . $RcFile),
|
|
$q->p(T('Error was') . ':'), $q->pre($!), $q->p(T('Note: This error is normal if no changes have been made.'));
|
|
} else {
|
|
WriteStringToFile($RcFile . '.old', $data);
|
|
}
|
|
# Move the old stuff from rc to temp
|
|
my @rc = split(/\n/, $data);
|
|
my @tmp = ();
|
|
my $line;
|
|
my $changed = 0;
|
|
while ($line = shift(@rc)) {
|
|
my ($ts, $id, $minor, $summary, $host, @rest) = split(/$FS/, $line);
|
|
last if $ts >= $starttime;
|
|
push(@tmp, join($FS, $ts, $id, $minor, $summary, 'Anonymous', @rest));
|
|
$changed = 1;
|
|
}
|
|
unshift(@rc, $line) if $line; # this one ended the loop
|
|
print $q->p(Ts('Moving %s log entries.', scalar(@tmp)));
|
|
AppendStringToFile($RcOldFile, join("\n", @tmp) . "\n") if @tmp;
|
|
# remove IP numbers from all but the last few days
|
|
$starttime = $Now - $KeepHostDays * 86400; # 24*60*60
|
|
@tmp = ();
|
|
while ($line = shift(@rc)) {
|
|
my ($ts, $id, $minor, $summary, $host, @rest) = split(/$FS/, $line);
|
|
last if $ts >= $starttime;
|
|
push(@tmp, join($FS, $ts, $id, $minor, $summary, 'Anonymous', @rest));
|
|
$changed = 1;
|
|
}
|
|
unshift(@rc, $line) if $line; # this one ended the loop
|
|
unshift(@rc, @tmp) if @tmp;
|
|
print $q->p(Ts('Removing IP numbers from %s log entries.', scalar(@tmp)));
|
|
WriteStringToFile($RcFile, @rc ? join("\n", @rc) . "\n" : '') if $changed;
|
|
if (opendir(DIR, $RssDir)) { # cleanup if they should expire anyway
|
|
foreach (readdir(DIR)) {
|
|
Unlink("$RssDir/$_") if $Now - Modified($_) > $RssCacheHours * 3600;
|
|
}
|
|
closedir DIR;
|
|
}
|
|
foreach my $func (@MyMaintenance) {
|
|
$func->();
|
|
}
|
|
WriteStringToFile($fname, 'Maintenance done at ' . TimeToText($Now));
|
|
ReleaseLock();
|
|
print $q->p(T('Main lock released.')), $q->end_div();
|
|
PrintFooter();
|
|
}
|
|
|
|
sub PageDeletable {
|
|
return unless $KeepDays;
|
|
my $expirets = $Now - ($KeepDays * 86400); # 24*60*60
|
|
return 0 if $Page{ts} >= $expirets;
|
|
return PageMarkedForDeletion();
|
|
}
|
|
|
|
sub PageMarkedForDeletion {
|
|
# Only pages explicitly marked for deletion or whitespace-only pages
|
|
# are deleted; taking into account the very rare possiblity of a
|
|
# read error and the page text being undefined.
|
|
return 1 if defined $Page{text} and $Page{text} =~ /^\s*$/;
|
|
return $DeletedPage && substr($Page{text}, 0, length($DeletedPage)) eq $DeletedPage;
|
|
}
|
|
|
|
sub DeletePage { # Delete must be done inside locks.
|
|
my $id = shift;
|
|
ValidIdOrDie($id);
|
|
AppendStringToFile($DeleteFile, "$id\n");
|
|
foreach my $name (GetPageFile($id), GetKeepFiles($id), GetKeepDir($id), GetLockedPageFile($id), $IndexFile) {
|
|
Unlink($name) if IsFile($name);
|
|
RemoveDir($name) if IsDir($name);
|
|
}
|
|
ReInit($id);
|
|
delete $IndexHash{$id};
|
|
@IndexList = sort(keys %IndexHash);
|
|
return ''; # no error
|
|
}
|
|
|
|
sub DoEditLock {
|
|
return unless UserIsAdminOrError();
|
|
print GetHeader('', T('Set or Remove global edit lock'));
|
|
my $fname = "$NoEditFile";
|
|
if (GetParam("set", 1)) {
|
|
WriteStringToFile($fname, 'editing locked.');
|
|
} else {
|
|
Unlink($fname);
|
|
}
|
|
utime time, time, $IndexFile; # touch index file
|
|
print $q->p(IsFile($fname) ? T('Edit lock created.') : T('Edit lock removed.'));
|
|
PrintFooter();
|
|
}
|
|
|
|
sub DoPageLock {
|
|
return unless UserIsAdminOrError();
|
|
print GetHeader('', T('Set or Remove page edit lock'));
|
|
my $id = GetParam('id', '');
|
|
ValidIdOrDie($id);
|
|
my $fname = GetLockedPageFile($id);
|
|
if (GetParam('set', 1)) {
|
|
WriteStringToFile($fname, 'editing locked.');
|
|
} else {
|
|
Unlink($fname);
|
|
}
|
|
utime time, time, $IndexFile; # touch index file
|
|
print $q->p(IsFile($fname) ? Ts('Lock for %s created.', GetPageLink($id))
|
|
: Ts('Lock for %s removed.', GetPageLink($id)));
|
|
PrintFooter();
|
|
}
|
|
|
|
sub DoShowVersion {
|
|
print GetHeader('', T('Displaying Wiki Version')), $q->start_div({-class=>'content version'});
|
|
print $WikiDescription, $q->p($q->server_software()),
|
|
$q->p(sprintf('Perl v%vd', $^V)),
|
|
$q->p($ENV{MOD_PERL} ? $ENV{MOD_PERL} : "no mod_perl"), $q->p('CGI: ', $CGI::VERSION),
|
|
$q->p('LWP::UserAgent ', eval { local $SIG{__DIE__}; require LWP::UserAgent; $LWP::UserAgent::VERSION; }),
|
|
$q->p('XML::RSS: ', eval { local $SIG{__DIE__}; require XML::RSS; $XML::RSS::VERSION; }),
|
|
$q->p('XML::Parser: ', eval { local $SIG{__DIE__}; $XML::Parser::VERSION; });
|
|
print $q->p('diff: ' . (`diff --version` || $!)), $q->p('diff3: ' . (`diff3 --version` || $!)) if $UseDiff;
|
|
print $q->end_div();
|
|
PrintFooter();
|
|
}
|
|
|
|
sub DoDebug {
|
|
print GetHeader('', T('Debugging Information')),
|
|
$q->start_div({-class=>'content debug'});
|
|
foreach my $func (@Debugging) { $func->() }
|
|
print $q->end_div();
|
|
PrintFooter();
|
|
}
|
|
|
|
sub DoSurgeProtection {
|
|
return unless $SurgeProtection;
|
|
my $name = GetParam('username', $q->remote_addr());
|
|
return unless $name;
|
|
ReadRecentVisitors();
|
|
AddRecentVisitor($name);
|
|
if (RequestLockDir('visitors')) { # not fatal
|
|
WriteRecentVisitors();
|
|
ReleaseLockDir('visitors');
|
|
if (DelayRequired($name)) {
|
|
ReportError(Ts('Too many connections by %s', $name)
|
|
. ': ' . Tss('Please do not fetch more than %1 pages in %2 seconds.',
|
|
$SurgeProtectionViews, $SurgeProtectionTime),
|
|
'503 SERVICE UNAVAILABLE');
|
|
}
|
|
} elsif (GetParam('action', '') ne 'unlock') {
|
|
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');
|
|
}
|
|
}
|
|
|
|
sub DelayRequired {
|
|
my $name = shift;
|
|
my @entries = @{$RecentVisitors{$name}};
|
|
my $ts = $entries[$SurgeProtectionViews];
|
|
return ($Now - $ts) < $SurgeProtectionTime;
|
|
}
|
|
|
|
sub AddRecentVisitor {
|
|
my $name = shift;
|
|
my $value = $RecentVisitors{$name};
|
|
my @entries = ($Now);
|
|
push(@entries, @{$value}) if $value;
|
|
$RecentVisitors{$name} = \@entries;
|
|
}
|
|
|
|
sub ReadRecentVisitors {
|
|
my ($status, $data) = ReadFile($VisitorFile);
|
|
%RecentVisitors = ();
|
|
return unless $status;
|
|
foreach (split(/\n/, $data)) {
|
|
my @entries = split /$FS/;
|
|
my $name = shift(@entries);
|
|
$RecentVisitors{$name} = \@entries if $name;
|
|
}
|
|
}
|
|
|
|
sub WriteRecentVisitors {
|
|
my $data = '';
|
|
my $limit = $Now - $SurgeProtectionTime;
|
|
foreach my $name (keys %RecentVisitors) {
|
|
my @entries = @{$RecentVisitors{$name}};
|
|
if ($entries[0] >= $limit) { # if the most recent one is too old, do not keep
|
|
$data .= join($FS, $name, @entries[0 .. $SurgeProtectionViews - 1]) . "\n";
|
|
}
|
|
}
|
|
WriteStringToFile($VisitorFile, $data);
|
|
}
|
|
|
|
sub TextIsFile { $_[0] =~ /^#FILE (\S+) ?(\S+)?\n/; }
|
|
|
|
sub AddModuleDescription { # cannot use $q here because this is module init time
|
|
my ($filename, $page, $dir, $tag) = @_;
|
|
my $src = "https://alexschroeder.ch/cgit/oddmuse/tree/modules/$dir" . UrlEncode($filename) . ($tag ? '?' . $tag : '');
|
|
my $doc = 'https://www.oddmuse.org/wiki/' . UrlEncode(FreeToNormal($page));
|
|
$ModulesDescription .= "<p><a href=\"$src\">" . QuoteHtml($filename) . "</a>" . ($tag ? " ($tag)" : '');
|
|
$ModulesDescription .= T(', see') . " <a href=\"$doc\">" . QuoteHtml($page) . "</a>" if $page;
|
|
$ModulesDescription .= "</p>";
|
|
}
|
|
|
|
DoWikiRequest() if $RunCGI and not exists $ENV{MOD_PERL}; # Do everything.
|
|
1; # In case we are loaded from elsewhere
|