| 1 | #!perl -w |
| 2 | use strict; |
| 3 | require './regen/regen_lib.pl'; |
| 4 | require './Porting/pod_lib.pl'; |
| 5 | our ($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', 'win32/GNUmakefile') { |
| 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 | if ($ENV{'PERL_BUILD_PACKAGING'}) { |
| 168 | print "ok # skip explicitly disabled git tests by PERL_BUILD_PACKAGING\n"; |
| 169 | exit 0; |
| 170 | } |
| 171 | |
| 172 | $fh = open_new('lib/.gitignore', '>', |
| 173 | { by => $0, |
| 174 | from => 'MANIFEST and parsing files in cpan/ dist/ and ext/'}); |
| 175 | |
| 176 | print $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 | |
| 181 | EOT |
| 182 | |
| 183 | print $fh "$_\n" foreach sort keys %ignore; |
| 184 | |
| 185 | read_only_bottom_close_and_rename($fh); |