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