t/test.pl

   1 # Copyright (C) 2004, 2005, 2006, 2008, 2012  Alex Schroeder <alex@gnu.org>
   2 #
   3 # This program is free software; you can redistribute it and/or modify it under
   4 # the terms of the GNU General Public License as published by the Free Software
   5 # Foundation; either version 3 of the License, or (at your option) any later
   6 # version.
   7 #
   8 # This program is distributed in the hope that it will be useful, but WITHOUT
   9 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  10 # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  11 #
  12 # You should have received a copy of the GNU General Public License along with
  13 # this program. If not, see <http://www.gnu.org/licenses/>.
  14
  15 package OddMuse;
  16 use lib '.';
  17 use XML::LibXML;
  18 use utf8;
  19 use vars qw($raw);
  20
  21 # Test::More explains how to fix wide character in print issues
  22 my $builder = Test::More->builder;
  23 binmode $builder->output,         ":utf8";
  24 binmode $builder->failure_output, ":utf8";
  25 binmode $builder->todo_output,    ":utf8";
  26
  27 # Import the functions
  28
  29 $raw = 0;       # capture utf8 is the default
  30 $RunCGI = 0;    # don't print HTML on stdout
  31 $UseConfig = 0; # don't read module files
  32 $DataDir = 'test-data';
  33 $ENV{WikiDataDir} = $DataDir;
  34 require 'wiki.pl';
  35
  36 # Try to guess which Perl we should be using. Since we loaded wiki.pl,
  37 # our $ENV{PATH} is set to /bin:/usr/bin in order to find diff and
  38 # grep.
  39 if ($ENV{PERLBREW_PATH}) {
  40   $ENV{PATH} = $ENV{PERLBREW_PATH} . ':' . $ENV{PATH};
  41 } elsif (-f '/usr/local/bin/perl') {
  42   $ENV{PATH} = '/usr/local/bin:' . $ENV{PATH};
  43 }
  44
  45 Init();
  46 use vars qw($redirect);
  47
  48 undef $/;
  49 $| = 1; # no output buffering
  50
  51 sub url_encode {
  52   my $str = shift;
  53   return '' unless $str;
  54   utf8::encode($str); # turn to byte string
  55   my @letters = split(//, $str);
  56   my @safe = ('a' .. 'z', 'A' .. 'Z', '0' .. '9', '-', '_', '.'); # shell metachars are unsafe
  57   foreach my $letter (@letters) {
  58     my $pattern = quotemeta($letter);
  59     if (not grep(/$pattern/, @safe)) {
  60       $letter = sprintf("%%%02x", ord($letter));
  61     }
  62   }
  63   return join('', @letters);
  64 }
  65
  66 # Run perl in a subprocess and make sure it prints UTF-8 and not Latin-1
  67 # If you use the download action, the output will be raw bytes. Use
  68 # something like the following:
  69 # {
  70 #   local $raw = 1;
  71 #   $page = get_page('action=download id=Trogs');
  72 # }
  73 sub capture {
  74   my $command = shift;
  75   if ($raw) {
  76     open (CL, '-|', $command) or die "Can't run $command: $!";
  77   } else {
  78     open (CL, '-|:encoding(utf-8)', $command) or die "Can't run $command: $!";
  79   }
  80   my $result = <CL>;
  81   close CL;
  82   return $result;
  83 }
  84
  85 sub update_page {
  86   my ($id, $text, $summary, $minor, $admin, @rest) = @_;
  87   my $pwd = $admin ? 'foo' : 'wrong';
  88   my $page = url_encode($id);
  89   $text = url_encode($text);
  90   $summary = url_encode($summary);
  91   $minor = $minor ? 'on' : 'off';
  92   my $rest = join(' ', @rest);
  93   $redirect = capture("perl wiki.pl 'Save=1' 'title=$page' 'summary=$summary' 'recent_edit=$minor' 'text=$text' 'pwd=$pwd' $rest");
  94   $output = capture("perl wiki.pl action=browse id=$page $rest");
  95   if ($redirect =~ /^Status: 302 /) {
  96     # just in case a new page got created or NearMap or InterMap
  97     $IndexHash{$id} = 1;
  98     @IndexList = sort(keys %IndexHash);
  99     ReInit($id); # if $id eq $InterMap, we need it to be in the $IndexHash before running ReInit()
 100   }
 101   return $output;
 102 }
 103
 104 sub get_page {
 105   return capture("perl wiki.pl @_");
 106 }
 107
 108 sub name {
 109   $_ = shift;
 110   s/\n/\\n/g;
 111   $_ = '...' . substr($_, -60) if length > 63;
 112   return $_;
 113 }
 114
 115 sub newlines {
 116   my @strings = @_;
 117   return map { s/\\n/\n/g; $_; } @strings;
 118 }
 119
 120 # alternating input and output strings for applying rules
 121 sub run_tests {
 122   # translate embedded newlines (other backslashes remain untouched)
 123   my @tests = newlines(@_);
 124   my ($input, $output);
 125   while (($input, $output, @tests) = @tests) {
 126     my $result = apply_rules($input);
 127     is($result, $output, name($input));
 128   }
 129 }
 130
 131 sub apply_rules {
 132   my $input = shift;
 133   local *STDOUT;
 134   $output = '';
 135   open(STDOUT, '>', \$output) or die "Can't open memory file: $!";
 136   $FootnoteNumber = 0;
 137   ApplyRules(QuoteHtml($input), 1);
 138   return $output;
 139 }
 140
 141 # alternating input and output strings for applying macros instead of rules
 142 sub run_macro_tests {
 143   # translate embedded newlines (other backslashes remain untouched)
 144   my %test = map { s/\\n/\n/g; $_; } @_;
 145   # Note that the order of tests is not specified!
 146   foreach my $input (keys %test) {
 147     $_ = $input;
 148     foreach my $macro (@MyMacros) { &$macro; }
 149     is($_, $test{$input}, $input);
 150   }
 151 }
 152
 153 # one string, many tests
 154 sub test_page {
 155   my ($page, @tests) = @_;
 156   foreach my $test (@tests) {
 157     like($page, qr($test), name($test));
 158   }
 159 }
 160
 161 # one string, many negative tests
 162 sub test_page_negative {
 163   my $page = shift;
 164   foreach my $str (@_) {
 165     unlike($page, qr($str), name("not $str"));
 166   }
 167 }
 168
 169 sub xpath_do {
 170   my ($check, $message, $page, @tests) = @_;
 171   $page =~ s/^.*?(<html)/$1/s; # strip headers
 172   $page =~ s/^.*?<\?xml.*?>\s*//s; # strip xml processing
 173   my $page_shown = 0;
 174   my $parser = XML::LibXML->new();
 175   my $doc;
 176   my $result;
 177  SKIP: {
 178     eval { $doc = $parser->parse_html_string($page) };
 179     eval { $doc = $parser->parse_string($page) } if $@;
 180     skip("Cannot parse ".name($page).": $@", $#tests + 1) if $@;
 181     foreach my $test (@tests) {
 182       my $nodelist;
 183       my $bytes = $test;
 184       # utf8::encode: Converts in-place the character sequence to the
 185       # corresponding octet sequence in *UTF-X*. The UTF8 flag is
 186       # turned off, so that after this operation, the string is a byte
 187       # string. (I have no idea why this is necessary, but there you
 188       # go. See encoding.t tests and make sure the page file is
 189       # encoded correctly.)
 190       utf8::encode($bytes);
 191       eval { $nodelist = $doc->findnodes($bytes) };
 192       if ($@) {
 193         fail(&$check(1) ? "$test: $@" : "not $test: $@");
 194       } elsif (ok(&$check($nodelist->size()),
 195                   name(&$check(1) ? $test : "not $test"))) {
 196         $result .= $nodelist->string_value();
 197       } else {
 198         $page =~ s/^.*?<html/<html/s;
 199         diag($message, substr($page,0,30000)) unless $page_shown;
 200         $page_shown = 1;
 201       }
 202     }
 203   }
 204   return $result; # return string_value() of all found nodes
 205 }
 206
 207 sub xpath_test {
 208   xpath_do(sub { shift > 0; }, "No Matches\n", @_);
 209 }
 210
 211 sub negative_xpath_test {
 212   xpath_do(sub { shift == 0; }, "Unexpected Matches\n", @_);
 213 }
 214
 215 # alias
 216 sub xpath_test_negative {
 217   return negative_xpath_test(@_);
 218 }
 219
 220 sub xpath_run_tests {
 221   # translate embedded newlines (other backslashes remain untouched)
 222   my @tests = newlines(@_);
 223   my ($input, $output);
 224   while (($input, $output, @tests) = @tests) {
 225     my $result = apply_rules($input);
 226     xpath_test("<div>$result</div>", $output);
 227   }
 228 }
 229
 230 sub remove_rule {
 231   my $rule = shift;
 232   my @list = ();
 233   my $found = 0;
 234   foreach my $item (@MyRules) {
 235     if ($item ne $rule) {
 236       push @list, $item;
 237     } else {
 238       $found = 1;
 239     }
 240   }
 241   die "Rule not found" unless $found;
 242   @MyRules = @list;
 243 }
 244
 245 sub add_module {
 246   my ($mod, $subdir) = @_;
 247   $subdir .= '/' if $subdir and substr($subdir, -1) ne '/';
 248   my $filename =
 249   mkdir $ModuleDir unless -d $ModuleDir;
 250   my $dir = `/bin/pwd`;
 251   chop($dir);
 252   if (-l "$ModuleDir/$mod") {
 253     # do nothing
 254   } elsif (eval{ symlink("$dir/modules/$subdir$mod", "$ModuleDir/$mod"); 1; }) {
 255     # do nothing
 256   } else {
 257     system("copy '$dir/modules/$subdir$mod' '$ModuleDir/$mod'");
 258   }
 259   die "Cannot symlink $mod: $!" unless -e "$ModuleDir/$mod";
 260   do "$ModuleDir/$mod";
 261   @MyRules = sort {$RuleOrder{$a} <=> $RuleOrder{$b}} @MyRules;
 262 }
 263
 264 sub remove_module {
 265   my $mod = shift;
 266   mkdir $ModuleDir unless -d $ModuleDir;
 267   unlink("$ModuleDir/$mod") or die "Cannot unlink: $!";
 268 }
 269
 270 sub clear_pages {
 271   if (-f "/bin/rm") {
 272     system("/bin/rm -rf $DataDir");
 273   } else {
 274     system("c:/cygwin/bin/rm.exe -rf $DataDir");
 275   }
 276   die "Cannot remove $DataDir!\n" if -e $DataDir;
 277   mkdir $DataDir;
 278   add_module('mac.pl') if $^O eq 'darwin'; # guessing HFS filesystem
 279   open(F, '>:encoding(utf-8)', "$DataDir/config");
 280   print F "\$AdminPass = 'foo';\n";
 281   # this used to be the default in earlier CGI.pm versions
 282   print F "\$ScriptName = 'http://localhost/wiki.pl';\n";
 283   print F "\$SurgeProtection = 0;\n";
 284   close(F);
 285   $ScriptName = 'http://localhost/test.pl'; # different!
 286   $IndexInit = 0;
 287   %IndexHash = ();
 288   @IndexList = ();
 289   $InterSiteInit = 0;
 290   %InterSite = ();
 291   $NearSiteInit = 0;
 292   %NearSite = ();
 293   %NearSearch = ();
 294 }
 295
 296 1;