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 ok(eq_array(\@current_order, \@sorted_order), "Files are referenced in order") or 56 print_right_order(); 57} 58else { 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. 63sub 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 80done_testing(); 81