# Copyright (C) 2005, 2006 Alex Schroeder # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA $ModulesDescription .= '

aggregate.pl (for 2.2.3-1-g1a561c3), see Front Page Extension

'; push(@MyRules, \&AggregateRule); sub AggregateRule { if ($bol && m/\G(<aggregate\s+((("[^\"&]+",?\s*)+)|(sort\s+)?search\s+(.+?))>)/gc) { Clean(CloseHtmlEnvironments()); Dirty($1); my ($oldpos, $old_, $str, $sort, $search) = ((pos), $_, $3, $5, $6); my $master = $OpenPageName; local ($OpenPageName, %Page); print $q->start_div({class=>"aggregate journal"}); my @pages = (); @pages = $str =~ m/"([^\"&]+)"/g if $str; @pages = SearchTitleAndBody($search) if $search; if ($sort) { if (defined &PageSort) { @pages = sort PageSort @pages; } else { @pages = sort(@pages); } } foreach my $id (@pages) { next if $id eq $master; my $title = $id; local $OpenPageName = FreeToNormal($id); my $page = GetPageContent($OpenPageName); my $size = length($page); my $i = index($page, "\n="); my $j = index($page, "\n----"); $page = substr($page, 0, $i) if $i >= 0; $page = substr($page, 0, $j) if $j >= 0; $page =~ s/^=.*\n//; # if it starts with a header print $q->start_div({class=>"page"}), $q->h2(GetPageLink($OpenPageName, $title)); ApplyRules(QuoteHtml($page), 1, 0, undef, 'p'); print $q->p(GetPageLink($OpenPageName, T('Learn more...'))) if length($page) < $size; print $q->end_div(); } print $q->end_div(); Clean(AddHtmlEnvironment('p')); ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!) return ''; } return undef; } $Action{aggregate} = \&DoAggregate; sub DoAggregate { print GetHttpHeader('application/xml'); my $frontpage = GetParam('id', $HomePage); my $title = $frontpage; $title =~ s/_/ /g; my $source = GetPageContent($frontpage); my $url = QuoteHtml($ScriptName); my $diffPrefix = $url . QuoteHtml("?action=browse;diff=1;id="); my $historyPrefix = $url . QuoteHtml("?action=history;id="); my $date = TimeToRFC822($LastUpdate); my $rss = qq{}; if ($RssStyleSheet =~ /\.(xslt?|xml)$/) { $rss .= qq{}; } elsif ($RssStyleSheet) { $rss .= qq{}; } $rss .= qq{ http://blogs.law.harvard.edu/tech/rss }; $rss .= "" . QuoteHtml("$SiteName: $title") . "\n"; $rss .= "" . $url . ($UsePathInfo ? "/" : "?") . UrlEncode($frontpage) . "\n"; $rss .= "" . QuoteHtml($SiteDescription) . "\n"; $rss .= "" . $date. "\n"; $rss .= "" . $date . "\n"; $rss .= "Oddmuse\n"; $rss .= "" . $RssRights . "\n" if $RssRights; if (ref $RssLicense eq 'ARRAY') { $rss .= join('', map {"$_\n"} @$RssLicense); } elsif ($RssLicense) { $rss .= "" . $RssLicense . "\n"; } $rss .= "" . $InterWikiMoniker . "\n" if $InterWikiMoniker; if ($RssImageUrl) { $rss .= "\n"; $rss .= "" . $RssImageUrl . "\n"; $rss .= "" . QuoteHtml($SiteName) . "\n"; $rss .= "" . $url . "\n"; $rss .= "\n"; } while ($source =~ m//g) { my ($str, $sort, $search) = ($1, $5, $6); my @pages = (); @pages = $str =~ m/"([^\"&]+)"/g if $str; @pages = SearchTitleAndBody($search) if $search; if ($sort) { if (defined &PageSort) { @pages = sort PageSort @pages; } else { @pages = sort(@pages); } } foreach my $id (@pages) { my %data = ParseData(ReadFileOrDie(GetPageFile(FreeToNormal($id)))); my $page = $data{text}; my $size = length($page); my $i = index($page, "\n="); my $j = index($page, "\n----"); $page = substr($page, 0, $i) if $i >= 0; $page = substr($page, 0, $j) if $j >= 0; $page =~ s/^=.*\n//; # if it starts with a header my $name = $id; $name =~ s/_/ /g; my $date = TimeToRFC822($data{ts}); my $host = $data{host}; my $username = $data{username}; $username = QuoteHtml($username); $username = $host unless $username; my $minor = $data{minor}; my $revision = $data{revision}; my $cluster = GetCluster($page); my $description; { local *STDOUT; open(STDOUT, '>', \$description) or die "Can't open memory file: $!"; ApplyRules(QuoteHtml($page), 1, 0, undef, 'p'); } $description .= $q->p(GetPageLink($id, T('Learn more...'))) if length($page) < $size; $rss .= "\n\n"; $rss .= "" . QuoteHtml($name) . "\n"; $rss .= "" . $url . (GetParam("all", 0) ? "?" . GetPageParameters("browse", $id, $revision, $cluster) : ($UsePathInfo ? "/" : "?") . UrlEncode($id)) . "\n"; $rss .= "" . QuoteHtml($description) . "\n"; $rss .= "" . $date . "\n"; $rss .= "" . $url . ($UsePathInfo ? "/" : "?") . $CommentsPrefix . UrlEncode($id) . "\n" if $CommentsPrefix and $id !~ /^$CommentsPrefix/; $rss .= "" . $username . "\n"; $rss .= "" . (1 == $revision ? "new" : "updated") . "\n"; $rss .= "" . ($minor ? "minor" : "major") . "\n"; $rss .= "" . $revision . "\n"; $rss .= "" . $historyPrefix . UrlEncode($id) . "\n"; $rss .= "" . $diffPrefix . UrlEncode($id) . "\n" if $UseDiff and GetParam("diffrclink", 1); $rss .= "\n"; } $rss .= "\n\n"; } print $rss; } # Copyright (C) 2004, 2005, 2009 Alex Schroeder # # 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 . $ModulesDescription .= '

anchors.pl (for 2.2.3-1-g1a561c3), see Comments on Local Anchor Extension

'; push(@MyRules, \&AnchorsRule); sub AnchorsRule { if (m/\G\[\[\#$FreeLinkPattern\]\]/gc) { return $q->a({-href=>'#' . FreeToNormal($1), -class=>'local anchor'}, $1); } elsif ($BracketWiki && m/\G\[\[\#$FreeLinkPattern\|([^\]]+)\]\]/gc) { return $q->a({-href=>'#' . FreeToNormal($1), -class=>'local anchor'}, $2); } elsif ($BracketWiki && m/\G(\[\[$FreeLinkPattern\#$FreeLinkPattern\|([^\]]+)\]\])/cog or m/\G(\[\[\[$FreeLinkPattern\#$FreeLinkPattern\]\]\])/cog or m/\G(\[\[$FreeLinkPattern\#$FreeLinkPattern\]\])/cog) { # This one is not a dirty rule because the output is always a page # link, never an edit link (unlike normal free links). my $bracket = (substr($1, 0, 3) eq '[[['); my $id = $2 . '#' . $3; my $text = $4; my $class = 'local anchor'; my $title = ''; $id = FreeToNormal($id); if (!$text && $bracket) { $text = BracketLink(++$FootnoteNumber); # s/_/ /g happens further down! $class .= ' number'; $title = $id; # override title $title =~ s/_/ /g if $free; } $text = $id unless $text; $text =~ s/_/ /g; return ScriptLink(UrlEncode($id), $text, $class, undef, $title); } elsif (m/\G\[\:$FreeLinkPattern\]/gc) { return $q->a({-name=>FreeToNormal($1), -class=>'anchor'}, ''); } return undef; } # Copyright (C) 2007, 2008, 2013 Alex Schroeder # # 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 . $ModulesDescription .= '

bbcode.pl (for 2.2.3-1-g1a561c3), see bbCode Extension

