App-Phoebe
view release on metacpan or search on metacpan
t/oddmuse-wiki.pl view on Meta::CPAN
#! /usr/bin/env perl
# Copyright (C) 2001-2020
# 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 = "<!DOCTYPE html>\n<html>";
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 {
t/oddmuse-wiki.pl view on Meta::CPAN
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;
t/oddmuse-wiki.pl view on Meta::CPAN
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 .= '<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 .= '<nav>';
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 .= '</nav>';
$result .= $q->div({-class=>'message'}, $Message) if $Message;
$result .= GetHeaderTitle($id, $title, $oldId);
$result .= '</header>';
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) {
t/oddmuse-wiki.pl view on Meta::CPAN
($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))));
}
}
}
( run in 0.697 second using v1.01-cache-2.11-cpan-39bf76dae61 )