1#! /usr/bin/perl 2############################################################################# 3# Does an in-memory removal of tar entries matching the given regex. 4# 5# Usage: 6# % perl tar-remove.pl regex tarball newtarball 7############################################################################# 8 9use strict; 10 11package MyTar; 12 13use Archive::Tar; 14 15our @ISA = qw(Archive::Tar); 16 17# Override the remove method. Order of remaining items is preserved. 18sub remove { 19 my $self = shift; 20 my %list = map { $_ => 1 } @_; 21 my @data = grep { !$list{$_->full_path} } @{$self->_data}; 22 $self->_data( \@data ); 23 return @data; 24} 25 26package main; 27 28my %suffix = ( 29 '\.tar\.gz$' => MyTar::COMPRESS_GZIP, 30 '\.tar\.bz2$' => MyTar::COMPRESS_BZIP, 31); 32 33sub matchsuffix { 34 my $arg = shift; 35 local $_; 36 for(keys(%suffix)) { 37 return $suffix{$_} if $arg =~ /$_/; 38 } 39 return undef; 40} 41 42die "Usage: $0 regex tarball newtarball\n" unless scalar(@ARGV) == 3; 43my $match = qr{$ARGV[0]}; 44my $tar = MyTar->new($ARGV[1]) || die "$0: Can't open $ARGV[1]\n"; 45my @list = grep { /$match/ } map { $_->full_path } $tar->get_files(); 46$tar->remove(@list); 47my $compress = matchsuffix($ARGV[2]); 48die "$0: Didn't recognize suffix of $ARGV[2]\n" unless defined($compress); 49$tar->write($ARGV[2], $compress) || die "$0: Can't create $ARGV[2]\n"; 50