$Is_MacOS $Is_VMS
$Debug $Verbose $Quiet $MANIFEST $DEFAULT_MSKIP);
-$VERSION = 1.38;
+$VERSION = 1.43;
@ISA=('Exporter');
@EXPORT_OK = qw(mkmanifest
manicheck filecheck fullcheck skipcheck
$Quiet = 0;
$MANIFEST = 'MANIFEST';
-my $manifest_mod = $INC{"ExtUtils/Manifest.pm"} ||
- ($Is_VMS ? $INC{'extutils/manifest.pm'} : '');
-$DEFAULT_MSKIP = (File::Spec->splitpath($manifest_mod))[1].
+my $Filename = __FILE__;
+$DEFAULT_MSKIP = (File::Spec->splitpath($Filename))[1].
"$MANIFEST.SKIP";
=cut
+sub _sort {
+ return sort { lc $a cmp lc $b } @_;
+}
+
sub mkmanifest {
my $manimiss = 0;
my $read = (-r 'MANIFEST' && maniread()) or $manimiss++;
%all = (%$found, %$read);
$all{$MANIFEST} = ($Is_VMS ? "$MANIFEST\t\t" : '') . 'This list of files'
if $manimiss; # add new MANIFEST to known file list
- foreach $file (sort keys %all) {
+ foreach $file (_sort keys %all) {
if ($skip->($file)) {
# Policy: only remove files if they're listed in MANIFEST.SKIP.
# Don't remove files just because they don't exist.
checks if all the files within a C<MANIFEST> in the current directory
really do exist. If C<MANIFEST> and the tree below the current
-directory are in sync it exits silently, returning an empty list.
+directory are in sync it silently returns an empty list.
Otherwise it returns a list of files which are listed in the
C<MANIFEST> but missing from the directory, and by default also
outputs these names to STDERR.
my $matches = _maniskip();
my @skipped = ();
- foreach my $file (sort keys %$found){
+ foreach my $file (_sort keys %$found){
if (&$matches($file)){
warn "Skipping $file\n";
push @skipped, $file;
my $found = manifind($p);
my(@missfile) = ();
- foreach my $file (sort keys %$read){
+ foreach my $file (_sort keys %$read){
warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug;
if ($dosnames){
$file = lc $file;
my $skip = _maniskip();
my @missentry = ();
- foreach my $file (sort keys %$found){
+ foreach my $file (_sort keys %$found){
next if $skip->($file);
warn "Debug: manicheck checking from disk $file\n" if $Debug;
unless ( exists $read->{$file} ) {
my $read = {};
local *M;
unless (open M, $mfile){
- warn "$mfile: $!";
- return $read;
+ warn "$mfile: $!";
+ return $read;
}
+ local $_;
while (<M>){
- chomp;
- next if /^#/;
+ chomp;
+ next if /^\s*#/;
my($file, $comment) = /^(\S+)\s*(.*)/;
next unless $file;
- if ($Is_MacOS) {
- $file = _macify($file);
- $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge;
- }
- elsif ($Is_VMS) {
- require File::Basename;
- my($base,$dir) = File::Basename::fileparse($file);
- # Resolve illegal file specifications in the same way as tar
- $dir =~ tr/./_/;
- my(@pieces) = split(/\./,$base);
- if (@pieces > 2) { $base = shift(@pieces) . '.' . join('_',@pieces); }
- my $okfile = "$dir$base";
- warn "Debug: Illegal name $file changed to $okfile\n" if $Debug;
+ if ($Is_MacOS) {
+ $file = _macify($file);
+ $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge;
+ }
+ elsif ($Is_VMS) {
+ require File::Basename;
+ my($base,$dir) = File::Basename::fileparse($file);
+ # Resolve illegal file specifications in the same way as tar
+ $dir =~ tr/./_/;
+ my(@pieces) = split(/\./,$base);
+ if (@pieces > 2) { $base = shift(@pieces) . '.' . join('_',@pieces); }
+ my $okfile = "$dir$base";
+ warn "Debug: Illegal name $file changed to $okfile\n" if $Debug;
$file = $okfile;
$file = lc($file) unless $file =~ /^MANIFEST(\.SKIP)?$/;
- }
+ }
$read->{$file} = $comment;
}
sub _maniskip {
my @skip ;
my $mfile = "$MANIFEST.SKIP";
- local *M;
+ local(*M,$_);
open M, $mfile or open M, $DEFAULT_MSKIP or return sub {0};
while (<M>){
chomp;
=item manicopy
- manicopy($src, $dest_dir);
- manicopy($src, $dest_dir, $how);
+ manicopy(\%src, $dest_dir);
+ manicopy(\%src, $dest_dir, $how);
+
+Copies the files that are the keys in %src to the $dest_dir. %src is
+typically returned by the maniread() function.
-copies the files that are the keys in the HASH I<%$src> to the
-$dest_dir. The HASH reference $read is typically returned by the
-maniread() function. This function is useful for producing a directory
-tree identical to the intended distribution tree. The third parameter
-$how can be used to specify a different methods of "copying". Valid
+ manicopy( maniread(), $dest_dir );
+
+This function is useful for producing a directory tree identical to the
+intended distribution tree.
+
+$how can be used to specify a different methods of "copying". Valid
values are C<cp>, which actually copies the files, C<ln> which creates
hard links, and C<best> which mostly links the files but copies any
-symbolic link to make a tree without any symbolic link. Best is the
+symbolic link to make a tree without any symbolic link. C<cp> is the
default.
=cut
local(*F,*T);
open(F,"< $from\0") or die "Can't read $from: $!\n";
if (open(T,"< $to\0")) {
+ local $_;
while (<F>) { $diff++,last if $_ ne <T>; }
$diff++ unless eof(T);
close T;
sub cp {
my ($srcFile, $dstFile) = @_;
- my ($perm,$access,$mod) = (stat $srcFile)[2,8,9];
+ my ($access,$mod) = (stat $srcFile)[8,9];
+
copy($srcFile,$dstFile);
utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile;
- # chmod a+rX-w,go-w
- chmod( 0444 | ( $perm & 0111 ? 0111 : 0 ), $dstFile )
- unless ($^O eq 'MacOS');
+ _manicopy_chmod($dstFile);
}
+
sub ln {
my ($srcFile, $dstFile) = @_;
return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95());
link($srcFile, $dstFile);
- # chmod a+r,go-w+X (except "X" only applies to u=x)
- local($_) = $dstFile;
- my $mode= 0444 | (stat)[2] & 0700;
- if (! chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ )) {
+ unless( _manicopy_chmod($dstFile) ) {
unlink $dstFile;
return;
}
1;
}
-unless (defined $Config{d_link}) {
- # Really cool fix from Ilya :)
- local $SIG{__WARN__} = sub {
- warn @_ unless $_[0] =~ /^Subroutine .* redefined/;
- };
- *ln = \&cp;
-}
-
-
+# 1) Strip off all group and world permissions.
+# 2) Let everyone read it.
+# 3) If the owner can execute it, everyone can.
+sub _manicopy_chmod {
+ my($file) = shift;
+ my $perm = 0444 | (stat $file)[2] & 0700;
+ chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $file );
+}
sub best {
my ($srcFile, $dstFile) = @_;
- if (-l $srcFile) {
+ if (!$Config{d_link} or -l $srcFile) {
cp($srcFile, $dstFile);
} else {
ln($srcFile, $dstFile) or cp($srcFile, $dstFile);
my($file) = @_;
return $file unless $Is_MacOS;
-
+
$file =~ s|^\./||;
if ($file =~ m|/|) {
$file =~ s|/+|:|g;
$file = ":$file";
}
-
+
$file;
}
sub _maccat {
my($f1, $f2) = @_;
-
+
return "$f1/$f2" unless $Is_MacOS;
-
+
$f1 .= ":$f2";
$f1 =~ s/([^:]:):/$1/g;
return $f1;
maniadd({ $file => $comment, ...});
-Adds an entry to an existing F<MANIFEST>.
+Adds an entry to an existing F<MANIFEST> unless its already there.
$file will be normalized (ie. Unixified). B<UNIMPLEMENTED>
my($additions) = shift;
_normalize($additions);
+ _fix_manifest($MANIFEST);
my $manifest = maniread();
- open(MANIFEST, ">>$MANIFEST") or die "Could not open $MANIFEST: $!";
- while( my($file, $comment) = each %$additions ) {
- $comment ||= '';
- printf MANIFEST "%-40s%s\n", $file, $comment unless
- exists $manifest->{$file};
+ my @needed = grep { !exists $manifest->{$_} } keys %$additions;
+ return 1 unless @needed;
+
+ open(MANIFEST, ">>$MANIFEST") or
+ die "maniadd() could not open $MANIFEST: $!";
+
+ foreach my $file (_sort @needed) {
+ my $comment = $additions->{$file} || '';
+ printf MANIFEST "%-40s %s\n", $file, $comment;
}
+ close MANIFEST or die "Error closing $MANIFEST: $!";
+
+ return 1;
+}
+
+
+# Sometimes MANIFESTs are missing a trailing newline. Fix this.
+sub _fix_manifest {
+ my $manifest_file = shift;
+
+ open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!";
+
+ # Yes, we should be using seek(), but I'd like to avoid loading POSIX
+ # to get SEEK_*
+ my @manifest = <MANIFEST>;
close MANIFEST;
+
+ unless( $manifest[-1] =~ /\n\z/ ) {
+ open MANIFEST, ">>$MANIFEST" or die "Could not open $MANIFEST: $!";
+ print MANIFEST "\n";
+ close MANIFEST;
+ }
}
+
# UNIMPLEMENTED
sub _normalize {
=head1 AUTHOR
-Andreas Koenig <F<andreas.koenig@anima.de>>
+Andreas Koenig C<andreas.koenig@anima.de>
+
+Currently maintained by Michael G Schwern C<schwern@pobox.com>
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff