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.34 $, 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 = 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         if ($Is_MacOS) {
 146             my($item,$text) = /^(\S+)\s*(.*)/;
 147             $item = _macify($item);
 148             $item =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge;
 149             $read->{$item}=$text;
 150         }
 151         elsif ($Is_VMS) {
 152             my($file)= /^(\S+)/;
 153             next unless $file;
 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             $read->{"\L$okfile"}=$_;
 162         }
 163         else { /^(\S+)\s*(.*)/ and $read->{$1}=$2; }
 164     }
 165     close M;
 166     $read;
 167 }
 168
 169 # returns an anonymous sub that decides if an argument matches
 170 sub _maniskip {
 171     my ($mfile) = @_;
 172     my $matches = sub {0};
 173     my @skip ;
 174     $mfile ||= "$MANIFEST.SKIP";
 175     local *M;
 176     open M, $mfile or open M, $DEFAULT_MSKIP or return $matches;
 177     while (<M>){
 178         chomp;
 179         next if /^#/;
 180         next if /^\s*$/;
 181         push @skip, _macify($_);
 182     }
 183     close M;
 184     my $opts = $Is_VMS ? 'oi ' : 'o ';
 185     my $sub = "\$matches = "
 186         . "sub { my(\$arg)=\@_; return 1 if "
 187         . join (" || ",  (map {s!/!\\/!g; "\$arg =~ m/$_/$opts"} @skip), 0)
 188         . " }";
 189     eval $sub;
 190     print "Debug: $sub\n" if $Debug;
 191     $matches;
 192 }
 193
 194 sub manicopy {
 195     my($read,$target,$how)=@_;
 196     croak "manicopy() called without target argument" unless defined $target;
 197     $how ||= 'cp';
 198     require File::Path;
 199     require File::Basename;
 200     my(%dirs,$file);
 201     $target = VMS::Filespec::unixify($target) if $Is_VMS;
 202     File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755);
 203     foreach $file (keys %$read){
 204         if ($Is_MacOS) {
 205             if ($file =~ m!:!) {
 206                 my $dir = _maccat($target, $file);
 207                 $dir =~ s/[^:]+$//;
 208                 File::Path::mkpath($dir,1,0755);
 209             }
 210             cp_if_diff($file, _maccat($target, $file), $how);
 211         } else {
 212             $file = VMS::Filespec::unixify($file) if $Is_VMS;
 213             if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not?
 214                 my $dir = File::Basename::dirname($file);
 215                 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 216                 File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755);
 217             }
 218             cp_if_diff($file, "$target/$file", $how);
 219         }
 220     }
 221 }
 222
 223 sub cp_if_diff {
 224     my($from, $to, $how)=@_;
 225     -f $from or carp "$0: $from not found";
 226     my($diff) = 0;
 227     local(*F,*T);
 228     open(F,"< $from\0") or croak "Can't read $from: $!\n";
 229     if (open(T,"< $to\0")) {
 230         while (<F>) { $diff++,last if $_ ne <T>; }
 231         $diff++ unless eof(T);
 232         close T;
 233     }
 234     else { $diff++; }
 235     close F;
 236     if ($diff) {
 237         if (-e $to) {
 238             unlink($to) or confess "unlink $to: $!";
 239         }
 240       STRICT_SWITCH: {
 241             best($from,$to), last STRICT_SWITCH if $how eq 'best';
 242             cp($from,$to), last STRICT_SWITCH if $how eq 'cp';
 243             ln($from,$to), last STRICT_SWITCH if $how eq 'ln';
 244             croak("ExtUtils::Manifest::cp_if_diff " .
 245                   "called with illegal how argument [$how]. " .
 246                   "Legal values are 'best', 'cp', and 'ln'.");
 247         }
 248     }
 249 }
 250
 251 sub cp {
 252     my ($srcFile, $dstFile) = @_;
 253     my ($perm,$access,$mod) = (stat $srcFile)[2,8,9];
 254     copy($srcFile,$dstFile);
 255     utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile;
 256     # chmod a+rX-w,go-w
 257     chmod(  0444 | ( $perm & 0111 ? 0111 : 0 ),  $dstFile ) unless ($^O eq 'MacOS');
 258 }
 259
 260 sub ln {
 261     my ($srcFile, $dstFile) = @_;
 262     return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95());
 263     link($srcFile, $dstFile);
 264     local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x)
 265     my $mode= 0444 | (stat)[2] & 0700;
 266     if (! chmod(  $mode | ( $mode & 0100 ? 0111 : 0 ),  $_  )) {
 267        unlink $dstFile;
 268        return;
 269     }
 270     1;
 271 }
 272
 273 sub best {
 274     my ($srcFile, $dstFile) = @_;
 275     if (-l $srcFile) {
 276         cp($srcFile, $dstFile);
 277     } else {
 278         ln($srcFile, $dstFile) or cp($srcFile, $dstFile);
 279     }
 280 }
 281
 282 sub _macify {
 283     my($file) = @_;
 284
 285     return $file unless $Is_MacOS;
 286
 287     $file =~ s|^\./||;
 288     if ($file =~ m|/|) {
 289         $file =~ s|/+|:|g;
 290         $file = ":$file";
 291     }
 292
 293     $file;
 294 }
 295
 296 sub _maccat {
 297     my($f1, $f2) = @_;
 298
 299     return "$f1/$f2" unless $Is_MacOS;
 300
 301     $f1 .= ":$f2";
 302     $f1 =~ s/([^:]:):/$1/g;
 303     return $f1;
 304 }
 305
 306 sub _unmacify {
 307     my($file) = @_;
 308
 309     return $file unless $Is_MacOS;
 310
 311     $file =~ s|^:||;
 312     $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge;
 313     $file =~ y|:|/|;
 314
 315     $file;
 316 }
 317
 318 1;
 319
 320 __END__
 321
 322 =head1 NAME
 323
 324 ExtUtils::Manifest - utilities to write and check a MANIFEST file
 325
 326 =head1 SYNOPSIS
 327
 328     require ExtUtils::Manifest;
 329
 330     ExtUtils::Manifest::mkmanifest;
 331
 332     ExtUtils::Manifest::manicheck;
 333
 334     ExtUtils::Manifest::filecheck;
 335
 336     ExtUtils::Manifest::fullcheck;
 337
 338     ExtUtils::Manifest::skipcheck;
 339
 340     ExtUtils::Manifest::manifind();
 341
 342     ExtUtils::Manifest::maniread($file);
 343
 344     ExtUtils::Manifest::manicopy($read,$target,$how);
 345
 346 =head1 DESCRIPTION
 347
 348 mkmanifest() writes all files in and below the current directory to a
 349 file named in the global variable $ExtUtils::Manifest::MANIFEST (which
 350 defaults to C<MANIFEST>) in the current directory. It works similar to
 351
 352     find . -print
 353
 354 but in doing so checks each line in an existing C<MANIFEST> file and
 355 includes any comments that are found in the existing C<MANIFEST> file
 356 in the new one. Anything between white space and an end of line within
 357 a C<MANIFEST> file is considered to be a comment. Filenames and
 358 comments are separated by one or more TAB characters in the
 359 output. All files that match any regular expression in a file
 360 C<MANIFEST.SKIP> (if such a file exists) are ignored.
 361
 362 manicheck() checks if all the files within a C<MANIFEST> in the
 363 current directory really do exist. It only reports discrepancies and
 364 exits silently if MANIFEST and the tree below the current directory
 365 are in sync.
 366
 367 filecheck() finds files below the current directory that are not
 368 mentioned in the C<MANIFEST> file. An optional file C<MANIFEST.SKIP>
 369 will be consulted. Any file matching a regular expression in such a
 370 file will not be reported as missing in the C<MANIFEST> file.
 371
 372 fullcheck() does both a manicheck() and a filecheck().
 373
 374 skipcheck() lists all the files that are skipped due to your
 375 C<MANIFEST.SKIP> file.
 376
 377 manifind() returns a hash reference. The keys of the hash are the
 378 files found below the current directory.
 379
 380 maniread($file) reads a named C<MANIFEST> file (defaults to
 381 C<MANIFEST> in the current directory) and returns a HASH reference
 382 with files being the keys and comments being the values of the HASH.
 383 Blank lines and lines which start with C<#> in the C<MANIFEST> file
 384 are discarded.
 385
 386 C<manicopy($read,$target,$how)> copies the files that are the keys in
 387 the HASH I<%$read> to the named target directory. The HASH reference
 388 $read is typically returned by the maniread() function. This
 389 function is useful for producing a directory tree identical to the
 390 intended distribution tree. The third parameter $how can be used to
 391 specify a different methods of "copying". Valid values are C<cp>,
 392 which actually copies the files, C<ln> which creates hard links, and
 393 C<best> which mostly links the files but copies any symbolic link to
 394 make a tree without any symbolic link. Best is the default.
 395
 396 =head1 MANIFEST.SKIP
 397
 398 The file MANIFEST.SKIP may contain regular expressions of files that
 399 should be ignored by mkmanifest() and filecheck(). The regular
 400 expressions should appear one on each line. Blank lines and lines
 401 which start with C<#> are skipped.  Use C<\#> if you need a regular
 402 expression to start with a sharp character. A typical example:
 403
 404     # Version control files and dirs.
 405     \bRCS\b
 406     \bCVS\b
 407     ,v$
 408
 409     # Makemaker generated files and dirs.
 410     ^MANIFEST\.
 411     ^Makefile$
 412     ^blib/
 413     ^MakeMaker-\d
 414
 415     # Temp, old and emacs backup files.
 416     ~$
 417     \.old$
 418     ^#.*#$
 419     ^\.#
 420
 421 If no MANIFEST.SKIP file is found, a default set of skips will be
 422 used, similar to the example above.  If you want nothing skipped,
 423 simply make an empty MANIFEST.SKIP file.
 424
 425
 426 =head1 EXPORT_OK
 427
 428 C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>,
 429 C<&maniread>, and C<&manicopy> are exportable.
 430
 431 =head1 GLOBAL VARIABLES
 432
 433 C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it
 434 results in both a different C<MANIFEST> and a different
 435 C<MANIFEST.SKIP> file. This is useful if you want to maintain
 436 different distributions for different audiences (say a user version
 437 and a developer version including RCS).
 438
 439 C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
 440 all functions act silently.
 441
 442 C<$ExtUtils::Manifest::Debug> defaults to 0.  If set to a true value,
 443 or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be
 444 produced.
 445
 446 =head1 DIAGNOSTICS
 447
 448 All diagnostic output is sent to C<STDERR>.
 449
 450 =over 4
 451
 452 =item C<Not in MANIFEST:> I<file>
 453
 454 is reported if a file is found, that is missing in the C<MANIFEST>
 455 file which is excluded by a regular expression in the file
 456 C<MANIFEST.SKIP>.
 457
 458 =item C<No such file:> I<file>
 459
 460 is reported if a file mentioned in a C<MANIFEST> file does not
 461 exist.
 462
 463 =item C<MANIFEST:> I<$!>
 464
 465 is reported if C<MANIFEST> could not be opened.
 466
 467 =item C<Added to MANIFEST:> I<file>
 468
 469 is reported by mkmanifest() if $Verbose is set and a file is added
 470 to MANIFEST. $Verbose is set to 1 by default.
 471
 472 =back
 473
 474 =head1 ENVIRONMENT
 475
 476 =over 4
 477
 478 =item B<PERL_MM_MANIFEST_DEBUG>
 479
 480 Turns on debugging
 481
 482 =back
 483
 484 =head1 SEE ALSO
 485
 486 L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.
 487
 488 =head1 AUTHOR
 489
 490 Andreas Koenig <F<andreas.koenig@anima.de>>
 491
 492 =cut