This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove "." from default @INC when default_inc_excludes_dot is set
[perl5.git] / t / porting / readme.t
CommitLineData
d4345e37
BG
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
5c7a8c6e
FC
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: $!";
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.
23die "Can't get contents of Porting/ directory.\n" unless @porting_files > 1;
24
5c7a8c6e
FC
25open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!");
26
d4345e37
BG
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) {
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}
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();