view release on metacpan or  search on metacpan

lib/Archive/Tar/Stream.pm  view on Meta::CPAN

Read a single 512 byte header off the input filehandle.

If the option (SkipInvalid => 1) is passed, it will skip
over blocks which fail to pass the checksum test.

Returns a copy of the header with _pos set to the position
in the output file.

=cut

sub WriteHeader {
  my $Self = shift;
  my $header = shift;

  my $block = $Self->CreateHeader($header);
  my $pos = $Self->WriteBlocks($block);
  return( {%$header, _pos => $pos} );
}

=head2 ParseHeader

   my $header = $ts->ParseHeader($block);

Parse a single block of raw bytes into a TARHEADER
format header.  $block must be exactly 512 bytes.

Returns undef if the block fails the checksum test.

=cut

sub ParseHeader {
  my $Self = shift;
  my $block = shift;

  # enforce length
  return unless(512 == length($block));

  # skip empty blocks
  return if substr($block, 0, 1) eq "\0";

  # unpack exactly 15 items from the block
  my @items = unpack("a100a8a8a8a12a12a8a1a100a8a32a32a8a8a155", $block);
  return unless (15 == @items);

  for (@items) {
    s/\0.*//; # strip from first null
  }

  my $chksum = oct($items[6]);
  # do checksum
  substr($block, 148, 8) = "        ";
  unless (unpack("%16C*", $block) == $chksum) {
    return;
  }

  my %header = (
    name => $items[0],
    mode => oct($items[1]),
    uid => oct($items[2]),
    gid => oct($items[3]),
    size => oct($items[4]),
    mtime => oct($items[5]),
    # checksum
    typeflag => $items[7],
    linkname => $items[8],
    # magic
    uname => $items[10],
    gname => $items[11],
    devmajor => oct($items[12]),
    devminor => oct($items[13]),
    prefix => $items[14],
  );

  return \%header;
}

=head2 BlankHeader

  my $header = $ts->BlankHeader(%extra);

Create a header with sensible defaults.  That means
time() for mtime, 0777 for mode, etc.

It then applies any 'extra' fields from %extra to
generate a final header.  Also validates the keys
in %extra to make sure they're all known keys.

=cut

sub BlankHeader {
  my $Self = shift;
  my %hash = (
    name => '',
    mode => 0777,
    uid => 0,
    gid => 0,
    size => 0,
    mtime => time(),
    typeflag => '0', # this is actually the STANDARD plain file format, phooey.  Not 'f' like Tar writes
    linkname => '',
    uname => '',
    gname => '',
    devmajor => 0,
    devminor => 0,
    prefix => '',
  );
  my %overrides = @_;
  foreach my $key (keys %overrides) {
    if (exists $hash{$key}) {
      $hash{$key} = $overrides{$key};
    }
    else {
      warn "invalid key $key for tar header\n";
    }
  }
  return \%hash;
}

=head2 CreateHeader

   my $block = $ts->CreateHeader($header);

Creates a 512 byte block from the TARHEADER format header.

=cut

sub CreateHeader {
  my $Self = shift;
  my $header = shift;

  my $block = pack("a100a8a8a8a12a12a8a1a100a8a32a32a8a8a155",
    $header->{name},
    sprintf("%07o", $header->{mode}),
    sprintf("%07o", $header->{uid}),
    sprintf("%07o", $header->{gid}),
    sprintf("%011o", $header->{size}),
    sprintf("%011o", $header->{mtime}),
    "        ",                  # chksum
    $header->{typeflag},
    $header->{linkname},
    "ustar  \0",                   # magic
    $header->{uname},
    $header->{gname},
    sprintf("%07o", $header->{devmajor}),
    sprintf("%07o", $header->{devminor}),
    $header->{prefix},
  );

  # calculate checksum
  my $checksum = sprintf("%06o", unpack("%16C*", $block));
  substr($block, 148, 8) = $checksum . "\0 ";

  # pad out to BLOCKSIZE characters
  if (length($block) < BLOCKSIZE) {
    $block .= "\0" x (BLOCKSIZE - length($block));
  }
  elsif (length($block) > BLOCKSIZE) {
    $block = substr($block, 0, BLOCKSIZE);
  }

  return $block;
}

=head2 CopyBytes

   $ts->CopyBytes($bytes);

Copies bytes from input to output filehandle, rounded up to
block size, so only whole blocks are actually copied.

=cut

sub CopyBytes {
  my $Self = shift;
  my $bytes = shift;
  my $buf;
  while ($bytes > 0) {
    my $n = int($bytes / BLOCKSIZE);
    $n = 16  if $n > 16;
    my $dump = $Self->ReadBlocks($n);
    $Self->WriteBlocks($dump, $n);
    $bytes -= length($dump);
  }
}

=head2 DumpBytes

   $ts->DumpBytes($bytes);

Just like CopyBytes, but it doesn't write anywhere.
Reads full blocks off the input filehandle, rounding
up to block size.

=cut

lib/Archive/Tar/Stream.pm  view on Meta::CPAN

sub WriteFromFh {
  my $Self = shift;
  my $Fh = shift;
  my $header = shift;

  my $pos = $Self->{outpos};

  my $block = $Self->CreateHeader($header);
  $Self->CopyFromFh($Fh, $header->{size}, $block, BLOCKSIZE);

  return( {%$header, _pos => $pos} );
}

=head2 WriteCopy

   $ts->WriteCopy($header);

Streams the record which matches the given header directly from the input
stream to the output stream.

=cut

sub WriteCopy {
  my $Self = shift;
  my $header = shift;

  my $pos = $Self->{outpos};

  my $toread = $header->{size};

  my $blocks = $Self->CreateHeader($header);
  my $count = 1;

  while ($count || $toread > 0) {
    if ($toread) {
      my $n = min(1 + int(($toread-1) / BLOCKSIZE), BLOCKCOUNT-$count);
      my $dump = $Self->ReadBlocks($n);
      die "Failed to read $n blocks for $toread at $Self->{inpos}\n" unless defined $dump;
      $blocks .= $dump;
      $count += $n;
      $toread -= length($dump);
    }
    $Self->WriteBlocks($blocks, $count);
    $blocks = '';
    $count = 0;
  }

  return( {%$header, _pos => $pos} );
}

=head1 TARHEADER format

This is the "BlankHeader" output, which includes all the fields
in a standard tar header:

  my %hash = (
    name => '',
    mode => 0777,
    uid => 0,
    gid => 0,
    size => 0,
    mtime => time(),
    typeflag => '0', # this is actually the STANDARD plain file format, phooey.  Not 'f' like Tar writes
    linkname => '',
    uname => '',
    gname => '',
    devmajor => 0,
    devminor => 0,
    prefix => '',
  );

You can read more about the tar header format produced by this
module on wikipedia:
L<http://en.wikipedia.org/wiki/Tar_(file_format)#UStar_format>
or here: L<http://www.mkssoftware.com/docs/man4/tar.4.asp>

Type flags:

  '0' Normal file
  (ASCII NUL) Normal file (now obsolete)
  '1' Hard link
  '2' Symbolic link
  '3' Character special
  '4' Block special
  '5' Directory
  '6' FIFO
  '7' Contiguous file

Obviously some module wrote 'f' as the type - I must have found
that during original testing.  That's bogus though.

=head1 AUTHOR

Bron Gondwana, C<< <perlcode at brong.net> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-archive-tar-stream
at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Archive-Tar-Stream>.
I will be notified, and then you'll automatically be notified of progress
on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Archive::Tar::Stream


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Archive-Tar-Stream>

=item * AnnoCPAN: Annotated CPAN documentation