perl/regen/lib_cleanup.pl

#!perl -w
use strict;
require 'regen/regen_lib.pl';
require 'Porting/pod_lib.pl';
use vars qw($TAP $Verbose);

# For processing later
my @ext;
# Lookup hash of all directories in lib/ in a clean distribution
my %libdirs;

open my $fh, '<', 'MANIFEST'
    or die "Can't open MANIFEST: $!";

while (<$fh>) {
    if (m<^((?:cpan|dist|ext)/[^/]+/              # In an extension directory
           (?!t/|private/|corpus/|demo/|testdir/) # but not a test or similar
           \S+                                    # filename characters
           (?:\.pm|\.pod|_pm\.PL|_pod\.PL|\.yml)) # useful ending
           (?:\s|$)                               # whitespace or end of line
          >x) {
        push @ext, $1;
    } elsif (m!^lib/([^ \t\n]+)/[^/ \t\n]+!) {
        # All we are interested in are shipped directories in lib/
        # leafnames (and package names) are actually irrelevant.
        my $dirs = $1;
        do {
            # lib/Pod/t is in MANIFEST, but lib/Pod is not. Rather than
            # special-casing this, generalise the code to ensure that all
            # parent directories of anything add are also added:
            ++$libdirs{$dirs}
        } while ($dirs =~ s!/.*!!);
    }
}

close $fh
    or die "Can't close MANIFEST: $!";

# Lines we need in lib/.gitignore
my %ignore;
# Directories that the Makfiles should remove
# With a special case already :-(
my %rmdir_s = my %rmdir = ('Unicode/Collate/Locale' => 1);

FILE:
foreach my $file (@ext) {
    my ($extname, $path) = $file =~ m!^(?:cpan|dist|ext)/([^/]+)/(.*)!
        or die "Can't parse '$file'";

    if ($path =~ /\.yml$/) {
	next unless $path =~ s!^lib/!!;
    } elsif ($path =~ /\.pod$/) {
        unless ($path =~ s!^lib/!!) {
            # ExtUtils::MakeMaker will install it to a path based on the
            # extension name:
            if ($extname =~ s!-[^-]+$!!) {
                $extname =~ tr!-!/!;
                $path = "$extname/$path";
            }
        }
    } elsif ($extname eq 'Unicode-Collate'  # Trust the package lines
             || $extname eq 'Encode'        # Trust the package lines
             || $path eq 'win32/Win32.pm'   # Trust the package line
             || ($path !~ tr!/!!            # No path
                 && $path ne 'DB_File.pm'   # ... but has multiple package lines
                )) {
        # Too many special cases to encode, so just open the file and figure it
        # out:
        my $package;
        open my $fh, '<', $file
            or die "Can't open $file: $!";
        while (<$fh>) {
            if (/^\s*package\s+([A-Za-z0-9_:]+)/) {
                $package = $1;
                last;
            }
            elsif (/^\s*package\s*$/) {
                # If they're hiding their package name, we ignore them
                ++$ignore{"/$path"};
                $package='';
                last;
            }
        }
        close $fh
            or die "Can't close $file: $!";
        die "Can't locate package statement in $file"
            unless defined $package;
        $package =~ s!::!/!g;
        $path = "$package.pm";
    } else {
        if ($path =~ s/\.PL$//) {
            # .PL files generate other files. By convention the output filename
            # has the .PL stripped, and any preceding _ changed to ., to comply
            # with historical VMS filename rules that only permit one .
            $path =~ s!_([^_/]+)$!.$1!;
        }
        $path =~ s!^lib/!!;
    }
    my @parts = split '/', $path;
    my $prefix = shift @parts;
    while (@parts) {
        if (!$libdirs{$prefix}) {
            # It is a directory that we will create. Ignore everything in it:
            ++$ignore{"/$prefix/"};
            ++$rmdir{$prefix};
            ++$rmdir_s{$prefix};
            pop @parts;
            while (@parts) {
                $prefix .= '/' . shift @parts;
                ++$rmdir{$prefix};
            }
            next FILE;
        }
        $prefix .= '/' . shift @parts;
        # If we've just shifted the leafname back onto $prefix, then @parts is
        # empty, so we should terminate this loop.
    }
    # We are creating a file in an existing directory. We must ignore the file
    # explicitly:
    ++$ignore{"/$path"};
}

sub edit_makefile_SH {
    my ($desc, $contents) = @_;
    my $start_re = qr/(\trm -f so_locations[^\n]+)/;
    my ($start) = $contents =~ $start_re;
    $contents = verify_contiguous($desc, $contents,
                                  qr/$start_re\n(?:\t-rmdir [^\n]+\n)+/sm,
                                  'lib directory rmdir rules');
    # Reverse sort ensures that any subdirectories are deleted first.
    # The extensions themselves delete files with the MakeMaker generated clean
    # targets.
    $contents =~ s{\0}
                  {"$start\n"
                   . wrap(79, "\t-rmdir ", "\t-rmdir ",
                          map {"lib/$_"} reverse sort keys %rmdir)
                   . "\n"}e;
    $contents;
}

sub edit_win32_makefile {
    my ($desc, $contents) = @_;
    my $start = "\t-del /f *.def *.map";
    my $start_re = quotemeta($start);
    $contents = verify_contiguous($desc, $contents,
                                  qr!$start_re\n(?:\t-if exist (\$\(LIBDIR\)\\\S+) rmdir /s /q \1\n)+!sm,
                                  'Win32 lib directory rmdir rules');
    # Win32 is (currently) using rmdir /s /q which deletes recursively
    # (seems to be analogous to rm -r) so we don't explicitly list
    # subdirectories to delete, and don't need to ensure that subdirectories are
    # deleted before their parents.
    # Might be able to rely on MakeMaker generated clean targets to clean
    # everything, but not in a position to test this.
    my $lines = join '', map {
        tr!/!\\!;
        "\t-if exist \$(LIBDIR)\\$_ rmdir /s /q \$(LIBDIR)\\$_\n"
    } sort {lc $a cmp lc $b} keys %rmdir_s;
    $contents =~ s/\0/$start\n$lines/;
    $contents;
}

process('Makefile.SH', 'Makefile.SH', \&edit_makefile_SH, $TAP && '', $Verbose);
foreach ('win32/Makefile', 'win32/makefile.mk') {
    process($_, $_, \&edit_win32_makefile, $TAP && '', $Verbose);
}

# This must come last as it can exit early:
if ($TAP && !-d '.git' && !-f 'lib/.gitignore') {
    print "ok # skip not being run from a git checkout, hence no lib/.gitignore\n";
    exit 0;
}

$fh = open_new('lib/.gitignore', '>',
               { by => $0,
                 from => 'MANIFEST and parsing files in cpan/ dist/ and ext/'});

print $fh <<"EOT";
# If this generated file has problems, it may be simpler to add more special
# cases to the top level .gitignore than to code one-off logic into the
# generation script $0

EOT

print $fh "$_\n" foreach sort keys %ignore;

read_only_bottom_close_and_rename($fh);