regen/lib_cleanup.pl

   1 #!perl -w
   2 use strict;
   3 require './regen/regen_lib.pl';
   4 require './Porting/pod_lib.pl';
   5 our ($TAP, $Verbose);
   6
   7 # For processing later
   8 my @ext;
   9 # Lookup hash of all directories in lib/ in a clean distribution
  10 my %libdirs;
  11
  12 open my $fh, '<', 'MANIFEST'
  13     or die "Can't open MANIFEST: $!";
  14
  15 while (<$fh>) {
  16     if (m<^((?:cpan|dist|ext)/[^/]+/              # In an extension directory
  17            (?!t/|private/|corpus/|demo/|testdir/) # but not a test or similar
  18            \S+                                    # filename characters
  19            (?:\.pm|\.pod|_pm\.PL|_pod\.PL|\.yml)) # useful ending
  20            (?:\s|$)                               # whitespace or end of line
  21           >x) {
  22         push @ext, $1;
  23     } elsif (m!^lib/([^ \t\n]+)/[^/ \t\n]+!) {
  24         # All we are interested in are shipped directories in lib/
  25         # leafnames (and package names) are actually irrelevant.
  26         my $dirs = $1;
  27         do {
  28             # lib/Pod/t is in MANIFEST, but lib/Pod is not. Rather than
  29             # special-casing this, generalise the code to ensure that all
  30             # parent directories of anything add are also added:
  31             ++$libdirs{$dirs}
  32         } while ($dirs =~ s!/.*!!);
  33     }
  34 }
  35
  36 close $fh
  37     or die "Can't close MANIFEST: $!";
  38
  39 # Lines we need in lib/.gitignore
  40 my %ignore;
  41 # Directories that the Makfiles should remove
  42 # With a special case already :-(
  43 my %rmdir_s = my %rmdir = ('Unicode/Collate/Locale' => 1);
  44
  45 FILE:
  46 foreach my $file (@ext) {
  47     my ($extname, $path) = $file =~ m!^(?:cpan|dist|ext)/([^/]+)/(.*)!
  48         or die "Can't parse '$file'";
  49
  50     if ($path =~ /\.yml$/) {
  51         next unless $path =~ s!^lib/!!;
  52     } elsif ($path =~ /\.pod$/) {
  53         unless ($path =~ s!^lib/!!) {
  54             # ExtUtils::MakeMaker will install it to a path based on the
  55             # extension name:
  56             if ($extname =~ s!-[^-]+$!!) {
  57                 $extname =~ tr!-!/!;
  58                 $path = "$extname/$path";
  59             }
  60         }
  61     } elsif ($extname eq 'Unicode-Collate'  # Trust the package lines
  62              || $extname eq 'Encode'        # Trust the package lines
  63              || $path eq 'win32/Win32.pm'   # Trust the package line
  64              || ($path !~ tr!/!!            # No path
  65                  && $path ne 'DB_File.pm'   # ... but has multiple package lines
  66                 )) {
  67         # Too many special cases to encode, so just open the file and figure it
  68         # out:
  69         my $package;
  70         open my $fh, '<', $file
  71             or die "Can't open $file: $!";
  72         while (<$fh>) {
  73             if (/^\s*package\s+([A-Za-z0-9_:]+)/) {
  74                 $package = $1;
  75                 last;
  76             }
  77         }
  78         close $fh
  79             or die "Can't close $file: $!";
  80         die "Can't locate package statement in $file"
  81             unless defined $package;
  82         $package =~ s!::!/!g;
  83         $path = "$package.pm";
  84     } else {
  85         if ($path =~ s/\.PL$//) {
  86             # .PL files generate other files. By convention the output filename
  87             # has the .PL stripped, and any preceding _ changed to ., to comply
  88             # with historical VMS filename rules that only permit one .
  89             $path =~ s!_([^_/]+)$!.$1!;
  90         }
  91         $path =~ s!^lib/!!;
  92     }
  93     my @parts = split '/', $path;
  94     my $prefix = shift @parts;
  95     while (@parts) {
  96         if (!$libdirs{$prefix}) {
  97             # It is a directory that we will create. Ignore everything in it:
  98             ++$ignore{"/$prefix/"};
  99             ++$rmdir{$prefix};
 100             ++$rmdir_s{$prefix};
 101             pop @parts;
 102             while (@parts) {
 103                 $prefix .= '/' . shift @parts;
 104                 ++$rmdir{$prefix};
 105             }
 106             next FILE;
 107         }
 108         $prefix .= '/' . shift @parts;
 109         # If we've just shifted the leafname back onto $prefix, then @parts is
 110         # empty, so we should terminate this loop.
 111     }
 112     # We are creating a file in an existing directory. We must ignore the file
 113     # explicitly:
 114     ++$ignore{"/$path"};
 115 }
 116
 117 sub edit_makefile_SH {
 118     my ($desc, $contents) = @_;
 119     my $start_re = qr/(\trm -f so_locations[^\n]+)/;
 120     my ($start) = $contents =~ $start_re;
 121     $contents = verify_contiguous($desc, $contents,
 122                                   qr/$start_re\n(?:\t-rmdir [^\n]+\n)+/sm,
 123                                   'lib directory rmdir rules');
 124     # Reverse sort ensures that any subdirectories are deleted first.
 125     # The extensions themselves delete files with the MakeMaker generated clean
 126     # targets.
 127     $contents =~ s{\0}
 128                   {"$start\n"
 129                    . wrap(79, "\t-rmdir ", "\t-rmdir ",
 130                           map {"lib/$_"} reverse sort keys %rmdir)
 131                    . "\n"}e;
 132     $contents;
 133 }
 134
 135 sub edit_win32_makefile {
 136     my ($desc, $contents) = @_;
 137     my $start = "\t-del /f *.def *.map";
 138     my $start_re = quotemeta($start);
 139     $contents = verify_contiguous($desc, $contents,
 140                                   qr!$start_re\n(?:\t-if exist (\$\(LIBDIR\)\\\S+) rmdir /s /q \1\n)+!sm,
 141                                   'Win32 lib directory rmdir rules');
 142     # Win32 is (currently) using rmdir /s /q which deletes recursively
 143     # (seems to be analogous to rm -r) so we don't explicitly list
 144     # subdirectories to delete, and don't need to ensure that subdirectories are
 145     # deleted before their parents.
 146     # Might be able to rely on MakeMaker generated clean targets to clean
 147     # everything, but not in a position to test this.
 148     my $lines = join '', map {
 149         tr!/!\\!;
 150         "\t-if exist \$(LIBDIR)\\$_ rmdir /s /q \$(LIBDIR)\\$_\n"
 151     } sort {lc $a cmp lc $b} keys %rmdir_s;
 152     $contents =~ s/\0/$start\n$lines/;
 153     $contents;
 154 }
 155
 156 process('Makefile.SH', 'Makefile.SH', \&edit_makefile_SH, $TAP && '', $Verbose);
 157 foreach ('win32/Makefile', 'win32/makefile.mk', 'win32/GNUmakefile') {
 158     process($_, $_, \&edit_win32_makefile, $TAP && '', $Verbose);
 159 }
 160
 161 # This must come last as it can exit early:
 162 if ($TAP && !-d '.git' && !-f 'lib/.gitignore') {
 163     print "ok # skip not being run from a git checkout, hence no lib/.gitignore\n";
 164     exit 0;
 165 }
 166
 167 if ($ENV{'PERL_BUILD_PACKAGING'}) {
 168     print "ok # skip explicitly disabled git tests by PERL_BUILD_PACKAGING\n";
 169     exit 0;
 170 }
 171
 172 $fh = open_new('lib/.gitignore', '>',
 173                { by => $0,
 174                  from => 'MANIFEST and parsing files in cpan/ dist/ and ext/'});
 175
 176 print $fh <<"EOT";
 177 # If this generated file has problems, it may be simpler to add more special
 178 # cases to the top level .gitignore than to code one-off logic into the
 179 # generation script $0
 180
 181 EOT
 182
 183 print $fh "$_\n" foreach sort keys %ignore;
 184
 185 read_only_bottom_close_and_rename($fh);