#!/usr/bin/perl =begin metadata Name: tar Description: manipulate tape archives Author: License: =end metadata =cut use strict; use File::Basename qw(basename); use Getopt::Std; use IO::File; use constant EX_SUCCESS => 0; use constant EX_FAILURE => 1; my $Program = basename($0); my %opt; getopts('ctxvmf:Zz', \%opt) or do { warn "usage: tar {-tx} [-mvZz] [-f archive] [file ...]\n"; exit EX_FAILURE; }; sub fatal { my $msg = shift; warn "$Program: $msg\n"; exit EX_FAILURE; } sub read_header { my $read = shift; my $buf = ''; my $err = &$read($buf,512); fatal("Cannot read:$err") if $err; if (length($buf) == 512) { return undef if $buf =~ /^\0{512}/; my %info; ($info{'archname'}, $info{'mode'}, $info{'uid'}, $info{'gid'}, $info{'size'}, $info{'mtime'}, $info{'chksum'}, $info{'linkflag'}, $info{'arch_linkname'}, $info{'magic'}, $info{'uname'}, $info{'gname'}, $info{'devmajor'}, $info{'devminor'}) = unpack('A100A8A8A8A12A12A8A1A100A8A32A32A8A8',$buf); foreach my $key (qw(archname arch_linkname magic uname gname)) { $info{$key} =~ s/\0(?:.|\n)*$//; } foreach my $key (qw(mode uid gid size mtime chksum)) { my $val = $info{$key}; if ($val =~ /^\s*([0-7]+)$/) { $info{$key} = oct($1); } else { $val =~ s/([^\x20-\x7f])/sprintf('\%03o',unpack('C',$1))/eg; warn "$key is '$val'\n"; } } return \%info; } else { fatal("size is " . length($buf) . " not 512") if (length($buf)); } return undef; } sub read_data { my ($read,$hdr,$fh) = @_; my $size = $hdr->{'size'}; my $blocks = int(($size+511)/512); my $first = 1; while ($blocks--) { my $buf = ''; my $err = &$read($buf,512); fatal("Cannot read: $err") if $err; my $len = length($buf); if ($len != 512) { fatal("Size is $len not 512: $!"); } if ($fh) { $buf = substr($buf,0,$size) if ($size < 512); if ($first) { if ($buf =~ /([^\r\n\s!-~])/) { warn "Binary due to $1 (".ord($1).")\n"; binmode($fh) } $first = 0; } print $fh $buf; $size -= length($buf); } } } sub skip_entry { my ($read,$hdr) = @_; read_data($read,$hdr,undef); } sub make_dir { my $name = shift; make_dir($1) if ($name =~ m#^(.*)/[^/]+#); unless (-d $name) { mkdir($name, 0777) or fatal("Cannot create directory '$name': $!"); warn "mkdir $name\n" if ($opt{'v'}); } } sub extract_entry { my ($read,$hdr) = @_; my $name = $hdr->{'archname'}; if ($opt{'m'}) { $name =~ s/([A-Z])/_\l$1/g; } make_dir($1) if ($name =~ m#^(.*)/[^/]+#); if (-f $name && !-w $name) { chmod(0666,$name); unlink($name) } my $fh = IO::File->new($name, 'w') unless ($name =~ m#/$#); warn "Cannot open $name:$!" unless ($fh); read_data($read,$hdr,$fh); if ($fh) { my $t = $hdr->{'mtime'}; $fh->close; utime($t,$t,$name); chmod($hdr->{'mode'} & 0777,$name); } } sub mode_str { my $mode = shift; my $str = ''; $str .= ($mode & 4) ? 'r' : '-'; $str .= ($mode & 2) ? 'w' : '-'; $str .= ($mode & 1) ? 'x' : '-'; } sub list_entry { my $hdr = shift; my $mode = $hdr->{'mode'}; my $str = '-'; # Needs to be 'd', 'l', 'c', 'b' etc. $str .= mode_str(($mode >> 6) & 7); $str .= mode_str(($mode >> 3) & 7); $str .= mode_str(($mode >> 0) & 7); $str .= sprintf(" %d/%d %12d ",$hdr->{'uid'},$hdr->{'gid'},$hdr->{'size'}); my $t = localtime($hdr->{'mtime'}); $t =~ s/^\w+\s//; $t =~ s/(\d+:\d+):\d+/$1/; $str .= $t; $str .= ' '; $str .= $hdr->{'archname'}; return $str; } if ($opt{'c'}) { fatal('-c not implemeted'); } else { my $fh; my $read; my $hdr; $| = 1; if (defined $opt{'f'}) { if ($opt{'f'} eq '-') { $fh = *STDIN; } else { fatal("Cannot open '$opt{'f'}': is a directory") if (-d $opt{'f'}); open($fh, '<', $opt{'f'}) or fatal("Cannot open $opt{'f'}: $!"); } } else { fatal("No archive file specified; -f must be set"); } binmode $fh; if ($opt{'z'} || $opt{'Z'}) { eval { require Compress::Zlib } or fatal('Compress::Zlib not found'); Compress::Zlib->import; my $gz = gzopen($fh, 'rb') or fatal("Cannot gzopen: $Compress::Zlib::gzerrno"); $read = sub { $gz->gzread($_[0],$_[1]) < 0 ? $Compress::Zlib::gzerrno : 0 }; } else { $read = sub { read($fh, $_[0], $_[1]) < 0 ? $! : 0 }; } while ($hdr = read_header($read)) { if ($opt{'x'}) { extract_entry($read,$hdr); } else { skip_entry($read,$hdr); } if ($opt{'v'}) { print list_entry($hdr),"\n" } elsif ($opt{'t'}) { print $hdr->{'archname'},"\n"; } } } exit EX_SUCCESS; __END__ =encoding utf8 =head1 NAME tar - manipulate tape archives