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 15open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!"); 16 17my @porting_files = grep { !/~\z/ } 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. 20die "Can't get contents of Porting/ directory.\n" unless @porting_files > 1; 21 22my (@current_order, @sorted_order, %files_in_pod); 23while(<$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 32for 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} 39for 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. 44eval { 45 require Unicode::Collate; 46 my $Collator = Unicode::Collate->new(); 47 @sorted_order = $Collator->sort(@current_order); 48}; 49 50if(@sorted_order) { 51 ok(eq_array(\@current_order, \@sorted_order), "Files are referenced in order") or 52 print_right_order(); 53} 54else { 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. 59sub 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 76done_testing(); 77