Add Ken Brown to AUTHORS
[perl.git] / regen / lib_cleanup.pl
1 #!perl -w
2 use strict;
3 require './regen/regen_lib.pl';
4 require './Porting/pod_lib.pl';
5 use vars qw($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') {
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 $fh = open_new('lib/.gitignore', '>',
168                { by => $0,
169                  from => 'MANIFEST and parsing files in cpan/ dist/ and ext/'});
170
171 print $fh <<"EOT";
172 # If this generated file has problems, it may be simpler to add more special
173 # cases to the top level .gitignore than to code one-off logic into the
174 # generation script $0
175
176 EOT
177
178 print $fh "$_\n" foreach sort keys %ignore;
179
180 read_only_bottom_close_and_rename($fh);