App-Phoebe
view release on metacpan or search on metacpan
t/oddmuse-wiki.pl view on Meta::CPAN
$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 '<article class="h-entry">', $q->h1({-class => 'p-name'},
$links ? GetPageLink($id) : $q->a({-name=>$id}, UrlEncode(FreeToNormal($id))));
if ($variation ne 'titles') {
PrintPageHtml();
PrintPageCommentsLink($id, $comments);
}
print '</article>';
$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};
t/oddmuse-wiki.pl view on Meta::CPAN
$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'}, ':')
( run in 5.024 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )