t/porting/readme.t

   1 #!./perl -w
   2 #
   3 # Check whether all files mentioned in Porting/README.pod exist in Porting and
   4 # vice versa.
   5
   6 BEGIN {
   7     @INC = '..' if -f '../TestInit.pm';
   8 }
   9
  10 use TestInit qw(T); # T is chdir to the top level
  11 use strict;
  12 use warnings;
  13 require 't/test.pl';
  14
  15 open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!");
  16
  17 my @porting_files = glob("Porting/*");
  18 # It seems that dying here is nicer than having several dozen failing tests
  19 # later.  But that assumes one will see the message from die.
  20 die "Can't get contents of Porting/ directory.\n" unless @porting_files > 1;
  21
  22 my (@current_order, @sorted_order, %files_in_pod);
  23 while(<$fh>) {
  24     next unless $_ =~ /^=head/;
  25     my @matches = $_ =~ m/F<([^>]+)>/g;
  26     for my $file (@matches) {
  27         $files_in_pod{$file} = 1;
  28         push @current_order, $file;
  29     }
  30 }
  31
  32 for my $file (@porting_files) {
  33     $file =~ s!^Porting/!!;
  34     $file =~ s/\.\z// if $^O eq 'VMS';
  35     next if $file =~ /^perl[0-9]+delta\.pod$/;
  36     ok(exists($files_in_pod{$file}), "$file is mentioned in Porting/README.pod");
  37     delete $files_in_pod{$file};
  38 }
  39 for my $file (keys %files_in_pod) {
  40     fail("$file exists in Porting/");
  41 }
  42
  43 # Check if the entries in the README are in some sort of order.
  44 eval {
  45     require Unicode::Collate;
  46     my $Collator = Unicode::Collate->new();
  47     @sorted_order = $Collator->sort(@current_order);
  48 };
  49
  50 if(@sorted_order) {
  51     ok(eq_array(\@current_order, \@sorted_order), "Files are referenced in order") or
  52         print_right_order();
  53 }
  54 else {
  55     note('Unicode collation did not work.  Not checking order of entries.');
  56 }
  57
  58 # Frankly this is a bit much for a porting test, but it exists now.
  59 sub print_right_order {
  60     my $max = 0;
  61     for(@current_order) {
  62         my $l = length $_;
  63         $max = $l if $l > $max;
  64     }
  65     $max = 36 if $max > 36;
  66     note(sprintf " N   %-${max}s %-${max}s\n", "Correct", "Current");
  67     for(0..$#current_order) {
  68         my $wrong = $sorted_order[$_] eq $current_order[$_] ? '' : 'X';
  69         my $line = sprintf "%2d %1s %-${max}s %-${max}s\n",
  70             $_, $wrong, $sorted_order[$_], $current_order[$_];
  71         $line =~ s{ ((?:  ){2,})}{" " . ". " x (length($1)/2)}e if $_&1;
  72         note($line);
  73     }
  74 }
  75
  76 done_testing();