This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
don't mess with the umask()
[perl5.git] / lib / ExtUtils / Manifest.pm
1 package ExtUtils::Manifest;
2
3 require Exporter;
4 use Config;
5 use File::Find;
6 use File::Copy 'copy';
7 use Carp;
8 use strict;
9
10 use vars qw($VERSION @ISA @EXPORT_OK
11             $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found);
12
13 $VERSION = substr(q$Revision: 1.33 $, 10);
14 @ISA=('Exporter');
15 @EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck', 
16               'skipcheck', 'maniread', 'manicopy');
17
18 $Is_VMS = $^O eq 'VMS';
19 if ($Is_VMS) { require File::Basename }
20
21 $Debug = 0;
22 $Verbose = 1;
23 $Quiet = 0;
24 $MANIFEST = 'MANIFEST';
25
26 # Really cool fix from Ilya :)
27 unless (defined $Config{d_link}) {
28     local $^W;
29     *ln = \&cp;
30 }
31
32 sub mkmanifest {
33     my $manimiss = 0;
34     my $read = maniread() or $manimiss++;
35     $read = {} if $manimiss;
36     local *M;
37     rename $MANIFEST, "$MANIFEST.bak" unless $manimiss;
38     open M, ">$MANIFEST" or die "Could not open $MANIFEST: $!";
39     my $matches = _maniskip();
40     my $found = manifind();
41     my($key,$val,$file,%all);
42     %all = (%$found, %$read);
43     $all{$MANIFEST} = ($Is_VMS ? "$MANIFEST\t\t" : '') . 'This list of files'
44         if $manimiss; # add new MANIFEST to known file list
45     foreach $file (sort keys %all) {
46         next if &$matches($file);
47         if ($Verbose){
48             warn "Added to $MANIFEST: $file\n" unless exists $read->{$file};
49         }
50         my $text = $all{$file};
51         ($file,$text) = split(/\s+/,$text,2) if $Is_VMS && $text;
52         my $tabs = (5 - (length($file)+1)/8);
53         $tabs = 1 if $tabs < 1;
54         $tabs = 0 unless $text;
55         print M $file, "\t" x $tabs, $text, "\n";
56     }
57     close M;
58 }
59
60 sub manifind {
61     local $found = {};
62     find(sub {return if -d $_;
63               (my $name = $File::Find::name) =~ s|./||;
64               warn "Debug: diskfile $name\n" if $Debug;
65               $name  =~ s#(.*)\.$#\L$1# if $Is_VMS;
66               $found->{$name} = "";}, ".");
67     $found;
68 }
69
70 sub fullcheck {
71     _manicheck(3);
72 }
73
74 sub manicheck {
75     return @{(_manicheck(1))[0]};
76 }
77
78 sub filecheck {
79     return @{(_manicheck(2))[1]};
80 }
81
82 sub skipcheck {
83     _manicheck(6);
84 }
85
86 sub _manicheck {
87     my($arg) = @_;
88     my $read = maniread();
89     my $found = manifind();
90     my $file;
91     my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0);
92     my(@missfile,@missentry);
93     if ($arg & 1){
94         foreach $file (sort keys %$read){
95             warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug;
96             if ($dosnames){
97                 $file = lc $file;
98                 $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge;
99                 $file =~ s=((\w|-)+)=substr ($1,0,8)=ge;
100             }
101             unless ( exists $found->{$file} ) {
102                 warn "No such file: $file\n" unless $Quiet;
103                 push @missfile, $file;
104             }
105         }
106     }
107     if ($arg & 2){
108         $read ||= {};
109         my $matches = _maniskip();
110         my $skipwarn = $arg & 4;
111         foreach $file (sort keys %$found){
112             if (&$matches($file)){
113                 warn "Skipping $file\n" if $skipwarn;
114                 next;
115             }
116             warn "Debug: manicheck checking from disk $file\n" if $Debug;
117             unless ( exists $read->{$file} ) {
118                 warn "Not in $MANIFEST: $file\n" unless $Quiet;
119                 push @missentry, $file;
120             }
121         }
122     }
123     (\@missfile,\@missentry);
124 }
125
126 sub maniread {
127     my ($mfile) = @_;
128     $mfile ||= $MANIFEST;
129     my $read = {};
130     local *M;
131     unless (open M, $mfile){
132         warn "$mfile: $!";
133         return $read;
134     }
135     while (<M>){
136         chomp;
137         next if /^#/;
138         if ($Is_VMS) {
139             my($file)= /^(\S+)/;
140             next unless $file;
141             my($base,$dir) = File::Basename::fileparse($file);
142             # Resolve illegal file specifications in the same way as tar
143             $dir =~ tr/./_/;
144             my(@pieces) = split(/\./,$base);
145             if (@pieces > 2) { $base = shift(@pieces) . '.' . join('_',@pieces); }
146             my $okfile = "$dir$base";
147             warn "Debug: Illegal name $file changed to $okfile\n" if $Debug;
148             $read->{"\L$okfile"}=$_;
149         }
150         else { /^(\S+)\s*(.*)/ and $read->{$1}=$2; }
151     }
152     close M;
153     $read;
154 }
155
156 # returns an anonymous sub that decides if an argument matches
157 sub _maniskip {
158     my ($mfile) = @_;
159     my $matches = sub {0};
160     my @skip ;
161     $mfile ||= "$MANIFEST.SKIP";
162     local *M;
163     return $matches unless -f $mfile;
164     open M, $mfile or return $matches;
165     while (<M>){
166         chomp;
167         next if /^#/;
168         next if /^\s*$/;
169         push @skip, $_;
170     }
171     close M;
172     my $opts = $Is_VMS ? 'oi ' : 'o ';
173     my $sub = "\$matches = "
174         . "sub { my(\$arg)=\@_; return 1 if "
175         . join (" || ",  (map {s!/!\\/!g; "\$arg =~ m/$_/$opts"} @skip), 0)
176         . " }";
177     eval $sub;
178     print "Debug: $sub\n" if $Debug;
179     $matches;
180 }
181
182 sub manicopy {
183     my($read,$target,$how)=@_;
184     croak "manicopy() called without target argument" unless defined $target;
185     $how ||= 'cp';
186     require File::Path;
187     require File::Basename;
188     my(%dirs,$file);
189     $target = VMS::Filespec::unixify($target) if $Is_VMS;
190     File::Path::mkpath([ $target ],1,$Is_VMS ? undef : 0755);
191     foreach $file (keys %$read){
192         $file = VMS::Filespec::unixify($file) if $Is_VMS;
193         if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not?
194             my $dir = File::Basename::dirname($file);
195             $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
196             File::Path::mkpath(["$target/$dir"],1,$Is_VMS ? undef : 0755);
197         }
198         cp_if_diff($file, "$target/$file", $how);
199     }
200 }
201
202 sub cp_if_diff {
203     my($from, $to, $how)=@_;
204     -f $from or carp "$0: $from not found";
205     my($diff) = 0;
206     local(*F,*T);
207     open(F,$from) or croak "Can't read $from: $!\n";
208     if (open(T,$to)) {
209         while (<F>) { $diff++,last if $_ ne <T>; }
210         $diff++ unless eof(T);
211         close T;
212     }
213     else { $diff++; }
214     close F;
215     if ($diff) {
216         if (-e $to) {
217             unlink($to) or confess "unlink $to: $!";
218         }
219       STRICT_SWITCH: {
220             best($from,$to), last STRICT_SWITCH if $how eq 'best';
221             cp($from,$to), last STRICT_SWITCH if $how eq 'cp';
222             ln($from,$to), last STRICT_SWITCH if $how eq 'ln';
223             croak("ExtUtils::Manifest::cp_if_diff " .
224                   "called with illegal how argument [$how]. " .
225                   "Legal values are 'best', 'cp', and 'ln'.");
226         }
227     }
228 }
229
230 sub cp {
231     my ($srcFile, $dstFile) = @_;
232     my ($perm,$access,$mod) = (stat $srcFile)[2,8,9];
233     copy($srcFile,$dstFile);
234     utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile;
235     # chmod a+rX-w,go-w
236     chmod(  0444 | ( $perm & 0111 ? 0111 : 0 ),  $dstFile );
237 }
238
239 sub ln {
240     my ($srcFile, $dstFile) = @_;
241     return &cp if $Is_VMS;
242     link($srcFile, $dstFile);
243     local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x)
244     my $mode= 0444 | (stat)[2] & 0700;
245     if (! chmod(  $mode | ( $mode & 0100 ? 0111 : 0 ),  $_  )) {
246        unlink $dstFile;
247        return;
248     }
249     1;
250 }
251
252 sub best {
253     my ($srcFile, $dstFile) = @_;
254     if (-l $srcFile) {
255         cp($srcFile, $dstFile);
256     } else {
257         ln($srcFile, $dstFile) or cp($srcFile, $dstFile);
258     }
259 }
260
261 1;
262
263 __END__
264
265 =head1 NAME
266
267 ExtUtils::Manifest - utilities to write and check a MANIFEST file
268
269 =head1 SYNOPSIS
270
271     require ExtUtils::Manifest;
272
273     ExtUtils::Manifest::mkmanifest;
274
275     ExtUtils::Manifest::manicheck;
276
277     ExtUtils::Manifest::filecheck;
278
279     ExtUtils::Manifest::fullcheck;
280
281     ExtUtils::Manifest::skipcheck;
282
283     ExtUtils::Manifest::manifind();
284
285     ExtUtils::Manifest::maniread($file);
286
287     ExtUtils::Manifest::manicopy($read,$target,$how);
288
289 =head1 DESCRIPTION
290
291 mkmanifest() writes all files in and below the current directory to a
292 file named in the global variable $ExtUtils::Manifest::MANIFEST (which
293 defaults to C<MANIFEST>) in the current directory. It works similar to
294
295     find . -print
296
297 but in doing so checks each line in an existing C<MANIFEST> file and
298 includes any comments that are found in the existing C<MANIFEST> file
299 in the new one. Anything between white space and an end of line within
300 a C<MANIFEST> file is considered to be a comment. Filenames and
301 comments are separated by one or more TAB characters in the
302 output. All files that match any regular expression in a file
303 C<MANIFEST.SKIP> (if such a file exists) are ignored.
304
305 manicheck() checks if all the files within a C<MANIFEST> in the
306 current directory really do exist. It only reports discrepancies and
307 exits silently if MANIFEST and the tree below the current directory
308 are in sync.
309
310 filecheck() finds files below the current directory that are not
311 mentioned in the C<MANIFEST> file. An optional file C<MANIFEST.SKIP>
312 will be consulted. Any file matching a regular expression in such a
313 file will not be reported as missing in the C<MANIFEST> file.
314
315 fullcheck() does both a manicheck() and a filecheck().
316
317 skipcheck() lists all the files that are skipped due to your
318 C<MANIFEST.SKIP> file.
319
320 manifind() returns a hash reference. The keys of the hash are the
321 files found below the current directory.
322
323 maniread($file) reads a named C<MANIFEST> file (defaults to
324 C<MANIFEST> in the current directory) and returns a HASH reference
325 with files being the keys and comments being the values of the HASH.
326 Blank lines and lines which start with C<#> in the C<MANIFEST> file
327 are discarded.
328
329 C<manicopy($read,$target,$how)> copies the files that are the keys in
330 the HASH I<%$read> to the named target directory. The HASH reference
331 $read is typically returned by the maniread() function. This
332 function is useful for producing a directory tree identical to the
333 intended distribution tree. The third parameter $how can be used to
334 specify a different methods of "copying". Valid values are C<cp>,
335 which actually copies the files, C<ln> which creates hard links, and
336 C<best> which mostly links the files but copies any symbolic link to
337 make a tree without any symbolic link. Best is the default.
338
339 =head1 MANIFEST.SKIP
340
341 The file MANIFEST.SKIP may contain regular expressions of files that
342 should be ignored by mkmanifest() and filecheck(). The regular
343 expressions should appear one on each line. Blank lines and lines
344 which start with C<#> are skipped.  Use C<\#> if you need a regular
345 expression to start with a sharp character. A typical example:
346
347     \bRCS\b
348     ^MANIFEST\.
349     ^Makefile$
350     ~$
351     \.html$
352     \.old$
353     ^blib/
354     ^MakeMaker-\d
355
356 =head1 EXPORT_OK
357
358 C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>,
359 C<&maniread>, and C<&manicopy> are exportable.
360
361 =head1 GLOBAL VARIABLES
362
363 C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it
364 results in both a different C<MANIFEST> and a different
365 C<MANIFEST.SKIP> file. This is useful if you want to maintain
366 different distributions for different audiences (say a user version
367 and a developer version including RCS).
368
369 C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
370 all functions act silently.
371
372 =head1 DIAGNOSTICS
373
374 All diagnostic output is sent to C<STDERR>.
375
376 =over
377
378 =item C<Not in MANIFEST:> I<file>
379
380 is reported if a file is found, that is missing in the C<MANIFEST>
381 file which is excluded by a regular expression in the file
382 C<MANIFEST.SKIP>.
383
384 =item C<No such file:> I<file>
385
386 is reported if a file mentioned in a C<MANIFEST> file does not
387 exist.
388
389 =item C<MANIFEST:> I<$!>
390
391 is reported if C<MANIFEST> could not be opened.
392
393 =item C<Added to MANIFEST:> I<file>
394
395 is reported by mkmanifest() if $Verbose is set and a file is added
396 to MANIFEST. $Verbose is set to 1 by default.
397
398 =back
399
400 =head1 SEE ALSO
401
402 L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.
403
404 =head1 AUTHOR
405
406 Andreas Koenig <F<koenig@franz.ww.TU-Berlin.DE>>
407
408 =cut