'; push(@MyRules, \&bbCodeRule); use vars qw($bbBlock); my %bbTitle = qw(h1 1 h2 1 h3 1 h4 1 h5 1 h6 1); # This code does not allow the nesting of block elements such as quote # and list. sub bbCodeRule { if (/\G(\[([a-z*][a-z1-6]*)(?:=([^]"]+))?\])/cgi) { my $bbcode = $1; my $tag = lc($2); my $option = $3; # sanitize? if ($tag eq 'b') { return AddHtmlEnvironment('b'); } elsif ($tag eq 'i') { return AddHtmlEnvironment('i'); } elsif ($tag eq 'u') { return AddHtmlEnvironment('em', qq{style="text-decoration: underline; } . qq{font-style: normal;"}); } elsif ($tag eq 's' or $tag eq 'strike') { return AddHtmlEnvironment('del'); } elsif ($tag eq 'sub') { return AddHtmlEnvironment('sub'); } elsif ($tag eq 'sup') { return AddHtmlEnvironment('sup'); } elsif ($tag eq 'color') { return AddHtmlEnvironment('em', qq{style="color: $option; } . qq{font-style: normal;"}); } elsif ($tag eq 'size') { $option *= 100; return $bbcode unless $option; # non-numeric? return AddHtmlEnvironment('em', qq{style="font-size: $option%; } . qq{font-style: normal;"}); } elsif ($tag eq 'font') { return AddHtmlEnvironment('span', qq{style="font-family: $option;"}); } elsif ($tag eq 'highlight') { return AddHtmlEnvironment('strong', qq{class="highlight"}); } elsif ($tag eq 'url') { if ($option) { $option =~ /^($UrlProtocols)/o; my $class = "url $1"; return AddHtmlEnvironment('a', qq{href="$option" class="$class"}); } elsif (/\G$FullUrlPattern\s*\[\/url\]/cogi) { return GetUrl($1); }} elsif ($tag eq 'img' and /\G$FullUrlPattern\s*\[\/img\]/cogi) { return GetUrl($1, undef, undef, 1); } # force image elsif ($tag eq 'quote') { my $html = CloseHtmlEnvironments(); $html .= "" if $bbBlock; $html .= "
"; $bbBlock = 'blockquote'; return $html . AddHtmlEnvironment('p'); } elsif ($tag eq 'center') { my $html = CloseHtmlEnvironments(); $html .= "" if $bbBlock; $html .= qq{
}; $bbBlock = 'div'; return $html . AddHtmlEnvironment('p'); } elsif ($tag eq 'left' or $tag eq 'right') { my $html = CloseHtmlEnvironments(); $html .= "" if $bbBlock; $html .= qq{
}; $bbBlock = 'div'; return $html . AddHtmlEnvironment('p'); } elsif ($tag eq 'list') { my $html = CloseHtmlEnvironments(); $html .= "" if $bbBlock; $bbBlock = 'ul'; return $html . '
    '; } elsif ($tag eq '*' and $bbBlock eq 'ul') { return CloseHtmlEnvironmentUntil('ul') . AddHtmlEnvironment('li'); } elsif ($tag eq 'code' and /\G((?:.*\n)*?.*?)\[\/code\]\n?/cgi) { return CloseHtmlEnvironments() . $q->pre($1) . AddHtmlEnvironment('p'); } elsif ($bbTitle{$tag}) { return CloseHtmlEnvironments() . AddHtmlEnvironment($tag); } # no opening tag after all return $bbcode; } # closing tags elsif (/\G(\[\/([a-z][a-z1-6]*)\])/cgi) { my $bbcode = $1; my $tag = lc($2); %translate = qw{b b i i u em color em size em font span url a quote blockquote h1 h1 h2 h2 h3 h3 h4 h4 h5 h5 h6 h6 center div left div right div list ul s del strike del sub sub sup sup highlight strong}; # closing a block level element closes all elements if ($bbBlock eq $translate{$tag}) { /\G([ \t]*\n)*/cg; # eat whitespace after closing block level element $bbBlock = undef; return CloseHtmlEnvironments() . "" . AddHtmlEnvironment('p'); } # ordinary elements just close themselves elsif (@HtmlStack and $HtmlStack[0] eq $translate{$tag}) { my $html = CloseHtmlEnvironment(); $html .= AddHtmlEnvironment('p') unless @HtmlStack; return $html; } # no closing tag after all else { return $bbcode; }} # smiley elsif (/\G(:-?[()])/cg) { if (substr($1,-1) eq ')') { # '☺' 0009786 00263a WHITE SMILING FACE, So, 0, ON, N, return '☺'; } else { # '☹' 0009785 002639 WHITE FROWNING FACE, So, 0, ON, N, return '☹'; }} elsif (/\G:(?:smile|happy):/cg) { return '☺'; } elsif (/\G:(?:sad|frown):/cg) { return '☹'; } # no match return undef; } # Copyright (C) 2005, 2009 Alex Schroeder # # 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 . package OddMuse; $ModulesDescription .= '

    big-brother.pl (for 2.2.3-1-g1a561c3), see Big Brother Extension

    '; use vars qw($VisitorTime); my $US = "\x1f"; $VisitorTime = 7200; # keep visitor data arround for 2 hours. push(@MyAdminCode, \&BigBrotherVisitors); sub BigBrotherVisitors { my ($id, $menuref, $restref) = @_; push(@$menuref, ScriptLink('action=visitors', Ts('Recent Visitors'), 'visitors')); } my %BigBrotherData; # replace the subs that DoSurgeProtection calls: # ReadRecentVisitors(); # AddRecentVisitor($name); # WriteRecentVisitors(); # if ($SurgeProtection and DelayRequired($name)) sub AddRecentVisitor { my ($name) = shift; my $value = $BigBrotherData{$name}; my %entries = $value ? %{$value} : (); # make sure we don't ignore hits in the same second my $ts = $Now; $ts++ while $entries{$ts}; my $action = GetParam('action', 'browse'); my $id = GetId(); # script/p/q -> q my $url = $q->url(-path_info=>1,-query=>1); my $download = GetParam('action', 'browse') eq 'download' || GetParam('download', 0) || $q->path_info() =~ m/\/download\//; if ($download) { # do nothing } elsif ($id) { $entries{$ts} = $id . $US . $url; } elsif ($action eq 'rss' or $action eq 'rc') { $entries{$ts} = $RCName . $US . $url; } else { $entries{$ts} = T('some action') . $US . $url; } $BigBrotherData{$name} = \%entries; } sub DelayRequired { my $name = shift; return 0 unless $BigBrotherData{$name}; my %entries = %{$BigBrotherData{$name}}; my @times = sort keys %entries; return 0 if not $times[$SurgeProtectionViews - 1]; # all slots must be filled return 0 if ($Now - $times[0]) > $SurgeProtectionTime; return 1; } sub ReadRecentVisitors { my ($status, $data) = ReadFile($VisitorFile); %BigBrotherData = (); return unless $status; foreach (split(/\n/,$data)) { my ($name, %entries) = split /$FS/; $BigBrotherData{$name} = \%entries if $name and %entries; } } sub WriteRecentVisitors { my $data = ''; my $limit = $Now - $VisitorTime; # don't save visits older than this foreach my $name (keys %BigBrotherData) { my %entries = %{$BigBrotherData{$name}}; my @times = sort keys %entries; # strip entries older than the older visits while (@times and $times[0] < $limit) { splice(@times, 0, 1); } # if we still have more than the number of elements required for # surge protection, delete these as well @times = @times[-$SurgeProtectionViews .. -1] if @times > $SurgeProtectionViews; $data .= join($FS, $name, map { $_, $entries{$_}} @times) . "\n" if @times; } WriteStringToFile($VisitorFile, $data); } $Action{visitors} = \&DoBigBrother; sub DoBigBrother { # no caching of this page! print GetHeader('', T('Recent Visitors'), '', 1), $q->start_div({-class=>'content visitors'}); ReadRecentVisitors(); print '

      '; my %latest = (); foreach (keys %BigBrotherData) { my %entries = %{$BigBrotherData{$_}}; my @times = sort keys %entries; $latest{$_} = $times[-1]; } foreach my $name (sort {$latest{$b} <=> $latest{$a}} keys %latest) { my $when = CalcTimeSince($Now - $latest{$name}); my $error = ValidId($name); my $who = $name && !$error && $name !~ /\./ ? GetPageLink($name) : T('Anonymous'); my %entries = %{$BigBrotherData{$name}}; my %reverse = (); # reverse hash to filter out duplicate targets foreach my $key (keys %entries) { $reverse{$entries{$key}} = $key; } my $what = join(', ', map { my ($id, $url) = split(/$US/, $entries{$_}); $q->a({-href=>$url}, $id); } sort values %reverse); print $q->li($who, T('was here'), $when, T('and read'), $what); } print '
    ' . $q->end_div(); PrintFooter(); } # Copyright (C) 2004, 2005, 2006 Alex Schroeder # Copyright (C) 2006 Ingo Belka # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA $ModulesDescription .= '

    calendar.pl (for 2.2.3-1-g1a561c3), see Calendar Extension

    '; use vars qw($CalendarOnEveryPage $CalAsTable $CalStartMonday); $CalendarOnEveryPage = 0; # 1=on every page is a month-div situated in the header, use css to control $CalAsTable = 0; # 0=every month-div is "free", 1=every month-div is caught in a table, use css to control $CalStartMonday = 0; # 0=week starts with Su, 1=week starts with Mo *OldCalendarGetHeader = *GetHeader; *GetHeader = *NewCalendarGetHeader; sub NewCalendarGetHeader { my $header = OldCalendarGetHeader(@_); return $header unless $CalendarOnEveryPage; my $action = GetParam('action', 'browse'); return $header if grep(/^$action$/, ('calendar', 'edit')); my $cal = Cal(); $header =~ s/
    /$cal
    /; return $header; } sub Cal { my ($year, $mon, $unlink_year, $id) = @_; # example: 2004, 12 $id = FreeToNormal($id); my ($sec_now, $min_now, $hour_now, $mday_now, $mon_now, $year_now) = localtime($Now); $mon_now += 1; $mon = $mon_now unless $mon; $year_now += 1900; $year = $year_now unless $year; if ($year < 1) { return $q->p(T('Illegal year value: Use 0001-9999')); } my @pages = AllPagesList(); my $cal = draw_month($mon, $year); $cal =~ s{( {1,2}\d{1,2})\b}{{ my $day = $1; my $date = sprintf("%d-%02d-%02d", $year, $mon, $day); my $re = "^$date"; $re .= ".*$id" if $id; my $page = $date; $page .= "_$id" if $id; my $class = ''; $class .= ' today' if $day == $mday_now and $mon == $mon_now and $year == $year_now; my @matches = grep(/$re/, @pages); my $link; if (@matches == 0) { # not using GetEditLink because of $class $link = ScriptLink('action=edit;id=' . UrlEncode($page), $day, 'edit' . $class); } elsif (@matches == 1) { # not using GetPageLink because of $class $link = ScriptLink($matches[0], $day, 'local exact' . $class); } else { $link = ScriptLink('action=collect;match=' . UrlEncode($re), $day, 'local collection' . $class); } $link; }}ge; $cal =~ s{(\S+) (\d\d\d\d)}{{ my ($month_text, $year_text) = ($1, $2); my $date = sprintf("%d-%02d", $year, $mon); if ($unlink_year) { $q->span({-class=>'title'}, ScriptLink('action=collect;match=%5e' . $date, "$month_text $year_text", 'local collection month')); } else { $q->span({-class=>'title'}, ScriptLink('action=collect;match=%5e' . $date, $month_text, 'local collection month') . ' ' . ScriptLink('action=calendar;year=' . $year, $year_text, 'local collection year')); } }}e; return "
    $cal
    "; } $Action{collect} = \&DoCollect; # inspired by journal sub DoCollect { my $id = shift; my $match = GetParam('match', ''); my $search = GetParam('search', ''); ReportError(T('The match parameter is missing.')) unless $match or $search; print GetHeader('', Ts('Page Collection for %s', $match||$search), ''); my @pages = (grep(/$match/, $search ? SearchTitleAndBody($search) : AllPagesList())); if (!$CollectingJournal) { $CollectingJournal = 1; # Now save information required for saving the cache of the current page. local (%Page, $OpenPageName); print $q->start_div({-class=>'content journal collection'}); PrintAllPages(1, 1, undef, @pages); print $q->end_div(); } $CollectingJournal = 0; PrintFooter(); } push(@MyRules, \&CalendarRule); sub CalendarRule { if (/\G(calendar:(\d\d\d\d))/gc) { my $oldpos = pos; Clean(CloseHtmlEnvironments()); Dirty($1); PrintYearCalendar($2); pos = $oldpos; return AddHtmlEnvironment('p'); } elsif (/\G(month:(\d\d\d\d)-(\d\d))/gc) { my $oldpos = pos; Clean(CloseHtmlEnvironments()); Dirty($1); print Cal($2, $3); pos = $oldpos; return AddHtmlEnvironment('p'); } elsif (/\G(month:([+-]\d\d?))/gc or /\G(\[\[month:([+-]\d\d?) $FreeLinkPattern\]\])/gc) { my $oldpos = pos; Clean(CloseHtmlEnvironments()); Dirty($1); my $delta = $2; my $id = $3; my ($sec, $min, $hour, $mday, $mon, $year) = localtime($Now); $year += 1900; $mon += 1 + $delta; while ($mon < 1) { $year -= 1; $mon += 12; }; while ($mon > 12) { $year += 1; $mon -= 12; }; print Cal($year, $mon, undef, $id); pos = $oldpos; return AddHtmlEnvironment('p'); } return undef; } sub PrintYearCalendar { my $year = shift; print $q->p({-class=>nav}, ScriptLink('action=calendar;year=' . ($year-1), T('Previous')), '|', ScriptLink('action=calendar;year=' . ($year+1), T('Next'))); if ($CalAsTable) { print ''; for $mon ((1..12)) { print ''; if (($mon==3) or ($mon==6) or ($mon==9)) { print ''; } } print '
    '.Cal($year, $mon, 1).'
    '; } else { for $mon ((1..12)) { print Cal($year, $mon, 1); } } } $Action{calendar} = \&DoYearCalendar; sub DoYearCalendar { my ($sec, $min, $hour, $mday, $mon, $year) = localtime($Now); $year += 1900; $year = GetParam('year', $year); print GetHeader('', Ts('Calendar %s', $year), ''); print $q->start_div({-class=>'content cal year'}); PrintYearCalendar($year); print $q->end_div(); PrintFooter(); } sub draw_month { my $month = shift; my $year = shift; my @weekday = (T('Su'), T('Mo'), T('Tu'), T('We'), T('Th'), T('Fr'), T('Sa')); my ($day, $col, $monthdays, $monthplus, $mod); my $weekday = zeller(1,$month,$year); # select the starting day for the week if ($CalStartMonday){ push @weekday, shift @weekday; if ($weekday) { $weekday = $weekday -1; } else { $weekday = 6; } } my $start = 1 - $weekday; my $space_count = int((21 - length(month_name($month).' '.sprintf("%04u",$year)))/2 + 0.5); # the Cal()-sub needs a 4 digit year working right my $output = (' ' x $space_count).month_name($month).' '.sprintf("%04u",$year)."\n"; $col = 0; $monthdays = &month_days($month,&leap_year($year)); if ((($monthdays-$start) < 42) and (($monthdays-$start) > 35)) { $monthplus=41 - ($monthdays-$start); } elsif ((($monthdays-$start)<35) and (($monthdays-$start)>28)) { $monthplus=34 - ($monthdays-$start); } else { $monthplus=0; } $output .= join('', map {" ".$_} @weekday); $output .= "\n"; for ($day=$start;$day<=$monthdays+$monthplus;$day++) { $col++; if (($day < 1) or ($day>$monthdays)) { $output .= ' '; } else { $output .= sprintf("%3d", $day); } $mod=($col/7)-int($col/7); if ($mod == 0) { $output .= "\n"; } if ($year==1582 and $month==10 and $day==4) { $day=14; } } $output .= "\n" x (8 - ($output =~ tr/\n//)); # every month has to have 8 lines as output return $output; } # formula of Zeller (Julius Christian Johannes Zeller * 1822, + 1899) for countig the day of week # only works for all years greater then 0 and can handle 1582 the year Pope Gregor has changed the # calculation of times from the Julian calendar to the Gregorian calendar sub zeller { my $t = shift; my $m = shift; my $year = shift; my ($h,$j,$w); $h=int($year/100); $j=$year%100; if ($m<3) { $m = $m+10; if ($j==0) { $j=99; $h=$h-1; } else { $j=$j-1; } } else { $m=$m-2; } if (($year > 0) and ($year < 1582)) { $w = $t + int((2.61 * $m) - 0.2) + $j + int($j/4) + 5 - $h; } elsif ($year==1582) { if ($m > 10) { $w = $t + int((2.61 * $m) - 0.2) + $j + int($j/4) + 5 - $h; } elsif ($m==8) { if ($t>=1 and $t<=4) { $w = $t + int((2.61 * $m) - 0.2) + $j + int($j/4) + 5 - $h; } elsif ($t>=15) { $w = $t + int((2.61 * $m) - 0.2) + $j + int($j/4) + int($h/4) - (2*$h); } } elsif ($m <= 10) { $w = $t + int((2.61 * $m) - 0.2) + $j + int($j/4) + int($h/4) - (2*$h); } } elsif ($year > 1582) { $w = $t + int((2.61 * $m) - 0.2) + $j + int($j/4) + int($h/4) - (2*$h); } if (($w % 7) >= 0) { $w = $w % 7; } else { $w = 7 - (-1 * ($w % 7)); } return $w; } sub leap_year { my $year = shift; if ((($year % 4)==0) and !((($year % 100)==0) and (($year % 400) != 0))) { return 1; } else { return 0; } } sub month_days { my $month = shift; my $leap_year = shift; my @month_days = (31,28,31,30,31,30,31,31,30,31,30,31); if (($month == 2) and $leap_year) { return $month_days[$month - 1] + 1; } else { return $month_days[$month - 1]; } } sub month_name { my $month = shift; my @month_name = (T('January'), T('February'), T('March'), T('April'), T('May'), T('June'), T('July'), T('August'), T('September'), T('October'), T('November'), T('December')); return $month_name[$month-1]; } # Copyright (C) 2006, 2012 Alex Schroeder # # 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 . use File::Glob ':glob'; use vars qw($DraftDir); $DraftDir = $DataDir."/draft"; # directory for drafts push(@MyInitVariables, \&DraftInit); sub DraftInit { if (GetParam('Draft', '')) { SetParam('action', 'draft') ; # Draft button used } elsif (-f "$DraftDir/" . GetParam('username', GetRemoteHost()) # draft exists and $FooterNote !~ /action=draft/) { # take care of mod_perl persistence $FooterNote = $q->p(ScriptLink('action=draft', T('Recover Draft'))) . $FooterNote; } } $Action{draft} = \&DoDraft; sub DoDraft { my $id = shift; my $draft = $DraftDir . '/' . GetParam('username', GetRemoteHost()); if ($id) { my $text = GetParam('text', ''); ReportError(T('No text to save'), '400 BAD REQUEST') unless $text; CreateDir($DraftDir); WriteStringToFile($draft, EncodePage(text=>$text, id=>$id)); SetParam('msg', T('Draft saved')); # invalidate cache print GetHttpHeader('', T('Draft saved'), '204 NO CONTENT'); } elsif (-f $draft) { my %data = ParseData(ReadFileOrDie($draft)); unlink ($draft); $Message .= $q->p(T('Draft recovered')); DoEdit($data{id}, $data{text}, 1); } else { ReportError(T('No draft available to recover'), '404 NOT FOUND'); } } # add preview button to edit page (but not to GetCommentForm!) *DraftOldGetEditForm = *GetEditForm; *GetEditForm = *DraftNewGetEditForm; sub DraftNewGetEditForm { my $html = DraftOldGetEditForm(@_); # assume that the preview button html is the same for two calls my $draft_button = $q->submit(-name=>'Draft', -value=>T('Save Draft')); $html =~ s!(]*name="Cancel"[^>]*>)!$1 $draft_button!; return $html; } # cleanup push(@MyMaintenance, \&DraftCleanup); sub DraftFiles { return map { $_ = substr($_, length($DraftDir) + 1); utf8::decode($_); $_; } bsd_glob("$DraftDir/*"), bsd_glob("$DraftDir/.*"); } sub DraftCleanup { print '

    ' . T('Draft Cleanup'); foreach my $draft (DraftFiles()) { next if $draft eq '.' or $draft eq '..'; my $ts = (stat("$DraftDir/$draft"))[9]; if ($Now - $ts < 1209600) { # 14*24*60*60 print $q->br(), Tss("%1 was last modified %2 and was kept", $draft, CalcTimeSince($Now - $ts)); } elsif (unlink("$DraftDir/$draft")) { print $q->br(), Tss("%1 was last modified %2 and was deleted", $draft, CalcTimeSince($Now - $ts)); } else { print $q->br(), Ts('Unable to delete draft %s', $draft); } } print '

    '; } #!/usr/bin/env perl # ====================[ footnotes.pl ]==================== =head1 NAME footnotes - An Oddmuse module for adding footnotes to Oddmuse Wiki pages. =head1 INSTALLATION footnotes is easily installable; move this file into the B directory for your Oddmuse Wiki. =cut package OddMuse; $ModulesDescription .= '

    footnotes.pl (for 2.2.3-1-g1a561c3), see Footnotes Extension

    '; # ....................{ CONFIGURATION }.................... =head1 CONFIGURATION footnotes is easily configurable; set these variables in the B file for your Oddmuse Wiki. =cut use vars qw($FootnotePattern $FootnotesPattern $FootnotesHeaderText @FootnoteList); =head2 $FootnotePattern A regular expression matching text within an Oddmuse Wiki page, which, when matched, replaces that text with a footnote reference. In other words, text matching this regular expression becomes a "footnote." If left unset, this regular expression takes one of two defaults - depending on which other Oddmuse markup modules are installed (so as not to conflict with those other Oddmuse markup modules' markup rules). =over =item (($FootnoteText)) =over =item If the Creole Markup module (B) is also installed, then this is the default regular expression for marking a footnote (where C<$FootnoteText> is the displayed text for that footnote). =back =item {{$FootnoteText}} =over =item If the Creole Markup module (B) is not installed, then this is the default regular expression for marking a footnote (where C<$FootnoteText> is the displayed text for that footnote). This is, also, the old default for this module. =back =back =cut $FootnotePattern = undef; =head2 $FootnotesPattern A regular expression matching text within an Oddmuse Wiki page, which, when matched, replaces that text with the set of all page footnotes. Any page with footnotes (i.e., any page with at least one string matching the C<$FootnotePattern>) should collect and show those footnotes somewhere in that page. Luckily, there are two mechanisms for effecting this - the first via explicit markup, and the second via implicit fallback; these are: =over =item =over =item If a page has markup explicitly matched by this regular expression, that markup is replaced by the set of footnotes for the page. =back =item N/A =over =item Otherwise, if a page has no such markup but does have at least one footnote, the set of footnotes for the page is automatically situated between the content and footer for that page. As this may, or may not, be the proper place for page footnotes, you're encouraged to explicitly provide page markup matched by this regular expression. =back =back =cut $FootnotesPattern = '\<footnotes\>[ \t]*(\n|$)'; =head2 $FootnotesHeaderText The string displayed as the header to the set of all page footnotes. =cut $FootnotesHeaderText = 'Footnotes:'; # ....................{ INITIALIZATION }.................... push(@MyInitVariables, \&FootnotesInit); sub FootnotesInit { @FootnoteList = (); if (not defined $FootnotePattern) { $FootnotePattern = defined &CreoleRule ? '\(\((.+?)\)\)' : '\{\{(.+?)\}\}'; } } # ....................{ MARKUP }.................... push(@MyRules, \&FootnotesRule); =head2 MARKUP =head3 CREATING FOOTNOTES footnotes handles markup resembling (assuming the Creole Markup module is also installed): (($FootnoteText)) C<$FootnoteText> is the text for that footnote. This extension replaces that text (and enclosing parentheses) with a numbered link to the footnote in the set of all footnotes for that page - usually, at the foot of the page. As example of a citation for Jared Diamond's "Collapse: How Societies Choose to Fail or Succeed" (2005), you might write: History suggests that societal decline does not result from a single cause, but rather the confluence of several interwoven causes.((Diamond, Jared. 2005. **Collapse: How Societies Choose to Fail or Succeed.** %%Viking, New York.%%)) Note that the example above embeds Wiki Creole syntax within the footnote definition itself. This is perfectly legal and, in fact, encouraged. =head3 CREATING MULTIPLE FOOTNOTES footnotes also handles markup resembling: (($FirstFootnoteText))(($NextFootnoteText)) C<$FirstFootnoteText> and C<$NextFootnoteText> are the text for two adjacent footnotes. These footnote definitions will be handled and displayed as above, except that the numbered link for the first footnote will be visually delimited from the numbered link for the footnote that follows it with a ", ". As example, you might write: History suggests that societal decline does not result from a single cause, but rather the confluence of several interwoven causes.((Diamond, Jared. 2005. **Collapse: How Societies Choose to Fail or Succeed.** %%Viking, New York.%%)) ((Tainter, Joseph. 1988. **The Collapse of Complex Societies.** %%Cambridge Univ Press, Cambridge, UK.%%)) =head3 REFERENCING ANOTHER FOOTNOTE footnotes also handles marking resembling: (($FootnoteNumber)) C<$FootnoteNumber> is the number for another footnote. This module assigns each footnote definition a unique number, beginning at "1". Thus, this markup allows you to reference one footnote definition in multiple places throughout a page. As example, you might write: History suggests that societal decline does not result from a single cause, but rather the confluence of several interwoven causes.((Diamond, Jared. 2005. **Collapse: How Societies Choose to Fail or Succeed.** %%Viking, New York.%%)) Such causes include a human-dominated ecosystem moving to a brittle, non- resilient state due to climatological changes.((Weiss H, Bradley RS. 2001. **What drives societal collapse?** %%Science 291:609–610.%%)) Societal decline only occurs, however, when socio-ecological systems become brittle and incapable of adaptation.((1)) The final footnote, above, is a reference to the first footnote definition rather than a new footnote definition. =head3 REFERENCING A RANGE OF OTHER FOOTNOTES footnotes also handles marking resembling: (($FirstFootnoteNumber-$LastFootnoteNumber)) C<$FirstFootnoteNumber> and C<$LastFootnoteNumber> are the numbers for two other footnotes. Thus, this markup allows you to reference a range of footnote definitions in multiple places throughout a page. As example, you might write: History suggests that societal decline does not result from a single cause, but rather the confluence of several interwoven causes.((Diamond, Jared. 2005. **Collapse: How Societies Choose to Fail or Succeed.** %%Viking, New York.%%)) Such causes include a human-dominated ecosystem moving to a brittle, non- resilient state due to climatological changes((Weiss H, Bradley RS. 2001. **What drives societal collapse?** %%Science 291:609–610.%%)), external forcings((Tainter, Jared. 2006. **Social complexity and sustainability.** %%Ecol Complex 3:91–103.%%)), or internal pressures((Cullen HM, et al. 2000. **Climate change and the collapse of the Akkadian empire: Evidence from the deep sea.** %%Geology 28:379–382.%%)). Societal decline only occurs, however, when socio-ecological systems become brittle and incapable of adaptation.((1-2))((4)) The final footnotes, above, are a reference to the first two footnote definitions followed by a reference to the fourth footnote definition. This module visually renders this disjoint list like: "1-2, 4". =head3 CREATING THE SET OF FOOTNOTES footnotes also handles markup resembling: This extension replaces that markup with the set of all footnotes for that page. Note that, if that page has no such markup, this extension automatically places the set of all footnotes for that page between the content and footer for that page. (This may or not be what you want, of course.) =cut sub FootnotesRule { # A "((...))" footnote anywhere in a page. # # Footnotes and the set of all footnotes must be marked so as to ensure their # reevaluation, as each of the footnotes might contain Wiki markup requiring # reevaluation (like, say, free links). if (m/\G($FootnotePattern)(?=([ \t]*$FootnotePattern)?)/gcos) { Dirty($1); # do not cache the prefixing "\G" my $footnote_text = $2; my $is_adjacent_footnote = defined $3; # A number range (e.g., "2-5") of references to other footnotes. if ($footnote_text =~ m/^(\d+)-(\d+)$/co) { my ($footnote_number_first, $footnote_number_last) = ($1, $2); # '–', below, is the HTML entity for a Unicode en-dash. print $q->a({-href=> '#footnotes' .$footnote_number_first, -title=> 'Footnote #'.$footnote_number_first, -class=> 'footnote' }, $footnote_number_first.'–') .$q->a({-href=> '#footnotes' .$footnote_number_last, -title=> 'Footnote #'.$footnote_number_last, -class=> 'footnote' }, $footnote_number_last.($is_adjacent_footnote ? ', ' : '')); } # A number (e.g., "5") implying reference to another footnote. elsif ($footnote_text =~ m/^(\d+)$/co) { my $footnote_number = $1; print $q->a({-href=> '#footnotes' .$footnote_number, -title=> 'Footnote #'.$footnote_number, -class=> 'footnote' }, $footnote_number.($is_adjacent_footnote ? ', ' : '')); } # Otherwise, a new footnote definition. else { push(@FootnoteList, $footnote_text); my $footnote_number = @FootnoteList; print $q->a({-href=> '#footnotes'.$footnote_number, -name=> 'footnote' .$footnote_number, -title=> 'Footnote: '. # Truncate link titles to one line. ( length($footnote_text) > 48 ? substr($footnote_text, 0, 44).'...' : $footnote_text), -class=> 'footnote' }, $footnote_number.($is_adjacent_footnote ? ', ' : '')); } return ''; } # The "" list of all footnotes at the foot of a page. elsif ($bol && m/\G($FootnotesPattern)/gcios) { Clean(CloseHtmlEnvironments()); Dirty($1); # do not cache the prefixing "\G" if (@FootnoteList) { my ($oldpos, $old_) = (pos, $_); PrintFootnotes(); Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!) } return ''; } return undef; } # ....................{ HTML OUTPUT }.................... *PrintFooterFootnotesOld = *PrintFooter; *PrintFooter = *PrintFooterFootnotes; =head2 PrintFooterFootnotes Appends the list of footnotes to the footer of the page, if and only if the user-provided content for that page had no content matching C<$FootersPattern>. Thus, this function is an eleventh-hour fallback; ideally, pages providing footnotes also provide an explicit place to list those footnotes. =cut sub PrintFooterFootnotes { my @params = @_; if (@FootnoteList) { PrintFootnotes(); } PrintFooterFootnotesOld(@params); } =head2 PrintFootnotes Prints the list of footnotes. =cut sub PrintFootnotes() { print $q->start_div({-class=> 'footnotes'}) .$q->h2(T($FootnotesHeaderText)); # Don't use
      , because we want to link from the number back to # its page location. my $footnote_number = 1; foreach my $footnote (@FootnoteList) { print $q->start_div({-class=> 'footnote'}) .$q->a({-class=> 'footnote_backlink', -name=> 'footnotes'.$footnote_number, -href=> '#footnote' .$footnote_number}, $footnote_number.'.') .' '; ApplyRules($footnote, 1); print $q->end_div(); $footnote_number++; } print $q->end_div(); # Empty the footnotes, now; this prevents our calling the fallback, later. @FootnoteList = (); } =head1 COPYRIGHT AND LICENSE The information below applies to everything in this distribution, except where noted. Copyleft 2008 by B.w.Curry . Copyright 2004 by Alex Schroeder . 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 L. =cut #!/usr/bin/env perl # ====================[ forms.pl ]==================== $ModulesDescription .= '

      forms.pl (for 2.2.3-1-g1a561c3), see Form Extension

      '; # ....................{ MARKUP }.................... push(@MyRules, \&FormsRule); sub FormsRule { if (-f GetLockedPageFile($OpenPageName) or (InElement('div', '^class="crossbar"$') and -f GetLockedPageFile($CrossbarPageName))) { if (/\G(\<form.*?\<\/form\>)/cgs) { my $form = $1; my $oldpos = pos; Clean(CloseHtmlEnvironments()); Dirty($form); $form =~ s/\%([a-z]+)\%/GetParam($1)/ge; $form =~ s/\$([a-z]+)\$/$q->span({-class=>'param'}, GetParam($1)) .$q->input({-type=>'hidden', -name=>$1, -value=>GetParam($1)})/ge; print UnquoteHtml($form); pos = $oldpos; return AddHtmlEnvironment('p'); } elsif (m/\G\<html\>(.*?)\<\/html\>/cgs) { return UnquoteHtml($1); } } return undef; } =head1 COPYRIGHT AND LICENSE The information below applies to everything in this distribution, except where noted. Copyleft 2008 by B.w.Curry . Copyright 2004 by Alex Schroeder . 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 L. =cut # Copyright (C) 2004, 2005, 2006, 2007 Alex Schroeder # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA $ModulesDescription .= '

      image.pl (for 2.2.3-1-g1a561c3), see Image Extension

      '; use vars qw($ImageUrlPath); $ImageUrlPath = '/images'; # URL where the images are to be found push(@MyRules, \&ImageSupportRule); # [[image/class:page name|alt text|target]] sub ImageSupportRule { my $result = undef; if (m!\G\[\[image((/[a-z]+)*)( external)?:\s*([^]|]+?)\s*(\|[^]|]+?)?\s*(\|[^]|]*?)?\s*(\|[^]|]*?)?\s*(\|[^]|]*?)?\s*\]\]!gc) { my $oldpos = pos; my $class = 'image' . $1; my $external = $3; my $name = $4; # Don't generate an alt text if none was specified, since the rule # forces you to pick an alt text if you're going to provide a # link target. my $alt = UnquoteHtml($5 ? substr($5, 1) : ''); $alt = NormalToFree($name) if not $alt and not $external and $name !~ /^$FullUrlPattern$/; my $link = $6 ? substr($6, 1) : ''; my $caption = $7 ? substr($7, 1) : ''; my $reference = $8 ? substr($8, 1) : ''; my $id = FreeToNormal($name); $class =~ s!/! !g; my $linkclass = $class; my $found = 1; # link to the image if no link was given $link = $name unless $link; if ($link =~ /^($FullUrlPattern|$FreeInterLinkPattern)$/ or $link =~ /^$FreeLinkPattern$/ and not $external) { ($link, $linkclass) = ImageGetExternalUrl($link, $linkclass); } else { $link = $ImageUrlPath . '/' . ImageUrlEncode($link); } my $src = $name; if ($src =~ /^($FullUrlPattern|$FreeInterLinkPattern)$/) { ($src) = ImageGetExternalUrl($src); } elsif ($src =~ /^$FreeLinkPattern$/ and not $external) { $found = $IndexHash{FreeToNormal($src)}; $src = ImageGetInternalUrl($src) if $found; } else { $src = $ImageUrlPath . '/' . ImageUrlEncode($name); } if ($found) { $result = $q->img({-src=>$src, -alt=>$alt, -title=>$alt, -class=>'upload'}); $result = $q->a({-href=>$link, -class=>$linkclass}, $result); } else { $result = GetDownloadLink($src, 1, undef, $alt); } if ($caption) { if ($reference) { my $refclass = $class; ($reference, $refclass) = ImageGetExternalUrl($reference, $refclass); $caption = $q->a({-href=>$reference, -class=>$refclass}, $caption); } $result .= $q->br() . $q->span({-class=>'caption'}, $caption); $result = CloseHtmlEnvironments() . $q->div({-class=>$class}, $result); } pos = $oldpos; } return $result; } sub ImageUrlEncode { # url encode everything except for slashes return join('/', map { UrlEncode($_) } split(/\//, shift)); } sub ImageGetExternalUrl { my ($link, $class) = @_; if ($link =~ /^$FullUrlPattern$/) { $link = UnquoteHtml($link); $class .= ' outside'; } elsif ($link =~ /^$FreeInterLinkPattern$/) { my ($site, $page) = split(/:/, $link, 2); $link = GetInterSiteUrl($site, $page, 1); # quote! $class .= ' inter ' . $site; } else { $link = FreeToNormal($link); if (substr($link, 0, 1) eq '/') { # do nothing -- relative URL on the same server } elsif ($UsePathInfo and !$Monolithic) { $link = $ScriptName . '/' . $link; } elsif ($Monolithic) { $link = '#' . $link; } else { $link = $ScriptName . '?' . $link; } } return ($link, $class); } # split off to support overriding from Static Extension sub ImageGetInternalUrl { my $id = FreeToNormal(shift); if ($UsePathInfo) { return $ScriptName . "/download/" . UrlEncode($id); } return $ScriptName . "?action=download;id=" . UrlEncode($id); } # Copyright (C) 2004 Alex Schroeder # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA $ModulesDescription .= '

      irc.pl (for 2.2.3-1-g1a561c3), see IRC Log Extension

      '; use vars qw($IrcNickRegexp $IrcLinkNick); push(@MyRules, \&IrcRule); $RuleOrder{\&IrcRule} = 200; # after HTML tags in Usemod Markup Extension. $IrcNickRegexp = qr{[]a-zA-Z^[;\\`_{}|][]^[;\\`_{}|a-zA-Z0-9-]*}; $IrcLinkNick = 0; # This adds an extra
      at the beginning. Alternatively, add it to # the last line, or only add it when required. sub IrcRule { if ($bol && m/\G(?:\[?(\d\d?:\d\d(?:am|pm)?)\]?)?\s*<($IrcNickRegexp)> ?/gc) { my ($time, $nick) = ($1, $2); my ($error) = ValidId($nick); # if we're in a dl, close the open dd but not the dl. (if we're # not in a dl, that closes all environments.) then open a dl # unless we're already in a dl. put the nick in a dt. my $html = CloseHtmlEnvironmentUntil('dd') . OpenHtmlEnvironment('dl', 1, 'irc') . AddHtmlEnvironment('dt'); $html .= $q->span({-class=>'time'}, $time, ' ') if $time; if ($error or not $IrcLinkNick) { $html .= $q->b($nick); } else { $html .= GetPageOrEditLink($nick); } $html .= CloseHtmlEnvironment('dt') . AddHtmlEnvironment('dd'); return $html; } return undef; } # Copyright (C) 2004 Alex Schroeder # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA # In your CSS file, use something like this, for example: # span[lang=en] { background-color:#ddf; } # span[lang=fr] { background-color:#fdd; } # span[lang=de] { background-color:#ffd; } # span[lang=it] { background-color:#dfd; } $ModulesDescription .= '

      lang.pl (for 2.2.3-1-g1a561c3), see Language Extension

      '; push(@MyRules, \&LangRule); sub LangRule { if (m/\G\[([a-z][a-z])\]/gc) { my $html; $html .= "" if $HtmlStack[0] eq 'span'; return $html . AddHtmlEnvironment('span', "lang=\"$1\"") . "[$1]"; } return undef; } *OldLangInitCookie = *InitCookie; *InitCookie = *NewLangInitCookie; sub NewLangInitCookie { OldLangInitCookie(@_); if ($q->param('setlang')) { my @old = split(/ /, GetParam('theme', '')); my @old_normal; my @old_languages; foreach $entry (@old) { if (length($entry) == 2) { push(@old_languages, $entry); } else { push(@old_normal, $entry); } } my @new = $q->param('languages'); SetParam('theme', join(' ', @old_normal, @new)); } } *OldLangGetNearLinksUsed = *GetNearLinksUsed; *GetNearLinksUsed = *NewLangGetNearLinksUsed; sub NewLangGetNearLinksUsed { my $id = shift; my $html = OldLangGetNearLinksUsed($id); my @langs = qw(en de fr it pt); my @selected = split(/ /, GetParam('theme', '')); # may contain elements that are not in @langs! $html .= $q->div({-class=>'languages'}, "
      ", $q->p(GetHiddenValue('action', 'browse'), GetHiddenValue('id', $id), T('Languages:'), ' ', $q->checkbox_group('languages', \@langs, \@selected), $q->hidden('setlang', '1'), $q->submit('dolang', T('Show!'))), '
      '); return $html; } # Copyright (C) 2004, 2005, 2007 Alex Schroeder # # 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 . $ModulesDescription .= '

      localnames.pl (for 2.2.3-1-g1a561c3), see Local Names Extension

      '; =head1 Local Names This module allows you to centrally define redirections. Thus you can define that whenever somebody links to the page Foo the link will point to http://example.com/. These redirects are defined on special page called LocalNames. You can change the name of that page by setting C<$LocalNamesPage>. You can also link to external lists of such redirections, as long as they use the namespace description format developed by Lion Kimbro. Basically you can "import" redirections. These external lists are cached in a directory called C inside the data directory. You can change the directory by setting C<$LnDir>. =cut use vars qw($LocalNamesPage %LocalNames $LocalNamesCollect $LocalNamesCollectMaxWords $LnDir $LnCacheHours %WantedPages); $LocalNamesPage = 'LocalNames'; $LocalNamesCollect = 0; $LocalNamesCollectMaxWords = 2; # LN caching is written very similar to the RSS file caching $LnDir = "$DataDir/ln"; $LnCacheHours = 12; sub GetLnFile { return $LnDir . '/' . UrlEncode(shift); } =head2 Maintenance Whenever maintenance runs, all the cached external lists of redirections are deleted whenever they are older than twelve hours. You can change this expiry time by setting C<$LnCacheHours>. =cut push (MyMaintenance, \&LnMaintenance); sub LnMaintenance { if (opendir(DIR, $RssDir)) { # cleanup if they should expire anyway foreach (readdir(DIR)) { unlink "$RssDir/$_" if $Now - (stat($_))[9] > $LnCacheHours * 3600; } closedir DIR; } } =head2 Defining Local Names Local Names are defined on the LocalNames page. If you create ordinary named external links such as C<[http://ln.taoriver.net/ Local Names Website]> on the LocalNames page, you will have defined a new Local Name. If you write C<[[Local Names Website]]> elsewhere on the site (and the page does not exist), that link will point to the website you specified. You can link from the LocalNames page to existing namespace descriptions. These other namespace descriptions must use the namespace description format developed by Lion Kimbro. If you write C<[[ln:URL]]> or C<[[ln:URL text]]>, this will import all the Local Names defined there into your wiki. Example: C<[[ln:http://ln.taoriver.net/localnames.txt Lion's Example Localnames List]]>. Currently only LN records with absolute URLs are parsed correctly. All other record types are ignored. If you want to learn more about local names, see L. =cut # render [[ln:url]] as something clickable push(@MyRules, \&LocalNamesRule); sub LocalNamesRule { if (m/\G\[\[ln:$FullUrlPattern\s*([^\]]*)\]\]/cog) { # [[ln:url text]], [[ln:url]] return $q->a({-class=>'url outside ln', -href=>$1}, $2||$1); } return undef; } =head2 Initialization The LocalNames page is added to C<%AdminPages> so that the Administration page will list a link to it. The LocalNames page will be read and parsed for every request. The result is that the C<%LocalNames> hash has pagenames as keys and URLs to redirect to as values. If the LocalNames page refers to external lists of redirections, these will be read from the cache or fetched anew if older than twelve hours. If you use the cache=0 parameter in an URL or set C<$UseCache> to zero or less, Oddmuse will B. Using the cache=0 parameter is a way to force Oddmuse to expire the cache. Setting C<$UseCache> to 0 should not be used on a live site. Definitions of redirections on the LocalNames take precedence over redirections defined on remote sites. Earlier lists of redirections take precedence over later lists. We ignore the spec at L when considering what names we allow, since Oddmuse will parse them as regular links anyway. =cut push(@MyInitVariables, \&LocalNamesInit); sub LocalNamesInit { %WantedPages = (); # list of missing pages used during this request %LocalNames = (); $LocalNamesPage = FreeToNormal($LocalNamesPage); # spaces to underscores $AdminPages{$LocalNamesPage} = 1; my $data = GetPageContent($LocalNamesPage); while ($data =~ m/\[$FullUrlPattern\s+([^\]]+?)\]/go) { my ($page, $url) = ($2, $1); my $id = FreeToNormal($page); $LocalNames{$id} = $url; } # Now read data from ln links, checking cache if possible. For all # URLs not in the cache or with invalid cache, fetch the file again, # and save it in the cache. my @ln = $data =~ m/\[\[ln:$FullUrlPattern[^\]]*?\]\]/go; my %todo = map {$_, GetLnFile($_)} @ln; my %data = (); if (GetParam('cache', $UseCache) > 0) { foreach my $uri (keys %todo) { # read cached rss files if possible if ($Now - (stat($todo{$uri}))[9] < $LnCacheHours * 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::Parllel::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))) { warn $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->content; } } } foreach my $uri (keys %todo) { # default operation: synchronous fetching $data{$uri} = GetRaw($uri); } if (GetParam('cache', $UseCache) > 0) { CreateDir($LnDir); foreach my $uri (@need_cache) { WriteStringToFile(GetLnFile($uri), $data{$uri}); } } # go through the urls in the right order, this time foreach my $ln (@ln) { my ($previous_type, $previous_url); foreach my $line (split(/[\r\n]+/, $data{$ln})) { if ($line =~ /^LN\s+"$FreeLinkPattern"\s+(?:"$FullUrlPattern"|\.)$/ or $previous_type eq 'LN' and $line =~ /^\.\s+"$FreeLinkPattern"\s+(?:"$FullUrlPattern"|\.)$/) { my ($name, $url) = ($1, $2); $url = $previous_url if not $url and $previous_url; $previous_url = $url; $previous_type = 'LN'; my $id = FreeToNormal($name); # Only store this, if not already stored! if (not $LocalNames{$id}) { $LocalNames{$id} = $url; } } else { $previous_type = undef; } # elsif ($line =~ /^NS "(.*)" "$FullUrlPattern"$/g) { # } } } } =head2 Name Resolution We want Near Links only to have an effect for pages that do not exist locally. It should not take precedence! Thus, we hook into C; this function returns a list of four elements: CSS class, resolved id, title (eg. for popups), and a boolean saying whether the page exists or not. If the second element is empty, then no page exists and we check C<%LocalNames> for a match. If there is a match, we return the URL using the CSS class "near" and the title "LocalNames". The CSS class is the same that is used for Near Links because the effect is so similar. Note: Existing local pages take precedence over local names, but local names take precedence over Near Links. We also keep track of wanted pages (links to missing pages) so that we can printe a list of definition links at the bottom using the Define Action (see below). =cut *OldLocalNamesResolveId = *ResolveId; *ResolveId = *NewLocalNamesResolveId; sub NewLocalNamesResolveId { my $id = shift; my ($class, $resolved, @rest) = OldLocalNamesResolveId($id, @_); if ((not $resolved or $class eq 'near') and $LocalNames{$id}) { return ('near', $LocalNames{$id}, $LocalNamesPage); } else { $WantedPages{$id} = 1 if not $resolved; # this is provisional! return ($class, $resolved, @rest); } } =head2 Automatically Defining Local Names It is possible to have Oddmuse automatically define local names as you edit pages. In order to enable this, set C<$LocalNamesCollect> to 1. Once you this, every time you save a page with a named external link such as C<[http://www.emacswiki.org/alex/ Alex]>, this will add or update the corresponding entry on the LocalNames page. In order to reduce the number of entries thus collected, only external links with a name consisting of one or two words are used. You can change this word limit by setting C<$LocalNamesCollectMaxWords>. The default limit of two words assumes that you might want to make C a link, or C, but not C (five “words”, since the code looks at whitespace only). =cut *LocalNamesOldSave = *Save; *Save = *LocalNamesNewSave; sub LocalNamesNewSave { LocalNamesOldSave(@_); my ($currentid, $text) = @_; # avoid recursion return if $currentid eq $LocalNamesPage or not $LocalNamesCollect; my $currentname = $currentid; $currentname =~ s/_/ /g; local ($OpenPageName, %Page); OpenPage($LocalNamesPage); my $localnames = $Page{text}; my %map = (); while ($text =~ /\[$FullUrlPattern\s+(([^ \]]+?\s*){1,$LocalNamesCollectMaxWords})\]/g) { my ($page, $url) = ($2, $1); my $id = FreeToNormal($page); $map{$id} = () unless defined $map{$id}; $map{$id}{$url} = 1; } my %collection = (); foreach my $id (keys %map) { # canonical form with trimmed spaces and no underlines my $page = $id; $page =~ s/_/ /g; # skip if the mapping from id to url already defined matches at # least one of the definitions on the current page. next if $map{$id}{$LocalNames{$id}}; $collection{$page} = 1; # pick a random url from the list my @urls = keys %{$map{$id}}; my $url = $urls[0]; # if a different mapping exists already; change the old mapping to the new one # if the change fails (eg. the page name is not in canonical form), don't skip! next if $LocalNames{$id} and $localnames =~ s/\[$LocalNames{$id}\s+$page\]/[$url $page]/g; # add a new entry at the end $localnames .= "\n\n* [$url $page]" . Ts(" -- defined on %s", "[[$currentname]]"); $LocalNames{$id} = $url; # prevent multiple additions } # minor change my @collection = sort keys %collection; Save($LocalNamesPage, $localnames, Tss("Local names defined on %1: %2", $currentname, length(@collection > 1) ? join(', and ', join(', ', @collection[0 .. $#collection-1]), @collection[-1]) : @collection), 1) unless $localnames eq $Page{text}; } =head2 Local Names Format The Ln Action lists all the local pages in the local names format defined in the specification. Example URL: C. If you want to learn more about local names and the format used, see L. =cut $Action{ln} = \&DoLocalNames; sub DoLocalNames { print GetHttpHeader('text/plain'); print "X VERSION 1.2\n"; print "# Local Pages\n"; foreach my $id (AllPagesList()) { my $title = $id; $title =~ s/_/ /g; my $url = $ScriptName . ($UsePathInfo ? '/' : '?') . $id; print qq{LN "$title" "$url"\n}; } if (GetParam('expand', 0)) { print "# Local names defined on $LocalNamesPage:\n"; my $data = GetPageContent($LocalNamesPage); while ($data =~ m/\[$FullUrlPattern\s+([^\]]+?)\]/go) { my ($title, $url) = ($2, $1); my $id = FreeToNormal($title); print qq{LN "$title" "$url"\n}; } print "# Namespace delegations defined on $LocalNamesPage:\n"; while ($data =~ m/\[\[ln:$FullUrlPattern([^\]]*)?\]\]/go) { my ($title, $url) = ($2, $1); my $id = FreeToNormal($title); print qq{NS "$title" "$url"\n}; } } else { print "# Local names defined on $LocalNamesPage:\n"; foreach my $id (keys %LocalNames) { my $title = $id; $title =~ s/_/ /g; print qq{LN "$title" "$LocalNames{$id}"\n}; } } } =head2 Define Action The Define Action allows you to interactively add local names using a form. Example URL: C. You can also provide the C and C parameters yourself if you want to use this action from a script. As wanted pages (links to missing pages) come up, you will get links to appropriate define actions in your footer. =cut $Action{define} = \&DoDefine; sub DoDefine { if (GetParam('link', '') and GetParam('name', '')) { SetParam('title', $LocalNamesPage); SetParam('text', GetPageContent($LocalNamesPage) . "\n* [" . GetParam('link', '') . ' ' . GetParam('name', '') . "]\n"); SetParam('summary', 'Defined ' . GetParam('name')); return DoPost($LocalNamesPage); } else { print GetHeader('', T('Define')), $q->start_div({-class=>'content define'}), GetFormStart(undef, 'get', 'def'); my $go = T('Go!'); print $q->p($q->label({-for=>"defined"}, T('Name: ')), $q->textfield(-name=>"name", -id=>"defined", -tabindex=>"1", -size=>20)); print $q->p($q->label({-for=>"definition"}, T('URL: ')), $q->textfield(-name=>"link", -id=>"definition", -tabindex=>"2", -size=>20)); print $q->p($q->submit(-label=>$go, -tabindex=>"3"), GetHiddenValue('action', 'define'), GetHiddenValue('recent_edit', 'on')); print $q->end_form, $q->end_div(); PrintFooter(); } } push(@MyAdminCode, sub { my ($id, $menuref, $restref) = @_; push(@$menuref, ScriptLink('action=define', T('Define Local Names'), 'define')); }); # link to define action for non-existing pages push(@MyFooters, \&GetWantedPages); sub GetWantedPages { # skip admin pages foreach my $id (@UserGotoBarPages, keys %AdminPages) { delete $WantedPages{$id}; } # skip comment pages if ($CommentsPrefix) { foreach my $id (keys %WantedPages) { delete $WantedPages{$id} if $id =~ /^$CommentsPrefix/o; } } # now something more complicated: if near-links.pl was loaded, then # %WantedPages may contain pages that will in fact resolve. That's # why we try to resolve all the wanted ids again. And since # resolving ids will do stuff to %WantedPages, we need to make a # copy of the ids we're looking at. my @wanted; foreach my $id (keys %WantedPages) { my ($class, $resolved) = ResolveId($id); push(@wanted, $id) unless $resolved; } # if any wanted pages remain, print them if (@wanted) { return $q->div({-class=>'definition'}, $q->p(T('Define external redirect: '), map { my $page = NormalToFree($_); ScriptLink('action=define;name=' . UrlEncode($page), $page, 'define'); } @wanted)); } return ''; } =head1 NAME tags - an Oddmuse module that implements email subscription to pages =head1 SYNOPSIS Visitors can add their email address and click a checkbox to subscribe to changes when they edit a page. The requirement to successfully edit a page acts as a defense mechanism against spammers and vandals. Email addresses are stored in a file. Each mail contains an unsubscribe link, and from there users can see (and unsubscribe from) all other pages they are subscribed to. The link contains a hash of the email address which prevents others from guessing what email addresses have subscriptions. There is also an admin interface that shows which email addresses are subscribed to which pages, allowing the easy removal of email addresses from the database. =head1 INSTALLATION Installing a module is easy: Create a modules subdirectory in your data directory, and put the Perl file in there. It will be loaded automatically. =cut $ModulesDescription .= '

      mail.pl (for 2.2.3-1-g1a561c3), see Mail Extension

      '; use vars qw($MailFile $MailPattern); push (@MyInitVariables, sub { $MailFile = "$DataDir/mail.db"; }); # May contain neither space nor @; I'm too scared to put # Mail::RFC822::Address here. $MailPattern = '^[^ ]+@[^ ]+$'; =head1 Commenting When commenting, users are presented with a form where they can provide username and homepage. With this extension, users can also provide their mail address and choose to subscribe to comment pages. In order to get caching right, we also use an invisible cookie parameter to make sure that visitors will get a new page when they subscribe or unsubscribe. The alternative would have been to touch the index file at the end of the subscribe and unsubscribe function. =cut *MailOldInitCookie = *InitCookie; *InitCookie = *MailNewInitCookie; $CookieParameters{mail} = ''; $CookieParameters{sub} = ''; $InvisibleCookieParameters{sub} = 1; sub MailNewInitCookie { MailOldInitCookie(@_); my $mail = GetParam('mail', ''); $q->delete('mail'); if (!$mail) { # do nothing } elsif (!($mail =~ /$MailPattern/o)) { $Message .= $q->p(Ts('Invalid Mail %s: not saved.', $mail)); } else { SetParam('mail', $mail); } } *MailOldGetCommentForm = *GetCommentForm; *GetCommentForm = *MailNewGetCommentForm; sub MailNewGetCommentForm { my $html = MailOldGetCommentForm(@_); my $id = shift; my $mail = GetParam('mail', ''); my $addition; if (MailIsSubscribed($id, $mail)) { $addition = ' ' . ScriptLink("action=unsubscribe;pages=$id", T('unsubscribe'), 'unsubscribe'); } else { $addition = $q->input({-type=>checkbox, -name=>"notify", -value=>'1'}) . ScriptLink("action=subscribe;pages=$id", T('subscribe'), 'subscribe'); } $addition = $q->span({-class=>'mail'}, $q->label({-for=>'mail'}, T('Email: ')) . ' ' . $q->textfield(-name=>'mail', -id=>'mail', -default=>GetParam('mail', '')) . $addition); $html =~ s!(name="homepage".*?)

      !$1 $addition

      !i; return $html; } sub MailIsSubscribed { # is not called within a lock my ($id, $mail) = @_; return 0 unless $mail; # open the DB file require DB_File; tie %h, "DB_File", $MailFile; my %subscribers = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($id)})); untie %h; return $subscribers{$mail}; } *MailOldGetFooterTimestamp = *GetFooterTimestamp; *GetFooterTimestamp = *MailNewGetFooterTimestamp; sub MailNewGetFooterTimestamp { my $html = MailOldGetFooterTimestamp(@_); my $id = shift; my $mail = GetParam('mail', ''); my $addition; if (MailIsSubscribed($id, $mail)) { $addition = ScriptLink("action=unsubscribe;pages=$id", T('unsubscribe'), 'unsubscribe'); } else { $addition = ScriptLink("action=subscribe;pages=$id", T('subscribe'), 'subscribe'); } $html =~ s!(.*)()!$1 $addition$2!i; return $html; } =head1 Saving When saving a comment page users can subscribe using a checkbox. To do this via an URL you need to provide the parameters id, mail, aftertext (a new comment), and notify (1). =cut *MailOldSave = *Save; *Save = *MailNewSave; sub MailNewSave { # is called within a lock! :) MailOldSave(@_); my $id = shift; my $mail = GetParam('mail', ''); my $comment = GetParam('aftertext', ''); # Compare to GetId() in order to prevent subscription to LocalNames # page and other automatic saves. if ($id and $id eq GetId() and $comment and $mail and GetParam('notify', '')) { my $valid = 1; eval { local $SIG{__DIE__}; require Mail::RFC822::Address; $valid = Mail::RFC822::Address::valid($mail); SetParam('msg', Ts('%s appears to be an invalid mail address', $mail)) unless $valid; }; MailSubscribe($mail, $id) if $valid; } } *OldMailDeletePage = *DeletePage; *DeletePage = *NewMailDeletePage; =head1 Deleting When a page is deleted, the appropriate subscriptions have to be deleted as well. =cut sub NewMailDeletePage { my $id = shift; MailDeletePage($id); return OldMailDeletePage($id, @_); } sub MailDeletePage { my $id = shift; require DB_File; tie %h, "DB_File", $MailFile; foreach my $mail (split(/$FS/, UrlDecode(delete $h{UrlEncode($id)}))) { my %subscriptions = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($mail)})); delete $subscriptions{$id}; if (%subscriptions) { $h{UrlEncode($mail)} = UrlEncode(join($FS, keys %subscriptions)); } else { delete $h{UrlEncode($mail)}; } } untie %h; } =head1 Administration menu The Administration page will have a list to your subscriptions, and if you are an administrator, it will also have a link to all subscriptions. =cut push(@MyAdminCode, \&MailMenu); sub MailMenu { my ($id, $menuref, $restref) = @_; push(@$menuref, ScriptLink('action=subscriptions', T('Your mail subscriptions'), 'subscriptions')); push(@$menuref, ScriptLink('action=subscriptionlist', T('All mail subscriptions'), 'subscriptionlist')) if UserIsAdmin(); } =head1 Your subscriptions The subscriptions action will show you subscriptions and offer to unsubscribe. =cut $Action{subscriptions} = \&DoMailSubscriptions; sub DoMailSubscriptions { my $mail = GetParam('mail', ''); print GetHeader('', T('Subscriptions')), $q->start_div({-class=>'content subscriptions'}), GetFormStart(undef, 'get', 'mail'); if (not $mail) { print $q->p($q->span($q->label({-for=>'mail'}, T('Email: ')) . ' ' . $q->textfield(-name=>'mail', -id=>'mail'))), $q->input({-type=>'hidden',-name=>'action',-value=>'subscriptions'}), ' ', $q->submit(-name=>'Show', -value=>T('Show')); } else { my @subscriptions = MailSubscription($mail); if (@subscriptions) { print $q->p(Ts('Subscriptions for %s:', $mail), $q->input({-type=>'hidden',-name=>'action',-value=>'unsubscribe'})); print $q->p(join($q->br(), map { $q->input({-type=>checkbox, -name=>"pages", -value=>"$_"}) . GetPageLink($_) } @subscriptions)); print $q->p($q->submit(-name=>'Unsubscribe', -value=>T('Unsubscribe'))); } else { print $q->p(Ts('There are no subscriptions for %s.', $mail)); } print $q->p(ScriptLink('action=subscriptions;mail=', T('Change email address'), 'change subscriptions')); } print $q->endform(), $q->end_div(); PrintFooter(); } sub MailSubscription { my $mail = shift; return unless $mail; require DB_File; tie %h, "DB_File", $MailFile; my @result = split(/$FS/, UrlDecode($h{UrlEncode($mail)})); untie %h; return sort @result; } =head1 Administrator Access The subscriptionlist action will show you the subscription database, if you're an administrator. It's a plain text file of the data, which you can use for debugging and scripting purposes. =cut $Action{subscriptionlist} = \&DoMailSubscriptionList; sub DoMailSubscriptionList { UserIsAdminOrError(); my $raw = GetParam('raw', 0); if ($raw) { print GetHttpHeader('text/plain'); } else { print GetHeader('', T('Subscriptions')), $q->start_div({-class=>'content subscribtionlist'}), $q->p(T('Mail addresses are linked to unsubscription links.')), '
        '; } require DB_File; tie %h, "DB_File", $MailFile; foreach my $encodedkey (sort keys %h) { my @values = sort split(/$FS/, UrlDecode($h{$encodedkey})); my $key = UrlDecode($encodedkey); if ($raw) { print join(' ', $key, @values) . "\n"; } else { print $q->li(Ts('%s: ', MailLink($key, @values)), join(' ', map { MailLink($_, $key) } @values)); } } print '
    ' unless $raw; PrintFooter() unless $raw; untie %h; } sub MailLink { my ($str, @pages) = @_; # The @ is not a legal character for pagenames. return GetPageLink($str) if index($str, '@') == -1; return ScriptLink("action=unsubscribe;who=$str;" . join(';', map { "pages=$_" } @pages), $str); } =head1 Subscription The subscribe action will subscribe you to pages. The mail parameter contains the mail address to use and defaults to the value store in your cookie. Multiple pages parameters contain the pages to subscribe. =cut $Action{subscribe} = \&DoMailSubscribe; sub DoMailSubscribe { my @pages = $q->param('pages'); return DoMailSubscriptions(@_) unless @pages; my $mail = GetParam('mail', ''); if (not $mail) { print GetHeader('', T('Subscriptions')), $q->start_div({-class=>'content subscribe'}), GetFormStart(undef, 'get', 'subscribe'); print $q->p(Ts('Subscribe to %s.', join(', ', map { GetPageLink($_) } @pages))); print $q->p($q->span($q->label({-for=>'mail'}, T('Email: ')) . ' ' . $q->textfield(-name=>'mail', -id=>'mail'))); print $q->hidden('pages', @pages); print $q->input({-type=>'hidden',-name=>'action',-value=>'subscribe'}), ' ', $q->submit(-name=>'Subscribe', -value=>T('Subscribe')); } else { my @real = (); foreach my $id (@pages) { push @real, $id if $IndexHash{$id}; } # subscriptions have to be added in a lock RequestLockOrError(); MailSubscribe($mail, @real); ReleaseLock(); # MailSubscribe will set a parameter and must run before printing # the header. print GetHeader('', T('Subscriptions')), $q->start_div({-class=>'content subscribe'}); print $q->p(Ts('Subscribed %s to the following pages:', $mail)); print $q->ul($q->li([map { GetPageLink($_) } @real])); print $q->p(T('The remaining pages do not exist.')) if $#real < $#pages; print $q->p(ScriptLink('action=subscriptions', T('Your mail subscriptions'), 'subscriptions') . '.'); } print $q->end_div(); PrintFooter(); } sub MailSubscribe { # is called within a lock! :) my ($mail, @pages) = @_; return unless $mail and @pages; # open the DB file require DB_File; tie %h, "DB_File", $MailFile; # add to the mail entry my %subscriptions = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($mail)})); for my $id (@pages) { $subscriptions{$id} = 1; } $h{UrlEncode($mail)} = UrlEncode(join($FS, keys %subscriptions)); # add to the page entries for my $id (@pages) { my %subscribers = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($id)})); $subscribers{$mail} = 1; $h{UrlEncode($id)} = UrlEncode(join($FS, keys %subscribers)); } untie %h; # changes made will affect how pages look SetParam('sub', GetParam('sub', 0) + 1); } =head1 Unsubscription The unsubscribe action will unsubscribe you from pages. The mail parameter contains the mail address to use and defaults to the value store in your cookie. Multiple pages parameters contain the pages to unsubscribe. The who parameter overrides the mail parameter and is used for administrator unsubscription from the subscriptionlist action. =cut $Action{unsubscribe} = \&DoMailUnsubscribe; sub DoMailUnsubscribe { my $mail = GetParam('who', GetParam('mail', '')); my @pages = $q->param('pages'); return DoMailSubscriptions(@_) unless $mail; my @real = (); foreach my $id (@pages) { push @real, $id if $IndexHash{$id}; } MailUnsubscribe($mail, @real); # MailUnsubscribe will set a parameter and must run before printing # the header. print GetHeader('', T('Subscriptions')), $q->start_div({-class=>'content unsubscribe'}); print $q->p(Ts('Unsubscribed %s from the following pages:', $mail)); print $q->ul($q->li([map { GetPageLink($_) } @real])); print $q->p(T('The remaining pages do not exist.')) if $#real < $#pages; print $q->p(ScriptLink('action=subscriptions', T('Your mail subscriptions'), 'subscriptions') . '.'); print $q->end_div(); PrintFooter(); } sub MailUnsubscribe { my ($mail, @pages) = @_; return unless $mail and @pages; require DB_File; tie %h, "DB_File", $MailFile; my %subscriptions = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($mail)})); foreach my $id (@pages) { delete $subscriptions{$id}; # take care of reverse lookup my %subscribers = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($id)})); delete $subscribers{$mail}; if (%subscribers) { $h{UrlEncode($id)} = UrlEncode(join($FS, keys %subscribers)); } else { delete $h{UrlEncode($id)}; } } if (%subscriptions) { $h{UrlEncode($mail)} = UrlEncode(join($FS, keys %subscriptions)); } else { delete $h{UrlEncode($mail)} unless %subscriptions; } untie %h; # changes made will affect how pages look SetParam('sub', GetParam('sub', 0) + 1); } =head1 Migrate The mailmigrate action will migrate your subscription list from the old format to the new format. This is necessary because these days because the keys and values of the DB_File are URL encoded. =cut $Action{'migrate-subscriptions'} = \&DoMailMigration; sub DoMailMigration { UserIsAdminOrError(); print GetHeader('', T('Migrating Subscriptions')), $q->start_div({-class=>'content mailmigrate'}); require DB_File; tie %h, "DB_File", $MailFile; my $found = 0; foreach my $key (keys %h) { if (index($key, '@') != -1) { $found = 1; last; } } if (not $found) { print $q->p(T('No non-migrated email addresses found, migration not necessary.')); } else { my %n; foreach my $key (sort keys %h) { my $value = $h{$key}; my @values = sort split(/$FS/, $value); $n{UrlEncode($key)} = join($FS, map { UrlEncode($_) } @values); } %h = %n; print $q->p(Ts('Migrated %s rows.', scalar(keys %n))); } print '
    '; untie %h; PrintFooter(); } # Copyright (C) 2004, 2005, 2006, 2009 Alex Schroeder # # 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 . $ModulesDescription .= '

    markup.pl (for 2.2.3-1-g1a561c3), see Markup Erweiterung

    '; use vars qw(%MarkupPairs %MarkupForcedPairs %MarkupSingles %MarkupLines $MarkupQuotes $MarkupQuoteTable); $MarkupQuotes = 1; # $MarkupQuotes 'hi' "hi" I'm Favored in # 0 'hi' "hi" I'm Typewriters # 1 ‘hi’ “hi” I’m Britain and North America # 2 ‹hi› «hi» I’m France and Italy # 3 ›hi‹ »hi« I’m Germany # 4 ‚hi’ „hi” I’m Germany # 0 1 2 3 4 $MarkupQuoteTable = [[ "'", "'", '"', '"' , "'" ], # 0 ['‘', '’', '”', '“', '’'], # 1 ['‹', '›', '»', '«', '’'], # 2 ['›', '‹', '«', '»', '’'], # 3 ['‚', '‘', '“', '„', '’'], # 4 ]; # $MarkupQuoteTable->[2]->[0] ‹ # $MarkupQuoteTable->[2]->[1] › # $MarkupQuoteTable->[2]->[2] » # $MarkupQuoteTable->[2]->[3] « # $MarkupQuoteTable->[2]->[4] ’ push(@MyRules, \&MarkupRule); # The ---- rule in usemod.pl conflicts with the --- rule $RuleOrder{\&MarkupRule} = 150; %MarkupPairs = ('*' => 'b', '/' => 'i', '_' => ['em', {'style'=>'text-decoration: underline; font-style: normal;'}], '~' => 'em', ); %MarkupForcedPairs = ("{{{\n" => ['pre', undef, '}}}'], '##' => 'code', '%%' => 'span', '**' => 'b', '//' => 'i', '__' => ['em', {'style'=>'text-decoration: underline; font-style: normal;'}], '~~' => 'em', ); # This could be done using macros, however: If we convert to the # numbered entity, the next person editing finds it hard to read. If # we convert to a unicode character, it is no longer obvious how to # achieve it. %MarkupSingles = ('...' => '…', # HORIZONTAL ELLIPSIS '---' => '—', # EM DASH '-- ' => '– ', # EN DASH '-> ' => '→ ', # RIGHTWARDS ARROW, NO-BREAK SPACE '<-' => '←', '<--' => '←', '-->' => '→', '=>' => '⇒', '==>' => '⇒', '<=>' => '⇔', '+/-' => '±', ); %MarkupLines = ('>' => 'pre', ); my $words = '([A-Za-z\x{0080}-\x{fffd}][-%.,:;\'"!?0-9 A-Za-z\x{0080}-\x{fffd}]*?)'; # zero-width look-ahead assertion to prevent km/h from counting my $noword = '(?=[^-0-9A-Za-z\x{0080}-\x{fffd}]|$)'; my $markup_pairs_re = ''; my $markup_forced_pairs_re = ''; my $markup_singles_re = ''; my $markup_lines_re = ''; # do not add all block elements, because not all of them make sense, # as they cannot be nested -- thus it would not be possible to put # list items inside a list element, for example. my %block_element = map { $_ => 1 } qw(p blockquote address div h1 h2 h3 h4 h5 h6 pre); # do this later so that the user can customize the vars push(@MyInitVariables, \&MarkupInit); sub MarkupInit { $markup_pairs_re = '\G([' . join('', (map { quotemeta(QuoteHtml($_)) } keys(%MarkupPairs))) . '])'; $markup_pairs_re = qr/${markup_pairs_re}${words}\1${noword}/; $markup_forced_pairs_re = '\G(' . join('|', (map { quotemeta(QuoteHtml($_)) } keys(%MarkupForcedPairs))) . ')'; $markup_forced_pairs_re = qr/$markup_forced_pairs_re/; $markup_singles_re = '\G(' . join('|', (map { quotemeta(QuoteHtml($_)) } sort {$b cmp $a} # longer regex first keys(%MarkupSingles))) . ')'; $markup_singles_re = qr/$markup_singles_re/; $markup_lines_re = '\G(' . join('|', (map { quotemeta(QuoteHtml($_)) } keys(%MarkupLines))) . ')(.*\n?)'; $markup_lines_re = qr/$markup_lines_re/; } sub MarkupTag { my ($tag, $str) = @_; my ($start, $end); if (ref($tag)) { my $arrayref = $tag; my ($tag, $hashref) = @{$arrayref}; my %hash = %{$hashref}; $start = $end = $tag; foreach my $attr (keys %hash) { $start .= ' ' . $attr . '="' . $hash{$attr} . '"'; } } else { $start = $end = $tag; } my $result = "<$start>$str"; $result = CloseHtmlEnvironments() . $result . AddHtmlEnvironment('p') if $block_element{$start}; return $result; } sub MarkupRule { if ($bol and %MarkupLines and m/$markup_lines_re/gc) { my ($tag, $str) = ($1, $2); $str = $q->span($tag) . $str; while (m/$markup_lines_re/gc) { $str .= $q->span($1) . $2; } return CloseHtmlEnvironments() . MarkupTag($MarkupLines{UnquoteHtml($tag)}, $str) . AddHtmlEnvironment('p'); } elsif (%MarkupSingles and m/$markup_singles_re/gc) { return $MarkupSingles{UnquoteHtml($1)}; } elsif (%MarkupForcedPairs and m/$markup_forced_pairs_re/gc) { my $tag = $1; my $start = $tag; my $end = $tag; # handle different end tag my $data = $MarkupForcedPairs{UnquoteHtml($tag)}; if (ref($data)) { my @data = @{$data}; $start = $data[0] if $data[0]; $end = $data[2] if $data[2]; } my $endre = quotemeta($end); $endre .= '[ \t]*\n?' if $block_element{$start}; # skip trailing whitespace if block # may match the empty string, or multiple lines, but may not span # paragraphs. if ($endre and m/\G$endre/gc) { return $tag . $end; } elsif ($tag eq $end && m/\G((:?.+?\n)*?.+?)$endre/gc) { # may not span paragraphs return MarkupTag($data, $1); } elsif ($tag ne $end && m/\G((:?.|\n)+?)$endre/gc) { return MarkupTag($data, $1); } else { return $tag; } } elsif (%MarkupPairs and m/$markup_pairs_re/gc) { return MarkupTag($MarkupPairs{UnquoteHtml($1)}, $2); } elsif ($MarkupPairs{'/'} and m|\G~/|gc) { return '~/'; # fix ~/elisp/ example } elsif ($MarkupPairs{'/'} and m|\G(/[-A-Za-z0-9\x{0080}-\x{fffd}/]+/$words/)|gc) { return $1; # fix /usr/share/lib/! example } # "foo elsif ($MarkupQuotes and (m/\G(?<=[[:space:]])"/cg or pos == 0 and m/\G"/cg)) { return $MarkupQuoteTable->[$MarkupQuotes]->[3]; } # foo" elsif ($MarkupQuotes and (m/\G"(?=[[:space:][:punct:]])/cg or m/\G"\z/cg)) { return $MarkupQuoteTable->[$MarkupQuotes]->[2]; } # foo." elsif ($MarkupQuotes and (m/\G(?<=[[:punct:]])"/cg)) { return $MarkupQuoteTable->[$MarkupQuotes]->[3]; } # single quotes at the beginning of the buffer elsif ($MarkupQuotes and pos == 0 and m/\G'/cg) { return $MarkupQuoteTable->[$MarkupQuotes]->[0]; } # 'foo elsif ($MarkupQuotes and (m/\G(?<=[[:space:]])'/cg or pos == 0 and m/\G'/cg)) { return $MarkupQuoteTable->[$MarkupQuotes]->[0]; } # foo' elsif ($MarkupQuotes and (m/\G'(?=[[:space:][:punct:]])/cg or m/\G'\z/cg)) { return $MarkupQuoteTable->[$MarkupQuotes]->[1]; } # foo's elsif ($MarkupQuotes and m/\G(?[$MarkupQuotes]->[4]; } return undef; } # Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008 Alex Schroeder # # 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 . $ModulesDescription .= '

    near-links.pl (for 2.2.3-1-g1a561c3), see Near Links

    '; =head1 Near Links URL abbreviations facilitate linking to other wikis. For example, if you define the abbreviation Community, you might link to Community:WhyWikiWorks. Near Links takes this even further: If you use an ordinary link to WhyWikiWorks, this will link to Community:WhyWikiWorks if there is no local WhyWikiWorks page. =cut use vars qw(%NearSite %NearSource %NearLinksUsed $NearDir $NearMap %NearSearch $SisterSiteLogoUrl $NearLinksException); =head2 Options =cut $NearMap = 'NearMap'; $NearDir = "$DataDir/near"; # for page indexes and .png files of other sites =head2 Initialization There are several steps required before Near Links work as expected. You must have an B page to define URL abbreviations. There, you associate a prefix with a partial URL on every line that starts with a space: Community http://www.communitywiki.org/en/ You must have a B page. There, you associate some of the prefixes defined on the InterMap page with an URL that tells Oddmuse how to retrieve the list of all pages from the site. Again, only lines starting with a single space are considered, allowing you to mix explanatory paragraphs with data. Community http://www.communitywiki.org/en?action=index;raw=1 Remember to use the same key as on the InterMap page! There is an optional third item you can place on that line telling Oddmuse how to forward searches to the remote site. You must run B once. At the end of the maintenance output you should see a line for every prefix on your NearMap telling you that the list of pages is being retrieved: "Getting page index file for Community." This page index file is created in the C directory in your data directory. You can change the name of the NearMap page by setting the C<$NearMap> option: $NearMap = 'Local_Near_Map'; You can change the directory used for caching the remote page index files by setting the C<$NearDir> option: $NearDir = '/var/oddmuse/near'; =cut push(@MyInitVariables, \&NearLinksInit); sub NearLinksInit { $NearMap = FreeToNormal($NearMap); # just making sure $AdminPages{$NearMap} = 1; # list it on the admin page %NearLinksUsed = (); # list of links used during this request %NearSite = (); %NearSearch = (); %NearSource = (); # Don't overwrite the values other modules might have set $NearLinksException{rc} = 1; $NearLinksException{rss} = 1; foreach (split(/\n/, GetPageContent($NearMap))) { if (/^ ($InterSitePattern)[ \t]+([^ ]+)(?:[ \t]+([^ ]+))?$/) { my ($site, $url, $search) = ($1, $2, $3); next unless $InterSite{$site}; $NearSite{$site} = $url; $NearSearch{$site} = $search if $search; my ($status, $data) = ReadFile("$NearDir/$site"); next unless $status; foreach my $page (split(/\n/, $data)) { push(@{$NearSource{$page}}, $site); } } } } =head2 Maintenance C is added to C<@MyMaintenance> in order to download all page indexes from the remote sites defined on the NearMap page. The download is skipped if the existing page index for the remote site is less than twelve hours old. If you want to force this, you need to delete the page indexes in the cache directory. Look for the C directory in your data directory, unless you set C<$NearDir>. =cut push(@MyMaintenance, \&NearLinksMaintenance); sub NearLinksMaintenance { if (%NearSite) { CreateDir($NearDir); # skip if less than 12h old and caching allowed (the default) foreach my $site (keys %NearSite) { next if GetParam('cache', $UseCache) > 0 and -f "$NearDir/$site" and -M "$NearDir/$site" < 0.5; print $q->p(Ts('Getting page index file for %s.', $site)); my $data = GetRaw($NearSite{$site}); print $q->p($q->strong(Ts('%s returned no data, or LWP::UserAgent is not available.', $q->a({-href=>$NearSite{$site}}, $NearSite{$site})))) unless $data; WriteStringToFile("$NearDir/$site", $data); } } } =head2 Debugging Initialization You can use the Debug Action to list the Near Links found in addition to the Inter Links: http://localhost/cgi-bin/wiki?action=debug If there are no Near Links defined, check the initialization requirements listed above. =cut push(@Debugging, \&DoNearLinksList); sub DoNearLinksList { print $q->h2(T('Near links:')), $q->p(join('; ', map { GetPageLink($_) . ': ' . join(', ', @{$NearSource{$_}})} sort keys %NearSource)); } =head2 Name Resolution We want Near Links only to have an effect for pages that do not exist locally. It should not take precedence! Thus, we hook into C; this function returns a list of four elements: CSS class, resolved id, title (eg. for popups), and a boolean saying whether the page exists or not. If the second element is empty, then no page exists and we check C<%NearSource> for a match. C<%NearSource> uses the page id as a key and a list of sites as the value. We just pick the first site on the list and return it as an URL (and using the CSS class "near"). The pages explicitly excluded from being Near Links are the ones most likely to confuse first users: All the pages on C<@UserGotoBarPages> and all pages in C<%AdminPages>. =cut *OldNearLinksResolveId = *ResolveId; *ResolveId = *NewNearLinksResolveId; sub NewNearLinksResolveId { my $id = shift; my @result = OldNearLinksResolveId($id, @_); my %forbidden = map { $_ => 1 } @UserGotoBarPages, %AdminPages; $forbidden{$id} = 1 if $CommentsPrefix and $id =~ /^$CommentsPrefix/o; if (not $result[1] and $NearSource{$id} and not $forbidden{$id}) { $NearLinksUsed{$id} = 1; my $site = $NearSource{$id}[0]; return ('near', GetInterSiteUrl($site, $id), $site); # return source as title attribute } else { return @result; } } =head2 Search This module allows you to send search terms to remote sites. You need to tell Oddmuse how to do this, however. On the NearMap, this is what you do: Lines starting with a single space and an URL abbreviation (defined on the InterMap), an URL that retrieves the list of pages on the remote site, and an URL that runs a search and returns the result in RSS 3.0 format. Here's an example. Remember that this should all go on a single line starting with a single space: Community http://www.communitywiki.org/cw?action=index;raw=1 http://www.communitywiki.org/cw?search=%s;raw=1;near=0 If you want to know more about the RSS 3.0 format, take a look at the specification: L. The effect is that when you search something, the search will be a local search. There will be a link called "Search sites on the NearMap as well" at the beginning of your local search results. Clicking on the link will include search results from remote sites as well. =head3 Development C<%NearLinksException> is used to store all the actions where a search should not result in the printing of pages. Theoretically we could use the presence of the C<$func> parameter in the call to C, but there are two problems with this approach: We don't know what the code does. It might just be collecting data without printing anything. And even if we did, and skipped the printing, we'd be searching the near pages in vain in the case of RecentChanges and RSS feeds, since the near pages have no change date and therefore can never be presented chronologically. Developer input will be necessary in all cases. =cut *OldNearLinksSearchMenu = *SearchMenu; *SearchMenu = *NewNearLinksSearchMenu; sub NewNearLinksSearchMenu { my $string = shift; my $result = OldNearLinksSearchMenu($string); $result .= ' ' . ScriptLink('near=2;search=' . UrlEncode($string), Ts('Search sites on the %s as well', $NearMap)) if %NearSearch and GetParam('near', 1) < 2; return $result; } *OldNearLinksSearchTitleAndBody = *SearchTitleAndBody; *SearchTitleAndBody = *NewNearLinksSearchTitleAndBody; sub NewNearLinksSearchTitleAndBody { my $string = shift; my @result = OldNearLinksSearchTitleAndBody($string, @_); my $action = GetParam('action', 'browse'); @results = SearchNearPages($string, @results) if GetParam('near', 1) and not $NearLinksException{$action}; return @result; } sub SearchNearPages { my $string = shift; my %found = map {$_ => 1} @_; my $regex = SearchRegexp($string); if (%NearSearch and GetParam('near', 1) > 1 and GetParam('context',1)) { foreach my $site (keys %NearSearch) { my $url = $NearSearch{$site}; $url =~ s/\%s/UrlEncode($string)/ge or $url .= UrlEncode($string); print $q->hr(), $q->p(Ts('Fetching results from %s:', $q->a({-href=>$url}, $site))) unless GetParam('raw', 0); my $data = GetRaw($url); my @entries = split(/\n\n+/, $data); shift @entries; # skip head foreach my $entry (@entries) { my %entry = ParseData($entry); # need to pass reference my $name = $entry{title}; next if $found{$name}; # do not duplicate local pages $found{$name} = 1; PrintSearchResultEntry(\%entry, $regex); # with context and full search! } } } if (%NearSource and (GetParam('near', 1) or GetParam('context',1) == 0)) { my $intro = 0; foreach my $name (sort keys %NearSource) { next if $found{$name}; # do not duplicate local pages if (SearchString($string, NormalToFree($name))) { $found{$name} = 1; print $q->hr() . $q->p(T('Near pages:')) unless GetParam('raw', 0) or $intro; $intro = 1; PrintPage($name); # without context! } } } return keys(%found); } =head2 Index Of All Pages The index of all pages will offer a new option called "Include near pages". This uses the C parameter. Example: C. We don't need to list remote pages that also exist locally, since the index will resolve pages as they get printed. If we list remote pages, all we'll do is have the name twice on the list, and they'll get resolved to the same target (the local page), which is unexpected. =cut push(@IndexOptions, ['near', T('Include near pages'), 0, \&ListNearPages]); sub ListNearPages { my %pages = %NearSource; if (GetParam('pages', 1)) { foreach my $page (AllPagesList()) { delete $pages{$page}; } } return keys %pages; } =head2 Defining Near Linked Pages When Oddmuse links to a remote site via NearLinks, it is difficult to create a local copy of the page. After all, there is no edit link. That's why the appropriate edit links will be presented at the bottom of the page. This list will be prefixed with a link to the page called B. This allows you to explain what's going on to your users. To change the name of this page, use translation: C<$Translate{EditNearLinks}='Define these pages locally';> These edit links for local pages are inside a div with the class "near". =cut push(@MyFooters, \&GetNearLinksUsed); sub GetNearLinksUsed { if (%NearLinksUsed) { return $q->div({-class=>'near'}, $q->p(GetPageLink(T('EditNearLinks')) . ':', map { GetEditLink($_, $_); } keys %NearLinksUsed)); } return ''; } =head2 Twin Pages When looking at local pages that also exist on remote sites, Oddmuse will add links to the various remote versions at the bottom of the page. (These remote sites are sometimes also referred to as "sister sites".) You will need logos for these remote sites. You specify where the logos are to be found by setting C<$SisterSiteLogoUrl>. The C<%s> will be replaced by the URL abbreviation used. Example: $SisterSiteLogoUrl = "http://www.emacswiki.org/pics/%s.png"; For the Community:WhyWikiWorks page, this will result in the URL L. These logos for twin pages are inside a div with the class "sister". =cut push(@MyFooters, \&GetSisterSites); $SisterSiteLogoUrl = 'file:///tmp/oddmuse/%s.png'; sub GetSisterSites { my $id = shift; if ($id and $NearSource{$id}) { my $sistersites = T('The same page on other sites:') . $q->br(); foreach my $site (@{$NearSource{$id}}) { my $logo = $SisterSiteLogoUrl; $logo =~ s/\%s/$site/g; $sistersites .= $q->a({-href=>GetInterSiteUrl($site, $id), -title=>"$site:$id"}, $q->img({-src=>$logo, -alt=>"$site:$id"})); } return $q->div({-class=>'sister'}, $q->p($sistersites)); } return ''; } # Copyright (C) 2003, 2004, 2005, 2006, 2007 Alex Schroeder # # 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 . $ModulesDescription .= '

    permanent-anchors.pl (for 2.2.3-1-g1a561c3), see Permanent Anchors

    '; =head1 Permanent Anchors This module allows you to create link targets within a page. These link targets are called named anchors in HTML. The anchors provided by this module are permanent, because moving the anchor from one page to another does not affect the links pointing to it. You link to these named anchors as if they were pagenames. For users, it makes no difference. =cut use vars qw(%PermanentAnchors %PagePermanentAnchors $PermanentAnchorsFile); $PermanentAnchorsFile = "$DataDir/permanentanchors"; =head2 Definition Permanent anchors are defined by using square brackets and a double colon, like this: C<[::Example]>. If you define a permanent anchor that already exists, the new definition will have no effect. Instead you will be shown a link to the existing permanent anchor so that you can easily resolve the conflict. If you define a permanent anchor and a page of the same name already exists, the definition will work, and all links will point to the permanent anchor. You will also be given a link to the existing page so that you can easily resolve the conflict (eg. by deleting the page). Note that if you mark the page for deletion, you will still have to wait for page expiry to kick in and actually delete the page before the message disappears. During anchor definition a lock is created in the temporary directory. If Oddmuse encounters a lock while defining a permanent anchor, it will wait a few seconds and try again. If the lock cannot be obtained, the definition fails. The unlock action available from the administration page allows you to remove any stale locks once you're sure the locks have been left behind by a crash. After having removed the stale lock, edit the page with the permanent anchor definition again. When linking to a permanent anchor on the same page, you'll notice that this only works flawlessly if the definition comes first. When rendering a page, permanent anchor definitions and links are parsed in order. Thus, if the link comes first, the permanent anchor definition is not yet available. Once you invalidate the HTML cache (by editing another page or by removing the C file from the data directory), this situation will have fixed itself. =cut push(@MyRules, \&PermanentAnchorsRule); sub PermanentAnchorsRule { my ($locallinks, $withanchors) = @_; if (m/\G(\[::$FreeLinkPattern\])/cog) { #[::Free Link] permanent anchor create only $withanchors Dirty($1); if ($withanchors) { print GetPermanentAnchor($2); } else { print $q->span({-class=>'permanentanchor'}, $2); } } return undef; } sub GetPermanentAnchor { my $id = FreeToNormal(shift); my $text = NormalToFree($id); my ($class, $resolved, $title, $exists) = ResolveId($id); if ($class eq 'alias' and $title ne $OpenPageName) { return '[' . Ts('anchor first defined here: %s', ScriptLink(UrlEncode($resolved), $text, 'alias')) . ']'; } elsif ($PermanentAnchors{$id} ne $OpenPageName # 10 tries, 3 second wait, die on error and RequestLockDir('permanentanchors', 10, 3, 1)) { # Somebody may have added a permanent anchor in the mean time. # Comparing $LastUpdate to the $IndexFile mtime does not work for # subsecond changes and updates are rare, so just reread the file! PermanentAnchorsInit(); $PermanentAnchors{$id} = $OpenPageName; WritePermanentAnchors(); ReleaseLockDir('permanentanchors'); } $PagePermanentAnchors{$id} = 1; # add to the list of anchors in page my $html = GetSearchLink($id, 'definition', $id, T('Click to search for references to this permanent anchor')); $html .= ' [' . Ts('the page %s also exists', ScriptLink("action=browse;anchor=0;id=" . UrlEncode($id), NormalToFree($id), 'local')) . ']' if $exists; return $html; } =head2 Storage Permanent anchor definitions need to be stored in a separate file. Otherwise linking to a permanent anchor would require a search of the entire page database. The permanent anchors are stored in a file called C in the data directory. The location can be changed by setting C<$PermanentAnchorsFile>. The format of the file is simple: permanent anchor names and the name of the page they are defined on follow each other, separated by whitespace. Spaces within permanent anchor names and page names are replaced with underlines, as always. Thus, the keys of C<%PermanentAnchors> is the name of the permanent anchor, and C<$PermanentAnchors{$name}> is the name of the page it is defined on. =cut push(@MyInitVariables, \&PermanentAnchorsInit); sub PermanentAnchorsInit { %PagePermanentAnchors = %PermanentAnchors = (); my ($status, $data) = ReadFile($PermanentAnchorsFile); return unless $status; # not fatal # $FS was used in 1.417 and earlier! %PermanentAnchors = split(/\n| |$FS/,$data); } sub WritePermanentAnchors { my $data = ''; foreach my $name (keys %PermanentAnchors) { $data .= $name . ' ' . $PermanentAnchors{$name} ."\n"; } WriteStringToFile($PermanentAnchorsFile, $data); } =head2 Deleting Anchors When deleting a page Oddmuse needs to delete the corresponding permanent anchors from its file. This is why the C function is called from C. When a page is edited, we want to make sure that Oddmuse deletes the permanent anchors no longer needed from its file. The safest way to do this is to delete all permanent anchors defined on the page being edited and redefine them when it is rendered for the first time. This is achieved by calling C from C. After hitting the save button, the user is automatically redirected to the new page. This will render the page, and redefine all permanent anchors. =cut *OldPermanentAnchorsDeletePage = *DeletePage; *DeletePage = *NewPermanentAnchorsDeletePage; sub NewPermanentAnchorsDeletePage { OldPermanentAnchorsDeletePage(@_); DeletePermanentAnchors(@_); # the only parameter is $id } *OldPermanentAnchorsSave = *Save; *Save = *NewPermanentAnchorsSave; sub NewPermanentAnchorsSave { OldPermanentAnchorsSave(@_); DeletePermanentAnchors(@_); # the first parameter is $id } sub DeletePermanentAnchors { my $id = shift; # 10 tries, 3 second wait, die on error RequestLockDir('permanentanchors', 10, 3, 1); foreach (keys %PermanentAnchors) { if ($PermanentAnchors{$_} eq $id and !$PagePermanentAnchors{$_}) { delete($PermanentAnchors{$_}) ; } } WritePermanentAnchors(); ReleaseLockDir('permanentanchors'); } =head2 Name Resolution Name resolution is done by C. This function returns a list of several items: The CSS class to use, the resolved id, the title (eg. for popups), and a boolean saying whether the page actually exists or not. When resolving a permanent anchor, the CSS class used will be “alias”, the resolved id will be the C, the title will be the page name. You can override this behaviour by providing the parameter C. This is used for the link in the warning message “the page foo also exists.” =cut *OldPermanentAnchorsResolveId = *ResolveId; *ResolveId = *NewPermanentAnchorsResolveId; sub NewPermanentAnchorsResolveId { my $id = shift; my $page = $PermanentAnchors{$id}; if (GetParam('anchor', 1) and $page and $page ne $id) { return ('alias', $page . '#' . $id, $page, $IndexHash{$id}) } else { return OldPermanentAnchorsResolveId($id, @_); } } =head2 Anchor Objects An anchor object is the text that starts after the anchor definition and goes up to the next heading, horizontal line, or the end of the page. By redefining C to work on anchor objects we automatically allow internal transclusion. =cut *OldPermanentAnchorsGetPageContent = *GetPageContent; *GetPageContent = *NewPermanentAnchorsGetPageContent; sub NewPermanentAnchorsGetPageContent { my $id = shift; my $result = OldPermanentAnchorsGetPageContent($id); if (not $result and $PermanentAnchors{$id}) { $result = OldPermanentAnchorsGetPageContent($PermanentAnchors{$id}); $result =~ s/^(.*\n)*.*\[::$id\]// or return ''; $result =~ s/(\n=|\n----|\[::$FreeLinkPattern\])(.*\n)*.*$//o; } return $result; } =head2 User Interface Changes Some user interface changes are required as well. =over =item * Allow the page index to list permanent anchors or not by setting C<@IndexOptions>. =cut push(@IndexOptions, ['permanentanchors', T('Include permanent anchors'), 1, sub { keys %PermanentAnchors }]); =item * Make sure that you can view old revisions of pages that have a permanent anchor of the same name. This requires link munging for all browse links from C. =back =cut *OldPermanentAnchorsGetHistoryLine = *GetHistoryLine; *GetHistoryLine = *NewPermanentAnchorsGetHistoryLine; sub NewPermanentAnchorsGetHistoryLine { my $id = shift; my $html = OldPermanentAnchorsGetHistoryLine($id, @_); if ($PermanentAnchors{$id}) { my $encoded_id = UrlEncode($id); # link to the current revision; ignore dependence on $UsePathInfo $html =~ s!$ScriptName[/?]$encoded_id!$ScriptName?action=browse;anchor=0;id=$encoded_id!; # link to old revisions $html =~ s!action=browse;id=$encoded_id!action=browse;anchor=0;id=$encoded_id!g; } return $html; } # Copyright (C) 2004, 2005, 2006, 2009 Alex Schroeder # # 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 . $ModulesDescription .= '

    portrait-support.pl (for 2.2.3-1-g1a561c3), see Portraits Support Extension

    '; push(@MyMacros, sub{ s/\[new::\]/"[new:" . GetParam('username', T('Anonymous')) . ':' . TimeToText($Now) . "]"/ge }); push(@MyMacros, sub{ s/\[new:$FreeLinkPattern\]/"[new:$1:" . TimeToText($Now) . "]"/ge }); push(@MyRules, \&PortraitSupportRule); use vars qw($PortraitSupportColorDiv $PortraitSupportColor); $PortraitSupportColor = 0; $PortraitSupportColorDiv = 0; my %Portraits = (); sub PortraitSupportRule { if ($bol) { if (m/\G(\s*\n)*----+[ \t]*\n?/cg) { $PortraitSupportColor = 0; my $html = CloseHtmlEnvironments() . ($PortraitSupportColorDiv ? '
' : '') . $q->hr() . AddHtmlEnvironment('p'); $PortraitSupportColorDiv = 0; return $html; } elsif ($bol && m/\Gportrait:$UrlPattern/gc) { return $q->img({-src=>$1, -alt=>T("Portrait"), -class=>'portrait'}); } elsif ($bol && m/\G(:*)\[new(.*)\]/gc) { my $portrait = ''; my $depth = length($1); my ($ignore, $name, $time) = split(/:/, $2, 3); if ($name) { if (not $Portrait{$name}) { my $oldpos = pos; if (GetPageContent($name) =~ m/portrait:$UrlPattern/) { $Portrait{$name} = $q->div({-class=>"portrait"}, $q->p(ScriptLink($name, $q->img({-src=>$1, -alt=>'new: ' . $time, -class=>'portrait'}), 'newauthor', '', $FS), $q->br(), GetPageLink($name))); } } $portrait = $Portrait{$name}; $portrait =~ s/$FS/$time/; } my $html = CloseHtmlEnvironments() . ($PortraitSupportColorDiv ? '
' : ''); $PortraitSupportColor = !$PortraitSupportColor; $html .= '
' . $portrait . AddHtmlEnvironment('p'); $PortraitSupportColorDiv = 1; return $html; } } return undef; } *OldPortraitSupportApplyRules = *ApplyRules; *ApplyRules = *NewPortraitSupportApplyRules; sub NewPortraitSupportApplyRules { my ($blocks, $flags) = OldPortraitSupportApplyRules(@_); if ($PortraitSupportColorDiv) { print '
'; $blocks .= $FS . ''; $flags .= $FS . 0; $PortraitSupportColorDiv = 0; } return ($blocks, $flags); } # Copyright (C) 2004 Brock Wilcox # Copyright (C) 2006, 2007 Alex Schroeder # # 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 . $ModulesDescription .= '

questionasker.pl (for 2.2.3-1-g1a561c3), see QuestionAsker Extension

'; use vars qw(@QuestionaskerQuestions $QuestionaskerRememberAnswer $QuestionaskerSecretKey $QuestionaskerRequiredList %QuestionaskerProtectedForms); # A list of arrays. The first element in each array is a string, the # question to be asked. The second element is a subroutine which is # passed the answer as the first argument. @QuestionaskerQuestions = (['What is the first letter of this question?' => sub { shift =~ /^\s*W\s*$/i }], ['How many letters are in the word "four"?' => sub { shift =~ /^\s*(4|four)\s*$/i }], ['Tell me any number between 1 and 10' => sub { shift =~ /^\s*([1-9]|10|one|two|three|four|five|six|seven|eight|nine|ten)\s*$/ }], ["How many lives does a cat have?" => sub { shift =~ /^\s*(7|seven|9|nine)\s*$/i }], ["What is 2 + 4?" => sub { shift =~ /^\s*(6|six)\s*$/i }], ); # The page name for exceptions, if defined. Every page linked to via # WikiWord or [[free link]] is considered to be a page which needs # questions asked. All other pages do not require questions asked. If # not set, then all pages need questions asked. $QuestionaskerRequiredList = ''; # If a user answers a question correctly, remember this in the cookie # and don't ask any further questions. The name of the parameter in # the cookie can be changed should a spam bot target this module # specifically. Changing the secret key will force all users to answer # another question. $QuestionaskerRememberAnswer = 1; $QuestionaskerSecretKey = 'question'; # Forms using one of the following classes are protected. %QuestionaskerProtectedForms = ('comment' => 1, 'edit upload' => 1, 'edit text' => 1,); push(@MyInitVariables, \&QuestionaskerInit); sub QuestionaskerInit { $QuestionaskerRequiredList = FreeToNormal($QuestionaskerRequiredList); $AdminPages{$QuestionaskerRequiredList} = 1; $CookieParameters{$QuestionaskerSecretKey} = ''; $InvisibleCookieParameters{$QuestionaskerSecretKey} = 1; } *OldQuestionaskerDoPost = *DoPost; *DoPost = *NewQuestionaskerDoPost; sub NewQuestionaskerDoPost { my(@params) = @_; my $id = FreeToNormal(GetParam('title', undef)); my $preview = GetParam('Preview', undef); # case matters! my $question_num = GetParam('question_num', undef); my $answer = GetParam('answer', undef); unless (UserIsEditor() or $QuestionaskerRememberAnswer && GetParam($QuestionaskerSecretKey, 0) or $preview or $QuestionaskerQuestions[$question_num][1]($answer) or QuestionaskerException($id)) { print GetHeader('', T('Edit Denied'), undef, undef, '403 FORBIDDEN'); print $q->p(T('You did not answer correctly.')); print GetFormStart(), QuestionaskerGetQuestion(1), (map { $q->hidden($_, '') } qw(title text oldtime summary recent_edit aftertext)), $q->end_form; PrintFooter(); # logging to the error log file of the server # warn "Q: '$QuestionaskerQuestions[$question_num][0]', A: '$answer'\n"; return; } # Set the secret key only if a question has in fact been answered if (not GetParam($QuestionaskerSecretKey, 0) and $QuestionaskerQuestions[$question_num][1]($answer)) { SetParam($QuestionaskerSecretKey, 1) } return (OldQuestionaskerDoPost(@params)); } *OldQuestionaskerGetEditForm = *GetEditForm; *GetEditForm = *NewQuestionaskerGetEditForm; sub NewQuestionaskerGetEditForm { return QuestionAddTo(OldQuestionaskerGetEditForm(@_)); } *OldQuestionaskerGetCommentForm = *GetCommentForm; *GetCommentForm = *NewQuestionaskerGetCommentForm; sub NewQuestionaskerGetCommentForm { return QuestionAddTo(OldQuestionaskerGetCommentForm(@_)); } sub QuestionAddTo { my $form = shift; if (not $upload and not QuestionaskerException(GetId()) and not $QuestionaskerRememberAnswer && GetParam($QuestionaskerSecretKey, 0) and not UserIsEditor()) { my $question = QuestionaskerGetQuestion(); $form =~ s/(.*)

(.*?)

$2

referrer-tracking.pl (for 2.2.3-1-g1a561c3), see Automatic Link Back

'; use LWP::UserAgent; push(@KnownLocks, "refer_*"); $Action{refer} = \&DoPrintAllReferers; use vars qw($RefererDir $RefererTimeLimit $RefererLimit $RefererFilter %Referers); $RefererTimeLimit = 86400; # How long referrals shall be remembered in seconds $RefererLimit = 15; # How many different referer shall be remembered $RefererFilter = 'ReferrerFilter'; # Name of the filter page $RefererTitleLimit = 70; # This is used to shorten long titles push(@MyInitVariables, \&RefererInit); sub RefererInit { $RefererFilter = FreeToNormal($RefererFilter); # spaces to underscores $AdminPages{$RefererFilter} = 1; $RefererDir = "$DataDir/referer"; # Stores referer data } push(@MyAdminCode, \&RefererMenu); sub RefererMenu { my ($id, $menuref, $restref) = @_; push(@$menuref, ScriptLink('action=refer', T('All Referrers'), 'refer')); } *RefererOldPrintFooter = *PrintFooter; *PrintFooter = *RefererNewPrintFooter; sub RefererNewPrintFooter { my ($id, $rev, $comment, @rest) = @_; if (not GetParam('embed', $EmbedWiki)) { my $referers = RefererTrack($id); print $referers if $referers; } RefererOldPrintFooter($id, $rev, $comment, @rest); } *RefererOldExpireKeepFiles = *ExpireKeepFiles; *ExpireKeepFiles = *RefererNewExpireKeepFiles; sub RefererNewExpireKeepFiles { RefererOldExpireKeepFiles(@_); # call with opened page ReadReferers($OpenPageName); # clean up reading (expiring) and writing WriteReferers($OpenPageName); } *RefererOldDeletePage = *DeletePage; *DeletePage = *RefererNewDeletePage; sub RefererNewDeletePage { my $status = RefererOldDeletePage(@_); return $status if $status; # this would be the error message my $id = shift; my $fname = GetRefererFile($id); unlink($fname) if (-f $fname); return ''; # no error } ## == Actual Code == sub GetRefererFile { my $id = shift; return $RefererDir . '/' . GetPageDirectory($id) . "/$id.rf"; } sub ReadReferers { my $file = GetRefererFile(shift); %Referers = (); if (-f $file) { my ($status, $data) = ReadFile($file); %Referers = split(/$FS/, $data, -1) if $status; } ExpireReferers(); } sub ExpireReferers { # no need to save the pruned list if nothing else changes if ($RefererTimeLimit) { foreach (keys %Referers) { if ($Now - $Referers{$_} > $RefererTimeLimit) { delete $Referers{$_}; } } } if ($RefererLimit) { my @list = sort {$Referers{$a} cmp $Referers{$b}} keys %Referers; @list = @list[$RefererLimit .. @list-1]; foreach (@list) { delete $Referers{$_}; } } } # maybe test for valid utf-8 later? # http://www.w3.org/International/questions/qa-forms-utf-8 # $field =~ # m/^( # [\x09\x0A\x0D\x20-\x7E] # ASCII # | [\xC2-\xDF][\x80-\xBF] # non-overlong 2-byte # | \xE0[\xA0-\xBF][\x80-\xBF] # excluding overlongs # | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2} # straight 3-byte # | \xED[\x80-\x9F][\x80-\xBF] # excluding surrogates # | \xF0[\x90-\xBF][\x80-\xBF]{2} # planes 1-3 # | [\xF1-\xF3][\x80-\xBF]{3} # planes 4-15 # | \xF4[\x80-\x8F][\x80-\xBF]{2} # plane 16 # )*$/x; sub UrlToTitle { my $title = QuoteHtml(shift); $title = $1 if $title =~ /$FullUrlPattern/; # extract valid URL $title =~ s/\%([0-9a-f][0-9a-f])/chr(hex($1))/egi; # decode if possible $title =~ s!^https?://!!; $title =~ s!\.html?$!!; $title =~ s!/$!!; # shorten it if necessary if (length($title) > $RefererTitleLimit) { $title = substr($title, 0, $RefererTitleLimit - 10) . "..." . substr($title, -7); } return $title; } sub GetReferers { my $result = join(' ', map { my ($ts, $title) = split(/ /, $Referers{$_}, 2); $title = UrlToTitle($_) unless $title; $q->a({-href=>$_}, $title); } keys %Referers); return $q->div({-class=>'refer'}, $q->p(T('Referrers') . ': ' . $result)) if $result; } sub PageContentToTitle { my ($content) = @_; my $title = $1 if $content =~ m!(.*?)!; $title = $1 if not $title and $content =~ m!(.*?)!; # get rid of extra tags $title =~ s!<.*?>!!g; # trimming $title =~ s!\s+! !g; $title =~ s!^ !!; $title =~ s! $!!; $title = substring($title, 0, $RefererTitleLimit) . "..." if length($title) > $RefererTitleLimit; return $title; } sub UpdateReferers { my $self = $ScriptName; my $referer = $q->referer(); return unless $referer and $referer !~ /$self/; foreach (split(/\n/,GetPageContent($RefererFilter))) { if (/^ ([^ ]+)[ \t]*$/) { # only read lines with one word after one space my $regexp = $1; return if $referer =~ /$regexp/i; } } my $ua = LWP::UserAgent->new; my $response = $ua->get($referer); return unless $response->is_success and $response->decoded_content =~ /$self/; my $title = PageContentToTitle($response->decoded_content); # starting with a timestamp makes sure that numerical comparisons still work! $Referers{$referer} = "$Now $title"; return 1; } sub WriteReferers { my $id = shift; return unless RequestLockDir('refer_' . $id); # not fatal my $data = join($FS, %Referers); my $file = GetRefererFile($id); if ($data) { CreatePageDir($RefererDir, $id); WriteStringToFile($file, $data); } else { unlink $file; # just try it, doesn't matter if it fails } ReleaseLockDir('refer_' . $id); } sub RefererTrack { my $id = shift; return unless $id; ReadReferers($id); WriteReferers($id) if UpdateReferers($id); return GetReferers(); } sub DoPrintAllReferers { print GetHeader('', T('All Referrers'), ''), $q->start_div({-class=>'content refer'}); PrintAllReferers(AllPagesList()); print $q->end_div(); PrintFooter(); } sub PrintAllReferers { for my $id (@_) { ReadReferers($id); print $q->div({-class=>'page'}, $q->p(GetPageLink($id)), GetReferers()) if %Referers; } } # Copyright (C) 2004 Tilmann Holst # Copyright (C) 2004, 2005, 2007 Alex Schroeder # # 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 . $ModulesDescription .= '

sidebar.pl (for 2.2.3-1-g1a561c3), see Sidebar Extension

'; use vars qw($SidebarName); # Include this page on every page: $SidebarName = 'SideBar'; # do this later so that the user can customize $SidebarName push(@MyInitVariables, \&SidebarInit); sub SidebarInit { $SidebarName = FreeToNormal($SidebarName); # spaces to underscores $AdminPages{$SidebarName} = 1; } *OldSideBarGetHeader = *GetHeader; *GetHeader = *NewSideBarGetHeader; # this assumes that *all* calls to GetHeader will print! sub NewSideBarGetHeader { my ($id) = @_; print OldSideBarGetHeader(@_); # While rendering, OpenPageName must point to the sidebar, so that # the form extension which checks whether the current page is locked # will check the SideBar lock and not the real page's lock. local $OpenPageName = $SidebarName; print ''; return ''; } # Copyright (C) 2004 Alex Schroeder # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA $ModulesDescription .= '

signature.pl (for 2.2.3-1-g1a561c3), see Signature Extension

'; push(@MyRules, \&SignatureExceptionRule); push(@MyMacros, sub{ s/(? # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA $ModulesDescription .= '

smiles.pl (for 2.2.3-1-g1a561c3), see Logo And Icons

'; %Smilies = ( ':-?D' => 'http://www.emacswiki.org/pics/grin.png', ':-?\)' => 'http://www.emacswiki.org/pics/smile.png', ':-?\}=' => 'http://www.emacswiki.org/pics/smile-cool-beard.png', ';-?\)' => 'http://www.emacswiki.org/pics/blink.png', ':-?]' => 'http://www.emacswiki.org/pics/forced.png', '=-?\)' => 'http://www.emacswiki.org/pics/bigeye-smile.png', '8-\)' => 'http://www.emacswiki.org/pics/braindamaged.png', '8-?D' => 'http://www.emacswiki.org/pics/goggle.png', ':-\|' => 'http://www.emacswiki.org/pics/indifferent.png', ':-?[/\\\]' => 'http://www.emacswiki.org/pics/wry.png', ':-?\(' => 'http://www.emacswiki.org/pics/sad.png', ':-?\{' => 'http://www.emacswiki.org/pics/frown.png', ':\'\(' => 'http://www.emacswiki.org/pics/cry.png', 'X-?[(|]' => 'http://www.emacswiki.org/pics/dead.png', '\>-?\{' => 'http://www.emacswiki.org/pics/evil.png', ':-[Ppb]' => 'http://www.emacswiki.org/pics/poke.png', '\(-?:' => 'http://www.emacswiki.org/pics/reverse-smile.png', '<3' => 'http://www.emacswiki.org/pics/round-heart.png', ':-?€' => 'http://www.emacswiki.org/pics/tentacle.png', ); # Copyright (C) 2004 Alex Schroeder # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA $ModulesDescription .= '

