Mercurial > repo
comparison perl-5.22.2/regen/lib_cleanup.pl @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
8044:711c038a7dce | 8045:a16537d2fe07 |
---|---|
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); |