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