local-lib5/bin/ptar

   1 #!/usr/bin/perl
   2
   3 eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
   4     if 0; # not running under some shell
   5 use strict;
   6
   7 use File::Find;
   8 use Getopt::Std;
   9 use Archive::Tar;
  10 use Data::Dumper;
  11
  12 my $opts = {};
  13 getopts('Ddcvzthxf:I', $opts) or die usage();
  14
  15 ### show the help message ###
  16 die usage() if $opts->{h};
  17
  18 ### enable debugging (undocumented feature)
  19 local $Archive::Tar::DEBUG                  = 1 if $opts->{d};
  20
  21 ### enable insecure extracting.
  22 local $Archive::Tar::INSECURE_EXTRACT_MODE  = 1 if $opts->{I};
  23
  24 ### sanity checks ###
  25 unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {
  26     die "You need exactly one of 'x', 't' or 'c' options: " . usage();
  27 }
  28
  29 my $compress    = $opts->{z} ? 1 : 0;
  30 my $verbose     = $opts->{v} ? 1 : 0;
  31 my $file        = $opts->{f} ? $opts->{f} : 'default.tar';
  32 my $tar         = Archive::Tar->new();
  33
  34
  35 if( $opts->{c} ) {
  36     my @files;
  37     find( sub { push @files, $File::Find::name;
  38                 print $File::Find::name.$/ if $verbose }, @ARGV );
  39
  40     if ($file eq '-') {
  41         use IO::Handle;
  42         $file = IO::Handle->new();
  43         $file->fdopen(fileno(STDOUT),"w");
  44     }
  45
  46     Archive::Tar->create_archive( $file, $compress, @files );
  47
  48 } else {
  49     if ($file eq '-') {
  50         use IO::Handle;
  51         $file = IO::Handle->new();
  52         $file->fdopen(fileno(STDIN),"r");
  53     }
  54
  55     ### print the files we're finding?
  56     my $print = $verbose || $opts->{'t'} || 0;
  57
  58     my $iter = Archive::Tar->iter( $file );
  59
  60     while( my $f = $iter->() ) {
  61         print $f->full_path . $/ if $print;
  62
  63         ### data dumper output
  64         print Dumper( $f ) if $opts->{'D'};
  65
  66         ### extract it
  67         $f->extract if $opts->{'x'};
  68     }
  69 }
  70
  71 ### pod & usage in one
  72 sub usage {
  73     my $usage .= << '=cut';
  74 =pod
  75
  76 =head1 NAME
  77
  78     ptar - a tar-like program written in perl
  79
  80 =head1 DESCRIPTION
  81
  82     ptar is a small, tar look-alike program that uses the perl module
  83     Archive::Tar to extract, create and list tar archives.
  84
  85 =head1 SYNOPSIS
  86
  87     ptar -c [-v] [-z] [-f ARCHIVE_FILE | -] FILE FILE ...
  88     ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]
  89     ptar -t [-z] [-f ARCHIVE_FILE | -]
  90     ptar -h
  91
  92 =head1 OPTIONS
  93
  94     c   Create ARCHIVE_FILE or STDOUT (-) from FILE
  95     x   Extract from ARCHIVE_FILE or STDIN (-)
  96     t   List the contents of ARCHIVE_FILE or STDIN (-)
  97     f   Name of the ARCHIVE_FILE to use. Default is './default.tar'
  98     z   Read/Write zlib compressed ARCHIVE_FILE (not always available)
  99     v   Print filenames as they are added or extraced from ARCHIVE_FILE
 100     h   Prints this help message
 101
 102 =head1 SEE ALSO
 103
 104     tar(1), L<Archive::Tar>.
 105
 106 =cut
 107
 108     ### strip the pod directives
 109     $usage =~ s/=pod\n//g;
 110     $usage =~ s/=head1 //g;
 111
 112     ### add some newlines
 113     $usage .= $/.$/;
 114
 115     return $usage;
 116 }
 117