"Fossies" - the Fresh Open Source Software Archive

Member "perl-5.32.1/t/porting/readme.t" (18 Dec 2020, 2487 Bytes) of package /linux/misc/perl-5.32.1.tar.xz:

    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;
   13 require './t/test.pl';
   14 
   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: $!";
   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 
   25 open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!");
   26 
   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) {
   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 }
   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();