codekingpro/portable-devtools

1#!/usr/bin/perl2    eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'3	if 0; # ^ Run only under a shell4#!/usr/bin/perl5use strict;6use warnings;7 8BEGIN { pop @INC if $INC[-1] eq '.' }9use File::Find;10use Getopt::Std;11use Archive::Tar;12use Data::Dumper;13 14# Allow (and ignore) --format=ustar, for compatibility with GNU tar15for (my $i = 0; $i < @ARGV; ++$i) {16    last if $ARGV[$i] eq '--';17    splice @ARGV, $i--, 1 if $ARGV[$i] eq '--format=ustar';18    splice @ARGV, $i--, 2 if $i < $#ARGV19        && $ARGV[$i] eq '--format' && $ARGV[$i + 1] eq 'ustar';20}21 22# Allow historic support for dashless bundled options23#  tar cvf file.tar24# is valid (GNU) tar style25@ARGV && $ARGV[0] =~ m/^[DdcvzthxIC]+[fT]?$/ and26    unshift @ARGV, map { "-$_" } split m// => shift @ARGV;27my $opts = {};28getopts('Ddcvzthxf:ICT:', $opts) or die usage();29 30### show the help message ###31die usage() if $opts->{h};32 33### enable debugging (undocumented feature)34local $Archive::Tar::DEBUG                  = 1 if $opts->{d};35 36### enable insecure extracting.37local $Archive::Tar::INSECURE_EXTRACT_MODE  = 1 if $opts->{I};38 39### sanity checks ###40unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {41    die "You need exactly one of 'x', 't' or 'c' options: " . usage();42}43 44my $compress    = $opts->{z} ? 1 : 0;45my $verbose     = $opts->{v} ? 1 : 0;46my $file        = $opts->{f} ? $opts->{f} : 'default.tar';47my $tar         = Archive::Tar->new();48 49if( $opts->{c} ) {50    my @files;51    my @src = @ARGV;52    if( $opts->{T} ) {53      if( $opts->{T} eq "-" ) {54        chomp( @src = <STDIN> );55	} elsif( open my $fh, "<", $opts->{T} ) {56	    chomp( @src = <$fh> );57	} else {58	    die "$0: $opts->{T}: $!\n";59	}60    }61 62    find( sub { push @files, $File::Find::name;63                print $File::Find::name.$/ if $verbose }, @src );64 65    if ($file eq '-') {66        use IO::Handle;67        $file = IO::Handle->new();68        $file->fdopen(fileno(STDOUT),"w");69    }70 71    my $tar = Archive::Tar->new;72    $tar->add_files(@files);73    if( $opts->{C} ) {74        for my $f ($tar->get_files) {75            $f->mode($f->mode & ~022); # chmod go-w76        }77    }78    $tar->write($file, $compress);79} else {80    if ($file eq '-') {81        use IO::Handle;82        $file = IO::Handle->new();83        $file->fdopen(fileno(STDIN),"r");84    }85 86    ### print the files we're finding?87    my $print = $verbose || $opts->{'t'} || 0;88 89    my $iter = Archive::Tar->iter( $file );90 91    while( my $f = $iter->() ) {92        print $f->full_path . $/ if $print;93 94        ### data dumper output95        print Dumper( $f ) if $opts->{'D'};96 97        ### extract it98        $f->extract if $opts->{'x'};99    }100}101 102### pod & usage in one103sub usage {104    my $usage .= << '=cut';105=pod106 107=head1 NAME108 109ptar - a tar-like program written in perl110 111=head1 DESCRIPTION112 113ptar is a small, tar look-alike program that uses the perl module114Archive::Tar to extract, create and list tar archives.115 116=head1 SYNOPSIS117 118    ptar -c [-v] [-z] [-C] [-f ARCHIVE_FILE | -] FILE FILE ...119    ptar -c [-v] [-z] [-C] [-T index | -] [-f ARCHIVE_FILE | -]120    ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]121    ptar -t [-z] [-f ARCHIVE_FILE | -]122    ptar -h123 124=head1 OPTIONS125 126    c   Create ARCHIVE_FILE or STDOUT (-) from FILE127    x   Extract from ARCHIVE_FILE or STDIN (-)128    t   List the contents of ARCHIVE_FILE or STDIN (-)129    f   Name of the ARCHIVE_FILE to use. Default is './default.tar'130    z   Read/Write zlib compressed ARCHIVE_FILE (not always available)131    v   Print filenames as they are added or extracted from ARCHIVE_FILE132    h   Prints this help message133    C   CPAN mode - drop 022 from permissions134    T   get names to create from file135 136=head1 SEE ALSO137 138L<tar(1)>, L<Archive::Tar>.139 140=cut141 142    ### strip the pod directives143    $usage =~ s/=pod\n//g;144    $usage =~ s/=head1 //g;145 146    ### add some newlines147    $usage .= $/.$/;148 149    return $usage;150}151 152