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     local $^W;
  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     umask 0 unless $Is_VMS;
 191     File::Path::mkpath([ $target ],1,$Is_VMS ? undef : 0755);
 192     foreach $file (keys %$read){
 193         $file = VMS::Filespec::unixify($file) if $Is_VMS;
 194         if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not?
 195             my $dir = File::Basename::dirname($file);
 196             $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 197             File::Path::mkpath(["$target/$dir"],1,$Is_VMS ? undef : 0755);
 198         }
 199         cp_if_diff($file, "$target/$file", $how);
 200     }
 201 }
 202
 203 sub cp_if_diff {
 204     my($from, $to, $how)=@_;
 205     -f $from or carp "$0: $from not found";
 206     my($diff) = 0;
 207     local(*F,*T);
 208     open(F,$from) or croak "Can't read $from: $!\n";
 209     if (open(T,$to)) {
 210         while (<F>) { $diff++,last if $_ ne <T>; }
 211         $diff++ unless eof(T);
 212         close T;
 213     }
 214     else { $diff++; }
 215     close F;
 216     if ($diff) {
 217         if (-e $to) {
 218             unlink($to) or confess "unlink $to: $!";
 219         }
 220       STRICT_SWITCH: {
 221             best($from,$to), last STRICT_SWITCH if $how eq 'best';
 222             cp($from,$to), last STRICT_SWITCH if $how eq 'cp';
 223             ln($from,$to), last STRICT_SWITCH if $how eq 'ln';
 224             croak("ExtUtils::Manifest::cp_if_diff " .
 225                   "called with illegal how argument [$how]. " .
 226                   "Legal values are 'best', 'cp', and 'ln'.");
 227         }
 228     }
 229 }
 230
 231 sub cp {
 232     my ($srcFile, $dstFile) = @_;
 233     my ($perm,$access,$mod) = (stat $srcFile)[2,8,9];
 234     copy($srcFile,$dstFile);
 235     utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile;
 236     # chmod a+rX-w,go-w
 237     chmod(  0444 | ( $perm & 0111 ? 0111 : 0 ),  $dstFile );
 238 }
 239
 240 sub ln {
 241     my ($srcFile, $dstFile) = @_;
 242     return &cp if $Is_VMS;
 243     link($srcFile, $dstFile);
 244     local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x)
 245     my $mode= 0444 | (stat)[2] & 0700;
 246     if (! chmod(  $mode | ( $mode & 0100 ? 0111 : 0 ),  $_  )) {
 247        unlink $dstFile;
 248        return;
 249     }
 250     1;
 251 }
 252
 253 sub best {
 254     my ($srcFile, $dstFile) = @_;
 255     if (-l $srcFile) {
 256         cp($srcFile, $dstFile);
 257     } else {
 258         ln($srcFile, $dstFile) or cp($srcFile, $dstFile);
 259     }
 260 }
 261
 262 1;
 263
 264 __END__
 265
 266 =head1 NAME
 267
 268 ExtUtils::Manifest - utilities to write and check a MANIFEST file
 269
 270 =head1 SYNOPSIS
 271
 272     require ExtUtils::Manifest;
 273
 274     ExtUtils::Manifest::mkmanifest;
 275
 276     ExtUtils::Manifest::manicheck;
 277
 278     ExtUtils::Manifest::filecheck;
 279
 280     ExtUtils::Manifest::fullcheck;
 281
 282     ExtUtils::Manifest::skipcheck;
 283
 284     ExtUtils::Manifest::manifind();
 285
 286     ExtUtils::Manifest::maniread($file);
 287
 288     ExtUtils::Manifest::manicopy($read,$target,$how);
 289
 290 =head1 DESCRIPTION
 291
 292 mkmanifest() writes all files in and below the current directory to a
 293 file named in the global variable $ExtUtils::Manifest::MANIFEST (which
 294 defaults to C<MANIFEST>) in the current directory. It works similar to
 295
 296     find . -print
 297
 298 but in doing so checks each line in an existing C<MANIFEST> file and
 299 includes any comments that are found in the existing C<MANIFEST> file
 300 in the new one. Anything between white space and an end of line within
 301 a C<MANIFEST> file is considered to be a comment. Filenames and
 302 comments are separated by one or more TAB characters in the
 303 output. All files that match any regular expression in a file
 304 C<MANIFEST.SKIP> (if such a file exists) are ignored.
 305
 306 manicheck() checks if all the files within a C<MANIFEST> in the
 307 current directory really do exist. It only reports discrepancies and
 308 exits silently if MANIFEST and the tree below the current directory
 309 are in sync.
 310
 311 filecheck() finds files below the current directory that are not
 312 mentioned in the C<MANIFEST> file. An optional file C<MANIFEST.SKIP>
 313 will be consulted. Any file matching a regular expression in such a
 314 file will not be reported as missing in the C<MANIFEST> file.
 315
 316 fullcheck() does both a manicheck() and a filecheck().
 317
 318 skipcheck() lists all the files that are skipped due to your
 319 C<MANIFEST.SKIP> file.
 320
 321 manifind() returns a hash reference. The keys of the hash are the
 322 files found below the current directory.
 323
 324 maniread($file) reads a named C<MANIFEST> file (defaults to
 325 C<MANIFEST> in the current directory) and returns a HASH reference
 326 with files being the keys and comments being the values of the HASH.
 327 Blank lines and lines which start with C<#> in the C<MANIFEST> file
 328 are discarded.
 329
 330 C<manicopy($read,$target,$how)> copies the files that are the keys in
 331 the HASH I<%$read> to the named target directory. The HASH reference
 332 $read is typically returned by the maniread() function. This
 333 function is useful for producing a directory tree identical to the
 334 intended distribution tree. The third parameter $how can be used to
 335 specify a different methods of "copying". Valid values are C<cp>,
 336 which actually copies the files, C<ln> which creates hard links, and
 337 C<best> which mostly links the files but copies any symbolic link to
 338 make a tree without any symbolic link. Best is the default.
 339
 340 =head1 MANIFEST.SKIP
 341
 342 The file MANIFEST.SKIP may contain regular expressions of files that
 343 should be ignored by mkmanifest() and filecheck(). The regular
 344 expressions should appear one on each line. Blank lines and lines
 345 which start with C<#> are skipped.  Use C<\#> if you need a regular
 346 expression to start with a sharp character. A typical example:
 347
 348     \bRCS\b
 349     ^MANIFEST\.
 350     ^Makefile$
 351     ~$
 352     \.html$
 353     \.old$
 354     ^blib/
 355     ^MakeMaker-\d
 356
 357 =head1 EXPORT_OK
 358
 359 C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>,
 360 C<&maniread>, and C<&manicopy> are exportable.
 361
 362 =head1 GLOBAL VARIABLES
 363
 364 C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it
 365 results in both a different C<MANIFEST> and a different
 366 C<MANIFEST.SKIP> file. This is useful if you want to maintain
 367 different distributions for different audiences (say a user version
 368 and a developer version including RCS).
 369
 370 C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
 371 all functions act silently.
 372
 373 =head1 DIAGNOSTICS
 374
 375 All diagnostic output is sent to C<STDERR>.
 376
 377 =over
 378
 379 =item C<Not in MANIFEST:> I<file>
 380
 381 is reported if a file is found, that is missing in the C<MANIFEST>
 382 file which is excluded by a regular expression in the file
 383 C<MANIFEST.SKIP>.
 384
 385 =item C<No such file:> I<file>
 386
 387 is reported if a file mentioned in a C<MANIFEST> file does not
 388 exist.
 389
 390 =item C<MANIFEST:> I<$!>
 391
 392 is reported if C<MANIFEST> could not be opened.
 393
 394 =item C<Added to MANIFEST:> I<file>
 395
 396 is reported by mkmanifest() if $Verbose is set and a file is added
 397 to MANIFEST. $Verbose is set to 1 by default.
 398
 399 =back
 400
 401 =head1 SEE ALSO
 402
 403 L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.
 404
 405 =head1 AUTHOR
 406
 407 Andreas Koenig <F<koenig@franz.ww.TU-Berlin.DE>>
 408
 409 =cut