Commit | Line | Data |
---|---|---|
d4345e37 BG |
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; | |
3d7c117d | 13 | require './t/test.pl'; |
d4345e37 | 14 | |
5c7a8c6e FC |
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: $!"; | |
d4345e37 BG |
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 | ||
5c7a8c6e FC |
25 | open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!"); |
26 | ||
d4345e37 BG |
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) { | |
f5b27708 KW |
55 | local $::TODO; |
56 | $::TODO = "Unicode::Collate not working on EBCDIC" if $::IS_EBCDIC || $::IS_EBCDIC; | |
d4345e37 BG |
57 | ok(eq_array(\@current_order, \@sorted_order), "Files are referenced in order") or |
58 | print_right_order(); | |
59 | } | |
60 | else { | |
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. | |
65 | sub 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 | ||
82 | done_testing(); |