summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm')
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm319
1 files changed, 319 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm b/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm
new file mode 100755
index 00000000000..a06715bbd9c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Parse/Binary/FixedFormat.pm
@@ -0,0 +1,319 @@
+package Parse::Binary::FixedFormat;
+
+use bytes;
+use strict;
+use integer;
+our $VERSION = '0.05';
+
+sub new {
+ my ($class, $layout) = @_;
+ my $self;
+ if (UNIVERSAL::isa($layout, 'HASH')) {
+ require Parse::Binary::FixedFormat::Variants;
+ $self = Parse::Binary::FixedFormat::Variants->new($layout);
+ } else {
+ $self = { Names=>[], Count=>[], Format=>"" };
+ bless $self, $class;
+ $self->parse_fields($layout) if $layout;
+ }
+ return $self;
+}
+
+sub parse_fields {
+ my ($self,$fmt) = @_;
+ foreach my $fld (@$fmt) {
+ my ($name, $format, $count, $group) = split /\s*:\s*/,$fld;
+ push @{$self->{Names}}, $name;
+ push @{$self->{Count}}, $count;
+ push @{$self->{Group}}, $group;
+ if (defined $count) {
+ push @{$self->{Format}||=[]}, "($format)$count";
+ }
+ else {
+ push @{$self->{Format}||=[]}, $format;
+ }
+ }
+}
+
+my %_format_cache;
+sub _format {
+ my ($self, $lazy) = @_;
+ $self->{_format} ||= do {
+ my $format = join('', @{$self->{Format}});
+ $_format_cache{$format} ||= do {
+ $format =~ s/\((.*?)\)\*$/a*/ if $lazy; # tail iteration
+ $format =~ s/\((.*?)\)(?:(\d+)|(\*))/$1 x ($3 ? 1 : $2)/eg if ($] < 5.008);
+ $format;
+ };
+ };
+}
+
+my %_parent_format;
+sub unformat {
+ my $self = shift;
+ my @flds = shift;
+ my $lazy = shift;
+ my $parent = shift;
+
+ my $format = $self->_format($lazy);
+ @flds = unpack($format, $flds[0]) unless $format eq 'a*';
+
+ my $rec = {};
+ foreach my $i (0 .. $#{$self->{Names}}) {
+ my $name = $self->{Names}[$i];
+ if (defined(my $count = $self->{Count}[$i])) {
+ next unless $count;
+
+ my $group = $self->{Group}[$i];
+ if ($count eq '*') {
+ $count = @flds;
+ $group ||= 1;
+ }
+
+ if ($group) {
+ my $pad = 0;
+ $pad = length($1) if $self->{Format}[$i] =~ /(X+)/;
+
+ if ($lazy and $i == $#{$self->{Names}}) {
+ my $format = $self->{Format}[$i] or die "No format found";
+ $format =~ s/^\((.*?)\)\*$/$1/ or die "Not a count=* field";
+
+ my $record = ($rec->{$name} ||= []);
+ push @$record, $self->lazy_unformat(
+ $parent, $record, $pad, $format, \($flds[0])
+ ) if @flds and length($flds[0]);
+
+ next;
+ }
+
+ my $count_idx = 0;
+ while (my @content = splice(@flds, 0, $group)) {
+ substr($content[-1], -$pad, $pad, '') if $pad;
+ push @{$rec->{$name}}, \@content;
+ $count_idx += $group;
+ last if $count_idx >= $count;
+ }
+ }
+ else {
+ @{$rec->{$name}} = splice @flds, 0, $count;
+ }
+ } else {
+ $rec->{$name} = shift @flds;
+ }
+ }
+ return $rec;
+}
+
+sub lazy_unformat {
+ my ($self, $parent, $record, $pad, $format, $data) = @_;
+
+ # for each request of a member data, we:
+ my $valid_sub = ($parent->can('valid_unformat') ? 1 : 0);
+ return sub { {
+ # grab one chunk of data
+ my @content = unpack($format, $$data);
+ my $length = length(pack($format, @content));
+
+ # eliminate it from the source string
+ my $chunk = substr($$data, 0, $length, '');
+ my $done = (length($$data) <= $pad);
+
+ if ($valid_sub and !$done and !$_[0]->valid_unformat(\@content, \$chunk, $done)) {
+ # weed out invalid data immediately
+ redo;
+ }
+
+ # remove extra padding
+ substr($content[-1], -$pad, $pad, '') if $pad;
+
+ # and prepend (or replace if there are no more data) with it
+ splice(@{$_[1]}, -1, $done, \@content);
+ return \@content;
+ } };
+}
+
+sub format {
+ my ($self,$rec) = @_;
+ my @flds;
+ my $i = 0;
+ foreach my $name (@{$self->{Names}}) {
+ if ($self->{Count}[$i]) {
+ push @flds,map {ref($_) ? @$_ : $_} @{$rec->{$name}};
+ } else {
+ if (ref($rec->{$name}) eq "ARRAY") {
+ if (@{$rec->{$name}}) {
+ push @flds,$rec->{$name};
+ }
+ } else {
+ push @flds,$rec->{$name};
+ }
+ }
+ $i++;
+ }
+ no warnings 'uninitialized';
+ return pack($self->_format, @flds);
+}
+
+sub blank {
+ my $self = shift;
+ my $rec = $self->unformat(pack($self->_format,
+ unpack($self->_format,
+ '')));
+ return $rec;
+}
+
+1;
+
+=head1 NAME
+
+Parse::Binary::FixedFormat - Convert between fixed-length fields and hashes
+
+=head1 SYNOPSIS
+
+ use Parse::Binary::FixedFormat;
+
+ my $tarhdr =
+ new Parse::Binary::FixedFormat [ qw(name:a100 mode:a8 uid:a8 gid:a8 size:a12
+ mtime:a12 chksum:a8 typeflag:a1 linkname:a100
+ magic:a6 version:a2 uname:a32 gname:a32
+ devmajor:a8 devminor:a8 prefix:a155) ];
+ my $buf;
+ read TARFILE, $buf, 512;
+
+ # create a hash from the buffer read from the file
+ my $hdr = $tarhdr->unformat($buf); # $hdr gets a hash ref
+
+ # create a flat record from a hash reference
+ my $buf = $tarhdr->format($hdr); # $hdr is a hash ref
+
+ # create a hash for a new record
+ my $newrec = $tarhdr->blank();
+
+=head1 DESCRIPTION
+
+B<Parse::Binary::FixedFormat> can be used to convert between a buffer with
+fixed-length field definitions and a hash with named entries for each
+field. The perl C<pack> and C<unpack> functions are used to perform
+the conversions. B<Parse::Binary::FixedFormat> builds the format string by
+concatenating the field descriptions and converts between the lists
+used by C<pack> and C<unpack> and a hash that can be reference by
+field name.
+
+=head1 METHODS
+
+B<Parse::Binary::FixedFormat> provides the following methods.
+
+=head2 new
+
+To create a converter, invoke the B<new> method with a reference to a
+list of field specifications.
+
+ my $cvt =
+ new Parse::Binary::FixedFormat [ 'field-name:descriptor:count', ... ];
+
+Field specifications contain the following information.
+
+=over 4
+
+=item field-name
+
+This is the name of the field and will be used as the hash index.
+
+=item descriptor
+
+This describes the content and size of the field. All of the
+descriptors get strung together and passed to B<pack> and B<unpack> as
+part of the template argument. See B<perldoc -f pack> for information
+on what can be specified here.
+
+Don't use repeat counts in the descriptor except for string types
+("a", "A", "h, "H", and "Z"). If you want to get an array out of the
+buffer, use the C<count> argument.
+
+=item count
+
+This specifies a repeat count for the field. If specified as a
+non-zero value, this field's entry in the resultant hash will be an
+array reference instead of a scalar.
+
+=back
+
+=head2 unformat
+
+To convert a buffer of data into a hash, pass the buffer to the
+B<unformat> method.
+
+ $hashref = $cvt->unformat($buf);
+
+Parse::Binary::FixedFormat applies the constructed format to the buffer with
+C<unpack> and maps the returned list of elements to hash entries.
+Fields can now be accessed by name though the hash:
+
+ print $hashref->{field-name};
+ print $hashref->{array-field}[3];
+
+=head2 format
+
+To convert the hash back into a fixed-format buffer, pass the hash
+reference to the B<format> method.
+
+ $buf = $cvt->format($hashref);
+
+=head2 blank
+
+
+To get a hash that can be used to create a new record, call the
+B<blank> method.
+
+ $newrec = $cvt->blank();
+
+=head1 ATTRIBUTES
+
+Each Parse::Binary::FixedFormat instance contains the following attributes.
+
+=over 4
+
+=item Names
+
+Names contains a list of the field names for this variant.
+
+=item Count
+
+Count contains a list of occurrence counts. This is used to indicate
+which fields contain arrays.
+
+=item Format
+
+Format contains the template string for the Perl B<pack> and B<unpack>
+functions.
+
+=back
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+Based on Data::FixedFormat, written by Thomas Pfau <pfau@nbpfaus.net>
+http://nbpfaus.net/~pfau/.
+
+=head1 COPYRIGHT
+
+Copyright 2004-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+Copyright (C) 2000,2002 Thomas Pfau. All rights reserved.
+
+This module is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2 of the License, or (at your
+option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+=cut