1188 lines
38 KiB
Perl
1188 lines
38 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Tar
|
|
# Author: Scott Beck
|
|
# CVS Info :
|
|
# $Id: Tar.pm,v 1.54 2005/03/09 01:26:17 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description: A general purpose taring and untaring module.
|
|
#
|
|
|
|
package GT::Tar;
|
|
# ==================================================================
|
|
# Pragmas
|
|
use vars qw/$DEBUG $ERRORS $FAKE_GETPWUID $HAVE_GZIP $FAKE_GETGRGID $FH/;
|
|
use strict;
|
|
|
|
# System modules
|
|
use Fcntl;
|
|
use Symbol qw/gensym/;
|
|
|
|
use constants
|
|
BLOCK => 4096,
|
|
|
|
# 'Type' constants - these are the actual chars, not the char values
|
|
FILE => 0,
|
|
HARDLINK => 1,
|
|
SYMLINK => 2,
|
|
CHARDEV => 3,
|
|
BLOCKDEV => 4,
|
|
DIR => 5,
|
|
FIFO => 6,
|
|
SOCKET => 8,
|
|
UNKNOWN => 9,
|
|
LONGNAME => 'L',
|
|
|
|
FORMAT_HEADER_PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12',
|
|
FORMAT_HEADER_UNPACK => 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155';
|
|
|
|
# Internal modules
|
|
use GT::Base;
|
|
|
|
# Globals
|
|
$DEBUG = 0;
|
|
@GT::Tar::ISA = qw{GT::Base};
|
|
|
|
$ERRORS = {
|
|
OPEN => "Could not open '%s': %s",
|
|
READ => "There was an error reading from '%s'. Expected to read %s bytes, but only got %s",
|
|
BINMODE => "Could not binmode '%s': %s",
|
|
BADARGS => "Bad arguments passed to %s: %s",
|
|
CHECKSUM => "Checksum error parsing tar file. Most likely this is a corrupt tar.\nHeader: %s\nChecksum: %s\nFile: %s\n",
|
|
NOBODY => "File '%s' has no body!",
|
|
CANTFIND => "Unable to find a file named '%s' in tar archive",
|
|
CHMOD => "Could not chmod '%s': %s",
|
|
DIRFILE => "Unable to create directory: '%s' exists and is a file",
|
|
MKDIR => "Could not mkdir '%s': %s",
|
|
RENAME => "Unable to rename temporary file '%s' to '%s': %s",
|
|
NOGZIP => "Compress::Zlib module is required to work with .tar.gz files"
|
|
};
|
|
|
|
$FAKE_GETPWUID = "unknown" if ($^O eq 'MSWin32');
|
|
$FAKE_GETGRGID = "unknown" if ($^O eq 'MSWin32');
|
|
$HAVE_GZIP = eval { local $SIG{__DIE__}; require Compress::Zlib; 1; } ? 1 : 0;
|
|
$FH = 0;
|
|
|
|
sub new {
|
|
# ------------------------------------------------------------------------------
|
|
# GT::Tar->new('/path/to/new/tar.tar');
|
|
# --------------------------------------
|
|
# Constructor for GT::Tar. Call this method to create a new archive.
|
|
# To do anything with an existing archive call GT::Tar->open.
|
|
#
|
|
my $this = shift;
|
|
my $class = ref $this || $this;
|
|
my $self = bless {}, $class;
|
|
|
|
my $opt = {};
|
|
if (@_ == 1) { $opt->{io} = shift }
|
|
else {
|
|
$opt = $self->common_param(@_);
|
|
}
|
|
|
|
$self->{_debug} = exists $opt->{debug} ? $opt->{debug} : $DEBUG;
|
|
$opt->{io} or return $self->fatal(BADARGS => "new()", "No output archive passed in");
|
|
|
|
$opt->{io} =~ /^(.+)$/;
|
|
$self->{clean} = exists $opt->{clean} ? $opt->{clean} : 1;
|
|
my $file = $1;
|
|
|
|
# If it's a gz file, store the name in gz_file, and work off a temp file.
|
|
if ($file =~ /\.t?gz$/) {
|
|
$HAVE_GZIP or return $self->warn('NOGZIP');
|
|
require GT::TempFile;
|
|
my $tmpfile = new GT::TempFile;
|
|
$self->{file} = $$tmpfile; # Filename of ungzipped tar file.
|
|
$self->{gz_file} = $file; # Filename of gzipped file.
|
|
$self->{tmp_file} = $tmpfile; # Don't unlink it till the object is destroyed.
|
|
}
|
|
else {
|
|
$self->{file} = $file;
|
|
}
|
|
$self->{io} = gensym;
|
|
sysopen $self->{io}, $self->{file}, O_CREAT|O_TRUNC|O_RDWR or return $self->fatal(OPEN => $self->{file}, "$!");
|
|
binmode $self->{io} or return $self->fatal(BINMODE => $self->{file}, "$!");
|
|
select((select($self->{io}), $| = 1)[0]);
|
|
|
|
$self->{parsed} = 0;
|
|
$self->{new_tar} = 1;
|
|
return $self;
|
|
}
|
|
|
|
sub open {
|
|
# ------------------------------------------------------------------------------
|
|
# GT::Tar->open('/path/to/tar.tar');
|
|
# -----------------------------------
|
|
# Opens the tar specified by the first argument for reading and calls
|
|
# $obj->parse to parse the contents.
|
|
# Returns a new GT::Tar object.
|
|
#
|
|
my $this = shift;
|
|
my $class = ref $this || $this;
|
|
my $self = bless {}, $class;
|
|
|
|
my $opt = {};
|
|
if (@_ == 1) { $opt->{io} = shift }
|
|
else {
|
|
$opt = $self->common_param(@_);
|
|
}
|
|
|
|
$self->{_debug} = exists $opt->{debug} ? $opt->{debug} : $DEBUG;
|
|
$opt->{io} or return $self->fatal(BADARGS => "open()", "No input archive passed in");
|
|
|
|
$opt->{io} =~ /^(.+)$/;
|
|
my $file = $1;
|
|
|
|
# If it's a gz file, uncompress it to a temp file and work off that.
|
|
if ($file =~ /\.t?gz$/) {
|
|
$HAVE_GZIP or return $self->warn('NOGZIP');
|
|
require GT::TempFile;
|
|
my $tmpfile = new GT::TempFile;
|
|
$self->debug("Decompressing gz file to temp file: $$tmpfile") if ($self->{_debug});
|
|
open(FH, "> $$tmpfile") or return $self->warn(OPEN => $$tmpfile, "$!");
|
|
binmode FH;
|
|
my $gz = Compress::Zlib::gzopen($file, 'rb') or return $self->warn(OPEN => $file, $Compress::Zlib::gzerrno);
|
|
my $line;
|
|
while ($gz->gzreadline($line)) {
|
|
print FH $line;
|
|
}
|
|
close FH;
|
|
|
|
$gz->gzclose;
|
|
$self->{file} = $$tmpfile; # Filename of open ungzipped tar file.
|
|
$self->{gz_file} = $file; # Filename of original gzipped file.
|
|
$self->{tmp_file} = $tmpfile; # Don't unlink it till the object is destroyed.
|
|
}
|
|
else {
|
|
$self->{file} = $file;
|
|
}
|
|
$self->{io} = gensym;
|
|
$self->debug("Opening $file") if ($self->{_debug});
|
|
sysopen $self->{io}, $self->{file}, O_RDONLY or return $self->warn(OPEN => $self->{file}, "$!");
|
|
binmode $self->{io} or return $self->warn(BINMODE => $self->{file} => "$!");
|
|
select((select($self->{io}), $| = 1)[0]);
|
|
|
|
my $parts = $self->parse;
|
|
defined $parts or return;
|
|
$self->{new_tar} = 0;
|
|
return $self;
|
|
}
|
|
|
|
sub close_tar {
|
|
# ------------------------------------------------------------------------------
|
|
# Closes the tar file.
|
|
#
|
|
my $self = shift;
|
|
$self->{parsed} = 0;
|
|
close $self->{io} if ($self->{io} and fileno($self->{io}));
|
|
}
|
|
sub DESTROY { my $self = shift; $self->close_tar; }
|
|
|
|
sub parse {
|
|
# ------------------------------------------------------------------------------
|
|
# Modified from code in Archive::Tar
|
|
# Untar a file, specified by first argument to directories, specified in third
|
|
# argument, and set the path to perl, specified in second argument, to all .pl
|
|
# and .cgi files
|
|
#
|
|
my $self = shift;
|
|
$self->{parts} = [];
|
|
my ($head, $msg);
|
|
my $tar = $self->{io}
|
|
or return $self->fatal(BADARGS => "parse", "An IO must be defined to parse");
|
|
|
|
seek($tar, 0, 0);
|
|
my $longname;
|
|
READLOOP: while (read($tar, $head, 512) and length($head) == 512) {
|
|
# End of archive
|
|
last READLOOP if $head eq "\0" x 512;
|
|
|
|
# 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.
|
|
|
|
my $file = GT::Tar::Parts->format_read($head);
|
|
|
|
$self->debug("Looking at $file->{name}") if ($self->{_debug});
|
|
|
|
substr($head, 148, 8) = " ";
|
|
if ($file->{type} eq FILE) {
|
|
if (unpack("%16C*", $head) != $file->{chksum}) {
|
|
return $self->warn(CHECKSUM => $head, $file->{chksum}, $file->{name});
|
|
}
|
|
}
|
|
|
|
if ($file->{type} eq FILE || $file->{type} eq LONGNAME) {
|
|
# Find the start and the end positions in the tar file for the body of the tar
|
|
# part
|
|
my $start = tell $tar;
|
|
seek($tar, $file->{size}, 1);
|
|
$file->body([$tar, $start]);
|
|
|
|
# Seek off trailing garbage.
|
|
my $block = $file->{size} & 0x01ff ? ($file->{size} & ~0x01ff) + 512 : $file->{size};
|
|
my $to_read = $block - $file->{size};
|
|
if ($to_read) { seek($tar, $to_read, 1) }
|
|
}
|
|
|
|
if ($longname and $file->{type} ne LONGNAME) {
|
|
my $filename = $longname->body_as_string;
|
|
$filename =~ s|\0.*||s;
|
|
$file->name($filename);
|
|
}
|
|
|
|
$file->name(_clean($file->name)) if $self->{clean};
|
|
|
|
# Guard against tarfiles with garbage at the end
|
|
last READLOOP if $file->{name} eq '';
|
|
|
|
if ($file->{type} eq LONGNAME) {
|
|
$longname = $file;
|
|
}
|
|
else {
|
|
$longname = undef;
|
|
push(@{$self->{parts}}, $file);
|
|
}
|
|
}
|
|
$self->{parsed} = 1;
|
|
seek($tar, 0, 0);
|
|
return wantarray ? @{$self->{parts}} : $self->{parts};
|
|
}
|
|
|
|
sub _clean {
|
|
# -----------------------------------------------------------------------------
|
|
# Sanitises a path, removing anything up to a .. path component, and removing
|
|
# any leading /'s.
|
|
#
|
|
my $path = shift;
|
|
$path =~ s#.*(?:^|/)\.\.(/|$)#$1#;
|
|
$path =~ s#^/+##;
|
|
$path;
|
|
}
|
|
|
|
sub untar {
|
|
# -----------------------------------------------------------------------------
|
|
# $obj->untar(\&code);
|
|
# ---------------------
|
|
# Untars tar file specified in $obj->open and runs callback for each entry in
|
|
# the tar file. Passed a parts object to that callback.
|
|
#
|
|
# $obj->untar;
|
|
# ------------
|
|
# Same a above but no callback.
|
|
#
|
|
# GT::Tar->untar('/path/to/tar.tar', \&code);
|
|
# -------------------------------------------
|
|
# Untars file specified by the first argument and runs callback in second
|
|
# argument.
|
|
#
|
|
# GT::Tar->untar('/path/to/tar.tar', '/path/for/extraction');
|
|
# -----------------------------------------------------------
|
|
# Untars tar file specified in first argument into path specified in second
|
|
# argument.
|
|
#
|
|
my $self = ref $_[0] eq __PACKAGE__ ? shift : shift->open(shift);
|
|
|
|
my $callback = pop;
|
|
if (ref $callback) {
|
|
(ref $callback eq 'CODE')
|
|
or return $self->fatal(BADARGS => "untar", "Callback that was passed in was not a code ref");
|
|
}
|
|
elsif ($callback) {
|
|
-d $callback or return $self->fatal(BADARGS => untar => "Extraction path '$callback' does not exist");
|
|
}
|
|
|
|
if (!$self->{parsed}) {
|
|
$self->debug("Parsing tar file") if ($self->{_debug});
|
|
$self->parse or return;
|
|
}
|
|
else {
|
|
$self->debug("Already parsed") if ($self->{_debug});
|
|
}
|
|
|
|
for (@{$self->{parts}}) {
|
|
if (ref $callback eq 'CODE') {
|
|
$callback->($_);
|
|
}
|
|
else {
|
|
$_->write($callback || ());
|
|
}
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub tar {
|
|
# ------------------------------------------------------------------------------
|
|
# $obj->tar;
|
|
# ----------
|
|
# Creates tar file that was specified in $obj->new with files that were added
|
|
# using $obj->add.
|
|
#
|
|
# GT::Tar->tar('/path/to/tar.tar', @files);
|
|
# ------------------------------------------
|
|
# Creates tar file specified by the first argument with the files specified
|
|
# by the remaining arguments.
|
|
#
|
|
my $self;
|
|
if (ref $_[0] eq __PACKAGE__) {
|
|
$self = shift;
|
|
}
|
|
else {
|
|
my $class = shift;
|
|
$self = $class->new( io => shift );
|
|
$self->add(@_) if (@_);
|
|
}
|
|
$self->write;
|
|
}
|
|
|
|
sub write {
|
|
# ------------------------------------------------------------------------------
|
|
# $obj->write;
|
|
# ------------
|
|
# Creates all the files that are internally in the parts objects. You add
|
|
# files to parts by calling $obj->add -or- by calling $obj->open on an
|
|
# existing tar file. This is similar to untar.
|
|
#
|
|
my $self = shift;
|
|
my ($out, $rename, $filename);
|
|
|
|
# Working off an existing tar file.
|
|
if (! $self->{new_tar}) {
|
|
if (@_) {
|
|
$filename = shift;
|
|
|
|
# If we have a new .tar.gz file, we need to write it to a tmp .tar first.
|
|
if ($filename =~ /\.t?gz$/) {
|
|
$HAVE_GZIP or return $self->warn('NOGZIP');
|
|
$self->{gz_file} = $filename;
|
|
undef $filename;
|
|
}
|
|
}
|
|
if (! $filename) {
|
|
require GT::TempFile;
|
|
my $tmp = new GT::TempFile;
|
|
$filename = $$tmp;
|
|
$rename = $self->{file};
|
|
}
|
|
$out = gensym;
|
|
sysopen $out, $filename, O_CREAT|O_TRUNC|O_RDWR or return $self->warn(OPEN => $filename, "$!");
|
|
binmode $out or return $self->fatal(BINMODE => $filename, "$!");
|
|
}
|
|
# Working off a new tar file.
|
|
else {
|
|
$out = $self->{io};
|
|
seek($out, 0, 0);
|
|
}
|
|
|
|
# Unbuffer output
|
|
select((select($out), $| = 1)[0]);
|
|
foreach my $entry (@{$self->{parts}}) {
|
|
my $head = $entry->format_write;
|
|
print $out $head;
|
|
my $save = tell $out;
|
|
if ($entry->type == FILE) {
|
|
my $bh;
|
|
my $body = $entry->body or return $self->warn(NOBODY => $entry->name);
|
|
my $ref = ref $body;
|
|
if ($ref eq 'GLOB' and fileno $body) {
|
|
my $fh = $body;
|
|
my $pos = tell $fh;
|
|
binmode $fh;
|
|
while (read $fh, $_, BLOCK) {
|
|
print $out $_;
|
|
}
|
|
seek($fh, $pos, 0);
|
|
}
|
|
elsif ($ref eq 'ARRAY') {
|
|
my ($reads, $rem, $data, $pos);
|
|
my ($fh, $start) = @{$body};
|
|
$pos = tell $fh;
|
|
seek($fh, $start, 0);
|
|
binmode $fh;
|
|
$reads = int($entry->{size} / BLOCK);
|
|
$rem = $entry->{size} % BLOCK;
|
|
for (1 .. $reads) {
|
|
my $read = read($fh, $data, BLOCK);
|
|
($read == BLOCK)
|
|
or return $self->warn(READ => join(',' => @{$body}), BLOCK, $read);
|
|
print $out $data;
|
|
}
|
|
if ($rem) {
|
|
my $read = read($fh, $data, $rem);
|
|
($read == $rem)
|
|
or return $self->warn(READ => join(',' => @{$body}), $rem, $read);
|
|
print $out $data;
|
|
}
|
|
seek($fh, $pos, 0);
|
|
}
|
|
elsif ($ref eq 'SCALAR') {
|
|
CORE::open F, ${$body} or return $self->warn(READOPEN => ${$body}, "$!");
|
|
binmode F;
|
|
while (read F, $_, BLOCK) {
|
|
print $out $_;
|
|
}
|
|
close F;
|
|
}
|
|
else {
|
|
print $out $body;
|
|
}
|
|
my $size = $entry->{size} & 511;
|
|
if ($size) {
|
|
print $out ("\0" x (512 - $size));
|
|
}
|
|
$entry->body( [ $out, $save ] );
|
|
}
|
|
}
|
|
print $out ("\0" x 1024);
|
|
|
|
# Copy the temp file over to the original file (can't rename across filesystems).
|
|
if ($rename and !$self->{gz_file}) {
|
|
seek($out, 0, 0);
|
|
$self->{io} = gensym;
|
|
sysopen($self->{io}, $rename, O_CREAT|O_TRUNC|O_RDWR) or return $self->warn(OPEN => $rename, "$!");
|
|
binmode $self->{io};
|
|
while (read($out, my $buffer, BLOCK)) {
|
|
print {$self->{io}} $buffer;
|
|
}
|
|
seek($self->{io}, 0, 0);
|
|
|
|
# Need to set the parts to the new file handle.
|
|
foreach my $entry (@{$self->{parts}}) {
|
|
if ($entry->type == FILE) {
|
|
$entry->{body}->[0] = $self->{io};
|
|
}
|
|
}
|
|
close $out;
|
|
$out = $self->{io};
|
|
$self->{file} = $rename;
|
|
unlink $filename or return $self->warn(UNLINK => $filename, "$!");
|
|
}
|
|
|
|
# Recompress if it was a .gz file.
|
|
if ($self->{gz_file}) {
|
|
$HAVE_GZIP or return $self->warn('NOGZIP');
|
|
seek($out, 0, 0);
|
|
my $gz = Compress::Zlib::gzopen($self->{gz_file}, 'wb') or return $self->warn(OPEN => $self->{gz_file}, $Compress::Zlib::gzerrno);
|
|
while (read($out, my $buffer, BLOCK)) {
|
|
$gz->gzwrite($buffer);
|
|
}
|
|
$gz->gzclose();
|
|
seek($out, 0, 0);
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub extract {
|
|
# ------------------------------------------------------------------------------
|
|
# $obj->extract(@list);
|
|
# ----------------------
|
|
# $obj->extract(\@list);
|
|
# -----------------------
|
|
# Extracts only the files specified in @list from the working tar file. No
|
|
# files are extracted if none are in memory.
|
|
#
|
|
my $self = shift;
|
|
my %files = map { $_ => 1 } ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_;
|
|
my $num = '0E0';
|
|
foreach my $entry (@{$self->{parts}}) {
|
|
next unless (exists $files{$entry->{name}});
|
|
$entry->write;
|
|
$num++;
|
|
}
|
|
return $num;
|
|
}
|
|
|
|
sub add_file {
|
|
# ------------------------------------------------------------------------------
|
|
# $obj->add_file(@list);
|
|
# ------------------
|
|
# $obj->add_file(\@list);
|
|
# -------------------
|
|
# Adds the files specified in @list to the in-memory archive.
|
|
#
|
|
my $self = shift;
|
|
my @files = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
|
|
|
|
while (my $file = shift @files or @files) {
|
|
next if not defined $file;
|
|
my ($mode, $nlnk, $uid, $gid, $rdev, $size, $mtime, $type, $linkname);
|
|
|
|
$self->debug("Looking at $file") if ($self->{_debug});
|
|
if (($mode, $nlnk, $uid, $gid, $rdev, $size, $mtime) = (lstat $file)[2 .. 7, 9]) {
|
|
$linkname = "";
|
|
$type = filetype($file);
|
|
|
|
$linkname = readlink $file if ($type == SYMLINK);
|
|
if ($type == DIR) {
|
|
my $dir = gensym;
|
|
opendir $dir, $file or return $self->warn(OPEN => "Can't add directory '$file'", "$!");
|
|
push(@files, map { $file . '/' . $_ } grep !/^\.\.?$/, readdir $dir);
|
|
closedir $dir;
|
|
}
|
|
|
|
my $part = GT::Tar::Parts->new(
|
|
{
|
|
name => $file,
|
|
mode => $mode,
|
|
uid => $uid,
|
|
gid => $gid,
|
|
size => $size,
|
|
mtime => ($mtime | 0),
|
|
chksum => " ",
|
|
magic => "ustar",
|
|
version => "",
|
|
type => $type,
|
|
linkname => $linkname,
|
|
devmajor => 0, # We don't handle this yet
|
|
devminor => 0, # We don't handle this yet
|
|
uname => ($FAKE_GETPWUID || scalar getpwuid($uid)),
|
|
gname => ($FAKE_GETGRGID || scalar getgrgid($gid)),
|
|
prefix => "",
|
|
}
|
|
);
|
|
if ($type == FILE) {
|
|
$self->debug("Adding $file to as body") if ($self->{_debug});
|
|
$part->body(\$file);
|
|
}
|
|
push(@{$self->{parts}}, $part);
|
|
|
|
}
|
|
else {
|
|
$self->debug("Could not stat file '$file'");
|
|
}
|
|
}
|
|
return wantarray ? @{$self->{parts}} : $self->{parts};
|
|
}
|
|
|
|
sub remove_file {
|
|
# -------------------------------------------------------------------
|
|
# Takes a string and removes the file from the tar.
|
|
#
|
|
my ($self, $filename) = @_;
|
|
return unless (defined $filename);
|
|
@{$self->{parts}} = grep { $_->{name} ne $filename } @{$self->{parts}};
|
|
}
|
|
|
|
sub get_file {
|
|
# -------------------------------------------------------------------
|
|
# Returns the file object of a given file name.
|
|
#
|
|
my ($self, $filename) = @_;
|
|
return unless (defined $filename);
|
|
my @files = grep { $_->{name} eq $filename } @{$self->{parts}};
|
|
if (! @files) {
|
|
return $self->warn(CANTFIND => $filename);
|
|
}
|
|
return wantarray ? @files : shift @files;
|
|
}
|
|
|
|
sub add_data {
|
|
# -------------------------------------------------------------------
|
|
# $obj->add_newfile( { ... } );
|
|
# ------------------------------
|
|
# Adds a file from a hash ref of part attributes.
|
|
#
|
|
my $self = shift;
|
|
my $part = @_ > 1 ? {@_} : shift;
|
|
ref $part eq 'HASH' or return $self->fatal(BADARGS => "Usage: \$obj->add_newfile( part options )");
|
|
|
|
defined $part->{name} or return $self->fatal(BADARGS => "You must supply a file name.");
|
|
defined $part->{body} or return $self->fatal(BADARGS => "You must supply a body for the file.");
|
|
|
|
if (ref $part->{body}) {
|
|
if (fileno $part->{body}) {
|
|
local $/;
|
|
my $fh = $part->{body};
|
|
$part->{body} = <$fh>;
|
|
}
|
|
else {
|
|
return $self->fatal(BADARGS => "You must supply either a scalar or a file handle to body");
|
|
}
|
|
}
|
|
my $file = GT::Tar::Parts->new({
|
|
name => $part->{name},
|
|
mode => defined $part->{mode} ? $part->{mode} : 0666 & (0777 - umask),
|
|
uid => defined $part->{uid} ? $part->{uid} : $>,
|
|
gid => defined $part->{gid} ? $part->{gid} : (split(/ /,$)))[0],
|
|
size => length $part->{body},
|
|
mtime => defined $part->{mtime} ? $part->{mtime} : time,
|
|
chksum => " ",
|
|
magic => "ustar",
|
|
version => "00",
|
|
type => FILE,
|
|
linkname => '',
|
|
devmajor => 0, # We don't handle this yet
|
|
devminor => 0, # We don't handle this yet
|
|
uname => ($FAKE_GETPWUID || scalar getpwuid(defined $part->{uid} ? int($part->{uid}) : $>)),
|
|
gname => ($FAKE_GETGRGID || scalar getgrgid(defined $part->{gid} ? int($part->{gid}) : (split(/ /,$)))[0])),
|
|
prefix => ""
|
|
});
|
|
$file->body($part->{body});
|
|
push(@{$self->{parts}}, $file);
|
|
return $file;
|
|
}
|
|
|
|
sub files {
|
|
# ------------------------------------------------------------------------------
|
|
# my @files = $obj->files;
|
|
# ------------------------
|
|
# Returns a list of the part objects that are in the in-memory archive.
|
|
# Returns an array ref in scalar context.
|
|
#
|
|
my @parts = defined $_[0]->{parts} ? @{$_[0]->{parts}} : ();
|
|
return wantarray ? @parts : \@parts;
|
|
}
|
|
|
|
sub filetype {
|
|
# ------------------------------------------------------------------------------
|
|
# Internal method. filetype -- Determine the type value for a given file
|
|
#
|
|
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?)
|
|
}
|
|
|
|
package GT::Tar::Parts;
|
|
# ==================================================================
|
|
# Pragmas
|
|
use vars qw/$DEBUG $ERRORS $ATTRIBS $ERROR_MESSAGE/;
|
|
use strict;
|
|
|
|
# System modules
|
|
use Fcntl;
|
|
use Symbol qw/gensym/;
|
|
|
|
# Globals
|
|
$DEBUG = $GT::Tar::DEBUG;
|
|
@GT::Tar::Parts::ISA = qw{GT::Base};
|
|
$ATTRIBS = {
|
|
name => '',
|
|
mode => '',
|
|
uid => '',
|
|
gid => '',
|
|
size => '',
|
|
mtime => '',
|
|
chksum => " ",
|
|
type => '',
|
|
linkname => '',
|
|
magic => "ustar",
|
|
version => undef,
|
|
uname => 'unknown',
|
|
gname => 'unknown',
|
|
devmajor => 0, # We don't handle this yet
|
|
devminor => 0, # We don't handle this yet
|
|
prefix => "",
|
|
body => undef,
|
|
set_owner => 1,
|
|
set_perms => 1,
|
|
set_time => 1,
|
|
};
|
|
$ERROR_MESSAGE = 'GT::Tar';
|
|
|
|
sub format_read {
|
|
# ------------------------------------------------------------------------------
|
|
# my $obj = GT::Tar::Parts->format_read($heading);
|
|
# -------------------------------------------------
|
|
# Unpacks the string that is passed in. The string need to be a valid header
|
|
# from a single entry in a tar file. Return a new object for the Tar part.
|
|
# You will need to set the body yourself after calling this.
|
|
#
|
|
my $head_tainted = pop;
|
|
my ($head) = $head_tainted =~ /(.+)/;
|
|
my $file = {};
|
|
(
|
|
$file->{name}, $file->{mode},
|
|
$file->{uid}, $file->{gid},
|
|
$file->{size}, $file->{mtime},
|
|
$file->{chksum}, $file->{type},
|
|
$file->{linkname}, $file->{magic},
|
|
$file->{version}, $file->{uname},
|
|
$file->{gname}, $file->{devmajor},
|
|
$file->{devminor}, $file->{prefix}
|
|
) = unpack(GT::Tar::FORMAT_HEADER_UNPACK, $head);
|
|
|
|
$file->{uid} = oct $file->{uid};
|
|
$file->{gid} = oct $file->{gid};
|
|
$file->{mode} = oct $file->{mode};
|
|
$file->{size} = oct $file->{size};
|
|
$file->{mtime} = oct $file->{mtime};
|
|
$file->{chksum} = oct $file->{chksum};
|
|
$file->{devmajor} = oct $file->{devmajor};
|
|
$file->{devminor} = oct $file->{devminor};
|
|
$file->{name} = $file->{prefix} . "/" . $file->{name} if $file->{prefix};
|
|
$file->{prefix} = "";
|
|
|
|
$file->{type} = GT::Tar::DIR
|
|
if $file->{name} =~ m|/$| and $file->{type} == GT::Tar::FILE;
|
|
return GT::Tar::Parts->new($file);
|
|
}
|
|
|
|
sub format_write {
|
|
# ------------------------------------------------------------------------------
|
|
# $obj->format_write;
|
|
# -------------------
|
|
# Formats the current object's header for writing to a tar file. Returns the
|
|
# formatted string. In the case of a file with a path+name longer than 100
|
|
# characters (in other words, longer than can fit in the tar's filename
|
|
# field), this actually returns a longlink header + longlink body + file
|
|
# header.
|
|
#
|
|
my $self = shift;
|
|
|
|
my $file = $self->{name};
|
|
if ($self->{type} == GT::Tar::DIR and $file !~ m,/$,) {
|
|
$file .= '/';
|
|
}
|
|
|
|
my $longlink;
|
|
if (length($file) > 100) {
|
|
my $body = $file . "\0"; # GNU tar produces a long link file with a body ending with a \0; copy it.
|
|
$longlink = pack(
|
|
GT::Tar::FORMAT_HEADER_PACK,
|
|
'././@LongLink', # Filename
|
|
sprintf('%07o', 0), # mode
|
|
sprintf('%07o', 0), # uid
|
|
sprintf('%07o', 0), # gid
|
|
sprintf('%011o', length $body), # size
|
|
sprintf('%011o', 0), # mtime
|
|
'', # checksum
|
|
GT::Tar::LONGNAME, # type
|
|
'ustar', ' ',
|
|
'root', # username (Using 'root' copied from GNU tar)
|
|
'root', # group name (Using 'root' copied from GNU tar)
|
|
'', # devmajor
|
|
'', # devminor
|
|
'' # prefix
|
|
);
|
|
substr($longlink, 148, 7) = sprintf("%06o\0", unpack("%16C*", $longlink));
|
|
$longlink .= $body;
|
|
|
|
my $pad_from = length($body) % 512;
|
|
if ($pad_from) {
|
|
$longlink .= "\0" x (512 - $pad_from);
|
|
}
|
|
}
|
|
|
|
my $header = pack(
|
|
GT::Tar::FORMAT_HEADER_PACK,
|
|
$file,
|
|
sprintf("%07o", $self->{mode}),
|
|
sprintf("%07o", $self->{uid}),
|
|
sprintf("%07o", $self->{gid}),
|
|
sprintf("%011o", $self->{type} == GT::Tar::DIR ? 0 : $self->{size}),
|
|
sprintf("%011o", $self->{mtime}),
|
|
"", #checksum field - space padded by pack("A8")
|
|
$self->{type},
|
|
$self->{linkname},
|
|
($self->{magic} eq 'ustar' and !$self->{version})
|
|
? ('ustar ', ' ') # oldgnu format, which treated magic+version as a contiguous field with a value of "ustar \0"
|
|
: ($self->{magic}, $self->{version} || '00'),
|
|
$self->{uname},
|
|
$self->{gname},
|
|
'', # sprintf("%6o ",$self->{devmajor}),
|
|
'', # sprintf("%6o ",$self->{devminor}),
|
|
'' # prefix
|
|
);
|
|
substr($header, 148, 7) = sprintf("%06o\0", unpack("%16C*", $header));
|
|
$header = $longlink . $header if $longlink;
|
|
return $header;
|
|
}
|
|
|
|
sub body {
|
|
# ------------------------------------------------------------------------------
|
|
# my $path = $obj->body;
|
|
# ----------------------
|
|
# $obj->body(\'/path/to/body');
|
|
# $obj->body("My body text.");
|
|
# -----------------------------
|
|
# Sets or gets the path to the body of this tar part. If a scalar ref is
|
|
# passed in it is considered a path to a file otherwize it is considered a
|
|
# string to write to the body when write is called.
|
|
#
|
|
my ($self, $io) = @_;
|
|
!$io and return $self->{body};
|
|
$self->{body} = $io;
|
|
my $ref = ref $io;
|
|
if ($ref eq 'GLOB' and fileno $io) {
|
|
$self->{size} = (lstat(${$self->{body}}))[7];
|
|
}
|
|
elsif ($ref eq 'SCALAR') {
|
|
$self->{size} = -s ${$self->{body}};
|
|
}
|
|
elsif (not $ref) {
|
|
$self->{size} = length $self->{body};
|
|
}
|
|
|
|
return $self->{body};
|
|
}
|
|
|
|
sub body_as_string {
|
|
# ------------------------------------------------------------------------------
|
|
# my $data = $obj->body_as_string;
|
|
# --------------------------------
|
|
# Returns the body of the file as a string.
|
|
#
|
|
my $self = shift;
|
|
my $data = '';
|
|
my $ref = ref $self->{body};
|
|
if ($ref eq 'GLOB' and fileno $self->{body}) {
|
|
my $fh = $self->{body};
|
|
my $pos = tell $fh;
|
|
seek($fh, 0, 0);
|
|
binmode $fh;
|
|
local $/;
|
|
$data = <$fh>;
|
|
seek($fh, $pos, 0);
|
|
}
|
|
elsif ($ref eq 'ARRAY') {
|
|
my ($fh, $start) = @{$self->{body}};
|
|
my $pos = tell $fh;
|
|
binmode $fh;
|
|
seek($fh, $start, 0);
|
|
read($fh, $data, $self->{size});
|
|
seek($fh, $pos, 0);
|
|
}
|
|
elsif ($ref eq 'SCALAR') {
|
|
my $fh = gensym;
|
|
open $fh, ${$self->{body}} or return $self->warn(READOPEN => ${$self->{body}}, "$!");
|
|
binmode $fh;
|
|
read($fh, $data, -s $fh);
|
|
close $fh;
|
|
}
|
|
else {
|
|
$data = $self->{body};
|
|
}
|
|
return $data;
|
|
}
|
|
|
|
sub write {
|
|
# ------------------------------------------------------------------------------
|
|
# $obj->write;
|
|
# ------------
|
|
# Writes this part to disk using the path that is in $obj->body. This function
|
|
# will recursively make the directories needed to create the structure of this
|
|
# part.
|
|
#
|
|
# An optional extraction path can be passed in - if provided, extraction will
|
|
# be based in that directory instead of the current directory.
|
|
#
|
|
my ($self, $extract_to) = @_;
|
|
|
|
# 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!
|
|
$self->_write_dir($extract_to) or return;
|
|
if ($self->{type} == GT::Tar::FILE) {
|
|
my $out = gensym;
|
|
my $name = ($self->{name} =~ /^(.+)$/s)[0];
|
|
$name = "$extract_to/$name" if $extract_to;
|
|
open $out, "> $name" or return $self->warn(OPEN => $name, "$!");
|
|
binmode $out or return $self->warn(BINMODE => $name => "$!");
|
|
my $ref = ref $self->{body};
|
|
if ($ref eq 'GLOB' and fileno $self->{body}) {
|
|
my $fh = $self->{body};
|
|
my $pos = tell $fh;
|
|
binmode $fh;
|
|
while (read $fh, $_, GT::Tar::BLOCK) {
|
|
print $out $_;
|
|
}
|
|
seek($fh, $pos, 0);
|
|
}
|
|
elsif ($ref eq 'ARRAY') {
|
|
my ($reads, $rem, $data, $pos);
|
|
my ($fh, $start) = @{$self->{body}};
|
|
$pos = tell $fh;
|
|
seek($fh, $start, 0);
|
|
binmode $fh;
|
|
$reads = int($self->{size} / GT::Tar::BLOCK);
|
|
$rem = $self->{size} % GT::Tar::BLOCK;
|
|
for (1 .. $reads) {
|
|
my $read = read($fh, $data, GT::Tar::BLOCK);
|
|
($read == GT::Tar::BLOCK)
|
|
or return $self->warn(READ => join(',' => @{$self->{body}}), GT::Tar::BLOCK, $read);
|
|
print $out $data;
|
|
}
|
|
if ($rem) {
|
|
my $read = read($fh, $data, $rem);
|
|
($read == $rem)
|
|
or return $self->warn(READ => join(',' => @{$self->{body}}), $rem, $read);
|
|
print $out $data;
|
|
}
|
|
seek($fh, $pos, 0);
|
|
}
|
|
elsif ($ref eq 'SCALAR') {
|
|
my $fh = gensym;
|
|
open $fh, ${$self->{body}} or return $self->warn(READOPEN => ${$self->{body}}, "$!");
|
|
binmode $fh;
|
|
while (read $fh, $_, GT::Tar::BLOCK) {
|
|
print $out $_;
|
|
}
|
|
close $fh;
|
|
}
|
|
else {
|
|
print $out $self->{body};
|
|
}
|
|
close $out;
|
|
$self->debug("Created $self->{name} size $self->{size}") if ($self->{_debug});
|
|
}
|
|
$self->_file_sets;
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub _write_dir {
|
|
# ------------------------------------------------------------------------------
|
|
# Internal method used to create a directory for a file, or just create a
|
|
# directory if this is a directory part and the directory does not exist.
|
|
#
|
|
my ($self, $base_dir) = @_;
|
|
|
|
my $name = $self->{name};
|
|
$name = "$base_dir/$name" if defined $base_dir;
|
|
|
|
if ($self->{type} == GT::Tar::DIR) {
|
|
-e $name and not -d _ and return $self->fatal(DIRFILE => $name);
|
|
-d _ or $self->_recurse_mkdir($base_dir) or return;
|
|
}
|
|
else {
|
|
$self->_recurse_mkdir($base_dir) or return;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub _recurse_mkdir {
|
|
# -----------------------------------------------------------------------------
|
|
# Internal method to recursivly make a directory. If the directory contains ..
|
|
# path components, everything up to the last one is removed. Likewise, a path
|
|
# starting with / has the initial / removed.
|
|
#
|
|
my ($self, $base_dir) = @_;
|
|
my $dir = $self->{name};
|
|
$dir = "$base_dir/$dir" if defined $base_dir;
|
|
my @path = split m|/|, $dir;
|
|
pop @path unless substr($dir, -1) eq '/';
|
|
|
|
my @subpath; # /foo/bar/baz/ -> ('/foo/bar/baz', '/foo/bar', '/foo', '')
|
|
for (reverse 0 .. $#path) {
|
|
push @subpath, join '/', @path[0 .. $_], '';
|
|
}
|
|
push @subpath, '.' unless substr($dir, 0, 1) eq '/' or $subpath[-1] eq '.' or $subpath[-1] eq './';
|
|
for my $i (0 .. $#subpath) {
|
|
my $path = $subpath[$i];
|
|
next if $path eq '';
|
|
if (-e $path and not -d _) { return $self->warn(DIRFILE => $path) }
|
|
elsif (-d _) {
|
|
for (reverse 0 .. $i-1) {
|
|
next if -d $subpath[$_];
|
|
mkdir $subpath[$_], 0777 or return $self->warn(MKDIR => $subpath[$_], "$!");
|
|
$self->debug("mkdir $subpath[$_]") if $DEBUG;
|
|
}
|
|
last;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub _file_sets {
|
|
# ------------------------------------------------------------------------------
|
|
# Internal method to set the file or directory permissions and or onership of
|
|
# this part.
|
|
#
|
|
my $self = shift;
|
|
|
|
# Set the file creation time.
|
|
if ($self->{set_time}) {
|
|
utime time, $self->{mtime}, $self->{name};
|
|
}
|
|
|
|
# Set the file owner.
|
|
if ($self->{set_owner}) {
|
|
$self->debug("chown ($self->{uid},$self->{gid}) $self->{name}") if ($self->{_debug});
|
|
chown($self->{uid}, $self->{gid}, $self->{name})
|
|
if ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32");
|
|
}
|
|
|
|
# Set the permissions (done last in case it makes file readonly)
|
|
if ($self->{set_perms}) {
|
|
my ($mode) = sprintf("%lo", $self->{mode}) =~ /(\d{3})$/;
|
|
$self->debug("chmod $mode, $self->{name}") if ($self->{_debug});
|
|
chmod $self->{mode}, $self->{name} or return $self->warn(CHMOD => $self->{name}, "$!");
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::Tar - Perl module to manipulate tar files.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use GT::Tar;
|
|
my $tar = GT::Tar->open('foo.tar');
|
|
$tar->add_file( '/path/to/file' );
|
|
$tar->write;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::Tar provides an OO intefrace to a tar file. It allows you to create or edit
|
|
tar files, and if you have Compress::Zlib installed, it allows you to work with
|
|
.tar.gz files as well!
|
|
|
|
=head2 Creating a tar file
|
|
|
|
To create a tar file, you simply call:
|
|
|
|
my $tar = new GT::Tar;
|
|
|
|
and then to save it:
|
|
|
|
$tar->write('filename.tar');
|
|
|
|
will save the tar file and any files you have added.
|
|
|
|
=head2 Opening an existing tar file
|
|
|
|
To open a tar file you call:
|
|
|
|
my $tar = GT::Tar->open('/path/to/file.tar')
|
|
or die "Can't open: $GT::Tar::error";
|
|
|
|
Note: the tar object keeps an open filehandle to the file, so if you are on
|
|
windows, you may not be able to manipulate it until you call $tar->close_tar, or
|
|
the tar object goes out of scope.
|
|
|
|
=head2 Untarring a tar file
|
|
|
|
To untar a tar file, you can simply call:
|
|
|
|
$tar->untar( \&code_ref );
|
|
|
|
or as a class method
|
|
|
|
GT::Tar->untar('/path/to/tar.tar', \&code_ref );
|
|
|
|
The code ref is optional. If provided, you will get passed in the a
|
|
GT::Tar::Part object before the file is extracted. This lets you change the
|
|
path, or alter any attributes of the file before it is saved to disk.
|
|
|
|
Alternatively, instead of a code reference you may pass an extraction path - if
|
|
passed, all files will be extracted relative to that path.
|
|
|
|
=head2 Adding files to a tar file
|
|
|
|
To add a file:
|
|
|
|
$tar->add_file( '/path/to/file' );
|
|
|
|
Note, if you add a directory, the tar module will recurse and add all files in
|
|
that directory.
|
|
|
|
To add a file that isn't saved:
|
|
|
|
$tar->add_data( name => 'Filename', body => 'File body' );
|
|
|
|
You can pass in either a scalar for the body, or an opened file handle.
|
|
|
|
=head2 Getting a list of files in a tar
|
|
|
|
To get a list of files in a tar:
|
|
|
|
my $files = $tar->files;
|
|
|
|
This returns an array ref of GT::Tar::Part objects. See below for how to access
|
|
information from a part.
|
|
|
|
Note: if you change a part, it will update the tar file if you save it.
|
|
|
|
=head2 Getting an individual file from a tar
|
|
|
|
If you know the name of the file you want:
|
|
|
|
my $file = $tar->get_file('Filename');
|
|
|
|
will return a single GT::Tar::Part object.
|
|
|
|
=head2 Removing a file from a tar
|
|
|
|
To remove a file, you need to know the name of it:
|
|
|
|
$tar->remove_file('Filename');
|
|
$tar->write;
|
|
|
|
and you need to save it before the change will take affect.
|
|
|
|
=head2 GT::Tar::Part
|
|
|
|
Each file is a separate part object. The part object has the following
|
|
attributes:
|
|
|
|
name file name
|
|
mode file permissions
|
|
uid user id
|
|
gid group id
|
|
size file size
|
|
mtime last modified time
|
|
type file type
|
|
body file body
|
|
|
|
You can access or set any of these attributes by just using the attribute name
|
|
as the method (as it inherits from L<GT::Base>).
|
|
|
|
You can also call:
|
|
|
|
$file->write;
|
|
|
|
or:
|
|
|
|
$file->write("/extraction/path")
|
|
|
|
and the file will be created with the given attributes. Basically untar just
|
|
foreach's through each of the objects and calls write() on it.
|
|
|
|
=head1 EXAMPLES
|
|
|
|
To create a new tar and add two directories to it, and save it in
|
|
'/tmp/foo.tar';
|
|
|
|
my $tar = new GT::Tar;
|
|
$tar->add_file( '/home/httpd/html' );
|
|
$tar->add_file( '/home/backup' );
|
|
$tar->write('/tmp/foo.tar');
|
|
|
|
To open an existing tar file and save all the .pl files in /home/alex.
|
|
|
|
my $tar = GT::Tar->open('files.tar');
|
|
my $files = $tar->files;
|
|
foreach my $file (@$files) {
|
|
my $name = $file->name;
|
|
if ($name =~ m,[^/]*\.pl$,) {
|
|
$file->write("/home/alex");
|
|
}
|
|
}
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Tar.pm,v 1.54 2005/03/09 01:26:17 jagerman Exp $
|
|
|
|
=cut
|
|
|