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