1#!perl -w
2use strict;
3require './regen/regen_lib.pl';
4require './Porting/pod_lib.pl';
5our ($TAP, $Verbose);
6
7# For processing later
8my @ext;
9# Lookup hash of all directories in lib/ in a clean distribution
10my %libdirs;
11
12open my $fh, '<', 'MANIFEST'
13    or die "Can't open MANIFEST: $!";
14
15while (<$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
36close $fh
37    or die "Can't close MANIFEST: $!";
38
39# Lines we need in lib/.gitignore
40my %ignore;
41# Directories that the Makfiles should remove
42# With a special case already :-(
43my %rmdir_s = my %rmdir = ('Unicode/Collate/Locale' => 1);
44
45FILE:
46foreach 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            elsif (/^\s*package\s*$/) {
78                # If they're hiding their package name, we ignore them
79                ++$ignore{"/$path"};
80                $package='';
81                last;
82            }
83        }
84        close $fh
85            or die "Can't close $file: $!";
86        die "Can't locate package statement in $file"
87            unless defined $package;
88        $package =~ s!::!/!g;
89        $path = "$package.pm";
90    } else {
91        if ($path =~ s/\.PL$//) {
92            # .PL files generate other files. By convention the output filename
93            # has the .PL stripped, and any preceding _ changed to ., to comply
94            # with historical VMS filename rules that only permit one .
95            $path =~ s!_([^_/]+)$!.$1!;
96        }
97        $path =~ s!^lib/!!;
98    }
99    my @parts = split '/', $path;
100    my $prefix = shift @parts;
101    while (@parts) {
102        if (!$libdirs{$prefix}) {
103            # It is a directory that we will create. Ignore everything in it:
104            ++$ignore{"/$prefix/"};
105            ++$rmdir{$prefix};
106            ++$rmdir_s{$prefix};
107            pop @parts;
108            while (@parts) {
109                $prefix .= '/' . shift @parts;
110                ++$rmdir{$prefix};
111            }
112            next FILE;
113        }
114        $prefix .= '/' . shift @parts;
115        # If we've just shifted the leafname back onto $prefix, then @parts is
116        # empty, so we should terminate this loop.
117    }
118    # We are creating a file in an existing directory. We must ignore the file
119    # explicitly:
120    ++$ignore{"/$path"};
121}
122
123sub edit_makefile_SH {
124    my ($desc, $contents) = @_;
125    my $start_re = qr/(\trm -f so_locations[^\n]+)/;
126    my ($start) = $contents =~ $start_re;
127    $contents = verify_contiguous($desc, $contents,
128                                  qr/$start_re\n(?:\t-rmdir [^\n]+\n)+/sm,
129                                  'lib directory rmdir rules');
130    # Reverse sort ensures that any subdirectories are deleted first.
131    # The extensions themselves delete files with the MakeMaker generated clean
132    # targets.
133    $contents =~ s{\0}
134                  {"$start\n"
135                   . wrap(79, "\t-rmdir ", "\t-rmdir ",
136                          map {"lib/$_"} reverse sort keys %rmdir)
137                   . "\n"}e;
138    $contents;
139}
140
141sub edit_win32_makefile {
142    my ($desc, $contents) = @_;
143    my $start = "\t-del /f *.def *.map";
144    my $start_re = quotemeta($start);
145    $contents = verify_contiguous($desc, $contents,
146                                  qr!$start_re\n(?:\t-if exist (\$\(LIBDIR\)\\\S+) rmdir /s /q \1\n)+!sm,
147                                  'Win32 lib directory rmdir rules');
148    # Win32 is (currently) using rmdir /s /q which deletes recursively
149    # (seems to be analogous to rm -r) so we don't explicitly list
150    # subdirectories to delete, and don't need to ensure that subdirectories are
151    # deleted before their parents.
152    # Might be able to rely on MakeMaker generated clean targets to clean
153    # everything, but not in a position to test this.
154    my $lines = join '', map {
155        tr!/!\\!;
156        "\t-if exist \$(LIBDIR)\\$_ rmdir /s /q \$(LIBDIR)\\$_\n"
157    } sort {lc $a cmp lc $b} keys %rmdir_s;
158    $contents =~ s/\0/$start\n$lines/;
159    $contents;
160}
161
162process('Makefile.SH', 'Makefile.SH', \&edit_makefile_SH, $TAP && '', $Verbose);
163foreach ('win32/Makefile', 'win32/GNUmakefile') {
164    process($_, $_, \&edit_win32_makefile, $TAP && '', $Verbose);
165}
166
167# This must come last as it can exit early:
168if ($TAP && !-d '.git' && !-f 'lib/.gitignore') {
169    print "ok # skip not being run from a git checkout, hence no lib/.gitignore\n";
170    exit 0;
171}
172
173if ($ENV{'PERL_BUILD_PACKAGING'}) {
174    print "ok # skip explicitly disabled git tests by PERL_BUILD_PACKAGING\n";
175    exit 0;
176}
177
178$fh = open_new('lib/.gitignore', '>',
179               { by => $0,
180                 from => 'MANIFEST and parsing files in cpan/ dist/ and ext/'});
181
182print $fh <<"EOT";
183# If this generated file has problems, it may be simpler to add more special
184# cases to the top level .gitignore than to code one-off logic into the
185# generation script $0
186
187EOT
188
189print $fh "$_\n" foreach sort keys %ignore;
190
191read_only_bottom_close_and_rename($fh);
192