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