# 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