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