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