1#!/usr/bin/perl 2use strict; 3use warnings; 4 5BEGIN { pop @INC if $INC[-1] eq '.' } 6use File::Find; 7use Getopt::Std; 8use Archive::Tar; 9use Data::Dumper; 10 11# Allow historic support for dashless bundled options 12# tar cvf file.tar 13# is valid (GNU) tar style 14@ARGV && $ARGV[0] =~ m/^[DdcvzthxIC]+[fT]?$/ and 15 unshift @ARGV, map { "-$_" } split m// => shift @ARGV; 16my $opts = {}; 17getopts('Ddcvzthxf:ICT:', $opts) or die usage(); 18 19### show the help message ### 20die usage() if $opts->{h}; 21 22### enable debugging (undocumented feature) 23local $Archive::Tar::DEBUG = 1 if $opts->{d}; 24 25### enable insecure extracting. 26local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I}; 27 28### sanity checks ### 29unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) { 30 die "You need exactly one of 'x', 't' or 'c' options: " . usage(); 31} 32 33my $compress = $opts->{z} ? 1 : 0; 34my $verbose = $opts->{v} ? 1 : 0; 35my $file = $opts->{f} ? $opts->{f} : 'default.tar'; 36my $tar = Archive::Tar->new(); 37 38if( $opts->{c} ) { 39 my @files; 40 my @src = @ARGV; 41 if( $opts->{T} ) { 42 if( $opts->{T} eq "-" ) { 43 chomp( @src = <STDIN> ); 44 } elsif( open my $fh, "<", $opts->{T} ) { 45 chomp( @src = <$fh> ); 46 } else { 47 die "$0: $opts->{T}: $!\n"; 48 } 49 } 50 51 find( sub { push @files, $File::Find::name; 52 print $File::Find::name.$/ if $verbose }, @src ); 53 54 if ($file eq '-') { 55 use IO::Handle; 56 $file = IO::Handle->new(); 57 $file->fdopen(fileno(STDOUT),"w"); 58 } 59 60 my $tar = Archive::Tar->new; 61 $tar->add_files(@files); 62 if( $opts->{C} ) { 63 for my $f ($tar->get_files) { 64 $f->mode($f->mode & ~022); # chmod go-w 65 } 66 } 67 $tar->write($file, $compress); 68} else { 69 if ($file eq '-') { 70 use IO::Handle; 71 $file = IO::Handle->new(); 72 $file->fdopen(fileno(STDIN),"r"); 73 } 74 75 ### print the files we're finding? 76 my $print = $verbose || $opts->{'t'} || 0; 77 78 my $iter = Archive::Tar->iter( $file ); 79 80 while( my $f = $iter->() ) { 81 print $f->full_path . $/ if $print; 82 83 ### data dumper output 84 print Dumper( $f ) if $opts->{'D'}; 85 86 ### extract it 87 $f->extract if $opts->{'x'}; 88 } 89} 90 91### pod & usage in one 92sub usage { 93 my $usage .= << '=cut'; 94=pod 95 96=head1 NAME 97 98ptar - a tar-like program written in perl 99 100=head1 DESCRIPTION 101 102ptar is a small, tar look-alike program that uses the perl module 103Archive::Tar to extract, create and list tar archives. 104 105=head1 SYNOPSIS 106 107 ptar -c [-v] [-z] [-C] [-f ARCHIVE_FILE | -] FILE FILE ... 108 ptar -c [-v] [-z] [-C] [-T index | -] [-f ARCHIVE_FILE | -] 109 ptar -x [-v] [-z] [-f ARCHIVE_FILE | -] 110 ptar -t [-z] [-f ARCHIVE_FILE | -] 111 ptar -h 112 113=head1 OPTIONS 114 115 c Create ARCHIVE_FILE or STDOUT (-) from FILE 116 x Extract from ARCHIVE_FILE or STDIN (-) 117 t List the contents of ARCHIVE_FILE or STDIN (-) 118 f Name of the ARCHIVE_FILE to use. Default is './default.tar' 119 z Read/Write zlib compressed ARCHIVE_FILE (not always available) 120 v Print filenames as they are added or extracted from ARCHIVE_FILE 121 h Prints this help message 122 C CPAN mode - drop 022 from permissions 123 T get names to create from file 124 125=head1 SEE ALSO 126 127L<tar(1)>, L<Archive::Tar>. 128 129=cut 130 131 ### strip the pod directives 132 $usage =~ s/=pod\n//g; 133 $usage =~ s/=head1 //g; 134 135 ### add some newlines 136 $usage .= $/.$/; 137 138 return $usage; 139} 140 141