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