Get rid of -r

There is a target in our Makefile to make a new release. This stores a
tarball with the appropriate release information in
https://oddmuse.org/releases. tarballs.pl offers an interface to serve
these files, or their individual member files, with a naive cache of
50 elements.

This is a Mojolicious application and is available here:
https://odddmuse.org/download

modules/git-another.pl

@@ -39,9 +39,9 @@ sub GitCommit {
 }
 
 sub GitInitRepository {
-  return if -d "$DataDir/page/.git";
+  return if IsDir("$DataDir/page/.git");
   capture {
-    system($GitBinary, qw(init -q --), "$DataDir/page");
+    system($GitBinary, qw(init -q --), encode_utf8("$DataDir/page"));
   };
   GitCommit('Initial import', 'Oddmuse');
 }

modules/header-and-footer-templates.pl

@@ -43,7 +43,7 @@ sub HtmlTemplate {
   my $type = shift;
   # return header.de.html, or header.html, or error.html, or report an error...
   foreach my $f ((map { "$type.$_" } HtmlTemplateLanguage()), $type, "error") {
-    return "$HtmlTemplateDir/$f.html" if -r "$HtmlTemplateDir/$f.html";
+    return "$HtmlTemplateDir/$f.html" if IsFile("$HtmlTemplateDir/$f.html");
   }
   ReportError(Tss('Could not find %1.html template in %2', $type, $HtmlTemplateDir),
 	      '500 INTERNAL SERVER ERROR');

modules/html-template.pl

@@ -87,7 +87,7 @@ sub GetActionHtmlTemplate {
   my $action = GetParam('action', 'browse');
   # return browse.de.html, or browse.html, or error.html, or report an error...
   foreach my $f ((map { "$action.$_" } HtmlTemplateLanguage()), $action, "error") {
-    return "$HtmlTemplateDir/$f.html" if -r "$HtmlTemplateDir/$f.html";
+    return "$HtmlTemplateDir/$f.html" if IsFile("$HtmlTemplateDir/$f.html");
   }
   ReportError(Tss('Could not find %1.html template in %2', $action, $HtmlTemplateDir),
 	      '500 INTERNAL SERVER ERROR');

modules/load-lang.pl

@@ -75,9 +75,9 @@ sub LoadLanguage {
     my $file = $TranslationsLibrary{$Lang{$_}};
     next unless $file; # file is not listed, eg. there is no file for "de-ch"
     $file = "$LoadLanguageDir/$file" if defined $LoadLanguageDir;
-    if (-r $file) {
+    if (IsFile($file)) {
       do $file;
-      do "$ConfigFile-$Lang{$_}" if -r "$ConfigFile-$Lang{$_}";
+      do "$ConfigFile-$Lang{$_}" if IsFile("$ConfigFile-$Lang{$_}");
       $CurrentLanguage = $Lang{$_};
       last;
     }

modules/localnames.pl

@@ -66,7 +66,7 @@ push (@MyMaintenance, \&LnMaintenance);
 sub LnMaintenance {
   if (opendir(DIR, encode_utf8($RssDir))) { # cleanup if they should expire anyway
     foreach my $file (readdir(DIR)) {
-      unlink("$RssDir/$file") if -M $file > $LnCacheHours * 3600;
+      Unlink("$RssDir/$file") if $Now - Modified($file) > $LnCacheHours * 3600;
     }
     closedir DIR;
   }

modules/module-updater.pl

@@ -81,8 +81,7 @@ sub ProcessModule {
 		     . ' If this is your own module, please contribute it to Oddmuse!'), $q->br();
     return;
   }
-  my $file = "$TempDir/$module";
-  open my $fh, ">:utf8", encode_utf8($file) or die("Could not open file $TempDir/$module: $!");
+  open my $fh, ">:utf8", encode_utf8("$TempDir/$module") or die("Could not open file $TempDir/$module: $!");
   print $fh $moduleData;
   close $fh;
 
@@ -109,6 +108,5 @@ sub ProcessModule {
 }
 
 sub DoModuleDiff {
-  my $diff = decode_utf8(`diff -U 3 -- \Q$_[0]\E \Q$_[1]\E`);
-  return $diff;
+  decode_utf8(`diff -U 3 -- \Q$_[0]\E \Q$_[1]\E`);
 }

modules/namespaces.pl

@@ -96,7 +96,7 @@ sub NamespacesInitVariables {
   }
   $NamespaceRoot = $ScriptName; # $ScriptName may be changed below
   $NamespaceCurrent = '';
-  my $ns = decode_utf8(GetParam('ns', ''));
+  my $ns = GetParam('ns', '');
   if (not $ns and $UsePathInfo) {
     my $path_info = decode_utf8($q->path_info());
     # make sure ordinary page names are not matched!

modules/private-wiki.pl

@@ -160,7 +160,7 @@ sub GetPrivatePageFile {
   }
   $cipher->set_iv($iv);
   # We cannot use full byte range because of the filesystem limits
-  my $returnName = unpack "H*", $iv . $cipher->encrypt(PadTo16Bytes(encode_utf8($id)), 96); # to hex string
+  my $returnName = unpack "H*", $iv . $cipher->encrypt(PadTo16Bytes(encode_utf8($id), 96)); # to hex string
   return $returnName;
 }
 

modules/smiley-dir.pl

@@ -24,14 +24,13 @@ AddModuleDescription('smiley-dir.pl', 'Smiley Directory Extension');
 our (@MyInitVariables, $ImageExtensions, %Smilies);
 our ($SmileyDir, $SmileyUrlPath);
 
-# $SmileyDir must be bytes! (use encode_utf8 if necessary)
 $SmileyDir = '/mnt/pics'; # directory with all the smileys
 $SmileyUrlPath = '/pics'; # path where all the smileys can be found (URL)
 
 push(@MyInitVariables, \&SmileyDirInit);
 
 sub SmileyDirInit {
-  if (opendir(DIR, $SmileyDir)) {
+  if (opendir(DIR, encode_utf8($SmileyDir))) {
     map {
       if (/^((.*)\.$ImageExtensions$)/ and IsFile("$SmileyDir/$_")) {
 	my $regexp = quotemeta("{$2}");

modules/static-copy.pl

@@ -135,19 +135,21 @@ sub StaticWriteFile {
   my ($mimetype, $encoding, $data) =
       $Page{text} =~ /^\#FILE ([^ \n]+) ?([^ \n]*)\n(.*)/s;
   my $filename = StaticFileName($id);
-  open(my $fh, '>', encode_utf8("$StaticDir/$filename"))
-    or ReportError(Ts('Cannot write %s', $filename));
+  my $file = "$StaticDir/$filename";
   if ($data) {
-    binmode($fh);
+    open(my $fh, '>', encode_utf8($file))
+	or ReportError(Ts('Cannot write %s', $filename));
     StaticFile($id, $fh, $mimetype, $data);
+    close($fh);
   } elsif ($html) {
-    binmode($fh, ':encoding(UTF-8)');
+    open(my $fh, '>:encoding(UTF-8)', encode_utf8($file))
+	or ReportError(Ts('Cannot write %s', $filename));
     StaticHtml($id, $fh);
+    close($fh);
   } else {
     print "no data for ";
   }
-  close($fh);
-  chmod 0644,"$StaticDir/$filename";
+  ChangeMod(0644,"$StaticDir/$filename");
   print $filename, $raw ? "\n" : $q->br();
 }
 

modules/toc.pl

@@ -229,16 +229,10 @@ my $TocCommentPattern = qr~\Q<!-- toc\E.*?\Q -->\E~;
 # appropriate, and then printed at the very end.
 sub NewTocApplyRules {
   my ($html, $blocks, $flags);
-  {
-    local *STDOUT;
-    my $html_unfixed;
-    open(  STDOUT, '>', \$html_unfixed) or die "Can't open memory file: $!";
-    binmode STDOUT, ":encoding(UTF-8)";
-    ($blocks, $flags) = map { decode_utf8($_) } OldTocApplyRules(@_);
-    close STDOUT;
-    # do not delete!
-    $html = decode_utf8($html_unfixed);
-  }
+  $html = ToString(sub{
+    # pass arguments on to OldTocApplyRules given that ToString takes a code ref
+    ($blocks, $flags) = OldTocApplyRules(@_);
+		   }, @_);
   # If there are at least two HTML headers on this page, insert a table of
   # contents.
   if ($TocHeaderNumber > 2) {

modules/upgrade.pl

@@ -69,7 +69,7 @@ sub DoUpgrade {
   print "<p>Renaming files...";
 
   for my $ns ('', keys %InterSite) {
-    next unless -d "$DataDir/$ns";
+    next unless IsDir("$DataDir/$ns");
     print "<br />\n<strong>$ns</strong>" if $ns;
     for my $dirname ($PageDir, $KeepDir, $RefererDir, $JoinerDir, $JoinerEmailDir) {
       next unless $dirname;

scripts/tarballs.pl

@@ -0,0 +1,122 @@
+#!/usr/bin/env perl
+use Mojolicious::Lite;
+use Mojo::Cache;
+use Archive::Tar;
+use File::Basename;
+use Encode qw(decode_utf8);
+my $dir = "/home/alex/oddmuse.org/releases";
+my $cache = Mojo::Cache->new(max_keys => 50);
+
+get '/' => sub {
+  my $c = shift;
+  my @tarballs = sort map {
+    my ($name, $path, $suffix) = fileparse($_, '.tar.gz');
+    $name;
+  } <$dir/*.tar.gz>;
+  $c->render(template => 'index', tarballs => \@tarballs);
+} => 'main';
+
+get '/#tarball' => sub {
+  my $c = shift;
+  my $tarball = $c->param('tarball');
+  my $files = $cache->get($tarball);
+  if (not $files) {
+    $c->app->log->info("Reading $tarball.tar.gz");
+    my $tar = Archive::Tar->new;
+    $tar->read("$dir/$tarball.tar.gz");
+    my @files = sort grep /./, map {
+      my @e = split('/', $_->name);
+      $e[1];
+    } $tar->get_files();
+    $files = \@files;
+    $cache->set($tarball => $files);
+  }
+  $c->render(template => 'release', tarball=> $tarball, files => $files);
+} => 'release';
+
+get '/#tarball/#file' => sub {
+  my $c = shift;
+  my $tarball = $c->param('tarball');
+  my $file = $c->param('file');
+  my $text = $cache->get("$tarball/$file");
+  if (not $text) {
+    $c->app->log->info("Reading $tarball/$file");
+    my $tar = Archive::Tar->new;
+    $tar->read("$dir/$tarball.tar.gz");
+    $text = decode_utf8($tar->get_content("$tarball/$file"));
+    $cache->set("$tarball/$file" => $text);
+  }
+  $c->render(template => 'file', format => 'txt', content => $text);
+} => 'file';
+
+app->start;
+
+__DATA__
+
+@@ index.html.ep
+% layout 'default';
+% title 'Oddmuse Releases';
+<h1>Oddmuse Releases</h1>
+
+<p>Welcome! This is where you get access to tarballs and files in released
+versions of Oddmuse.</p>
+
+<ul>
+% for my $tarball (@$tarballs) {
+<li>
+<a href="https://oddmuse.org/releases/<%= $tarball %>.tar.gz"><%= $tarball %>.tar.gz</a>
+(files for <%= link_to release => {tarball => $tarball} => begin %>\
+<%= $tarball =%><%= end %>)
+</li>
+% }
+</ul>
+
+
+@@ release.html.ep
+% layout 'default';
+% title 'Release';
+<h1>Files for <%= $tarball %></h1>
+<p>
+Back to the list of <%= link_to 'releases' => 'main' %>.
+Remember,
+%= link_to file => {file => 'wiki.pl'} => begin
+wiki.pl
+% end
+is the main script.
+
+<ul>
+% for my $file (@$files) {
+<li>
+%= link_to file => {file => $file} => begin
+%= $file
+% end
+% }
+</ul>
+
+@@ file.txt.ep
+%layout 'file';
+<%== $content %>
+
+@@ layouts/default.html.ep
+<!DOCTYPE html>
+<html>
+<head>
+<title><%= title %></title>
+%= stylesheet '/tarballs.css'
+%= stylesheet begin
+body {
+  padding: 1em;
+  font-family: "Palatino Linotype", "Book Antiqua", Palatino, serif;
+}
+% end
+<meta name="viewport" content="width=device-width">
+</head>
+<body>
+<%= content %>
+<hr>
+<p>
+<a href="https://oddmuse.org/">Oddmuse</a>&#x2003;
+<%= link_to 'Releases' => 'main' %>&#x2003;
+<a href="https://alexschroeder.ch/wiki/Contact">Alex Schroeder</a>
+</body>
+</html>

t/meta.t

@@ -1,5 +1,5 @@
+# Copyright (C) 2015-2016  Alex Schroeder <alex@gnu.com>
 # 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
@@ -20,13 +20,14 @@ use utf8;
 
 package OddMuse;
 require 't/test.pl';
-use Test::More tests => 11;
+use Test::More tests => 29;
 use File::Basename;
 use Pod::Strip;
 use Pod::Simple::TextContent;
 
 my @modules = grep { $_ ne 'modules/404handler.pl' } <modules/*.pl>;
 my @other = 'wiki.pl';
+my %text = (map { $_ => ReadFileOrDie($_) } @modules, @other);
 my @badModules;
 
 @badModules = grep { (stat $_)[2] != oct '100644' } @modules;
@@ -35,20 +36,19 @@ unless (ok(@badModules == 0, 'Consistent file permissions of modules')) {
   diag("▶▶▶ Use this command to fix it: chmod 644 @badModules");
 }
 
-@badModules = grep { ReadFile($_) !~ / ^ use \s+ strict; /mx } @modules;
+@badModules = grep { $text{$_} !~ / ^ use \s+ strict; /mx } @modules;
 unless (ok(@badModules == 0, '"use strict;" in modules')) {
   diag(qq{$_ has no "use strict;"}) for @badModules;
 }
 
-@badModules = grep { ReadFile($_) !~ / ^ use \s+ v5\.10; /mx } @modules;
+@badModules = grep { $text{$_} !~ / ^ use \s+ v5\.10; /mx } @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);
+  my $code = $text{$_};
 
   # check Perl source code
   my $perl;
@@ -72,39 +72,39 @@ ok(@badModules == 0, 'utf8 in modules');
 
  SKIP: {
    skip 'documentation tests, we did not try to document every module yet', 1;
-   @badModules = grep { ReadFile($_) !~ / ^ AddModuleDescription\(' [^\']+ ', /mx } @modules;
+   @badModules = grep { $text{$_} !~ / ^ AddModuleDescription\(' [^\']+ ', /mx } @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; /imx } @modules;
+@badModules = grep { $text{$_} =~ / ^ package \s+ OddMuse; /imx } @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 /mx } @modules;
+@badModules = grep { $text{$_} =~ / ^ use \s+ vars /mx } @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]+ $ /mx } @modules, @other;
+@badModules = grep { $text{$_} =~ / [ \t]+ $ /mx } @modules, @other;
 unless (ok(@badModules == 0, 'no trailing whitespace in modules (and other perl files)')) {
   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;
+@badModules = grep { $text{$_} =~ / 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;
+  $text{$_} !~ /^AddModuleDescription\('$name.pl'/mx;
  } @modules;
 unless (ok(@badModules == 0, 'AddModuleDescription is used in every module')) {
   diag(qq{$_ does not use AddModuleDescription}) for @badModules;
@@ -116,3 +116,49 @@ unless (ok(@badModules == 0, 'modules are syntatically correct')) {
   diag(qq{$_ has syntax errors}) for @badModules;
   diag("▶▶▶ Use this command to see the problems: for f in @badModules; do perl -c \$f; done");
 }
+
+my %changes = (
+  '-f' => 'IsFile',
+  '-e' => 'IsFile',
+  '-r' => 'IsFile',
+  '-d' => 'IsDir',
+  '-z' => 'ZeroSize',
+  '-M' => '$Now - Modified',
+  'unlink' => 'Unlink',
+  'stat(.*)[9]' => 'Modified',
+  'bsd_glob' => 'Glob',
+  'chmod' => 'ChangeMod',
+  'rename' => 'Rename',
+  'rmdir' => 'RemoveDir',
+  'chdir' => 'ChangeDir',
+  'mkdir' => 'CreateDir',
+    );
+
+for my $re (sort keys %changes) {
+  @badModules = grep {
+    my $text = $text{$_};
+    $text =~s/#.*\n//g; # get rid of comments
+    $text =~s/Tss?\([^\)]+//g; # getting rid of "rename" in strings
+    $text =~s/\{\w+\}//g; # getting rid of "rename" in $Action{rename}
+    $text =~s/'\w+'//g; # getting rid of "rename" in 'rename'
+    not ($_ eq 'modules/pygmentize.pl' and $re eq '-f'
+	or $_ eq 'modules/static-copy.pl' and $re eq 'chmod'
+	or $_ eq 'modules/static-hybrid.pl' and $re eq 'chmod')
+	and (substr($re, 0, 1) eq '-' and $text =~ /[ (] $re \s/x
+	     or $re eq 'stat(.*)[9]' and $text =~ /\b $re /x
+	     or $re =~ /^\w+$/ and $text =~ /\b $re \b/x);
+  } @modules;
+  unless (ok(@badModules == 0, "modules do not use $re")) {
+    diag(qq{$_ uses $re instead of $changes{$re}}) for @badModules;
+  }
+}
+
+for my $fun ('open.*,.*[<>]', 'sysopen', 'tie', 'opendir') {
+  @badModules = grep {
+    my @lines = map { s/#.*//; $_ } split(/\n/, $text{$_});
+    grep(!/encode_utf8/, grep(/\b $fun \b/x, @lines));
+  } @modules;
+  unless (ok(@badModules == 0, qq{modules use encode_utf8 with $fun})) {
+    diag(qq{$_ does not use encode_utf8 with $fun}) for @badModules;
+  }
+}

wiki.pl

@@ -798,8 +798,8 @@ sub UrlEncode {
 
 sub UrlDecode {
   my $str = shift;
-  $str =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/eg;
-  return decode_utf8($str); # make internal string
+  return decode_utf8($str) if $str =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/eg;
+  return $str;
 }
 
 sub QuoteRegexp {
@@ -1256,15 +1256,14 @@ sub PrintPageDiff {   # print diff for open page
 }
 
 sub ToString {
-  my ($sub_ref) = @_;
+  my $sub_ref = shift;
   my $output;
   open(my $outputFH, '>:encoding(UTF-8)', \$output) or die "Can't open memory file: $!";
   my $oldFH = select $outputFH;
-  $sub_ref->();
+  $sub_ref->(@_);
   select $oldFH;
   close $outputFH;
-  my $output_fixed = $output;        # Do not delete! This is a workarond for a perl bug.
-  return decode_utf8($output_fixed); # Otherwise UTF8 characters are SOMETIMES not decoded.
+  return decode_utf8($output);
 }
 
 sub PageHtml {
@@ -1298,10 +1297,10 @@ sub Tss {
 
 sub GetId {
   my $id = UnquoteHtml(GetParam('id', GetParam('title', ''))); # id=x or title=x -> x
-  if (not $id) {
-    $id ||= decode_utf8(join('_', $q->keywords)); # script?p+q -> p_q
+  if (not $id and $q->keywords) {
+    $id = decode_utf8(join('_', $q->keywords)); # script?p+q -> p_q
   }
-  if ($UsePathInfo) {
+  if ($UsePathInfo and $q->path_info) {
     my @path = map { decode_utf8($_) } split(/\//, $q->path_info);
     $id ||= pop(@path); # script/p/q -> q
     foreach my $p (@path) {
@@ -2881,6 +2880,7 @@ sub ZeroSize  { return -z encode_utf8(shift); }
 sub Unlink    { return unlink(map { encode_utf8($_) } @_); }
 sub Modified  { return (stat(encode_utf8(shift)))[9]; }
 sub Glob      { return map { decode_utf8($_) } bsd_glob(encode_utf8(shift)); }
+sub ChangeMod { return chmod(shift, map { encode_utf8($_) } @_); }
 sub Rename    { return rename(encode_utf8($_[0]), encode_utf8($_[1])); }
 sub RemoveDir { return rmdir(encode_utf8(shift)); }
 sub ChangeDir { return chdir(encode_utf8(shift)); }