App-Phoebe
view release on metacpan or search on metacpan
t/oddmuse-wiki.pl view on Meta::CPAN
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);
t/oddmuse-wiki.pl view on Meta::CPAN
}
}
}
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, -loading=>'lazy'});
} 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', -loading=>'lazy'});
$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) and $Page{text};
my $lang = (split /,/, $Page{languages})[0] || $CurrentLanguage;
print qq{<div class="e-content" lang="$lang">};
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
}
print '</div>';
}
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;
return $diff . $q->p($error) if $limit and length($diff . $page) > $limit;
return $diff . $page;
}
sub T {
my $text = shift;
t/oddmuse-wiki.pl view on Meta::CPAN
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()
t/oddmuse-wiki.pl view on Meta::CPAN
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;
t/oddmuse-wiki.pl view on Meta::CPAN
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
( run in 2.266 seconds using v1.01-cache-2.11-cpan-b16cb0d3907 )