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