diff -r 6d08f4a05d93 -r 3145852acc89 releasing/cbrtools/perl/Archive/Zip/Tree.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/releasing/cbrtools/perl/Archive/Zip/Tree.pm Fri Jun 25 18:37:20 2010 +0800 @@ -0,0 +1,238 @@ +# Copyright (c) 2000 Ned Konz. All rights reserved. This program is free +# software; you can redistribute it and/or modify it under the same terms +# as Perl itself. + +# $Revision: 1.5 $ +package Archive::Zip::Archive; +use File::Find (); +use Archive::Zip qw(:ERROR_CODES :UTILITY_METHODS); + +=head1 NAME + +Archive::Zip::Tree -- methods for adding/extracting trees using Archive::Zip + +=head1 SYNOPSIS + + use Archive::Zip; + use Archive::Zip::Tree; + my $zip = Archive::Zip->new(); + # add all readable files and directories below . as xyz/* + $zip->addTree( '.', 'xyz' ); + # add all readable plain files below /abc as /def/* + $zip->addTree( '/abc', '/def', sub { -f && -r } ); + # add all .c files below /tmp as stuff/* + $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' ); + # add all .o files below /tmp as stuff/* if they aren't writable + $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } ); + # and write them into a file + $zip->writeToFile('xxx.zip'); + + # now extract the same files into /tmpx + $zip->extractTree( 'stuff', '/tmpx' ); + +=head1 METHODS + +=over 4 + +=item $zip->addTree( $root, $dest [,$pred] ) + +$root is the root of the tree of files and directories to be added + +$dest is the name for the root in the zip file (undef or blank means to use +relative pathnames) + +C<$pred> is an optional subroutine reference to select files: it is passed the +name of the prospective file or directory using C<$_>, +and if it returns true, the file or +directory will be included. The default is to add all readable files and +directories. + +For instance, using + + my $pred = sub { /\.txt/ }; + $zip->addTree( '.', '.', $pred ); + +will add all the .txt files in and below the current directory, +using relative names, and making the names identical in the zipfile: + + original name zip member name + ./xyz xyz + ./a/ a/ + ./a/b a/b + +To use absolute pathnames, just pass them in: + +$zip->addTree( '/a/b', '/a/b' ); + + original name zip member name + /a/ /a/ + /a/b /a/b + +To translate relative to absolute pathnames, just pass them in: + +$zip->addTree( '.', '/c/d' ); + + original name zip member name + ./xyz /c/d/xyz + ./a/ /c/d/a/ + ./a/b /c/d/a/b + +To translate absolute to relative pathnames, just pass them in: + +$zip->addTree( '/c/d', 'a' ); + + original name zip member name + /c/d/xyz a/xyz + /c/d/a/ a/a/ + /c/d/a/b a/a/b + +Returns AZ_OK on success. + +Note that this will not follow symbolic links to directories. + +Note also that this does not check for the validity of filenames. + +=back + +=cut + +sub addTree +{ + my $self = shift; + my $root = shift or return _error("root arg missing in call to addTree()"); + my $dest = shift || ''; + my $pred = shift || sub { -r }; + $root =~ s{\\}{/}g; # normalize backslashes in case user is misguided + $root =~ s{([^/])$}{$1/}; # append slash if necessary + $dest =~ s{([^/])$}{$1/} if $dest; # append slash if necessary + my @files; + File::Find::find( sub { push( @files, $File::Find::name ) }, $root ); + @files = grep { &$pred } @files; # pass arg via local $_ + foreach my $fileName ( @files ) + { + ( my $archiveName = $fileName ) =~ s{^\Q$root}{$dest}; + $archiveName =~ s{^\./}{}; + next if $archiveName =~ m{^\.?/?$}; # skip current dir + my $member = ( -d $fileName ) + ? $self->addDirectory( $fileName, $archiveName ) + : $self->addFile( $fileName, $archiveName ); + return _error( "add $fileName failed in addTree()" ) if !$member; + } + return AZ_OK; +} + +=over 4 + +=item $zip->addTreeMatching( $root, $dest, $pattern [,$pred] ) + +$root is the root of the tree of files and directories to be added + +$dest is the name for the root in the zip file (undef means to use relative +pathnames) + +$pattern is a (non-anchored) regular expression for filenames to match + +$pred is an optional subroutine reference to select files: it is passed the +name of the prospective file or directory in C<$_>, +and if it returns true, the file or +directory will be included. The default is to add all readable files and +directories. + +To add all files in and below the current dirctory +whose names end in C<.pl>, and make them extract into a subdirectory +named C, do this: + + $zip->addTreeMatching( '.', 'xyz', '\.pl$' ) + +To add all I files in and below the dirctory named C +whose names end in C<.pl>, and make them extract into a subdirectory +named C, do this: + + $zip->addTreeMatching( '/abc', 'xyz', '\.pl$', sub { -w } ) + +Returns AZ_OK on success. + +Note that this will not follow symbolic links to directories. + +=back + +=cut + +sub addTreeMatching +{ + my $self = shift; + my $root = shift + or return _error("root arg missing in call to addTreeMatching()"); + my $dest = shift || ''; + my $pattern = shift + or return _error("pattern missing in call to addTreeMatching()"); + my $pred = shift || sub { -r }; + my $matcher = sub { m{$pattern} && &$pred }; + return $self->addTree( $root, $dest, $matcher ); +} + +=over 4 + +=item $zip->extractTree( $root, $dest ) + +Extracts all the members below a given root. Will +translate that root to a given dest pathname. + +For instance, + + $zip->extractTree( '/a/', 'd/e/' ); + +when applied to a zip containing the files: + /a/x /a/b/c /d/e + +will extract: + /a/x to d/e/x + /a/b/c to d/e/b/c + +and ignore /d/e + +=back + +=cut + +sub extractTree +{ + my $self = shift(); + my $root = shift(); + return _error("root arg missing in call to extractTree()") + unless defined($root); + my $dest = shift || '.'; + $root =~ s{\\}{/}g; # normalize backslashes in case user is misguided + $root =~ s{([^/])$}{$1/}; # append slash if necessary + my @members = $self->membersMatching( "^$root" ); + foreach my $member ( @members ) + { + my $fileName = $member->fileName(); + $fileName =~ s{$root}{$dest}; + my $status = $member->extractToFileNamed( $fileName ); + return $status if $status != AZ_OK; + } + return AZ_OK; +} + +1; +__END__ + +=head1 AUTHOR + +Ned Konz, perl@bike-nomad.com + +=head1 COPYRIGHT + +Copyright (c) 2000 Ned Konz. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=head1 SEE ALSO + +L +L + +=cut + +# vim: ts=4 sw=4 columns=80