subscriberc.pl (for 2.2.3-1-g1a561c3), see Subscribed Recent Changes

'; push(@MyRules, \&SubscribedRecentChangesRule); sub SubscribedRecentChangesRule { if ($bol) { if (m/\GMy\s+subscribed\s+pages:\s*((?:(?:$LinkPattern|\[\[$FreeLinkPattern\]\]),\s*)+)categories:\s*((?:(?:$LinkPattern|\[\[$FreeLinkPattern\]\]),\s*)*(?:$LinkPattern|\[\[$FreeLinkPattern\]\]))/gc) { return Subscribe($1, $4); } elsif (m/\GMy\s+subscribed\s+pages:\s*((?:(?:$LinkPattern|\[\[$FreeLinkPattern\]\]),\s*)*(?:$LinkPattern|\[\[$FreeLinkPattern\]\]))/gc) { return Subscribe($1, ''); } elsif (m/\GMy\s+subscribed\s+categories:\s*((?:(?:$LinkPattern|\[\[$FreeLinkPattern\]\]),\s*)*(?:$LinkPattern|\[\[$FreeLinkPattern\]\]))/gc) { return Subscribe('', $1); } } return undef; } sub Subscribe { my ($pages, $categories) = @_; my $oldpos = pos; my @pageslist = map { if (/\[\[$FreeLinkPattern\]\]/) { FreeToNormal($1); } else { $_; } } split(/\s*,\s*/, $pages); my @catlist = map { if (/\[\[$FreeLinkPattern\]\]/) { FreeToNormal($1); } else { $_; } } split(/\s*,\s*/, $categories); my $regexp; $regexp .= '^(' . join('|', @pageslist) . ")\$" if @pageslist; $regexp .= '|' if @pageslist and @catlist; $regexp .= '(' . join('|', @catlist) . ')' if @catlist; pos = $oldpos; my $html = 'My subscribed '; return $html unless @pageslist or @catlist; $html .= 'pages: ' . join(', ', map { s/_/ /g; $_; } @pageslist) if @pageslist; $html .= ', ' if @pageslist and @catlist; $html .= 'categories: ' . join(', ', map { s/_/ /g; $_; } @catlist) if @catlist; return ScriptLink('action=rc;rcfilteronly=' . $regexp, $html); } # Copyright (C) 2010 Alex Schroeder # # 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 . use vars qw($SvgMimeType $SvgEditorUrl); $SvgMimeType = 'image/svg+xml'; $SvgEditorUrl = 'http://svg-edit.googlecode.com/svn/tags/stable/editor/svg-editor.html'; push (@MyInitVariables, \&SvgInitVariables); sub SvgInitVariables { $UploadAllowed = 1; push (@UploadTypes, $SvgMimeType) unless grep {$_ eq $SvgMimeType} @UploadTypes; } *OldSvgGetDownloadLink = *GetDownloadLink; *GetDownloadLink = *NewSvgGetDownloadLink; sub NewSvgGetDownloadLink { my ($name, $image, $revision, $alt) = @_; return OldSvgGetDownloadLink(@_) if $image != 1; # determine if this is SVG data we need to show in an iframe my $data; local (%Page, $OpenPageName); OpenPage($name); if ($revision) { ($data) = GetTextRevision($revision); # ignore revision reset } else { $data = $Page{text}; } return OldSvgGetDownloadLink(@_) unless SvgItIs($data); my ($width, $height) = SvgDimensions($data); # add 20 to compensate for scrollbars? return $q->iframe({-width => $width + 20, -height => $height + 20, -src => OldSvgGetDownloadLink($name, 2, $revision)}, ""); } sub SvgItIs { my ($type) = TextIsFile(shift); return $type eq $SvgMimeType; } sub SvgDimensions { my $data = shift; $data =~ s/.*\n//; # strip first line require MIME::Base64; $data = MIME::Base64::decode($data); # crude hack to avoid parsing the SVG XML my ($x) = $data =~ /width="(.*?)"/; my ($y) = $data =~ /height="(.*?)"/; return $x, $y; } *OldSvgGetEditForm = *GetEditForm; *GetEditForm = *NewSvgGetEditForm; sub NewSvgGetEditForm { my $html = OldSvgGetEditForm(@_); my $action = 'action=svg;id=' . UrlEncode($OpenPageName); $action .= ";revision=" . GetParam('revision', '') if GetParam('revision', ''); my $link = ScriptLink($action, T('Edit image in the browser'), 'svg'); my $text1 = T('Replace this file with text'); my $text2 = T('Replace this text with a file'); $html =~ s!($text1|$text2)!$1 $link!; return $html; } $Action{svg} = \&DoSvg; sub DoSvg { my $id = shift; my $summary = T('Summary of your changes: '); $HtmlHeaders .= qq{ }; print GetHeader('', Ts('Editing %s', $id)); # This only works if editor and file are on the same site, I think. my $url = GetDownloadLink($id, 2, GetParam('revision', '')); my $src = $SvgEditorUrl . '?url=' . UrlEncode($url); print $q->iframe({-src => $src, -name => 'svgeditor', -width => "100%", -height => "500"}, ""); PrintFooter($id, 'edit'); } # Copyright (C) 2004, 2005 Alex Schroeder # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA $ModulesDescription .= '

tables-long.pl (for 2.2.3-1-g1a561c3), see Long Table Markup Extension

'; push(@MyRules, \&TablesLongRule); my $TablesLongLabels = ''; sub TablesLongRule { # start table by declaring the abbreviations used: # # end with a horizontal line: # ---- # use label: or label= to start a cell # label: bla # bla bla bla # a new row is started when a cell is repeated # if cells are missing, column spans are created (the first row # could use row spans...) if ($bol && m|\G\s*\n*\<table(/[A-Za-z\x{0080}-\x{fffd}/]+)? +([A-Za-z\x{0080}-\x{fffd},;\/ ]+)\> *\n|cg) { my $class = join(' ', split(m|/|, $1)); # leading / in $1 will make sure we have leading space Clean(CloseHtmlEnvironments() . "
"); # labels and their default class my %default_class = (); my @labels = map { my ($label, @classes) = split m|/|; $default_class{$label} = join(' ', @classes); $label; } split(/ *[,;] */, $2); my $regexp = join('|', @labels); # read complete table my @lines = (); while (m/\G(.*)\n?/cg) { # last line may miss newline my $line = $1; last if substr($line,0,4) eq ('----'); # the rest of this line is ignored! push(@lines, $line); } # parse lines and print table rows my $lastpos = pos; my @rows = (); my %row = (); my %class = %default_class; my %rowspan = (); my $label = ''; my $rowspan = ''; my $first = 1; for my $line (@lines) { if ($line =~ m|^($regexp)/?([0-9]+)?/?([A-Za-z\x{0080}-\x{fffd}/]+)?[:=] *(.*)|) { # regexp changes for other tables $label = $1; $rowspan = $2; $class = join(' ', split(m|/|, $3)); # no leading / therefore no leading space $line = $4; if ($row{$label}) { # repetition of label, we must start a new row TablesLongRow(\@labels, \%row, \%class, \%rowspan, $first); $first = 0; %row = (); %class = %default_class; foreach my $key (keys %rowspan) { delete $rowspan{$key} if $rowspan{$key} == 1; $rowspan{$key}--; # 0 will turn into negative numbers } } $class{$label} = $class if $class; $rowspan{$label} = $rowspan if $rowspan; } $row{$label} .= $line . "\n"; } TablesLongRow(\@labels, \%row, \%class, \%rowspan, $first); # don't forget the last row Clean('
' . AddHtmlEnvironment('p')); pos = $lastpos; return ''; } return undef; } sub TablesLongRow { my @labels = @{$_[0]}; my %row = %{$_[1]}; my %class = %{$_[2]}; my %rowspan = %{$_[3]}; my $first = $_[4]; Clean(''); # first print the old row for my $i (0 .. $#labels) { next if not $row{$labels[$i]}; # should only happen after previous cellspans my $colspan = 1; while ($i + $colspan < $#labels + 1 and not $row{$labels[$i+$colspan]} and not $rowspan{$labels[$i+$colspan]}) { $colspan++; } my $rowspan = $rowspan{$labels[$i]}; my $class = $class{$labels[$i]}; my $html = '<'; $html .= $first ? 'th' : 'td'; $html .= " colspan=\"$colspan\"" if $colspan != 1; $html .= " rowspan=\"$rowspan\"" if defined $rowspan and $rowspan >= 0; # ignore negatives $html .= " class=\"$class\"" if $class; $html .= '>'; Clean($html); # WATCH OUT: here comes the evil magic messing with the internals! # first, clean everything up like at the end of ApplyRules if ($Fragment ne '') { $Fragment =~ s|

||g; # clean up extra paragraphs (see end Dirty()) print $Fragment; push(@Blocks, $Fragment); push(@Flags, 0); $Fragment = ''; } # call ApplyRules, and *inline* the results; ignoring $PortraitSupportColorDiv local $PortraitSupportColorDiv; my ($blocks, $flags) = ApplyRules($row{$labels[$i]}, 1, 1); # local links, anchors push(@Blocks, split(/$FS/, $blocks)); push(@Flags, split(/$FS/, $flags)); # end of evil magic # Alternatively, just use # Clean($row{$labels[$i]}); # or mark this block as dirty. Clean(CloseHtmlEnvironments() . ''); } Clean(''); } =head1 NAME tags - an Oddmuse module that implements tagging of pages and searching for tagged pages =head1 SYNOPSIS This module recognises the pattern C<[[tag:foo]]> on a page and will render this as a link to all pages tagged foo, as well as a link to the RSS feed for all pages tagged foo. Alternatively, the pattern C<[[tag:foo|bar]]> is also recognized. The only difference is that this will look like a link to bar instead of foo. When searching for a term of the form C the term "foo" be searched in a separate tag index, making it much faster. You can also negate this particular form by using C<-tag:foo>. These searches will also work for Journal Pages, Recent Changes, and RSS feed. =head1 INSTALLATION Installing a module is easy: Create a modules subdirectory in your data directory, and put the Perl file in there. It will be loaded automatically. =cut $ModulesDescription .= '

tags.pl (for 2.2.3-1-g1a561c3), see Tagging Extension

'; =head1 CONFIGURATION =head2 $TagUrl and $TagFeed These variable will be used to link the tags. By default, they will point at the wiki itself, using C<$ScriptName>. They use C<%s> as a placeholder for the URL encoded tag. Example: $TagUrl = 'http://technorati.com/tag/%s'; $TagFeed = 'http://feeds.technorati.com/tag/%s'; By default, these two will point to the list of recent changes, filtered by the appropriate tag, formatted as HTML or RSS respectively. =head2 $TagFeedIcon This variable should point to an RSS icon. You can get one from L, for example. Example: $TagFeedIcon = 'http://www.example.org/pics/rss.png'; =cut use vars qw($TagUrl $TagFeed $TagFeedIcon $TagFile); push(@MyInitVariables, \&TagsInit); sub TagsInit { $TagUrl = ScriptUrl('action=rc;rcfilteronly=tag:%s') unless $TagUrl; $TagFeed = ScriptUrl('action=rss;rcfilteronly=tag:%s') unless $TagFeed; $TagFile = "$DataDir/tag.db"; } sub TagsGetLink { my ($url, $id) = @_; $id = UrlEncode($id); $url =~ s/\%s/$id/g or $url .= $id; return $url; } push(@MyRules, \&TagsRule); sub TagsRule { if (m/\G(\[\[tag:$FreeLinkPattern\]\])/cog or m/\G(\[\[tag:$FreeLinkPattern\|([^]|]+)\]\])/cog) { # [[tag:Free Link]], [[tag:Free Link|alt text]] my ($tag, $text) = ($2, $3); my $html = $q->a({-href=>TagsGetLink($TagUrl, $tag), -class=>'outside tag', -title=>T('Tag'), -rel=>'tag' }, $text || $tag); if ($TagFeedIcon) { $html .= ' ' . $q->a({-href=>TagsGetLink($TagFeed, $tag), -class=>'feed tag', -title=>T('Feed for this tag'), -rel=>'feed' }, $q->img({-src=>$TagFeedIcon, -alt=>T('RSS')})); } return $html; } return undef; } =pod When saving, a tags db is written to disk. If it doesn't exist, it will be regenerated. =cut *OldTagSave = *Save; *Save = *NewTagSave; sub NewTagSave { # called within a lock! OldTagSave(@_); my $id = shift; # Within a tag, space is replaced by _ as in foo_bar. my %tag = map { lc(FreeToNormal($_)) => 1 } ($Page{text} =~ m/\[\[tag:$FreeLinkPattern\]\]/g, $Page{text} =~ m/\[\[tag:$FreeLinkPattern\|([^]|]+)\]\]/g); # open the DB file require DB_File; tie %h, "DB_File", $TagFile; # For each tag we list the files tagged. Add the current file for # all those tags where it is missing. Note that the values in %h is # an encoded string; the alternative would be to use a form of # freeze and thaw. foreach my $tag (keys %tag) { my %file = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($tag)})); if (not $file{$id}) { $file{$id} = 1; $h{UrlEncode($tag)} = UrlEncode(join($FS, keys %file)); } } # For each file in our hash, we have a reverse lookup of all the # tags used. This allows us to delete the references that no longer # show up without looping through them all. The files are indexed # with a starting underscore because this is an illegal tag name. foreach my $tag (split (/$FS/, UrlDecode($h{UrlEncode("_$id")}))) { # If the tag we're looking at is no longer listed, we have work to # do. if (!$tag{$tag}) { my %file = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($tag)})); delete $file{$id}; if (%file) { $h{UrlEncode($tag)} = UrlEncode(join($FS, keys %file)); } else { delete $h{UrlEncode($tag)}; } } } # Store the new reverse lookup of all the tags used on the current # page. If no more tags appear on this page, delete the entry. if (%tag) { $h{UrlEncode("_$id")} = UrlEncode(join($FS, keys %tag)); } else { delete $h{UrlEncode("_$id")}; } untie %h; } =pod When a page expires, the relevant pages and references have to be removed from the tags db. =cut *OldTagDeletePage = *DeletePage; *DeletePage = *NewTagDeletePage; sub NewTagDeletePage { # called within a lock! my $id = shift; # open the DB file require DB_File; tie %h, "DB_File", $TagFile; # For each file in our hash, we have a reverse lookup of all the # tags used. This allows us to delete the references that no longer # show up without looping through them all. foreach my $tag (split (/$FS/, UrlDecode($h{UrlEncode("_$id")}))) { my %file = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($tag)})); delete $file{$id}; if (%file) { $h{UrlEncode($tag)} = UrlEncode(join($FS, keys %file)); } else { delete $h{UrlEncode($tag)}; } } # Delete reverse lookup entry. delete $h{UrlEncode("_$id")}; untie %h; # Return any error codes? return OldTagDeletePage($id, @_); } =pod When searching, the tags db is read and used. This works by scanning the search string for tag:foo and -tag:bar elements, searching for those, and then calling the grep filter code with the new list of pages and a new search term without the tag terms. =cut sub TagFind { my @tags = @_; # open the DB file require DB_File; tie %h, "DB_File", $TagFile; my %page; foreach my $tag (@tags) { foreach my $id (split(/$FS/, UrlDecode($h{UrlEncode(lc($tag))}))) { $page{$id} = 1; } } untie %h; return sort keys %page; } *OldTagGrepFiltered = *GrepFiltered; *GrepFiltered = *NewTagGrepFiltered; sub NewTagGrepFiltered { # called within a lock! my ($string, @pages) = @_; my %page = map { $_ => 1 } @pages; # this is based on the code in SearchRegexp() my @tagterms = map { FreeToNormal($_) } grep(/^-?tag:/, shift =~ /\"([^\"]+)\"|(\S+)/g); my @positives = map {substr($_, 4)} grep(/^tag:/, @tagterms); my @negatives = map {substr($_, 5)} grep(/^-tag:/, @tagterms); if (@positives) { my %found; foreach my $id (TagFind(@positives)) { $found{$id} = 1 if $page{$id}; } %page = %found; } # remove the negatives foreach my $id (TagFind(@negatives)) { delete $page{$id}; } # filter out the tags from the search string $string = join(' ', grep(!/^-?tag:/, $string =~ /\"([^\"]+)\"|(\S+)/g)); # run the old code for any remaining search terms return OldTagGrepFiltered($string, sort keys %page); } =pod There remains a problem: The real search code will still be in operation, and terms of the form -tag:foo will never match. That's why the code that does the ordinary search has to be changed as well. We're need to remove all tag terms (again) in order to not confuse it. =cut *OldTagSearchString = *SearchString; *SearchString = *NewTagSearchString; sub NewTagSearchString { # filter out the negative tags from the search string my $string = join(' ', map { NormalToFree($_) } grep(!/^-tag:/, shift =~ /\"([^\"]+)\"|(\S+)/g)); return 1 unless $string; return OldTagSearchString($string, @_); } =pod We also want to provide a visual feedback of tag importance using a "tag cloud" -- larger font size means that a tag has been used more often. =cut $Action{tagcloud} = \&TagCloud; sub TagCloud { print GetHeader('', T('Tag Cloud'), ''), $q->start_div({-class=>'content cloud'}) . '

'; # open the DB file require DB_File; tie %h, "DB_File", $TagFile; my $max = 0; my $min = 0; my %count = (); foreach my $encoded_tag (grep !/^_/, keys %h) { $count{$encoded_tag} = split(/$FS/, UrlDecode($h{$encoded_tag})); $max = $count{$encoded_tag} if $count{$encoded_tag} > $max; $min = $count{$encoded_tag} if not $min or $count{$encoded_tag} < $min; } untie %h; foreach my $encoded_tag (sort keys %count) { my $n = $count{$encoded_tag}; print $q->a({-href => "$ScriptName?search=tag:" . $encoded_tag, -title => $n, -style => 'font-size: ' . int(80+120*($max == $min ? 1 : ($n-$min)/($max-$min))) . '%;', }, NormalToFree(UrlDecode($encoded_tag))), T(' ... '); } print '

'; PrintFooter(); } =pod Finally, we need to provide the means to reindex the entire site. The Reindex Action will do this. This should only be necessary when you install the module, and when you suspect that the tag.db is out of sync such as after a restoration from backup. Example: http://example.org/cgi-bin/wiki?action=reindex =cut $Action{reindex} = \&DoTagsReindex; sub DoTagsReindex { if (!UserIsAdmin() && (-f $TagFile) && ((-M $TagFile) < 0.5)) { ReportError(T('Rebuilding index not done.'), '403 FORBIDDEN', 0, T('(Rebuilding the index can only be done once every 12 hours.)')); } # Request the main lock, because we want to prevent anybody from # saving while we are reindexing. RequestLockOrError(); print GetHttpHeader('text/plain'); # open the DB file require DB_File; tie %h, "DB_File", $TagFile; %h = (); foreach my $id (AllPagesList()) { print "$id\n"; OpenPage($id); my %tag = map { lc(FreeToNormal($_)) => 1 } ($Page{text} =~ m/\[\[tag:$FreeLinkPattern\]\]/g, $Page{text} =~ m/\[\[tag:$FreeLinkPattern\|([^]|]+)\]\]/g); next unless %tag; # For each tag we list the files tagged. Add the current file for # all tags. foreach my $tag (keys %tag) { my $encoded_tag = UrlEncode($tag); $h{$encoded_tag} = $h{$encoded_tag} ? $h{$encoded_tag} . UrlEncode($FS . $id) : UrlEncode($id); } # Store the reverse lookup of all the tags used on the current # page. $h{UrlEncode("_$id")} = UrlEncode(join($FS, keys %tag)); } untie %h; ReleaseLock(); } =pod If you want to debug the data structure, use the Tag List Action. All keys starting with an underscore are pagenames, the others are tags. Example: http://example.org/cgi-bin/wiki?action=taglist =cut $Action{taglist} = \&TagList; sub TagList { print GetHttpHeader('text/plain'); # open the DB file require DB_File; tie %h, "DB_File", $TagFile; foreach my $id (sort map { UrlDecode($_) } keys %h) { print "$id: " . join(', ', split(/$FS/, UrlDecode($h{UrlEncode($id)}))) . "\n"; } untie %h; } =pod Both these actions are of course available from the Administration menu. =cut push(@MyAdminCode, \&TagsMenu); sub TagsMenu { my ($id, $menuref, $restref) = @_; push(@$menuref, ScriptLink('action=reindex', T('Rebuild tag index'), 'reindex') . ', ' . ScriptLink('action=taglist', T('list tags'), 'taglist') . ', ' . ScriptLink('action=tagcloud', T('tag cloud'), 'tagcloud')); } =head1 COPYRIGHT AND LICENSE Copyright (C) 2005, 2009, 2013 Alex Schroeder 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 . =cut # Copyright (C) 2004, 2006 Alex Schroeder # 2004 Sebastian Blatt # # 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 2 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, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA # Limits the number of parallel Oddmuse instances to # $InstanceThrottleLimit by keeping track of the process ids in # $InstanceThrottleDir $ModulesDescription .= '

throttle.pl (for 2.2.3-1-g1a561c3), see Limit Number Of Instances Running

'; use File::Glob ':glob'; use vars qw($InstanceThrottleDir $InstanceThrottleLimit); $InstanceThrottleDir = $DataDir."/pids"; # directory for pid files $InstanceThrottleLimit = 2; # maximum number of parallel processes *OldDoSurgeProtection = *DoSurgeProtection; *DoSurgeProtection = *NewDoSurgeProtection; *OldDoBrowseRequest = *DoBrowseRequest; *DoBrowseRequest = *NewDoBrowseRequest; sub NewDoSurgeProtection { DoInstanceThrottle(); CreatePidFile(); OldDoSurgeProtection(); } sub NewDoBrowseRequest { OldDoBrowseRequest(); RemovePidFile(); } # limit the script to a maximum of $InstanceThrottleLimit instances sub DoInstanceThrottle { my @pids = bsd_glob($InstanceThrottleDir."/*"); # Go over all pids: validate each pid by sending signal 0, unlink # pidfile if pid does not exist and return 0. Count the number of # zeros (= removed files = zombies) with grep. my $zombies = grep /^0$/, (map {/(\d+)$/ and kill 0,$1 or unlink and 0} @pids); if (scalar(@pids)-$zombies >= $InstanceThrottleLimit) { ReportError(Ts('Too many instances. Only %s allowed.', $InstanceThrottleLimit), '503 Service Unavailable', undef, $q->p(T('Please try again later. Perhaps somebody is running maintenance or doing a long search. Unfortunately the site has limited resources, and so we must ask you for a bit of patience.'))); } } sub CreatePidFile { CreateDir($InstanceThrottleDir); my $data = $q->request_method . ' ' . $q->url(-path_info=>1) . "\n"; foreach my $param ($q->param) { next if $param eq 'pwd'; $data .= "Param " . $param . "=" . $q->param($param) . "\n"; } WriteStringToFile("$InstanceThrottleDir/$$", $data); } sub RemovePidFile { my $file = "$InstanceThrottleDir/$$"; # not fatal unlink $file; } #!/usr/bin/env perl # ====================[ usemod.pl ]==================== $ModulesDescription .= '

usemod.pl (for 2.2.3-1-g1a561c3), see Usemod Markup Extension

'; use vars qw($RFCPattern $ISBNPattern @HtmlTags $HtmlTags $HtmlLinks $RawHtml $UseModSpaceRequired $UseModMarkupInTitles); push(@MyRules, \&UsemodRule); # The ---- rule conflicts with the --- rule in markup.pl and portrait-support.pl # The == heading rule conflicts with the same rule in portrait-support.pl # The : indentation rule conflicts with a similar rule in portrait-support.pl $RuleOrder{\&UsemodRule} = 100; $RFCPattern = 'RFC\\s?(\\d+)'; $ISBNPattern = 'ISBN:?([0-9- xX]{10,14})'; $HtmlLinks = 0; # 1 = desc is a link $RawHtml = 0; # 1 = allow environment for raw HTML inclusion @HtmlTags = (); # List of HTML tags. If not set, determined by $HtmlTags $HtmlTags = 0; # 1 = allow some 'unsafe' HTML tags $UseModSpaceRequired = 1; # 1 = require space after * # : ; for lists. $UseModMarkupInTitles = 0; # 1 = may use links and other markup in ==titles== $UseModExtraSpaceRequired = 0; # 1 = require space before : in definition lists # do this later so that the user can customize some vars push(@MyInitVariables, \&UsemodInit); sub UsemodInit { if (not @HtmlTags) { # do not override settings in the config file if ($HtmlTags) { # allow many tags @HtmlTags = qw(b i u font big small sub sup h1 h2 h3 h4 h5 h6 cite code em s strike strong tt var div center blockquote ol ul dl table caption br p hr li dt dd tr td th); } else { # only allow a very small subset @HtmlTags = qw(b i u em strong tt); } } } my $UsemodHtmlRegExp; my $rowcount; sub UsemodRule { $UsemodHtmlRegExp = join('|',(@HtmlTags)) unless $UsemodHtmlRegExp; #
 for monospaced, preformatted and escaped
  if ($bol && m/\G<pre>\n?(.*?\n)<\/pre>[ \t]*\n?/cgs) {
    return CloseHtmlEnvironments() . $q->pre({-class=>'real'}, $1) . AddHtmlEnvironment('p');
  }
  #  for monospaced and escaped
  elsif (m/\G\<code\>(.*?)\<\/code\>/cgis) { return $q->code($1); }
  #  for escaped
  elsif (m/\G\<nowiki\>(.*?)\<\/nowiki\>/cgis) { return $1; }
  # whitespace for monospaced, preformatted and escaped, all clean
  # note that ([ \t]+(.+\n)*.*) seems to crash very long blocks (2000 lines and more)
  elsif ($bol && m/\G(\s*\n)*([ \t]+.+)\n?/gc) {
    my $str = $2;
    while (m/\G([ \t]+.*)\n?/gc) {
      $str .= "\n" . $1;
    }
    return OpenHtmlEnvironment('pre',1) . $str; # always level 1
  }
  # unumbered lists using *
  elsif ($bol && m/\G(\s*\n)*(\*+)[ \t]{$UseModSpaceRequired,}/cog
	 or InElement('li') && m/\G(\s*\n)+(\*+)[ \t]{$UseModSpaceRequired,}/cog) {
    return CloseHtmlEnvironmentUntil('li') . OpenHtmlEnvironment('ul',length($2))
      . AddHtmlEnvironment('li');
  }
  # numbered lists using #
  elsif ($bol && m/\G(\s*\n)*(\#+)[ \t]{$UseModSpaceRequired,}/cog
	 or InElement('li') && m/\G(\s*\n)+(\#+)[ \t]{$UseModSpaceRequired,}/cog) {
    return CloseHtmlEnvironmentUntil('li') . OpenHtmlEnvironment('ol',length($2))
      . AddHtmlEnvironment('li');
  }
  # indented text using : (use blockquote instead?)
  elsif ($bol && m/\G(\s*\n)*(\:+)[ \t]{$UseModSpaceRequired,}/cog
	 or InElement('dd') && m/\G(\s*\n)+(\:+)[ \t]{$UseModSpaceRequired,}/cog) {
    return CloseHtmlEnvironmentUntil('dd') . OpenHtmlEnvironment('dl',length($2), 'quote')
      . $q->dt() . AddHtmlEnvironment('dd');
  }
  # definition lists using ;
  elsif (($bol and m/\G(\s*\n)*(\;+)[ \t]{$UseModSpaceRequired,}(?=.*[ \t]{$UseModExtraSpaceRequired,}\:)/cog) or
         (InElement('dd') and m/\G(\s*\n)+(\;+)[ \t]{$UseModSpaceRequired,}(?=.*[ \t]{$UseModExtraSpaceRequired,}\:)/cog)) {
    return CloseHtmlEnvironmentUntil('dd')
      .OpenHtmlEnvironment('dl', length($2))
      .AddHtmlEnvironment('dt');  # `:' needs special treatment, later
  }
  elsif (InElement('dt') and m/\G(?<=[ \t]){$UseModExtraSpaceRequired,}:[ \t]*/cg) {
    return CloseHtmlEnvironmentUntil('dt')
      .CloseHtmlEnvironment()
      .AddHtmlEnvironment('dd');
  }
  # headings using = (with lookahead)
  elsif ($bol && $UseModMarkupInTitles
	 && m/\G(\s*\n)*(\=+)[ \t]*(?=[^=\n]+=)/cg) {
    my $depth = length($2);
    $depth = 6 if $depth > 6;
    $depth = 2 if $depth < 2;
    my $html = CloseHtmlEnvironments() . ($PortraitSupportColorDiv ? '' : '')
      . AddHtmlEnvironment('h' . $depth);
    $PortraitSupportColorDiv = 0; # after the HTML has been determined.
    $PortraitSupportColor = 0;
    return $html;
  } elsif ($UseModMarkupInTitles
	   && (InElement('h1') || InElement('h2') || InElement('h3')
	       || InElement('h4') || InElement('h5') || InElement('h6'))
	   && m/\G[ \t]*=+\n?/cg) {
    return CloseHtmlEnvironments() . AddHtmlEnvironment('p');
  } elsif ($bol && !$UseModMarkupInTitles
	   && m/\G(\s*\n)*(\=+)[ \t]*(.+?)[ \t]*(=+)[ \t]*\n?/cg) {
    my $html = CloseHtmlEnvironments() . ($PortraitSupportColorDiv ? '' : '')
      . WikiHeading($2, $3) . AddHtmlEnvironment('p');
    $PortraitSupportColorDiv = 0; # after the HTML has been determined.
    $PortraitSupportColor = 0;
    return $html;
  }
  # horizontal lines using ----
  elsif ($bol && m/\G(\s*\n)*----+[ \t]*\n?/cg) {
    my $html = CloseHtmlEnvironments() . ($PortraitSupportColorDiv ? '' : '')
      . $q->hr() . AddHtmlEnvironment('p');
    $PortraitSupportColorDiv = 0;
    $PortraitSupportColor = 0;
    return $html;
  }
  # tables using || -- the first row of a table
  elsif ($bol && m/\G(\s*\n)*((\|\|)+)([ \t])*(?=.*\|\|[ \t]*(\n|$))/cg) {
    $rowcount = 1;
    return OpenHtmlEnvironment('table',1,'user')
      . AddHtmlEnvironment('tr', 'class="odd first"')
      . AddHtmlEnvironment('td', UsemodTableAttributes(length($2)/2, $4));
  }
  # tables using || -- end of the row and beginning of the next row
  elsif (InElement('td') && m/\G[ \t]*((\|\|)+)[ \t]*\n((\|\|)+)([ \t]*)/cg) {
    my $attr = UsemodTableAttributes(length($3)/2, $5);
    my $type = ++$rowcount % 2 ? 'odd' : 'even';
    $attr = " " . $attr if $attr;
    return qq{};
  }
  # tables using || -- an ordinary table cell
  elsif (InElement('td') && m/\G[ \t]*((\|\|)+)([ \t]*)(?!(\n|$))/cg) {
    my $attr = UsemodTableAttributes(length($1)/2, $3);
    $attr = " " . $attr if $attr;
    return "";
  }
  # tables using || -- since "next row" was taken care of above, this must be the last row
  elsif (InElement('td') && m/\G[ \t]*((\|\|)+)[ \t]*/cg) {
    return CloseHtmlEnvironments() . AddHtmlEnvironment('p');
  }
  # RFC
  elsif (m/\G$RFCPattern/cog) { return &RFC($1); }
  # ISBN -- dirty because the URL translations will change
  elsif (m/\G($ISBNPattern)/cog) { Dirty($1); print ISBN($2); return ''; }
  # traditional wiki syntax closure for bold italic'''''
  elsif (InElement('strong') and InElement('em') and m/\G'''''/cg) { # close both
    return CloseHtmlEnvironment('strong').CloseHtmlEnvironment('em');
  }
  # traditional wiki syntax for '''bold'''
  elsif (m/\G'''/cg) { return AddOrCloseHtmlEnvironment('strong'); }
  # traditional wiki syntax for ''italic''
  elsif (m/\G''/cg ) { return AddOrCloseHtmlEnvironment('em'); }
  #  for raw html
  elsif ($RawHtml && m/\G\<html\>(.*?)\<\/html\>/cgis) {
    return UnquoteHtml($1);
  }
  # miscellaneous html tags
  elsif (m/\G\<($UsemodHtmlRegExp)(\s+[^<>]*?)?\>/cogi) { 
    return AddHtmlEnvironment($1, $2); }
  elsif (m/\G\<\/($UsemodHtmlRegExp)\>/cogi) {
    return CloseHtmlEnvironment($1); }
  elsif (m/\G\<($UsemodHtmlRegExp) *\/\>/cogi) {
    return "<$1 />"; }
  # text for html links
  elsif ($HtmlLinks && m/\G\<a(\s[^<>]+?)\>(.*?)\<\/a\>/cgi) {
    return "$2";
  }
  return undef;
}

sub UsemodTableAttributes {
  my ($span, $left, $right) = @_;
  my $attr = '';
  $attr = "colspan=\"$span\"" if ($span != 1);
  m/\G(?=.*?([ \t]*)\|\|)/;
  $right = $1;
  $attr .= ' ' if ($attr and ($left or $right));
  if ($left and $right) { $attr .= 'align="center"' }
  elsif ($left ) { $attr .= 'align="right"' }
  elsif ($right) { $attr .= 'align="left"' }
  return $attr;
}

sub WikiHeading {
  my ($depth, $text) = @_;
  $depth = length($depth);
  $depth = 6 if $depth > 6;
  $depth = 2 if $depth < 2;
  return "$text";
}

sub RFC {
  my $num = shift;
  return $q->a({-href=>"http://tools.ietf.org/html/rfc${num}"}, "RFC $num");
}

sub ISBN {
  my $rawnum = shift;
  my $num = $rawnum;
  my $rawprint = $rawnum;
  $rawprint =~ s/ +$//;
  $num =~ s/[- ]//g;
  my $len = length($num);
  return "ISBN $rawnum" unless $len == 10 or $len == 13 or $len = 14; # be prepared for 2007-01-01
  my $first  = $q->a({-href => Ts('http://search.barnesandnoble.com/booksearch/isbninquiry.asp?ISBN=%s', $num)},
      "ISBN " . $rawprint);
  my $second = $q->a({-href => Ts('http://www.amazon.com/exec/obidos/ISBN=%s', $num)},
      T('alternate'));
  my $third  = $q->a({-href => Ts('http://www.pricescan.com/books/BookDetail.asp?isbn=%s', $num)},
      T('search'));
  my $html = "$first ($second, $third)";
  $html .= ' '  if ($rawnum =~ / $/);  # Add space if old ISBN had space.
  return $html;
}

=head1 COPYRIGHT AND LICENSE

The information below applies to everything in this distribution,
except where noted.

Copyright 2008, 2009, 2010 by Alex Schroeder .
Copyleft  2008 by Brian Curry .
Copyright 2008 by Weakish Jiang .
Copyright 2004, 2005, 2006, 2007 by Alex Schroeder .

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 L.

=cut