This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Replace multiple 'use vars' by 'our' in regen.
[perl5.git] / regen / lib_cleanup.pl
CommitLineData
e275ec0e
NC
1#!perl -w
2use strict;
3d7c117d
MB
3require './regen/regen_lib.pl';
4require './Porting/pod_lib.pl';
e64a0c47 5our ($TAP, $Verbose);
e275ec0e
NC
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
727d4ce6 19 (?:\.pm|\.pod|_pm\.PL|_pod\.PL|\.yml)) # useful ending
e275ec0e
NC
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;
727d4ce6
NC
41# Directories that the Makfiles should remove
42# With a special case already :-(
7afc9753 43my %rmdir_s = my %rmdir = ('Unicode/Collate/Locale' => 1);
e275ec0e
NC
44
45FILE:
46foreach my $file (@ext) {
47 my ($extname, $path) = $file =~ m!^(?:cpan|dist|ext)/([^/]+)/(.*)!
48 or die "Can't parse '$file'";
49
727d4ce6
NC
50 if ($path =~ /\.yml$/) {
51 next unless $path =~ s!^lib/!!;
52 } elsif ($path =~ /\.pod$/) {
e275ec0e
NC
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/"};
7afc9753
NC
99 ++$rmdir{$prefix};
100 ++$rmdir_s{$prefix};
727d4ce6
NC
101 pop @parts;
102 while (@parts) {
103 $prefix .= '/' . shift @parts;
7afc9753 104 ++$rmdir{$prefix};
727d4ce6 105 }
e275ec0e
NC
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
727d4ce6
NC
117sub 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.
7afc9753
NC
125 # The extensions themselves delete files with the MakeMaker generated clean
126 # targets.
727d4ce6
NC
127 $contents =~ s{\0}
128 {"$start\n"
7afc9753
NC
129 . wrap(79, "\t-rmdir ", "\t-rmdir ",
130 map {"lib/$_"} reverse sort keys %rmdir)
727d4ce6
NC
131 . "\n"}e;
132 $contents;
133}
134
7afc9753
NC
135sub 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
727d4ce6 156process('Makefile.SH', 'Makefile.SH', \&edit_makefile_SH, $TAP && '', $Verbose);
7afc9753
NC
157foreach ('win32/Makefile', 'win32/makefile.mk') {
158 process($_, $_, \&edit_win32_makefile, $TAP && '', $Verbose);
159}
727d4ce6
NC
160
161# This must come last as it can exit early:
e275ec0e
NC
162if ($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
ba673321
DH
167if ($ENV{'PERL_BUILD_PACKAGING'}) {
168 print "ok # skip explicitly disabled git tests by PERL_BUILD_PACKAGING\n";
169 exit 0;
170}
171
e275ec0e
NC
172$fh = open_new('lib/.gitignore', '>',
173 { by => $0,
174 from => 'MANIFEST and parsing files in cpan/ dist/ and ext/'});
175
176print $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
181EOT
182
183print $fh "$_\n" foreach sort keys %ignore;
184
185read_only_bottom_close_and_rename($fh);