Archive-TarGzip
view release on metacpan or search on metacpan
lib/Archive/TarGzip.pm view on Meta::CPAN
$default_options = Archive::TarGzip->defaults() unless $default_options;
my $self = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : $default_options;
$self = ref($self) ? $self : $default_options;
$self->Data::Startup::config(@_);
}
#######
# Object used to set default, startup, options values.
#
sub defaults
{
my $class = shift;
$class = ref($class) if ref($class);
my $self = $class->Data::Startup::new(
warn => 1,
compress => 1,
gz_suffix => '.gz',
tar_suffix => '.tar',
);
$self->Data::Startup::override(@_);
}
#######
# add a file to the TAR file
#
#
sub encode_tar
{
my ($self, $file_name, $file_contents) = @_;
my $tar = $self->{tar};
########
# Pack the header
#
my ($prefix,$pos);
if (length($file_name)>99) {
$pos = index $file_name, "/",(length($file_name) - 100);
next if $pos == -1; # Filename longer than 100 chars!
$prefix = substr $file_name,0,$pos;
$file_name = substr $file_name,$pos+1;
substr($prefix,0,-155)="" if length($prefix)>154;
}
else {
$prefix="";
}
my $umask = $self->{TarGzip}->{umask};
$umask = umask unless $umask;
my $size = length($file_contents);
my $tar_contents = pack("a100a8a8a8a12a12a8a1a100",
$file_name,
sprintf("%6o ",($file_contents ? 0666 : 0777) & (0777-umask)), # mode
sprintf("%6o ",0), # uid
sprintf("%6o ",0), # gid
sprintf("%11o ",$size),
sprintf("%11o ",time()), # mtime
" ", # chksum
0, # typeflag
''); # linkname
$tar_contents .= pack("a6", "ustar\0"); # magic
$tar_contents .= '00'; # version
$tar_contents .= pack("a32","unknown"); # uname
$tar_contents .= pack("a32","unknown"); # gname
$tar_contents .= pack("a8",sprintf("%6o ",0)); # minor device
$tar_contents .= pack("a8",sprintf("%6o ",0)); # major device
$tar_contents .= pack("a155",$prefix);
substr($tar_contents,148,6) = sprintf("%6o", unpack("%16C*",$tar_contents));
substr($tar_contents,154,1) = "\0";
$tar_contents .= "\0" x ($tar_header_length-length($tar_contents));
######
# Add the file contents
#
$tar_contents .= $file_contents;
if ($size>0) {
$tar_contents .= "\0" x (512 - ($size%512)) unless $size%512==0;
}
\$tar_contents;
}
#####
#
#
sub EOF
{
my $self = shift;
my $fh = $self->{FH};
unless ($fh) {
return undef if $self->{event} =~ /No open file handle/;
$self->{event} .= "No open file handle\n";
$self->{event} .= "\tArchive::TarGzip::EOF() $VERSION\n";
if($self->{warn}) {
warn($self->{event});
}
return undef;
}
eof($fh);
}
######
#
#
sub FILENO
{
my $self = shift;
my $fh = $self->{FH};
unless ($fh) {
return undef if $self->{event} =~ /No open file handle/;
$self->{event} .= "No open file handle\n";
$self->{event} .= "\tArchive::TarGzip::FILENO() $VERSION\n";
if($self->{options}->{warn}) {
warn($self->{event});
}
lib/Archive/TarGzip.pm view on Meta::CPAN
tie *TAR, $compress;
}
else {
tie *TAR, 'Tie::Gzip';
}
}
######
# Open tar file
#
unless (open TAR, "$flag $tar_file") {
warn( "Cannot open $flag $tar_file\n");
return undef;
}
binmode TAR;
$self->{FH} = \*TAR;
}
return 1;
EVENT:
$self->{event} = $event;
$self->{event} .= "\tTie::Layers::OPEN() $VERSION\n";
if($self->{warn}) {
warn($self->{event});
}
undef;
}
######
# This is taken directly from big loop in Archive::Tar::read_tar
# Need to get it out of the loop for use in this module
#
sub parse_header
{
######
# This subroutine uses no object data.
#
shift @_ if UNIVERSAL::isa($_[0],__PACKAGE__);
unless(@_) {
warn "No arguments.\n";
return undef;
}
my $tar_unpack_header
= 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155';
my ($header) = @_;
########
# 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.
return { end_of_tar => 1 } if $header eq "\0" x 512; # End of tar file
my ($name, # string
$mode, # octal number
$uid, # octal number
$gid, # octal number
$size, # octal number
$mtime, # octal number
$chksum, # octal number
$typeflag, # character
$linkname, # string
$magic, # string
$version, # two bytes
$uname, # string
$gname, # string
$devmajor, # octal number
$devminor, # octal number
$prefix) = unpack($tar_unpack_header, $header);
$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 typeflag for directories
# so we ass_u_me a directory if the name ends in slash
$typeflag = 5 if $name =~ m|/$| and not $typeflag;
my $error = '';
substr($header,148,8) = " ";
$error .= "$name: checksum error.\n" unless (unpack("%16C*",$header) == $chksum);
$error .= "$name: wrong header length\n" unless( $tar_header_length == length($header));
my $end_of_tar = 0;
# Guard against tarfiles with garbage at the end
$end_of_tar = 1 if $name eq '';
warn( $error ) if $error;
return {
name => $name,
mode => $mode,
uid => $uid,
gid => $gid,
size => $size,
mtime => $mtime,
chksum => $chksum,
typeflag => $typeflag,
linkname => $linkname,
magic => $magic,
version => $version,
uname => $uname,
gname => $gname,
devmajor => $devmajor,
devminor => $devminor,
prefix => $prefix,
error => $error,
end_of_tar => $end_of_tar,
header_only => 0,
skip_file => 0,
data => ''};
}
#######
# add a file to the TAR file
#
sub PRINT
{
my ($self, $file_name, $file_contents) = @_;
my $handle = $self->{FH};
$! = 0;
unless( defined $file_contents ) {
unless (open FILE, $file_name) {
warn "Cannot open $file_name\n";
return undef;
}
binmode FILE;
$file_contents = join '', <FILE>;
close FILE;
############################
# Do not add empty files to tar archive file
#
return 1 unless $file_contents;
}
my $tar_contents = $self->encode_tar($file_name,$file_contents);
my $success = print $handle $$tar_contents;
unless($success || $!) {
$self->{event} .= "Bad Print.\n\t$!\n";
$self->{event} .= "\tArchive::TarGzip::PRINT() $VERSION\n";
if($self->{options}->{warn}) {
warn($self->{event});
}
$self->CLOSE();
return undef;
}
$success;
}
#####
lib/Archive/TarGzip.pm view on Meta::CPAN
=head2 PRINT
$success = $tar->taradd($file_name, $file_contents);
The taradd method appends $file_contents using
the name $file_name
to the end of the tar archive file taropen for writing.
If $file_contents is undefined,
the taradd method will use the
contents from the file $file_name.
The tarwrite method will remove the first file
in the Archive::Tar memory and append it
to the end of the tar archive file taropen for writing.
The tarwrite method uses the $option{compress} to
decide whether use gzip compress or normal writing
of the tar archive file.
=head2 READLINE
\%tar_header = $tar->tarread(@file, [\%options or\@options]);
\%tar_header = $tar->tarread(\%options or\@options);
The tarread method reads the next file from the tar archive file
taropen for reading.
The tar file header and file contents are returned in
the %tar_header hash along with other information needed
for processing by the Archive::Tar and Archive::TarGzip
classes.
If the $option{header_only} exists the tarread method
skips the file contents and it is not return in the
%tar_header.
If either the @file or the @{$option{extract_files}} list is
present, the tarread method will check to see if
the file is in either of these lists.
If the file name is not in the @files list or
the @{$option{extract_files}} list,
the tarread method will set the $tar_header{skip_file} key
and all other %tar_header keys are indetermined.
If the @{$option{exclude_files}} list is
present, the tarread method will check to see if
the file is in this list.
If the file name is in the list,
the tarread method will set the $tar_header{skip_file} key
and all other %tar_header keys are indetermined.
If the tarread method reaches the end of the tar archive
file, it will set the $tar_header{end_of_tar} key and
all other %tar_header keys are indermeined.
The $tar_header keys are as follows:
name
mode
uid
gid
size
mtime
chksum
typeflag
linkname
magic
version
uname
gname
devmajor
devminor
prefix
error
end_of_tar
header_only
skip_file
data
file_position
=head2 target
$status = $tar->target( \$buffer, $size);
The target method gets bytes in 512 byte chunks from
the tar archive file taropen for reading.
If \$buffer is undefined, the target method skips
over the $size bytes and any additional bytes to pad out
to 512 byte boundaries.
The target method uses the $option{compress} to
decide whether use gzip uncompress or normal reading
of the tar archive file.
=head2 CLOSE
$success = $tar->CLOSE( );
This closes the tar archive opened by the OPEN subroutine.
=head2 parse_header
\%tar_header = Archive::TarGzip->parse_header($buffer) ;
\%tar_header = parse_header($buffer); # only if imported
The C<parse_header> subroutine takes the pack 512 byte tar file
header and parses it into a the C<Archive::Tar> header hash
with a few additional hash keys.
This is the return for the C<READLINE> subroutine.
=head1 REQUIREMENTS
Someday
=head1 DEMONSTRATION
#########
# perl TarGzip.d
###
~~~~~~ Demonstration overview ~~~~~
( run in 2.091 seconds using v1.01-cache-2.11-cpan-ceb78f64989 )