diff -r 6d08f4a05d93 -r 3145852acc89 releasing/cbrtools/perl/Archive/Tar.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/releasing/cbrtools/perl/Archive/Tar.pm Fri Jun 25 18:37:20 2010 +0800 @@ -0,0 +1,1242 @@ +# Copyright 1997 Calle Dybedahl. All rights reserved. +# Copyright 1998 Stephen Zander. All rights reserved. +# +# It is currently developed by Stephen Zander +# +# This library is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. + +package Archive::Tar; + +use strict; +use Carp qw(carp); +use Cwd; +use Fcntl qw(O_RDONLY O_RDWR O_WRONLY O_CREAT O_TRUNC F_DUPFD F_GETFL); +use File::Basename; +use Symbol; +require Time::Local if $^O eq "MacOS"; + +use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); +$VERSION = do { my @a=q$Name: version_0_22 $ =~ /\d+/g; sprintf "%d." . ("%02d" x $#a ),@a }; + +require Exporter; +@ISA = qw(Exporter); + +@EXPORT_OK = qw(FILE HARDLINK SYMLINK + CHARDEV BLOCKDEV DIR + FIFO SOCKET INVALID); +%EXPORT_TAGS = (filetypes => \@EXPORT_OK); + +# Check if symbolic links are available +my $symlinks = eval { readlink $0 or 1; }; +carp "Symbolic links not available" + unless $symlinks || !$^W; + +# Check if Compress::Zlib is available +my $compression = eval { + local $SIG{__DIE__}; + require Compress::Zlib; + sub Compress::Zlib::gzFile::gzseek { + my $tmp; + + $_[0]->gzread ($tmp, 4096), $_[1] -= 4096 + while ($_[1] > 4096); + + $_[0]->gzread ($tmp, $_[1]) + if $_[1]; + } + 1; +}; +carp "Compression not available" + unless $compression || !$^W; + +# Check for get* (they don't exist on WinNT) +my $fake_getpwuid; +$fake_getpwuid = "unknown" + unless eval { $_ = getpwuid (0); }; # Pointless assigment to make -w shut up + +my $fake_getgrgid; +$fake_getgrgid = "unknown" + unless eval { $_ = getgrgid (0); }; # Pointless assigment to make -w shut up + +# Automagically detect gziped files if they start with this +my $gzip_magic_number = "^(?:\037\213|\037\235)"; + +my $tar_unpack_header + = 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12'; +my $tar_pack_header + = 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12', +my $tar_header_length = 512; + +my $time_offset = ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0; + +## Subroutines to return type constants +sub FILE() { return 0; } +sub HARDLINK() { return 1; } +sub SYMLINK() { return 2; } +sub CHARDEV() { return 3; } +sub BLOCKDEV() { return 4; } +sub DIR() { return 5; } +sub FIFO() { return 6; } +sub SOCKET() { return 8; } +sub UNKNOWN() { return 9; } + +### +### Non-method functions +### + +my $error; +sub _drat { + $error = $! . ''; + return; +} + +sub error { + $error; +} + +sub set_error { + shift; + $error = "@_"; +} + +## filetype -- Determine the type value for a given file +sub filetype { + my $file = shift; + + return SYMLINK + if (-l $file); # Symlink + + return FILE + if (-f _); # Plain file + + return DIR + if (-d _); # Directory + + return FIFO + if (-p _); # Named pipe + + return SOCKET + if (-S _); # Socket + + return BLOCKDEV + if (-b _); # Block special + + return CHARDEV + if (-c _); # Character special + + return UNKNOWN; # Something else (like what?) +} + +sub _make_special_file_UNIX { + # $file is the last component of $entry->{name} + my ($entry, $file) = @_; + + if ($entry->{type} == SYMLINK) { + symlink $entry->{linkname}, $file or + $^W && carp ("Making symbolic link from ", $entry->{linkname}, + " to ", $entry->{name}, ", failed.\n"); + } + elsif ($entry->{type} == HARDLINK) { + link $entry->{linkname}, $file or + $^W && carp ("Hard linking ", $entry->{linkname}, + " to ", $entry->{name}, ", failed.\n"); + } + elsif ($entry->{type} == FIFO) { + system("mknod","$file","p") or + $^W && carp "Making fifo ", $entry->{name}, ", failed.\n"; + } + elsif ($entry->{type} == BLOCKDEV) { + system("mknod","$file","b",$entry->{devmajor},$entry->{devminor}) or + $^W && carp ("Making block device ", $entry->{name}, + " (maj=", $entry->{devmajor}, + ", min=", $entry->{devminor}, "), failed.\n"); + } + elsif ($entry->{type} == CHARDEV) { + system("mknod", "$file", "c", $entry->{devmajor}, $entry->{devminor}) or + $^W && carp ("Making block device ", $entry->{name}, + " (maj=", $entry->{devmajor}, + " ,min=", $entry->{devminor}, "), failed.\n"); + } +} + +sub _make_special_file_Win32 { + # $file is the last component of $entry->{name} + my ($entry, $file) = @_; + + if ($entry->{type} == SYMLINK) { + $^W && carp ("Making symbolic link from ", $entry->{linkname}, + " to ", $entry->{name}, ", failed.\n"); + } + elsif ($entry->{type} == HARDLINK) { + link $entry->{linkname}, $file or + $^W && carp ("Making hard link from ", $entry->{linkname}, + " to ", $entry->{name}, ", failed.\n"); + } + elsif ($entry->{type} == FIFO) { + $^W && carp "Making fifo ", $entry->{name}, ", failed.\n"; + } + elsif ($entry->{type} == BLOCKDEV) { + $^W && carp ("Making block device ", $entry->{name}, + " (maj=", $entry->{devmajor}, + ", min=", $entry->{devminor}, "), failed.\n"); + } + elsif ($entry->{type} == CHARDEV) { + $^W && carp ("Making block device ", $entry->{name}, + " (maj=", $entry->{devmajor}, + " ,min=", $entry->{devminor}, "), failed.\n"); + } +} + +*_make_special_file = $^O eq "MSWin32" ? + \&_make_special_file_Win32 : \&_make_special_file_UNIX; + +sub _munge_file { +# +# Mac path to the Unix like equivalent to be used in tar archives +# + my $inpath = $_[0]; +# +# If there are no :'s in the name at all, assume it's a single item in the +# current directory. Return it, changing any / in the name into : +# + if ($inpath !~ m,:,) { + $inpath =~ s,/,:,g; + return $inpath; + } +# +# If we now split on :, there will be just as many nulls in the list as +# there should be up requests, except if it begins with a :, where there +# will be one extra. +# + my @names = split (/:/, $inpath); + shift (@names) + if ($names[0] eq ""); + my @outname = (); +# +# Work from the end. +# + my $i; + for ($i = $#names; $i >= 0; --$i) { + if ($names[$i] eq "") { + unshift (@outname, ".."); + } + else { + $names[$i] =~ s,/,:,g; + unshift (@outname, $names[$i]); + } + } + my $netpath = join ("/", @outname); + $netpath = $netpath . "/" if ($inpath =~ /:$/); + if ($inpath !~ m,^:,) { + return "/".$netpath; + } + else { + return $netpath; + } +} + +sub _get_handle { + my ($fh, $flags, $mode); + + sysseek ($_[0], 0, 0) + or goto &_drat; + + if ($^O eq "MSWin32") { + $fh = $_[0]; + } + else { + $fh = fcntl ($_[0], F_DUPFD, 0) + or goto &_drat; + } + if ($compression && (@_ < 2 || $_[1] != 0)) { + $mode = $#_ ? (int($_[1]) > 1 ? + "wb".int($_[1]) : "wb") : "rb"; + + $fh = Compress::Zlib::gzdopen_ ($fh, $mode, 0) + or &_drat; + } + else { + $flags = fcntl ($_[0], F_GETFL, 0) & (O_RDONLY | O_WRONLY | O_RDWR); + $mode = ($flags == O_WRONLY) ? ">&=$fh" : + ($flags == O_RDONLY) ? "<&=$fh" : "+>&=$fh"; + $fh = gensym; + open ($fh, $mode) + or goto &_drat; + + $fh = bless *{$fh}{IO}, "Archive::Tar::_io"; + binmode $fh + or goto &_drat; + } + + return $fh; +} + +sub _read_tar { + my ($file, $seekable, $extract) = @_; + my $tarfile = []; + my ($head, $offset, $size); + + $file->gzread ($head, $tar_header_length) + or goto &_drat; + + if (substr ($head, 0, 2) =~ /$gzip_magic_number/o) { + $error = + "Compression not available\n"; + return undef; + } + + $offset = $tar_header_length + if $seekable; + + READLOOP: + while (length ($head) == $tar_header_length) { + my ($name, # string + $mode, # octal number + $uid, # octal number + $gid, # octal number + $size, # octal number + $mtime, # octal number + $chksum, # octal number + $type, # character + $linkname, # string + $magic, # string + $version, # two bytes + $uname, # string + $gname, # string + $devmajor, # octal number + $devminor, # octal number + $prefix) = unpack ($tar_unpack_header, $head); + my ($data, $block, $entry); + + $mode = oct $mode; + $uid = oct $uid; + $gid = oct $gid; + $size = oct $size; + $mtime = oct $mtime; + $chksum = oct $chksum; + $devmajor = oct $devmajor; + $devminor = oct $devminor; + $name = $prefix."/".$name if $prefix; + $prefix = ""; + # some broken tar-s don't set the type for directories + # so we ass_u_me a directory if the name ends in slash + $type = DIR + if $name =~ m|/$| and $type == FILE; + + last READLOOP if $head eq "\0" x 512; # End of archive + # Apparently this should really be two blocks of 512 zeroes, + # but GNU tar sometimes gets it wrong. See comment in the + # source code (tar.c) to GNU cpio. + + substr ($head, 148, 8) = " "; + if (unpack ("%16C*", $head) != $chksum) { + warn "$name: checksum error.\n"; + } + + unless ($extract || $type != FILE) { + # Always read in full 512 byte blocks + $block = $size & 0x01ff ? ($size & ~0x01ff) + 512 : $size; + if ($seekable) { + while ($block > 4096) { + $file->gzread ($data, 4096) + or goto &_drat; + $block -= 4096; + } + $file->gzread ($data, $block) + or goto &_drat + if ($block); + + # Ignore everything we've just read. + undef $data; + } else { + if ($file->gzread ($data, $block) < $block) { + $error = "Read error on tarfile."; + return undef; + } + + # Throw away any trailing garbage + substr ($data, $size) = ""; + } + } + + # Guard against tarfiles with garbage at the end + last READLOOP if $name eq ''; + + $entry = {name => $name, + mode => $mode, + uid => $uid, + gid => $gid, + size => $size, + mtime => $mtime, + chksum => $chksum, + type => $type, + linkname => $linkname, + magic => $magic, + version => $version, + uname => $uname, + gname => $gname, + devmajor => $devmajor, + devminor => $devminor, + prefix => $prefix, + offset => $offset, + data => $data}; + + if ($extract) { + _extract_file ($entry, $file); + $file->gzread ($head, 512 - ($size & 0x1ff)) + or goto &_drat + if ($size & 0x1ff && $type == FILE); + } + else { + push @$tarfile, $entry; + } + + if ($seekable) { + $offset += $tar_header_length; + $offset += ($size & 0x01ff) ? ($size & ~0x01ff) + 512 : $size + if $type == FILE; + } + $file->gzread ($head, $tar_header_length) + or goto &_drat; + } + + $file->gzclose () + unless $seekable; + + return $tarfile + unless $extract; +} + +sub _format_tar_entry { + my ($ref) = shift; + my ($tmp,$file,$prefix,$pos); + + $file = $ref->{name}; + if (length ($file) > 99) { + $pos = index $file, "/", (length ($file) - 100); + next + if $pos == -1; # Filename longer than 100 chars! + + $prefix = substr $file,0,$pos; + $file = substr $file,$pos+1; + substr ($prefix, 0, -155) = "" + if length($prefix)>154; + } + else { + $prefix=""; + } + + $tmp = pack ($tar_pack_header, + $file, + sprintf("%06o ",$ref->{mode}), + sprintf("%06o ",$ref->{uid}), + sprintf("%06o ",$ref->{gid}), + sprintf("%11o ",$ref->{size}), + sprintf("%11o ",$ref->{mtime}), + "", #checksum field - space padded by pack("A8") + $ref->{type}, + $ref->{linkname}, + $ref->{magic}, + $ref->{version} || '00', + $ref->{uname}, + $ref->{gname}, + sprintf("%6o ",$ref->{devmajor}), + sprintf("%6o ",$ref->{devminor}), + $prefix); + substr($tmp,148,7) = sprintf("%6o\0", unpack("%16C*",$tmp)); + + return $tmp; +} + +sub _format_tar_file { + my @tarfile = @_; + my $file = ""; + + foreach (@tarfile) { + $file .= _format_tar_entry $_; + $file .= $_->{data}; + $file .= "\0" x (512 - ($_->{size} & 0x1ff)) + if ($_->{size} & 0x1ff); + } + $file .= "\0" x 1024; + + return $file; +} + +sub _write_tar { + my $file = shift; + my $entry; + + foreach $entry ((ref ($_[0]) eq 'ARRAY') ? @{$_[0]} : @_) { + next + unless (ref ($entry) eq 'HASH'); + + my $src; + if ($^O eq "MacOS") { #convert back from Unix to Mac path + my @parts = split(/\//, $entry->{name}); + + $src = $parts[0] ? ":" : ""; + foreach (@parts) { + next if !$_ || $_ eq "."; + s,:,/,g; + + $_ = ":" + if ($_ eq ".."); + + $src .= ($src =~ /:$/) ? $_ : ":$_"; + } + } + else { + $src = $entry->{name}; + } + sysopen (FH, $src, O_RDONLY) + && binmode (FH) + or next + unless $entry->{type} != FILE || $entry->{data}; + + $file->gzwrite (_format_tar_entry ($entry)) + or goto &_drat; + + if ($entry->{type} == FILE) { + if ($entry->{data}) { + $file->gzwrite ($entry->{data}) + or goto &_drat; + } + else { + my $size = $entry->{size}; + my $data; + while ($size >= 4096) { + sysread (FH, $data, 4096) + && $file->gzwrite ($data) + or goto &_drat; + $size -= 4096; + } + sysread (FH, $data, $size) + && $file->gzwrite ($data) + or goto &_drat + if $size; + close FH; + } + $file->gzwrite ("\0" x (512 - ($entry->{size} & 511))) + or goto &_drat + if ($entry->{size} & 511); + } + } + + $file->gzwrite ("\0" x 1024) + and !$file->gzclose () + or goto &_drat; +} + +sub _add_file { + my $file = shift; + my ($mode,$nlnk,$uid,$gid,$rdev,$size,$mtime,$type,$linkname); + + if (($mode,$nlnk,$uid,$gid,$rdev,$size,$mtime) = (lstat $file)[2..7,9]) { + $linkname = ""; + $type = filetype ($file); + + $linkname = readlink $file + if ($type == SYMLINK) && $symlinks; + + $file = _munge_file ($file) + if ($^O eq "MacOS"); + + return +{name => $file, + mode => $mode, + uid => $uid, + gid => $gid, + size => $size, + mtime => (($mtime - $time_offset) | 0), + chksum => " ", + type => $type, + linkname => $linkname, + magic => "ustar", + version => "00", + # WinNT protection + uname => ($fake_getpwuid || scalar getpwuid($uid)), + gname => ($fake_getgrgid || scalar getgrgid ($gid)), + devmajor => 0, # We don't handle this yet + devminor => 0, # We don't handle this yet + prefix => "", + data => undef, + }; + } +} + +sub _extract_file { + my ($entry, $handle) = @_; + my ($file, $cwd, @path); + + # For the moment, we assume that all paths in tarfiles + # are given according to Unix standards. + # Which they *are*, according to the tar format spec! + @path = split(/\//,$entry->{name}); + $path[0] = '/' unless defined $path[0]; # catch absolute paths + $file = pop @path; + $file =~ s,:,/,g + if $^O eq "MacOS"; + $cwd = cwd + if @path; + foreach (@path) { + if ($^O eq "MacOS") { + s,:,/,g; + $_ = "::" if $_ eq ".."; + $_ = ":" if $_ eq "."; + } + if (-e $_ && ! -d _) { + $^W && carp "$_ exists but is not a directory!\n"; + next; + } + mkdir $_, 0777 unless -d _; + chdir $_; + } + + if ($entry->{type} == FILE) { # Ordinary file + sysopen (FH, $file, O_WRONLY|O_CREAT|O_TRUNC) + and binmode FH + or goto &_drat; + + if ($handle) { + my $size = $entry->{size}; + my $data; + while ($size > 4096) { + $handle->gzread ($data, 4096) + and syswrite (FH, $data, length $data) + or goto &_drat; + $size -= 4096; + } + $handle->gzread ($data, $size) + and syswrite (FH, $data, length $data) + or goto &_drat + if ($size); + } + else { + syswrite FH, $entry->{data}, $entry->{size} + or goto &_drat + } + close FH + or goto &_drat + } + elsif ($entry->{type} == DIR) { # Directory + goto &_drat + if (-e $file && ! -d $file); + + mkdir $file,0777 + unless -d $file; + } + elsif ($entry->{type} == UNKNOWN) { + $error = "unknown file type: $_->{type}"; + return undef; + } + else { + _make_special_file ($entry, $file); + } + utime time, $entry->{mtime} + $time_offset, $file; + + # We are root, and chown exists + chown $entry->{uid}, $entry->{gid}, $file + if ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32"); + + # chmod is done last, in case it makes file readonly + # (this accomodates DOSish OSes) + chmod $entry->{mode}, $file; + chdir $cwd + if @path; +} + +### +### Methods +### + +## +## Class methods +## + +# Perfom the equivalent of ->new()->add_files(), ->write() without the +# overhead of maintaining an Archive::Tar object. +sub create_archive { + my ($handle, $file, $compress) = splice (@_, 0, 3); + + if ($compress && !$compression) { + $error = "Compression not available.\n"; + return undef; + } + + $handle = gensym; + open $handle, ref ($file) ? ">&". fileno ($file) : ">" . $file + and binmode ($handle) + or goto &_drat; + + _write_tar (_get_handle ($handle, int ($compress)), + map {_add_file ($_)} @_); +} + +# Perfom the equivalent of ->new()->list_files() without the overhead +# of maintaining an Archive::Tar object. +sub list_archive { + my ($handle, $file, $fields) = @_; + + $handle = gensym; + open $handle, ref ($file) ? "<&". fileno ($file) : "<" . $file + and binmode ($handle) + or goto &_drat; + + my $data = _read_tar (_get_handle ($handle), 1); + + return map {my %h; @h{@$fields} = @$_{@$fields}; \%h} @$data + if (ref $fields eq 'ARRAY' + && (@$fields > 1 || $fields->[0] ne 'name')); + + return map {$_->{name}} @$data; +} + +# Perform the equivalen of ->new()->extract() without the overhead of +# maintaining an Archive::Tar object. +sub extract_archive { + my ($handle, $file) = @_; + + $handle = gensym; + open $handle, ref ($file) ? "<&". fileno ($file) : "<" . $file + and binmode ($handle) + or goto &_drat; + + _read_tar (_get_handle ($handle), 0, 1); +} + +# Constructor. Reads tarfile if given an argument that's the name of a +# readable file. +sub new { + my ($class, $file) = @_; + + my $self = bless {}, $class; + + $self->read ($file) + if defined $file; + + return $self; +} + + +# Read a tarfile. Returns number of component files. +sub read { + my ($self, $file) = @_; + + $self->{_data} = []; + + $self->{_handle} = gensym; + open $self->{_handle}, ref ($file) ? "<&". fileno ($file) : "<" . $file + and binmode ($self->{_handle}) + or goto &_drat; + + $self->{_data} = _read_tar (_get_handle ($self->{_handle}), + sysseek $self->{_handle}, 0, 1); + return scalar @{$self->{_data}}; +} + +# Write a tar archive to file +sub write { + my ($self, $file, $compress) = @_; + + return _format_tar_file (@{$self->{_data}}) + unless (@_ > 1); + + my $handle = gensym; + open $handle, ref ($file) ? ">&". fileno ($file) : ">" . $file + and binmode ($handle) + or goto &_drat; + + if ($compress && !$compression) { + $error = "Compression not available.\n"; + return undef; + } + + _write_tar (_get_handle ($handle, $compress || 0), $self->{_data}); +} + +# Add files to the archive. Returns number of successfully added files. +sub add_files { + my $self = shift; + my ($counter, $file, $entry); + + foreach $file (@_) { + if ($entry = _add_file ($file)) { + push (@{$self->{'_data'}}, $entry); + ++$counter; + } + } + + return $counter; +} + +# Add data as a file +sub add_data { + my ($self, $file, $data, $opt) = @_; + my $ref = {}; + my ($key); + + if($^O eq "MacOS") { + $file = _munge_file($file); + } + $ref->{'data'} = $data; + $ref->{name} = $file; + $ref->{mode} = 0666 & (0777 - umask); + $ref->{uid} = $>; + $ref->{gid} = (split(/ /,$)))[0]; # Yuck + $ref->{size} = length $data; + $ref->{mtime} = ((time - $time_offset) | 0), + $ref->{chksum} = " "; # Utterly pointless + $ref->{type} = FILE; # Ordinary file + $ref->{linkname} = ""; + $ref->{magic} = "ustar"; + $ref->{version} = "00"; + # WinNT protection + $ref->{uname} = $fake_getpwuid || getpwuid ($>); + $ref->{gname} = $fake_getgrgid || getgrgid ($ref->{gid}); + $ref->{devmajor} = 0; + $ref->{devminor} = 0; + $ref->{prefix} = ""; + + if ($opt) { + foreach $key (keys %$opt) { + $ref->{$key} = $opt->{$key} + } + } + + push (@{$self->{'_data'}}, $ref); + return 1; +} + +sub rename { + my ($self) = shift; + my $entry; + + foreach $entry (@{$self->{_data}}) { + @{$self->{_data}} = grep {$_->{name} ne $entry} @{$self->{'_data'}}; + } + return $self; +} + +sub remove { + my ($self) = shift; + my $entry; + + foreach $entry (@_) { + @{$self->{_data}} = grep {$_->{name} ne $entry} @{$self->{'_data'}}; + } + return $self; +} + +# Get the content of a file +sub get_content { + my ($self, $file) = @_; + my ($entry, $data); + + foreach $entry (@{$self->{_data}}) { + next + unless $entry->{name} eq $file; + + return $entry->{data} + unless $entry->{offset}; + + my $handle = _get_handle ($self->{_handle}); + $handle->gzseek ($entry->{offset}, 0) + or goto &_drat; + + $handle->gzread ($data, $entry->{size}) != -1 + or goto &_drat; + + return $data; + } + + return; +} + +# Replace the content of a file +sub replace_content { + my ($self, $file, $content) = @_; + my $entry; + + foreach $entry (@{$self->{_data}}) { + next + unless $entry->{name} eq $file; + + $entry->{data} = $content; + $entry->{size} = length $content; + $entry->{offset} = undef; + return 1; + } +} + +# Write a single (probably) file from the in-memory archive to disk +sub extract { + my $self = shift; + my @files = @_; + my ($file, $entry); + + @files = list_files ($self) unless @files; + foreach $entry (@{$self->{_data}}) { + my $cnt = 0; + foreach $file (@files) { + ++$cnt, next + unless $entry->{name} eq $file; + my $handle = $entry->{offset} && _get_handle ($self->{_handle}); + $handle->gzseek ($entry->{offset}, 0) + or goto &_drat + if $handle; + _extract_file ($entry, $handle); + splice (@_, $cnt, 1); + last; + } + last + unless @_; + } + $self; +} + + +# Return a list names or attribute hashes for all files in the +# in-memory archive. +sub list_files { + my ($self, $fields) = @_; + + return map {my %h; @h{@$fields} = @$_{@$fields}; \%h} @{$self->{'_data'}} + if (ref $fields eq 'ARRAY' && (@$fields > 1 || $fields->[0] ne 'name')); + + return map {$_->{name}} @{$self->{'_data'}} +} + + +### Standard end of module :-) +1; + +# +# Sub-package to hide I/O differences between compressed & +# uncompressed archives. +# +# Yes, I could have used the IO::* class hierarchy here, but I'm +# trying to minimise the necessity for non-core modules on perl5 +# environments < 5.004 + +package Archive::Tar::_io; + +sub gzseek { + sysseek $_[0], $_[1], $_[2]; +} + +sub gzread { + sysread $_[0], $_[1], $_[2]; +} + +sub gzwrite { + syswrite $_[0], $_[1], length $_[1]; +} + +sub gzclose { + !close $_[0]; +} + +1; + +__END__ + +=head1 NAME + +Tar - module for manipulation of tar archives. + +=head1 SYNOPSIS + + use Archive::Tar; + + Archive::Tar->create_archive ("my.tar.gz", 9, "/this/file", "/that/file"); + print join "\n", Archive::Tar->list_archive ("my.tar.gz"), ""; + + $tar = Archive::Tar->new(); + $tar->read("origin.tar.gz",1); + $tar->add_files("file/foo.c", "file/bar.c"); + $tar->add_data("file/baz.c","This is the file contents"); + $tar->write("files.tar"); + +=head1 DESCRIPTION + +This is a module for the handling of tar archives. + +Archive::Tar provides an object oriented mechanism for handling tar +files. It provides class methods for quick and easy files handling +while also allowing for the creation of tar file objects for custom +manipulation. If you have the Compress::Zlib module installed, +Archive::Tar will also support compressed or gzipped tar files. + +=head2 Class Methods + +The class methods should be sufficient for most tar file interaction. + +=over 4 + +=item create_archive ($file, $compression, @filelist) + +Creates a tar file from the list of files provided. The first +argument can either be the name of the tar file to create or a +reference to an open file handle (e.g. a GLOB reference). + +The second argument specifies the level of compression to be used, if +any. Compression of tar files requires the installation of the +Compress::Zlib module. Specific levels or compression may be +requested by passing a value between 2 and 9 as the second argument. +Any other value evaluating as true will result in the default +compression level being used. + +The remaining arguments list the files to be included in the tar file. +These files must all exist. Any files which don\'t exist or can\'t be +read are silently ignored. + +If the archive creation fails for any reason, C will +return undef. Please use the C method to find the cause of the +failure. + +=item list_archive ($file, ['property', 'property',...]) + +=item list_archive ($file) + +Returns a list of the names of all the files in the archive. The +first argument can either be the name of the tar file to create or a +reference to an open file handle (e.g. a GLOB reference). + +If C is passed an array reference as its second +argument it returns a list of hash references containing the requested +properties of each file. The following list of properties is +supported: name, size, mtime (last modified date), mode, uid, gid, +linkname, uname, gname, devmajor, devminor, prefix. + +Passing an array reference containing only one element, 'name', is +special cased to return a list of names rather than a list of hash +references. + +=item extract_archive ($file) + +Extracts the contents of the tar file. The first argument can either +be the name of the tar file to create or a reference to an open file +handle (e.g. a GLOB reference). All relative paths in the tar file will +be created underneath the current working directory. + +If the archive extraction fails for any reason, C +will return undef. Please use the C method to find the cause +of the failure. + +=item new ($file) + +=item new () + +Returns a new Tar object. If given any arguments, C calls the +C method automatically, parsing on the arguments provided L. + +If C is invoked with arguments and the read method fails for +any reason, C returns undef. + +=back + +=head2 Instance Methods + +=over 4 + +=item read ($ref, $compressed) + +Read the given tar file into memory. The first argument can either be +the name of a file or a reference to an already open file handle (e.g. a +GLOB reference). The second argument indicates whether the file +referenced by the first argument is compressed. + +The second argument is now optional as Archive::Tar will automatically +detect compressed archives. + +The C will I any previous content in C<$tar>! + +=item add_files(@filenamelist) + +Takes a list of filenames and adds them to the in-memory archive. On +MacOS, the path to the file is automatically converted to a Unix like +equivalent for use in the archive, and the file\'s modification time +is converted from the MacOS epoch to the Unix epoch. So tar archives +created on MacOS with B can be read both with I on +Unix and applications like I or I on MacOS. +Be aware that the file\'s type/creator and resource fork will be lost, +which is usually what you want in cross-platform archives. + +=item add_data ($filename, $data, $opthashref) + +Takes a filename, a scalar full of data and optionally a reference to +a hash with specific options. Will add a file to the in-memory +archive, with name C<$filename> and content C<$data>. Specific +properties can be set using C<$opthashref>, The following list of +properties is supported: name, size, mtime (last modified date), mode, +uid, gid, linkname, uname, gname, devmajor, devminor, prefix. (On +MacOS, the file\'s path and modification times are converted to Unix +equivalents.) + +=item remove (@filenamelist) + +Removes any entries with names matching any of the given filenames +from the in-memory archive. String comparisons are done with C. + +=item write ($file, $compressed) + +Write the in-memory archive to disk. The first argument can either be +the name of a file or a reference to an already open file handle (be a +GLOB reference). If the second argument is true, the module will use +Compress::Zlib to write the file in a compressed format. If +Compress:Zlib is not available, the C method will fail. +Specific levels of compression can be chosen by passing the values 2 +through 9 as the second parameter. + +If no arguments are given, C returns the entire formatted +archive as a string, which could be useful if you\'d like to stuff the +archive into a socket or a pipe to gzip or something. This +functionality may be deprecated later, however, as you can also do +this using a GLOB reference for the first argument. + +=item extract(@filenames) + +Write files whose names are equivalent to any of the names in +C<@filenames> to disk, creating subdirectories as necessary. This +might not work too well under VMS. Under MacPerl, the file\'s +modification time will be converted to the MacOS zero of time, and +appropriate conversions will be done to the path. However, the length +of each element of the path is not inspected to see whether it\'s +longer than MacOS currently allows (32 characters). + +If C is called without a list of file names, the entire +contents of the archive are extracted. + +=item list_files(['property', 'property',...]) + +=item list_files() + +Returns a list of the names of all the files in the archive. + +If C is passed an array reference as its first argument +it returns a list of hash references containing the requested +properties of each file. The following list of properties is +supported: name, size, mtime (last modified date), mode, uid, gid, +linkname, uname, gname, devmajor, devminor, prefix. + +Passing an array reference containing only one element, 'name', is +special cased to return a list of names rather than a list of hash +references. + +=item get_content($file) + +Return the content of the named file. + +=item replace_content($file,$content) + +Make the string $content be the content for the file named $file. + +=back + +=head1 CHANGES + +=over 4 + +=item Version 0.20 + +Added class methods for creation, extraction and listing of tar files. +No longer maintain a complete copy of the tar file in memory. Removed +the C method. + +=item Version 0.10 + +Numerous changes. Brought source under CVS. All changes now recorded +in ChangeLog file in distribution. + +=item Version 0.08 + +New developer/maintainer. Calle has carpal-tunnel syndrome and cannot +type a great deal. Get better as soon as you can, Calle. + +Added proper support for MacOS. Thanks to Paul J. Schinder +. + +=item Version 0.071 + +Minor release. + +Arrange to chmod() at the very end in case it makes the file read only. +Win32 is actually picky about that. + +SunOS 4.x tar makes tarfiles that contain directory entries that +don\'t have typeflag set properly. We use the trailing slash to +recognise directories in such tar files. + +=item Version 0.07 + +Fixed (hopefully) broken portability to MacOS, reported by Paul J. +Schinder at Goddard Space Flight Center. + +Fixed two bugs with symlink handling, reported in excellent detail by +an admin at teleport.com called Chris. + +Primitive tar program (called ptar) included with distribution. Usage +should be pretty obvious if you\'ve used a normal tar program. + +Added methods get_content and replace_content. + +Added support for paths longer than 100 characters, according to +POSIX. This is compatible with just about everything except GNU tar. +Way to go, GNU tar (use a better tar, or GNU cpio). + +NOTE: When adding files to an archive, files with basenames longer + than 100 characters will be silently ignored. If the prefix part + of a path is longer than 155 characters, only the last 155 + characters will be stored. + +=item Version 0.06 + +Added list_files() method, as requested by Michael Wiedman. + +Fixed a couple of dysfunctions when run under Windows NT. Michael +Wiedmann reported the bugs. + +Changed the documentation to reflect reality a bit better. + +Fixed bug in format_tar_entry. Bug reported by Michael Schilli. + +=item Version 0.05 + +Quoted lots of barewords to make C stop complaining under +perl version 5.003. + +Ties to L put in. Will warn if it isn\'t available. + +$tar->write() with no argument now returns the formatted archive. + +=item Version 0.04 + +Made changes to write_tar so that Solaris tar likes the resulting +archives better. + +Protected the calls to readlink() and symlink(). AFAIK this module +should now run just fine on Windows NT. + +Add method to write a single entry to disk (extract) + +Added method to add entries entirely from scratch (add_data) + +Changed name of add() to add_file() + +All calls to croak() removed and replaced with returning undef and +setting Tar::error. + +Better handling of tarfiles with garbage at the end. + +=head1 COPYRIGHT + +Archive::Tar is Copyright 1997 Calle Dybedahl. All rights reserved. + Copyright 1998 Stephen Zander. All rights reserved. + +It is currently developed by Stephen Zander + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut