This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/porting/readme.t: TODO tests now passing on EBCDIC
[perl5.git] / 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 my @porting_files;
16 open my $man, "MANIFEST" or die "Can't open MANIFEST: $!";
17 while(<$man>) {
18     /^Porting\// and s/[\t\n].*//s, push @porting_files, $_;
19 }
20 close $man or die "Can't close MANIFEST: $!";
21 # It seems that dying here is nicer than having several dozen failing tests
22 # later.  But that assumes one will see the message from die.
23 die "Can't get contents of Porting/ directory.\n" unless @porting_files > 1;
24
25 open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!");
26
27 my (@current_order, @sorted_order, %files_in_pod);
28 while(<$fh>) {
29     next unless $_ =~ /^=head/;
30     my @matches = $_ =~ m/F<([^>]+)>/g;
31     for my $file (@matches) {
32         $files_in_pod{$file} = 1;
33         push @current_order, $file;
34     }
35 }
36
37 for my $file (@porting_files) {
38     $file =~ s!^Porting/!!;
39     next if $file =~ /^perl[0-9]+delta\.pod$/;
40     ok(exists($files_in_pod{$file}), "$file is mentioned in Porting/README.pod");
41     delete $files_in_pod{$file};
42 }
43 for my $file (keys %files_in_pod) {
44     fail("$file exists in Porting/");
45 }
46
47 # Check if the entries in the README are in some sort of order.
48 eval {
49     require Unicode::Collate;
50     my $Collator = Unicode::Collate->new();
51     @sorted_order = $Collator->sort(@current_order);
52 };
53
54 if(@sorted_order) {
55     ok(eq_array(\@current_order, \@sorted_order), "Files are referenced in order") or
56         print_right_order();
57 }
58 else {
59     note('Unicode collation did not work.  Not checking order of entries.');
60 }
61
62 # Frankly this is a bit much for a porting test, but it exists now.
63 sub print_right_order {
64     my $max = 0;
65     for(@current_order) {
66         my $l = length $_;
67         $max = $l if $l > $max;
68     }
69     $max = 36 if $max > 36;
70     note(sprintf " N   %-${max}s %-${max}s\n", "Correct", "Current");
71     for(0..$#current_order) {
72         my $wrong = $sorted_order[$_] eq $current_order[$_] ? '' : 'X';
73         my $line = sprintf "%2d %1s %-${max}s %-${max}s\n",
74             $_, $wrong, $sorted_order[$_], $current_order[$_];
75         $line =~ s{ ((?:  ){2,})}{" " . ". " x (length($1)/2)}e if $_&1;
76         note($line);
77     }
78 }
79
80 done_testing();