--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/releasing/cbrtools/perl/Archive/Zip/Tree.pm Wed Jun 30 11:35:58 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<xyz>, do this:
+
+ $zip->addTreeMatching( '.', 'xyz', '\.pl$' )
+
+To add all I<writable> files in and below the dirctory named C</abc>
+whose names end in C<.pl>, and make them extract into a subdirectory
+named C<xyz>, 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<Compress::Zlib>
+L<Archive::Zip>
+
+=cut
+
+# vim: ts=4 sw=4 columns=80