Remove Emacs reminder

Running perl t/crypto.t only rarely works. Most of the time the token
cannot be decrypted.

Makefile

@@ -21,7 +21,7 @@ clean:
 	rm -rf build
 
 build/wiki.pl: wiki.pl
-	perl -lne "s/(\\\$$q->a\({-href=>'http:\/\/www.oddmuse.org\/'}, 'Oddmuse'\))/\\\$$q->a({-href=>'http:\/\/git.savannah.gnu.org\/cgit\/oddmuse.git\/tag\/?id=$(VERSION_NO)'}, 'wiki.pl') . ' ($(VERSION_NO)), see ' . \$$1/; print" < $< > $@
+	perl build.pl $< $@ $(VERSION_NO)
 
 build/%-utf8.pl: modules/translations/%-utf8.pl
 	perl -lne "s/(AddModuleDescription\('[^']+', '[^']+')\)/\$$1, 'translations\/', '$(VERSION_NO)')/; print" < $< > $@

build.pl

@@ -0,0 +1,36 @@
+# Copyright (C) 2015  Alex Schroeder <alex@gnu.org>
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+# This script processes wiki.pl, replacing the link to www.oddmuse.org with a
+# link to the current version. It also changes the default of the random
+# Challenge Token so that everybody gets a different one.
+
+use Crypt::Random qw( makerandom );
+
+my ($old_file, $new_file, $version) = @ARGV;
+
+undef $/;
+open(my $in, '<:utf8', $old_file) or die "Cannot read $old_file: $!";
+$_ = <$in>;
+close($in);
+
+s!(\$q->a\({-href=>'http://www.oddmuse.org/'}, 'Oddmuse'\))!\$q->a\({-href=>'http://git.savannah.gnu.org/cgit/oddmuse.git/tag/?id=$version'}, 'wiki.pl'\) . ' ($version), see ' . $1!;
+
+my $r = join('', map { sprintf('\x%x', makerandom( Size => 8, Uniform => 1, Strength => 1 )) } 1..16);
+
+s!our \$TokenKey //= '(.*?)'!our \$TokenKey //= '$r'!;
+
+open(my $out, '>:utf8', $new_file) or die "Cannot write $new_file: $!";
+print $out $_;
+close($out);

contrib/oddmuse-curl.el

@@ -602,7 +602,7 @@ This command is used to reflect new pages to `oddmuse-pages-hash'."
     ("{{{.*?}}}"
      0 '(face shadow
 	      help-echo "Creole code"))
-    ("^{{{\n\\(.*\n\\)+?}}}\n"
+    ("^{{{\\(.*\n\\)+?}}}\n"
      0 '(face shadow
 	      help-echo "Creole multiline code")))
     "Implement markup rules for the Creole markup extension.
@@ -841,7 +841,9 @@ WIKI is the name of the wiki as defined in `oddmuse-wikis',
 PAGENAME is the pagename of the page you want to edit. If the
 page is already in a buffer, pop to that buffer instead of
 loading the page Use a prefix argument to force a reload of the
