1#!./perl -w 2# 3# Check whether all files mentioned in Porting/README.pod exist in Porting and 4# vice versa. 5 6BEGIN { 7 @INC = '..' if -f '../TestInit.pm'; 8} 9 10use TestInit qw(T); # T is chdir to the top level 11use strict; 12use warnings; 13require './t/test.pl'; 14 15my @porting_files; 16open my $man, "MANIFEST" or die "Can't open MANIFEST: $!"; 17while(<$man>) { 18 /^Porting\// and s/[\t\n].*//s, push @porting_files, $_; 19} 20close $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. 23die "Can't get contents of Porting/ directory.\n" unless @porting_files > 1; 24 25open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!"); 26 27my (@current_order, @sorted_order, %files_in_pod); 28while(<$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 37for 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} 43for 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. 48eval { 49 require Unicode::Collate; 50 my $Collator = Unicode::Collate->new(); 51 @sorted_order = $Collator->sort(@current_order); 52}; 53 54if(@sorted_order) { 55 local $::TODO; 56 $::TODO = "Unicode::Collate not working on EBCDIC" if $::IS_EBCDIC || $::IS_EBCDIC; 57 ok(eq_array(\@current_order, \@sorted_order), "Files are referenced in order") or 58 print_right_order(); 59} 60else { 61 note('Unicode collation did not work. Not checking order of entries.'); 62} 63 64# Frankly this is a bit much for a porting test, but it exists now. 65sub print_right_order { 66 my $max = 0; 67 for(@current_order) { 68 my $l = length $_; 69 $max = $l if $l > $max; 70 } 71 $max = 36 if $max > 36; 72 note(sprintf " N %-${max}s %-${max}s\n", "Correct", "Current"); 73 for(0..$#current_order) { 74 my $wrong = $sorted_order[$_] eq $current_order[$_] ? '' : 'X'; 75 my $line = sprintf "%2d %1s %-${max}s %-${max}s\n", 76 $_, $wrong, $sorted_order[$_], $current_order[$_]; 77 $line =~ s{ ((?: ){2,})}{" " . ". " x (length($1)/2)}e if $_&1; 78 note($line); 79 } 80} 81 82done_testing(); 83