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