-page."
+page. Use \\[oddmuse-reload] to reload the list of pages
+available if you changed the URL in `oddmuse-wikis' or if other
+people have been editing the wiki in the mean time."
   (interactive (oddmuse-pagename))
   (make-directory (concat oddmuse-directory "/" wiki) t)
   (let ((name (concat wiki ":" pagename)))

modules/404handler.pl

@@ -27,7 +27,7 @@ my @path = split(/\//, $ENV{REDIRECT_URL});
 my $file = $path[$#path];
 
 # for dynamic pages
-use vars qw($NotFoundHandlerExceptionsPage);
+our ($NotFoundHandlerExceptionsPage);
 $NotFoundHandlerExceptionsPage = 'NoCachePages';
 $RunCGI = 0;
 do $script;

modules/admin.pl

@@ -39,7 +39,7 @@ sub AdminPowerDelete {
   } else {
     print $q->p(GetPageLink($id) . ' ' . T('deleted'));
     WriteRcLog($id, Ts('Deleted %s', $id), 0, $Page{revision},
-	       GetParam('username', ''), GetRemoteHost(), $Page{languages},
+	       GetParam('username', ''), $q->remote_addr(), $Page{languages},
 	       GetCluster($Page{text}));
   }
   # Regenerate index on next request
@@ -88,10 +88,10 @@ sub AdminPowerRename {
   # RecentChanges
   OpenPage($new);
   WriteRcLog($id, Ts('Renamed to %s', $new), 0, $Page{revision},
-	     GetParam('username', ''), GetRemoteHost(), $Page{languages},
+	     GetParam('username', ''), $q->remote_addr(), $Page{languages},
 	     GetCluster($Page{text}));
   WriteRcLog($new, Ts('Renamed from %s', $id), 0, $Page{revision},
-	     GetParam('username', ''), GetRemoteHost(), $Page{languages},
+	     GetParam('username', ''), $q->remote_addr(), $Page{languages},
 	     GetCluster($Page{text}));
   print $q->p(Tss('Renamed %1 to %2.', GetPageLink($id), GetPageLink($new)));
   ReleaseLock();

modules/agree-disagree.pl

@@ -0,0 +1,119 @@
+# Copyright (C) 2005  Bayle Shanks http://purl.net/net/bshanks
+#
+# 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
+
+use strict;
+use v5.10;
+
+our ($Now, @MyMacros, @MyRules, $DefaultStyleSheet, $q, $bol);
+
+AddModuleDescription('agree-disagree.pl', 'AgreeDisagreePlugin');
+
+push(@MyRules, \&AgreeDisagreeSupportRule);
+
+push(@MyMacros, sub{ s/\[\+\]/"[+:" . GetParam('username', T('Anonymous'))
+                       . ':' . TimeToText($Now) . "]"/ge });
+push(@MyMacros, sub{ s/\[\+(:[^]:]+)\]/"[+$1:" . TimeToText($Now) . "]"/ge });
+push(@MyMacros, sub{ s/\[\-\]/"[-:" . GetParam('username', T('Anonymous'))
+                       . ':' . TimeToText($Now) . "]"/ge });
+push(@MyMacros, sub{ s/\[\-(:[^]:]+)\]/"[-$1:" . TimeToText($Now) . "]"/ge });
+
+
+$DefaultStyleSheet .= <<'EOT' unless $DefaultStyleSheet =~ /div\.agree/; # mod_perl?
+    div.agreeCount {
+ float: left;
+ clear: left;
+background-color: Green;
+padding-left: .5em;
+padding-right: .5em;
+padding-top: .5em;
+padding-bottom: .5em;
+}
+div.disagreeCount {
+  float: left;
+ clear: right;
+background-color: Red;
+padding-left: .5em;
+padding-right: .5em;
+padding-top: .5em;
+padding-bottom: .5em;
+}
+
+div.agreeNames {
+  float: left;
+background-color: Green;
+font-size: xx-small;
+ display: none;
+}
+div.disagreeNames {
+  float: left;
+background-color: Red;
+font-size: xx-small;
+ display: none;
+}
+
+
+
+EOT
+
+
+
+
+    my %AgreePortraits = ();
+
+
+sub AgreeDisagreeSupportRule {
+  if ($bol) {
+    if ($bol && m/(\G(\s*\[\+(.*?)\]|\s*\[-(.*?)\])+)/gcs) {
+
+      my $votes = $1;
+      my @ayes = ();
+      my @nayes = ();
+      while ($votes =~ m/\G.*?\[\+(.*?)\]/gcs) {
+        my ($ignore, $name, $time) = split(/:/, $1, 3);
+        push(@ayes, $name);
+      }
+      my $votes2 = $votes;
+      while ($votes2 =~ m/\G.*?\[-(.*?)\]/gcs) {
+        my ($ignore, $name, $time) = split(/:/, $1, 3);
+        push(@nayes, $name);
+      }
+
+      my $html = CloseHtmlEnvironments() ;
+      $html .= $q->div({-class=>'agreeCount'}) . ($#ayes+1) . '  ' . '</div>' ;
+
+      $html .= $q->div({-class=>'agreeNames'}) . printNames(@ayes) . '</div>' ;
+      $html .= $q->div({-class=>'disagreeCount'}) . '  ' . ($#nayes+1) . '</div>' ;
+      $html .= $q->div({-class=>'disagreeNames'}) . printNames(@nayes) . '</div>' ;
+
+
+      return $html;
+    }
+  }
+  return undef;
+}
+
+
+sub printNames {
+  my @names = @_;
+
+  my $html = '';
+  foreach my $name (@names)  {
+    $html .= "$name<br>";
+  }
+  return $html;
+}

modules/ban-quick-editors.pl

@@ -29,7 +29,7 @@ sub BanQuickNewUserIsBanned {
   if (not $rule
       and $SurgeProtection # need surge protection
       and GetParam('title')) {
-    my $name = GetParam('username', GetRemoteHost());
+    my $name = GetParam('username', $q->remote_addr());
     my @entries = @{$RecentVisitors{$name}};
     # $entry[0] is $Now after AddRecentVisitor
     my $ts = $entries[1];

modules/banned-regexps.pl

@@ -16,11 +16,13 @@ use strict;
 
 AddModuleDescription('banned-regexps.pl', 'Banning Regular Expressions');
 
-=h1 Compatibility
+=encoding utf8
+
+=head1 Compatibility
 
 This extension works with logbannedcontent.pl.
 
-=h1 Example content for the BannedRegexps page:
+=head1 Example content for the BannedRegexps page:
 
     # This page lists regular expressions that prevent the saving of a page.
     # The regexps are matched against any page or comment submitted.

modules/drafts.pl

@@ -28,7 +28,7 @@ push(@MyInitVariables, \&DraftInit);
 sub DraftInit {
   if (GetParam('Draft', '')) {
     SetParam('action', 'draft') ; # Draft button used
-  } elsif (-f "$DraftDir/" . GetParam('username', GetRemoteHost()) # draft exists
+  } elsif (-f "$DraftDir/" . GetParam('username', $q->remote_addr()) # draft exists
 	   and $FooterNote !~ /action=draft/) {                    # take care of mod_perl persistence
     $FooterNote = $q->p(ScriptLink('action=draft', T('Recover Draft'))) . $FooterNote;
   }
@@ -38,7 +38,7 @@ $Action{draft} = \&DoDraft;
 
 sub DoDraft {
   my $id = shift;
-  my $draft = $DraftDir . '/' . GetParam('username', GetRemoteHost());
+  my $draft = $DraftDir . '/' . GetParam('username', $q->remote_addr());
   if ($id) {
     my $text = GetParam('text', '');
     ReportError(T('No text to save'), '400 BAD REQUEST') unless $text;

modules/flashbox.pl

@@ -3,6 +3,8 @@ use strict;
 
 # ====================[ flashbox.pl                        ]====================
 
+=encoding utf8
+
 =head1 NAME
 
 flashbox - An Oddmuse module for embedding offsite-hosted Flash videos within

modules/footnotes.pl

@@ -3,6 +3,8 @@ use strict;
 
 # ====================[ footnotes.pl                       ]====================
 
+=encoding utf8
+
 =head1 NAME
 
 footnotes - An Oddmuse module for adding footnotes to Oddmuse Wiki pages.

modules/google-plus-one.pl

@@ -52,7 +52,7 @@ function loadScript(jssource,thelink) {
 };
 }
 
-# Google +1 list                                                                                         
+# Google +1 list
 
 push(@MyAdminCode, sub {
        my ($id, $menuref, $restref) = @_;
@@ -71,7 +71,7 @@ sub DoPlusOne {
   foreach my $id (AllPagesList()) {
     push(@pages, $id) if $id =~ /^\d\d\d\d-\d\d-\d\d/;
   }
-  splice(@pages, 0, $#pages - 19); # last 20 items                                                       
+  splice(@pages, 0, $#pages - 19); # last 20 items
   print "<ul>";
   foreach my $id (@pages) {
     my $url = ScriptUrl(UrlEncode($id));

modules/hibernal.pl

@@ -1,8 +1,11 @@
 #!/usr/bin/env perl
 use strict;
+use utf8;
 
 # ====================[ hibernal.pl                        ]====================
 
+=encoding utf8
+
 =head1 NAME
 
 hibernal - An Oddmuse module for improved multi- and single-blogging.

modules/like.pl

@@ -23,7 +23,7 @@ AddModuleDescription('like.pl', 'Like Button');
 our $LikeRegexp =      T('====(\d+) persons? liked this===='); # must match all translations
 our $LikeReplacement = T('====%d persons liked this===='); # used for sprintf
 our $LikeFirst =       T('====1 person liked this====');
-    
+
 our (%Action, %Page, $OpenPageName, @MyFooters);
 $Action{like} = \&DoLike;
 push(@MyFooters, \&LikeFooter);

modules/localnames.pl

@@ -19,6 +19,8 @@ AddModuleDescription('localnames.pl', 'Local Names Extension');
 
 our ($q, $Now, %Page, %Action, $OpenPageName, $ScriptName, $DataDir, $RssDir, @MyRules, @MyMaintenance, @MyInitVariables, $FullUrlPattern, $FreeLinkPattern, $CommentsPrefix, $UseCache, @UserGotoBarPages, %AdminPages, @MyAdminCode, @MyFooters, $UsePathInfo);
 
+=encoding utf8
+
 =head1 Local Names
 
 This module allows you to centrally define redirections. Thus you can

modules/logbannedcontent.pl

@@ -47,6 +47,6 @@ sub LogWrite {
   my $rule = shift;
   my $id = $OpenPageName || GetId();
   AppendStringToFile($BannedFile,
-		     join("\t", TimeToW3($Now), GetRemoteHost(), $id, $rule)
+		     join("\t", TimeToW3($Now), $q->remote_addr(), $id, $rule)
 		     . "\n");
 }

modules/open-proxy.pl

@@ -36,10 +36,10 @@ $Action{$SelfBan} = \&DoSelfBan;
 
 sub DoSelfBan {
   my $date = &TimeToText($Now);
-  my $str = '^' . quotemeta(GetRemoteHost());
+  my $str = '^' . quotemeta($q->remote_addr());
   OpenPage($BannedHosts);
   Save ($BannedHosts, $Page{text} . "\n\nself-ban on $date\n $str",
-	Ts("Self-ban by %s", GetRemoteHost()), 1); # minor edit
+	Ts("Self-ban by %s", $q->remote_addr()), 1); # minor edit
   ReportError(T("You have banned your own IP."));
 }
 
@@ -55,7 +55,7 @@ sub OpenProxyNewDoEdit {
 
 sub BanOpenProxy {
   my ($force) = @_;
-  my $ip = GetRemoteHost();
+  my $ip = $q->remote_addr();
   my $limit = 60*60*24*30; # rescan after 30 days
   # Only check each IP address once a month
   my %proxy = split(/\s+/,  ReadFile($OpenProxies));

modules/permanent-anchors.pl

@@ -19,6 +19,8 @@ AddModuleDescription('permanent-anchors.pl', 'Permanent Anchors');
 
 our ($q, $OpenPageName, %IndexHash, $DataDir, $ScriptName, @MyRules, @MyInitVariables, $FS, $FreeLinkPattern, @IndexOptions);
 
+=encoding utf8
+
 =head1 Permanent Anchors
 
 This module allows you to create link targets within a page. These

modules/recaptcha.pl

@@ -252,7 +252,7 @@ sub ReCaptchaCheckAnswer {
   eval "use Captcha::reCAPTCHA";
   my $result = Captcha::reCAPTCHA->new()->check_answer(
     $ReCaptchaPrivateKey,
-    GetRemoteHost(),
+    $q->remote_addr(),
     GetParam('recaptcha_challenge_field'),
     GetParam('recaptcha_response_field')
   );

modules/static-hybrid.pl

@@ -425,7 +425,7 @@ sub StaticNewDoRollback {
     } elsif (!UserCanEdit($id, 1)) {
       print Ts('Editing not allowed for %s.', $id), $q->br();
     } else {
-      Save($id, $text, Ts('Rollback to %s', TimeToText($to)), $minor, ($Page{host} ne GetRemoteHost()));
+      Save($id, $text, Ts('Rollback to %s', TimeToText($to)), $minor, ($Page{host} ne $q->remote_addr()));
       StaticDeleteFile($id);
       print Ts('%s rolled back', GetPageLink($id)), ($ts ? ' ' . Ts('to %s', TimeToText($to)) : ''), $q->br();
     }

modules/tags.pl

@@ -1,5 +1,7 @@
 use strict;
 
+=encoding utf8
+
 =head1 NAME
 
 tags - an Oddmuse module that implements tagging of pages and

modules/toc-js.pl

@@ -13,6 +13,7 @@
 # this program. If not, see <http://www.gnu.org/licenses/>.
 
 use strict;
+use utf8;
 
 AddModuleDescription('toc-js.pl', 'Javascript Table of Contents Extension');
 

modules/upload.pl

@@ -78,7 +78,7 @@ for (my $i=0; $q->param("fileToUpload$i"); $i++) {
 
   my $uploadFileHandle = $q->upload("fileToUpload$i");
 
-  open($UPLOADFILE, '>', "$uploadDir/$curFilename") or squeak "$!";
+  open(my $UPLOADFILE, '>', "$uploadDir/$curFilename") or squeak "$!";
   binmode $UPLOADFILE;
   while (<$uploadFileHandle>) {
     print $UPLOADFILE;

t/crypto.t

@@ -0,0 +1,25 @@
+# Copyright (C) 2015  Alex Schroeder <alex@gnu.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+require 't/test.pl';
+package OddMuse;
+use Test::More tests => 3;
+
+$page = get_page('title=Test text="Editing a page"');
+test_page_negative($page, "Editing a page");
+test_page($page, "Token is missing");
+test_page(update_page("Test", "Editing a page using update_page"),
+          "Editing a page using update_page");
+print $redirect;

t/lock-expiration.t

@@ -1,20 +1,24 @@
-# Copyright (C) 2007–2015  Alex Schroeder <alex@gnu.org>
+# Copyright (C) 2007  Alex Schroeder <alex@emacswiki.org>
 #
-# 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 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.
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
 #
-# You should have received a copy of the GNU General Public License along with
-# this program. If not, see <http://www.gnu.org/licenses/>.
+# 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
 
 require 't/test.pl';
 package OddMuse;
-use Test::More tests => 19;
+use Test::More tests => 17;
 
 AppendStringToFile($ConfigFile, "\$SurgeProtection = 1;\n");
 $localhost = 'confusibombus';
@@ -23,44 +27,25 @@ my $lock = $LockDir . 'visitors';
 ok(! -d $lock, 'visitors lock does not exist yet');
 ok(! -f $VisitorFile, 'visitors log does not exist yet');
 
-# Don't loop forever trying to remove a lock older than $LockExpiration that
-# cannot be removed (eg. if the script user was changed, so that the old
-# lockfile cannot be removed by the new user). Locks are directories; we
-# simulate a lock that cannot be removed by creating a file with the same name
-# instead. At the same time, test fake-time!
+# Don't loop forever trying to remove a lock older than
+# $LockExpiration that cannot be removed (eg. if the script user was
+# changed, so that the old lockfile cannot be removed by the new
+# user). Locks are directories; we simulate a lock that cannot be
+# removed by creating a file with the same name instead.
 mkdir($TempDir);
 ok(open(F, '>', $lock), "create bogus ${LockDir}visitors");
 my $ts = time - 120;
 utime($ts, $ts, $lock); # change mtime of the lockfile
-
-# Getting a time will now time out because no visitor lock can ge aquired.
 $ts = time;
 get_page('fail-to-get-lock');
-
-# Since we're using fake-time, let's make sure that no real time passed.
 my $waiting = time - $ts;
-ok($waiting <= 1, "waited $waiting real seconds (max. 1)");
-
-# Fake time is available in the timestamp file.
-my $fakets = (stat("$DataDir/ts"))[9];
-$waiting = $fakets - $ts;
-ok($waiting >= 16, "waited $waiting fake seconds (min. 16)");
-
-# Remove the fake visitors lock and redo this. Reset the fake timestamp on the
-# file. Get a file. This should take no real time and no fake time (as there was
-# no sleeping involved).
+ok($waiting >= 16, "waited $waiting seconds (min. 16)");
 unlink($LockDir . 'visitors');
 $ts = time;
-utime($ts, $ts, "$DataDir/ts");
 test_page(get_page('get-lock'), 'get-lock');
-$waiting = time - $ts;
+my $waiting = time - $ts;
 ok($waiting <= 2, "waited $waiting seconds (max. 2)");
 
-# Make sure no fake time elapsed!
-$fakets = (stat("$DataDir/ts"))[9];
-$waiting = $fakets - time;
-ok($waiting <= 2, "waited $waiting fake seconds (max. 2)");
-
 # The main lock works as intended.
 RequestLockOrError();
 update_page('cannot', 'create');
@@ -82,7 +67,7 @@ test_page($redirect, 'Status: 503 SERVICE UNAVAILABLE',
 ok(-d $LockDir . 'visitors', 'visitors lock remained');
 ok($ts == (stat($VisitorFile))[10], 'visitors log was not modified');
 
-AppendStringToFile($ConfigFile, "\$LockExpiration = -1;\n");
+AppendStringToFile($ConfigFile, "\$LockExpiration = 3;\n");
 test_page(update_page('Test', 'page updated'), 'page updated');
 ok(! -d $LockDir . 'visitors', 'visitors lock expired');
 ok($ts != (stat($VisitorFile))[10], 'visitors log was modified');

t/meta.t

@@ -0,0 +1,120 @@
+# Copyright (C) 2015  Alex Jakimenko <alex.jakimenko@gmail.com>
+# Copyright (C) 2015  Alex Schroeder <alex@gnu.com>
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+use strict;
+use warnings;
+use v5.10;
+use utf8;
+
+package OddMuse;
+require 't/test.pl';
+use Test::More tests => 11;
+use File::Basename;
+use Pod::Strip;
+use Pod::Simple::TextContent;
+
+my @modules = grep { $_ ne 'modules/404handler.pl' } <modules/*.pl>;
+my @badModules;
+
+@badModules = grep { (stat $_)[2] != oct '100644' } @modules;
+unless (ok(@badModules == 0, 'Consistent file permissions of modules')) {
+  diag(sprintf "$_ has %o but 100644 was expected", (stat $_)[2]) for @badModules;
+  diag("▶▶▶ Use this command to fix it: chmod 644 @badModules");
+}
+
+@badModules = grep { ReadFile($_) !~ / ^ use \s+ strict; /xm } @modules;
+unless (ok(@badModules == 0, '"use strict;" in modules')) {
+  diag(qq{$_ has no "use strict;"}) for @badModules;
+}
+
+ SKIP: {
+   skip '"use v5.10;" tests, we are not doing "use v5.10;" everywhere yet', 1;
+   @badModules = grep { ReadFile($_) !~ / ^ use \s+ v5\.10; /xm } @modules;
+   unless (ok(@badModules == 0, '"use v5.10;" in modules')) {
+     diag(qq{$_ has no "use v5.10;"}) for @badModules;
+     diag(q{Minimum perl version for the core is v5.10, it seems like there is no reason not to have "use v5.10;" everywhere else.});
+   }
+}
+
+@badModules = grep {
+  my $code = ReadFile($_);
+  # warn "Looking at $_: " . length($code);
+
+  # check Perl source code
+  my $perl;
+  my $pod_stripper = Pod::Strip->new;
+  $pod_stripper->output_string(\$perl);
+  $pod_stripper->parse_string_document($code);
+  $perl =~ s/#.*//g;
+  my $bad_perl = $perl !~ / ^ use \s+ utf8; /xm && $perl =~ / ([[:^ascii:]]+) /x;
+  diag(qq{$_ has no "use utf8;" but contains non-ASCII characters in Perl code, eg. "$1"}) if $bad_perl;
+
+  # check POD
+  my $pod;
+  my $pod_text = Pod::Simple::TextContent->new;
+  $pod_text->output_string(\$pod);
+  $pod_text->parse_string_document($code);
+  my $bad_pod = $code !~ / ^ =encoding \s+ utf8 /xm && $pod =~ / ([[:^ascii:]]+) /x;
+  diag(qq{$_ has no "=encoding utf8" but contains non-ASCII characters in POD, eg. "$1"}) if $bad_pod;
+  $bad_perl || $bad_pod;
+} @modules;
+ok(@badModules == 0, 'utf8 in modules');
+
+ SKIP: {
+   skip 'documentation tests, we did not try to document every module yet', 1;
+   @badModules = grep { ReadFile($_) !~ / ^ AddModuleDescription\(' [^\']+ ', /xm } @modules;
+   unless (ok(@badModules == 0, 'link to the documentation in modules')) {
+     diag(qq{$_ has no link to the documentation}) for @badModules;
+   }
+}
+
+@badModules = grep { ReadFile($_) =~ / ^ package \s+ OddMuse; /xmi } @modules;
+unless (ok(@badModules == 0, 'no "package OddMuse;" in modules')) {
+  diag(qq{$_ has "package OddMuse;"}) for @badModules;
+  diag(q{When we do "do 'somemodule.pl';" it ends up being in the same namespace of a caller, so there is no need to use "package OddMuse;"});
+}
+
+@badModules = grep { ReadFile($_) =~ / ^ use \s+ vars /xm } @modules;
+unless (ok(@badModules == 0, 'no "use vars" in modules')) {
+  diag(qq{$_ is using "use vars"}) for @badModules;
+  diag('▶▶▶ Use "our ($var, ...)" instead of "use vars qw($var ...)"');
+  diag(q{▶▶▶ Use this command to do automatic conversion: perl -0pi -e 's/^([\t ]*)use vars qw\s*\(\s*(.*?)\s*\);/$x = $2; $x =~ s{(?<=\w)\b(?!$)}{,}g;"$1our ($x);"/gems' } . "@badModules");
+}
+
+@badModules = grep { ReadFile($_) =~ / [ \t]+ $ /xm } @modules;
+unless (ok(@badModules == 0, 'no trailing whitespace in modules')) {
+  diag(qq{$_ has trailing whitespace}) for @badModules;
+  diag(q{▶▶▶ Use this command to do automatic trailing whitespace removal: perl -pi -e 's/[ \t]+$//g' } . "@badModules");
+}
+
+@badModules = grep { ReadFile($_) =~ / This (program|file) is free software /x } @modules;
+unless (ok(@badModules == 0, 'license is specified in every module')) {
+  diag(qq{$_ has no license specified}) for @badModules;
+}
+
+@badModules = grep {
+  my ($name, $path, $suffix) = fileparse($_, '.pl');
+  ReadFile($_) !~ /^AddModuleDescription\('$name.pl'/mx;
+ } @modules;
+unless (ok(@badModules == 0, 'AddModuleDescription is used in every module')) {
+  diag(qq{$_ does not use AddModuleDescription}) for @badModules;
+}
+
+# we have to use shell to redirect the output :(
+@badModules = grep { system("perl -cT \Q$_\E > /dev/null 2>&1") != 0 } @modules;
+unless (ok(@badModules == 0, 'modules are syntatically correct')) {
+  diag(qq{$_ has syntax errors}) for @badModules;
+  diag("▶▶▶ Use this command to see the problems: perl -c @badModules");
+}

t/test.pl

@@ -13,7 +13,9 @@
 # this program. If not, see <http://www.gnu.org/licenses/>.
 
 package OddMuse;
-use lib '.';
+use Crypt::CBC;
+use Crypt::Cipher::AES;
+use MIME::Base64;
 use XML::LibXML;
 use utf8;
 use vars qw($raw);
@@ -74,12 +76,12 @@ sub url_encode {
 sub capture {
   my $command = shift;
   if ($raw) {
-    open ($fh, '-|', $command) or die "Can't run $command: $!";
+    open (CL, '-|', $command) or die "Can't run $command: $!";
   } else {
-    open ($fh, '-|:encoding(utf-8)', $command) or die "Can't run $command: $!";
+    open (CL, '-|:encoding(utf-8)', $command) or die "Can't run $command: $!";
   }
-  my $result = <$fh>;
-  close $fh;
+  my $result = <CL>;
+  close CL;
   return $result;
 }
 
@@ -90,9 +92,10 @@ sub update_page {
   $text = url_encode($text);
   $summary = url_encode($summary);
   $minor = $minor ? 'on' : 'off';
+  my $token = GetChallengeToken('edit', $id);
   my $rest = join(' ', @rest);
-  $redirect = capture("perl $DataDir/test-wiki.pl 'Save=1' 'title=$page' 'summary=$summary' 'recent_edit=$minor' 'text=$text' 'pwd=$pwd' $rest");
-  $output = capture("perl $DataDir/test-wiki.pl action=browse id=$page $rest");
+  $redirect = capture("perl wiki.pl 'Save=1' 'title=$page' 'summary=$summary' 'recent_edit=$minor' 'text=$text' 'token=$token' 'pwd=$pwd' $rest");
+  $output = capture("perl wiki.pl action=browse id=$page $rest");
   if ($redirect =~ /^Status: 302 /) {
     # just in case a new page got created or NearMap or InterMap
     $IndexHash{$id} = 1;
@@ -103,7 +106,7 @@ sub update_page {
 }
 
 sub get_page {
-  return capture("perl $DataDir/test-wiki.pl @_");
+  return capture("perl wiki.pl @_");
 }
 
 sub name {
@@ -312,12 +315,12 @@ sub remove_module {
 }
 
 sub write_config_file {
-  open($fh, '>:encoding(utf-8)', "$DataDir/config");
-  print $fh "\$AdminPass = 'foo';\n";
+  open(F, '>:encoding(utf-8)', "$DataDir/config");
+  print F "\$AdminPass = 'foo';\n";
   # this used to be the default in earlier CGI.pm versions
-  print $fh "\$ScriptName = 'http://localhost/wiki.pl';\n";
-  print $fh "\$SurgeProtection = 0;\n";
-  close($fh);
+  print F "\$ScriptName = 'http://localhost/wiki.pl';\n";
+  print F "\$SurgeProtection = 0;\n";
+  close(F);
   $ScriptName = 'http://localhost/test.pl'; # different!
   $IndexInit = 0;
   %IndexHash = ();
@@ -329,31 +332,6 @@ sub write_config_file {
   %NearSearch = ();
 }
 
-sub write_modified_wiki {
-  my $preamble = <<EOT;
-
-BEGIN {
-  my \$delta = 0;
-
-  *CORE::GLOBAL::sleep = sub {
-    \$delta += shift;
-    my \$ts = time + \$delta;
-    utime(\$ts, \$ts, "$DataDir/ts")
-  };
-
-  sub newtime {
-    return time + \$delta;
-  };
-
-  *CORE::GLOBAL::time = \&newtime;
-}
-
-EOT
-     
-  WriteStringToFile("$DataDir/test-wiki.pl", $preamble . ReadFileOrDie('wiki.pl'));
-  WriteStringToFile("$DataDir/ts", '');
-}
-
 sub clear_pages {
   if (-f "/bin/rm") {
     system('/bin/rm', '-rf', $DataDir);
@@ -371,7 +349,6 @@ sub clear_pages {
     add_module('mac.pl');
   }
   write_config_file();
-  write_modified_wiki();
 }
 
 1;

test.pl

@@ -0,0 +1,18 @@
+use Crypt::CBC;
+use Crypt::Cipher::AES;
+use MIME::Base64;
+ 
+my $key = 'my secret key'; # length has to be valid key size for this cipher
+my $cipher = Crypt::CBC->new( -cipher=>'Cipher::AES', -key=>$key );
+my $ciphertext = $cipher->encrypt("secret data");
+my $code = encode_base64($ciphertext);
+chomp $code;
+print "$code\n";
+
+my $cipher2 = Crypt::CBC->new( -cipher=>'Cipher::AES', -key=>$key );
+my $plaintext = $cipher2->decrypt(decode_base64($code));
+print $plaintext . "\n";
+
+use Crypt::Random qw( makerandom );
+my $r = join('', map { sprintf("\\x%x", makerandom( Size => 8, Uniform => 1, Strength => 1 )) } 1..16);
+printf "$r\n";

wiki.pl

@@ -35,6 +35,9 @@ use utf8; # in case anybody ever addes UTF8 characters to the source
 use CGI qw/-utf8/;
 use CGI::Carp qw(fatalsToBrowser);
 use File::Glob ':glob';
+use Crypt::CBC;
+use Crypt::Cipher::AES;
+use MIME::Base64;
 local $| = 1; # Do not buffer output (localized for mod_perl)
 
 # Options:
@@ -91,7 +94,8 @@ our $AdminPass //= '';              # Whitespace separated passwords.
 our $EditPass  //= '';              # Whitespace separated passwords.
 our $PassHashFunction //= '';       # Name of the function to create hashes
 our $PassSalt  //= '';              # Salt will be added to any password before hashing
-
+# Key to encrypt challenge token. Use make prepare to create a new one.
+our $TokenKey //= '\x40\x77\x79\xfc\xd9\x33\x21\xf0\x6e\xf7\xa1\x86\xbe\xc6\x5f\xed';
 our $BannedHosts = 'BannedHosts';   # Page for banned hosts
 our $BannedCanRead = 1;             # 1 = banned cannot edit, 0 = banned cannot read
 our $BannedContent = 'BannedContent'; # Page for banned content (usually for link-ban)
@@ -1326,6 +1330,7 @@ sub DoBrowseRequest {
     SetParam('action', 'search'); # make sure this gets a NOINDEX
     DoSearch();
   } elsif (GetParam('title', '') and not GetParam('Cancel', '')) {
+    SetParam('action', 'edit'); # make sure this gets a NOINDEX
     DoPost(GetParam('title', ''));
   } else {
     BrowseResolvedPage($id || $HomePage);  # default action!
@@ -2087,7 +2092,7 @@ sub DoRollback {
     } elsif (not UserIsEditor() and my $rule = BannedContent($text)) {
       print Ts('Rollback of %s would restore banned content.', $id), $rule, $q->br();
     } else {
-      Save($id, $text, Ts('Rollback to %s', TimeToText($to)), $minor, ($Page{host} ne GetRemoteHost()));
+      Save($id, $text, Ts('Rollback to %s', TimeToText($to)), $minor, ($Page{host} ne $q->remote_addr()));
       print Ts('%s rolled back', GetPageLink($id)), ($ts ? ' ' . Ts('to %s', TimeToText($to)) : ''), $q->br();
     }
   }
@@ -2180,10 +2185,6 @@ sub ScriptLinkDiff {
   return ScriptLink($action, $text, 'diff');
 }
 
-sub GetRemoteHost {
-  return $ENV{REMOTE_ADDR};
-}
-
 sub GetAuthor {
   my ($host, $username) = @_;
   return $username . ' ' . Ts('from %s', $host) if $username and $host;
@@ -2487,12 +2488,34 @@ sub GetCommentForm {
   return '';
 }
 
+sub GetChallengeToken {
+  my ($action, $id) = @_;
+  my $token = join($FS, $Now, GetParam('username'), $q->remote_addr(), $action, $id);
+  my $cipher = Crypt::CBC->new( -cipher=>'Cipher::AES', -key=>$TokenKey );
+  my $ciphertext = $cipher->encrypt($token);
+  return encode_base64($ciphertext);
+}
+
+sub CheckToken {
+  my $code = UnquoteHtml(GetParam('token'));
+  ReportError(T('Token is missing.'), '403 FORBIDDEN') unless $code;
+  my $cipher = Crypt::CBC->new( -cipher=>'Cipher::AES', -key=>$TokenKey );
+  my ($ts, $name, $ip, $action, $id) = split(/$FS/, $cipher->decrypt(decode_base64($code)));
+  # FIXME add retry functionality
+  ReportError(T('Token mismatch on time.'), '403 FORBIDDEN', '', "$ts >= $Now - 60 * 60") unless $ts >= $Now - 60 * 60; # 1h
+  ReportError(T('Token mismatch on IP number.'), '403 FORBIDDEN', '', $q->remote_addr . "eq $ip") unless $q->remote_addr eq $ip;
+  ReportError(T('Token mismatch on action.'), '403 FORBIDDEN', '', GetParam('action') . "eq $action") unless GetParam('action') eq $action;
+  ReportError(T('Token mismatch on id.'), '403 FORBIDDEN') unless GetParam('id', GetParam('title')) eq $id;
+}
+
 sub GetFormStart {
-  my ($ignore, $method, $class) = @_;
+  my ($ignore, $method, $class, $action, $id) = @_;
   $method ||= 'post';
   $class  ||= 'form';
-  return $q->start_multipart_form(-method=>$method, -action=>$FullUrl,
-				  -accept_charset=>'utf-8', -class=>$class);
+  my $html = $q->start_multipart_form(-method=>$method, -action=>$FullUrl,
+                                      -accept_charset=>'utf-8', -class=>$class);
+  $html .= GetHiddenValue('token', GetChallengeToken($action, $id)) if $action;
+  return $html;
 }
 
 sub GetSearchForm {
@@ -3059,9 +3082,9 @@ sub DoEdit {
 }
 
 sub GetEditForm {
-  my ($page_name, $upload, $oldText, $revision) = @_;
-  my $html = GetFormStart(undef, undef, $upload ? 'edit upload' : 'edit text') # protected by questionasker
-    .$q->p(GetHiddenValue("title", $page_name),
+  my ($id, $upload, $oldText, $revision) = @_;
+  my $html = GetFormStart(undef, undef, $upload ? 'edit upload' : 'edit text', 'edit', $id) # protected by questionasker
+    .$q->p(GetHiddenValue("title", $id),
 	   ($revision ? GetHiddenValue('revision', $revision) : ''),
            GetHiddenValue('oldtime', GetParam('oldtime', $Page{ts})), # prefer parameter over actual timestamp
 	   ($upload ? GetUpload() : GetTextArea('text', $oldText)));
@@ -3079,9 +3102,9 @@ sub GetEditForm {
            ($upload ? '' : ' ' . $q->submit(-name=>'Preview', -accesskey=>T('p'), -value=>T('Preview'))).
            ' '.$q->submit(-name=>'Cancel', -value=>T('Cancel')));
   if ($upload) {
-    $html .= $q->p(ScriptLink('action=edit;upload=0;id=' . UrlEncode($page_name), T('Replace this file with text'),   'upload'));
+    $html .= $q->p(ScriptLink('action=edit;upload=0;id=' . UrlEncode($id), T('Replace this file with text'),   'upload'));
   } elsif ($UploadAllowed or UserIsAdmin()) {
-    $html .= $q->p(ScriptLink('action=edit;upload=1;id=' . UrlEncode($page_name), T('Replace this text with a file'), 'upload'));
+    $html .= $q->p(ScriptLink('action=edit;upload=1;id=' . UrlEncode($id), T('Replace this text with a file'), 'upload'));
   }
   $html .= $q->end_form();
   return $html;
@@ -3108,9 +3131,8 @@ sub DoDownload {
       ReportError(Ts('Files of type %s are not allowed.', $type), '415 UNSUPPORTED MEDIA TYPE');
     }
     print GetHttpHeader($type, $Page{ts}, undef, $encoding);
-    require MIME::Base64;
     binmode(STDOUT, ":pop:raw"); # need to pop utf8 for Windows users!?
-    print MIME::Base64::decode($data);
+    print decode_base64($data);
   } else {
     print GetHttpHeader('text/plain', $Page{ts});
     print $text;
@@ -3199,7 +3221,7 @@ sub UserCanEdit {
 
 sub UserIsBanned {
   return 0 if GetParam('action', '') eq 'password'; # login is always ok
-  my $host = GetRemoteHost();
+  my $host = $q->remote_addr();
   foreach (split(/\n/, GetPageContent($BannedHosts))) {
     if (/^\s*([^#]\S+)/) { # all lines except empty lines and comments, trim whitespace
       my $regexp = $1;
@@ -3347,9 +3369,10 @@ sub AddToIndex {
 }
 
 sub DoSearch {
-  my $string = shift || GetParam('search', '');;
+  my $string = shift || GetParam('search', '');
+  my $re = UnquoteHtml($string);
   return DoIndex() if $string eq '';
-  eval { qr/$string/ }
+  eval { qr/$re/ }
     or $@ and ReportError(Ts('Malformed regular expression in %s', $string),
 			  '400 BAD REQUEST');
   my $replacement = GetParam('replace', undef);
@@ -3562,7 +3585,7 @@ sub Replace {
     };
     if (s/$from/$replacement->()/gei) { # allows use of backreferences
       push (@result, $id);
-      Save($id, $_, $from . ' → ' . $to, 1, ($Page{host} ne GetRemoteHost()));
+      Save($id, $_, $from . ' → ' . $to, 1, ($Page{host} ne $q->remote_addr()));
     }
   }
   ReleaseLock();
@@ -3572,6 +3595,7 @@ sub Replace {
 sub DoPost {
   my $id = FreeToNormal(shift);
   UserCanEditOrDie($id);
+  CheckToken();
   # Lock before getting old page to prevent races
   RequestLockOrError();		# fatal
   OpenPage($id);
@@ -3600,7 +3624,7 @@ sub DoPost {
     local $/ = undef;		# Read complete files
     my $content = <$file>; # Apparently we cannot count on <$file> to always work within the eval!?
     my $encoding = substr($content, 0, 2) eq "\x1f\x8b" ? 'gzip' : '';
-    eval { require MIME::Base64; $_ = MIME::Base64::encode($content) };
+    $_ = encode_base64($content);
     $string = "#FILE $type $encoding\n" . $_;
   } else {			# ordinary text edit
     $string = AddComment($old, $comment) if $comment;
@@ -3641,7 +3665,7 @@ sub DoPost {
   if ($oldrev) { # the first author (no old revision) is not considered to be "new"
     # prefer usernames for potential new author detection
     $newAuthor = 1 if not $Page{username} or $Page{username} ne GetParam('username', '');
-    $newAuthor = 1 if not GetRemoteHost() or not $Page{host} or GetRemoteHost() ne $Page{host};
+    $newAuthor = 1 if not $q->remote_addr() or not $Page{host} or $q->remote_addr() ne $Page{host};
   }
   my $oldtime = $Page{ts};
   my $myoldtime = GetParam('oldtime', ''); # maybe empty!
@@ -3715,7 +3739,7 @@ sub AddComment {
 sub Save {      # call within lock, with opened page
   my ($id, $new, $summary, $minor, $upload) = @_;
   my $user = GetParam('username', '');
-  my $host = GetRemoteHost();
+  my $host = $q->remote_addr();
   my $revision = $Page{revision} + 1;
   my $old = $Page{text};
   my $olddiff = $Page{'diff-major'} == '1' ? $Page{'diff-minor'} : $Page{'diff-major'};
@@ -3943,7 +3967,7 @@ sub DoDebug {
 
 sub DoSurgeProtection {
   return unless $SurgeProtection;
-  my $name = GetParam('username', GetRemoteHost());
+  my $name = GetParam('username', $q->remote_addr());
   return unless $name;
   ReadRecentVisitors();
   AddRecentVisitor($name);