"Fossies" - the Fresh Open Source Software Archive

Member "Archive-Tar-2.38/bin/ptar" (25 Jun 2020, 3470 Bytes) of package /linux/privat/Archive-Tar-2.38.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "ptar": 2.36_vs_2.38.

    1 #!/usr/bin/perl
    2 use strict;
    3 use warnings;
    4 
    5 BEGIN { pop @INC if $INC[-1] eq '.' }
    6 use File::Find;
    7 use Getopt::Std;
    8 use Archive::Tar;
    9 use 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;
   16 my $opts = {};
   17 getopts('Ddcvzthxf:ICT:', $opts) or die usage();
   18 
   19 ### show the help message ###
   20 die usage() if $opts->{h};
   21 
   22 ### enable debugging (undocumented feature)
   23 local $Archive::Tar::DEBUG                  = 1 if $opts->{d};
   24 
   25 ### enable insecure extracting.
   26 local $Archive::Tar::INSECURE_EXTRACT_MODE  = 1 if $opts->{I};
   27 
   28 ### sanity checks ###
   29 unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {
   30     die "You need exactly one of 'x', 't' or 'c' options: " . usage();
   31 }
   32 
   33 my $compress    = $opts->{z} ? 1 : 0;
   34 my $verbose     = $opts->{v} ? 1 : 0;
   35 my $file        = $opts->{f} ? $opts->{f} : 'default.tar';
   36 my $tar         = Archive::Tar->new();
   37 
   38 if( $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
   92 sub usage {
   93     my $usage .= << '=cut';
   94 =pod
   95 
   96 =head1 NAME
   97 
   98 ptar - a tar-like program written in perl
   99 
  100 =head1 DESCRIPTION
  101 
  102 ptar is a small, tar look-alike program that uses the perl module
  103 Archive::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 
  127 L<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