| Subject: | [PATCH] allow extract() to select files by regexes or substrings |
My name is Marco Marongiu (CPAN ID: BRONTO). I am an Archive::Tar user.
I am using Archive::Tar for an application I wrote for my employer. I
needed it to extract some files that I don't know the full name of, but
I know the extension. Unfortunately, extract() can't handle patterns. I
could use a workaround using list_files() or such, but I thought that
would have been quite inefficient. Therefore, I decided to write a patch
against Archive::Tar 1.28 for the extract() method to support pattern
matching and substring search, too.
The patch is attached. It passes the
make test the same way as 1.28. I also added the POD documentation for
it. I hope you find it useful and want to include it in Archive::Tar.
| Subject: | Archive-Tar-1.28.patch.bronto.2.patch |
*** lib/Archive/Tar.pm.dist 2006-01-30 15:09:46.000000000 +0100
--- lib/Archive/Tar.pm 2006-01-30 16:58:43.000000000 +0100
***************
*** 14,24 ****
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
! $VERSION = "1.28";
$CHOWN = 1;
$CHMOD = 1;
$DO_NOT_USE_PREFIX = 0;
BEGIN {
use Config;
$HAS_PERLIO = $Config::Config{useperlio};
--- 14,26 ----
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
! $VERSION = "1.28.patch.bronto.2";
$CHOWN = 1;
$CHMOD = 1;
$DO_NOT_USE_PREFIX = 0;
+ my @_ALLOWED_MATCHES = qw(exact pattern substring) ;
+
BEGIN {
use Config;
$HAS_PERLIO = $Config::Config{useperlio};
***************
*** 400,406 ****
return;
}
! =head2 $tar->extract( [@filenames] )
Write files whose names are equivalent to any of the names in
C<@filenames> to disk, creating subdirectories as necessary. This
--- 402,408 ----
return;
}
! =head2 $tar->extract( [@filenames[,{type => matching_type}]] )
Write files whose names are equivalent to any of the names in
C<@filenames> to disk, creating subdirectories as necessary. This
***************
*** 414,419 ****
--- 416,454 ----
If C<extract> is called without a list of file names, the entire
contents of the archive are extracted.
+ You can pass the method an hash of options. By now, only the 'type' options
+ is defined and it affects the way C<extract> matches C<@filenames> against
+ the file names in the archive.
+
+ =over 4
+
+ =item exact
+
+ Only files that match exactly file names in C<@filenames> are extracted.
+ This is the default (i.e.: is what happens if you don't pass
+ C<extract()> any option.
+
+ =item pattern
+
+ This extract only files that match the patterns given in C<@filenames>.
+ You better pass your patterns through C<qr> before handing them to C<extract>
+ for performance reasons.
+
+
+ Example:
+
+ my @list = $tar->extract(qw('.*\.$dat$'),{ type => 'pattern' }) ;
+
+ extracts only filenames ending in '.dat'.
+
+ =item substring
+
+ This extracts only files whose name matches the strings given in C<@filenames>.
+
+ =back
+
+ Any unknown C<type> is forced to C<exact>.
+
Returns a list of filenames extracted.
=cut
***************
*** 421,433 ****
sub extract {
my $self = shift;
my @files;
### you requested the extraction of only certian files
if( @_ ) {
for my $file (@_) {
my $found;
for my $entry ( @{$self->_data} ) {
! next unless $file eq $entry->full_path;
### we found the file you're looking for
push @files, $entry;
--- 456,483 ----
sub extract {
my $self = shift;
my @files;
+ my $opts ;
### you requested the extraction of only certian files
if( @_ ) {
+ my $type = $_ALLOWED_MATCHES[0]; # giv this variable a suitable default
+ if (ref $_[$#_]) {
+ # pop away the last element of @_ in case it is a reference
+ $opts = pop @_ ;
+
+ # get a value for $type, to be tested later
+ $type = exists $opts->{type}? $opts->{type}: $_ALLOWED_MATCHES[0] ;
+ }
+
+ # Reset $type's value if someone tried to give it an invalid value
+ $type = $_ALLOWED_MATCHES[0] unless grep { $type eq $_ } @_ALLOWED_MATCHES ;
+
for my $file (@_) {
my $found;
for my $entry ( @{$self->_data} ) {
! $type eq 'exact' and next unless $entry->full_path eq $file ;
! $type eq 'pattern' and next unless $entry->full_path =~ /$file/ ;
! $type eq 'substring' and next if index($entry->full_path,$file) == -1 ;
### we found the file you're looking for
push @files, $entry;