diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
commit | 661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch) | |
tree | 2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/Parse | |
parent | b645030efc22e13c2498a1522083634ab91b2de1 (diff) |
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Parse')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Parse/Binary.pm | 960 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat.pm | 319 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat/Variants.pm | 149 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm | 437 |
4 files changed, 1865 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Parse/Binary.pm b/Master/tlpkg/tlperl/lib/Parse/Binary.pm new file mode 100755 index 00000000000..3c1c675915f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Parse/Binary.pm @@ -0,0 +1,960 @@ +package Parse::Binary; +$Parse::Binary::VERSION = '0.11'; + +use 5.005; +use bytes; +use strict; +use integer; +use Parse::Binary::FixedFormat; + +=head1 NAME + +Parse::Binary - Unpack binary data structures into object hierarchies + +=head1 VERSION + +This document describes version 0.11 of Parse::Binary, released +January 25, 2009. + +=head1 SYNOPSIS + +# This class represents a Win32 F<.ico> file: + + package IconFile; + use base 'Parse::Binary'; + use constant FORMAT => ( + Magic => 'a2', + Type => 'v', + Count => 'v', + 'Icon' => [ 'a16', '{$Count}', 1 ], + Data => 'a*', + ); + +# An individual icon resource: + + package Icon; + use base 'Parse::Binary'; + use constant FORMAT => ( + Width => 'C', + Height => 'C', + ColorCount => 'C', + Reserved => 'C', + Planes => 'v', + BitCount => 'v', + ImageSize => 'V', + ImageOffset => 'v', + ); + sub Data { + my ($self) = @_; + return $self->parent->substr($self->ImageOffset, $self->ImageSize); + } + +# Simple F<.ico> file dumper that uses them: + + use IconFile; + my $icon_file = IconFile->new('input.ico'); + foreach my $icon ($icon_file->members) { + print "Dimension: ", $icon->Width, "x", $icon->Height, $/; + print "Colors: ", 2 ** $icon->BitCount, $/; + print "Image Size: ", $icon->ImageSize, " bytes", $/; + print "Actual Size: ", length($icon->Data), " bytes", $/, $/; + } + $icon_file->write('output.ico'); # save as another .ico file + +=head1 DESCRIPTION + +This module makes parsing binary data structures much easier, by serving +as a base class for classes that represents the binary data, which may +contain objects of other classes to represent parts of itself. + +Documentation is unfortunately a bit lacking at this moment. Please read +the tests and source code of L<Parse::AFP> and L<Win32::Exe> for examples +of using this module. + +=cut + +use constant PROPERTIES => qw( + %struct $filename $size $parent @siblings %children + $output $lazy $iterator $iterated +); +use constant ENCODED_FIELDS => ( 'Data' ); +use constant FORMAT => ( Data => 'a*' ); +use constant SUBFORMAT => (); +use constant DEFAULT_ARGS => (); +use constant DELEGATE_SUBS => (); +use constant DISPATCH_TABLE => (); + +use constant DISPATCH_FIELD => undef; +use constant BASE_CLASS => undef; +use constant ENCODING => undef; +use constant PADDING => undef; + +unless (eval { require Scalar::Util; 1 }) { + *Scalar::Util::weaken = sub { 1 }; + *Scalar::Util::blessed = sub { UNIVERSAL::can($_[0], 'can') }; +} + +### Constructors ### + +sub new { + my ($self, $input, $attr) = @_; + + no strict 'refs'; + my $class = $self->class; + $class->init unless ${"$class\::init_done"}; + + $attr ||= {}; + $attr->{filename} ||= $input unless ref $input; + + my $obj = $class->spawn; + %$obj = (%$obj, %$attr); + + my $data = $obj->read_data($input); + $obj->load($data, $attr); + + if ($obj->{lazy}) { + $obj->{lazy} = $obj; + } + elsif (!$obj->{iterator}) { + $obj->make_members; + } + + return $obj; +} + +sub dispatch_field { + return undef; +} + +use vars qw(%HasMembers %DefaultArgs); +use vars qw(%Fields %MemberFields %MemberClass %Packer %Parser %FieldPackFormat); +use vars qw(%DispatchField %DispatchTable); + +sub init { + no strict 'refs'; + return if ${"$_[0]\::init_done"}; + + my $class = shift; + + *{"$class\::class"} = sub { ref($_[0]) || $_[0] }; + *{"$class\::is_type"} = \&is_type; + + foreach my $item ($class->PROPERTIES) { + no strict 'refs'; + my ($sigil, $name) = split(//, $item, 2); + *{"$class\::$name"} = + ($sigil eq '$') ? sub { $_[0]{$name} } : + ($sigil eq '@') ? sub { wantarray ? @{$_[0]{$name}||=[]} : ($_[0]{$name}||=[]) } : + ($sigil eq '%') ? sub { $_[0]{$name}||={} } : + die "Unknown sigil: $sigil"; + *{"$class\::set_$name"} = + ($sigil eq '$') ? sub { $_[0]->{$name} = $_[1] } : + ($sigil eq '@') ? sub { @{$_[0]->{$name}||=$_[1]||[]} = @{$_[1]||[]} } : + ($sigil eq '%') ? sub { %{$_[0]->{$name}||=$_[1]||{}} = %{$_[1]||{}} } : + die "Unknown sigil: $sigil"; + } + + my @args = $class->default_args; + *{"$class\::default_args"} = \@args; + *{"$class\::default_args"} = sub { @args }; + my $delegate_subs = $class->delegate_subs; + if (defined(&{"$class\::DELEGATE_SUBS"})) { + $delegate_subs = { $class->DELEGATE_SUBS }; + } + *{"$class\::delegate_subs"} = sub { $delegate_subs }; + while (my ($subclass, $methods) = each %$delegate_subs) { + $methods = [ $methods ] unless ref $methods; + foreach my $method (grep length, @$methods) { + *{"$class\::$method"} = sub { + goto &{$_[0]->require_class($subclass)->can($method)}; + }; + } + } + my $dispatch_table = $class->dispatch_table; + if (defined(&{"$class\::DISPATCH_TABLE"})) { + $dispatch_table = { $class->DISPATCH_TABLE }; + } + $DispatchTable{$class} = $dispatch_table; + *{"$class\::dispatch_table"} = sub { $dispatch_table }; + + my $dispatch_field = undef; + if (defined(&{"$class\::DISPATCH_FIELD"})) { + $dispatch_field = $class->DISPATCH_FIELD; + } + $DispatchField{$class} = $dispatch_field; + *{"$class\::dispatch_field"} = sub { $dispatch_field }; + + my @format = $class->format_list; + if (my @subformat = $class->subformat_list) { + my @new_format; + while (my ($field, $format) = splice(@format, 0, 2)) { + if ($field eq 'Data') { + push @new_format, @subformat; + } + else { + push @new_format, ($field => $format); + } + } + @format = @new_format; + } + my @format_list = @format; + *{"$class\::format_list"} = sub { @format_list }; + + my (@fields, @formats, @pack_formats, $underscore_count); + my (%field_format, %field_pack_format); + my (%field_parser, %field_packer, %field_length); + my (@member_fields, %member_class); + while (my ($field, $format) = splice(@format, 0, 2)) { + if ($field eq '_') { + # "we don't care" fields + $underscore_count++; + $field = "_${underscore_count}_$class"; + $field =~ s/:/_/g; + } + + if (ref $format) { + $member_class{$field} = $class->classname($field); + $field =~ s/:/_/g; + $member_class{$field} = $class->classname($field); + $class->require($member_class{$field}); + push @member_fields, $field; + } + else { + $format = [ $format ]; + } + + push @fields, $field; + + my $string = join(':', $field, @$format); + $field_format{$field} = [ @$format ]; + if (!grep /\{/, @$format) { + $field_length{$field} = length(pack($format->[0], 0)); + $field_parser{$field} = Parse::Binary::FixedFormat->new( [ $string ] ); + } + push @formats, $string; + + s/\s*X\s*//g for @$format; + my $pack_string = join(':', $field, @$format); + $field_pack_format{$field} = [ @$format ]; + $field_packer{$field} = Parse::Binary::FixedFormat->new( [ $pack_string ] ); + push @pack_formats, $pack_string; + } + + my $parser = $class->make_formatter(@formats); + my $packer = $class->make_formatter(@pack_formats); + + $Packer{$class} = $packer; + $Parser{$class} = $parser; + $Fields{$class} = \@fields; + $HasMembers{$class} = @member_fields ? 1 : 0; + $DefaultArgs{$class} = \@args; + $MemberClass{$class} = \%member_class; + $MemberFields{$class} = \@member_fields; + $FieldPackFormat{$class} = { map { ref($_) ? $_->[0] : $_ } %field_pack_format }; + + *{"$class\::fields"} = \@fields; + *{"$class\::member_fields"} = \@member_fields; + *{"$class\::has_members"} = @member_fields ? sub { 1 } : sub { 0 }; + *{"$class\::fields"} = sub { @fields }; + *{"$class\::formats"} = sub { @formats }; + *{"$class\::member_fields"} = sub { @member_fields }; + *{"$class\::member_class"} = sub { $member_class{$_[1]} }; + *{"$class\::pack_formats"} = sub { @pack_formats }; + *{"$class\::field_format"} = sub { $field_format{$_[1]}[0] }; + *{"$class\::field_pack_format"} = sub { $field_pack_format{$_[1]}[0] }; + *{"$class\::field_length"} = sub { $field_length{$_[1]} }; + + *{"$class\::parser"} = sub { $parser }; + *{"$class\::packer"} = sub { $packer }; + *{"$class\::field_parser"} = sub { + my ($self, $field) = @_; + $field_parser{$field} || do { + Parse::Binary::FixedFormat->new( [ + $self->eval_format( + $self->{struct}, + join(':', $field, @{$field_format{$field}}), + ), + ] ); + }; + }; + + *{"$class\::field_packer"} = sub { $field_packer{$_[1]} }; + *{"$class\::has_field"} = sub { $field_packer{$_[1]} }; + + my %enc_fields = map { ($_ => 1) } $class->ENCODED_FIELDS; + + foreach my $field (@fields) { + next if defined &{"$class\::$field"}; + + if ($enc_fields{$field} and my $encoding = $class->ENCODING) { + require Encode; + + *{"$class\::$field"} = sub { + my ($self) = @_; + return Encode::decode($encoding => $self->{struct}{$field}); + }; + + *{"$class\::Set$field"} = sub { + my ($self, $data) = @_; + $self->{struct}{$field} = Encode::encode($encoding => $data); + }; + next; + } + + *{"$class\::$field"} = sub { $_[0]->{struct}{$field} }; + *{"$class\::Set$field"} = sub { $_[0]->{struct}{$field} = $_[1] }; + } + + ${"$class\::init_done"} = 1; +} + +sub initialize { + return 1; +} + +### Miscellanous ### + +sub field { + my ($self, $field) = @_; + return $self->{struct}{$field}; +} + +sub set_field { + my ($self, $field, $data) = @_; + $self->{struct}{$field} = $data; +} + +sub classname { + my ($self, $class) = @_; + return undef unless $class; + + $class =~ s/__/::/g; + + my $base_class = $self->BASE_CLASS or return $class; + return $base_class if $class eq '::BASE::'; + + return "$base_class\::$class"; +} + +sub member_fields { + return (); +} + +sub dispatch_class { + my ($self, $field) = @_; + my $table = $DispatchTable{ref $self}; + my $class = exists($table->{$field}) ? $table->{$field} : $table->{'*'}; + + $class = &$class($self, $field) if UNIVERSAL::isa($class, 'CODE'); + defined $class or return; + + if (my $members = $self->{parent}{callback_members}) { + return unless $members->{$class}; + } + my $subclass = $self->classname($class) or return; + return if $subclass eq $class; + return $subclass; +} + +sub require { + my ($class, $module) = @_; + return unless defined $module; + + my $file = "$module.pm"; + $file =~ s{::}{/}g; + + return $module if (eval { require $file; 1 }); + die $@ unless $@ =~ /^Can't locate /; + return; +} + +sub require_class { + my ($class, $subclass) = @_; + return $class->require($class->classname($subclass)); +} + +sub format_list { + my ($self) = @_; + return $self->FORMAT; +} + +sub subformat_list { + my ($self) = @_; + $self->SUBFORMAT ? $self->SUBFORMAT : (); +} + +sub default_args { + my ($self) = @_; + $self->DEFAULT_ARGS ? $self->DEFAULT_ARGS : (); +} + +sub dispatch_table { + my ($self) = @_; + $self->DISPATCH_TABLE ? { $self->DISPATCH_TABLE } : {}; +} + +sub delegate_subs { + my ($self) = @_; + $self->DELEGATE_SUBS ? { $self->DELEGATE_SUBS } : {}; +} + +sub class { + my ($self) = @_; + return(ref($self) || $self); +} + +sub make_formatter { + my ($self, @formats) = @_; + return Parse::Binary::FixedFormat->new( $self->make_format(@formats) ); +} + +sub make_format { + my ($self, @formats) = @_; + return \@formats unless grep /\{/, @formats; + + my @prefix; + foreach my $format (@formats) { + last if $format =~ /\{/; + push @prefix, $format; + } + return { + Chooser => sub { $self->chooser(@_) }, + Formats => [ \@prefix, \@formats ], + }; +} + +sub chooser { + my ($self, $rec, $obj, $mode) = @_; + my $idx = @{$obj->{Layouts}}; + my @format = $self->eval_format($rec, @{$obj->{Formats}[1]}); + $obj->{Layouts}[$idx] = $self->make_formatter(@format); + return $idx; +} + +sub eval_format { + my ($self, $rec, @format) = @_; + foreach my $key (sort keys %$rec) { + s/\$$key\b/$rec->{$key}/ for @format; + } + !/\$/ and s/\{(.*?)\}/$1/eeg for @format; + die $@ if $@; + return @format; +} + +sub padding { + return ''; +} + +sub load_struct { + my ($self, $data) = @_; + $self->{struct} = $Parser{ref $self}->unformat($$data . $self->padding, $self->{lazy}, $self); +} + +sub load_size { + my ($self, $data) = @_; + $self->{size} = length($$data); + return 1; +} + +sub lazy_load { + my ($self) = @_; + ref(my $sub = $self->{lazy}) or return; + $self->{lazy} = 1; + $self->make_members unless $self->{iterator}; +} + +my %DispatchClass; +sub load { + my ($self, $data, $attr) = @_; + return $self unless defined $data; + + no strict 'refs'; + my $class = ref($self) || $self; + $class->init unless ${"$class\::init_done"}; + + $self->load_struct($data); + $self->load_size($data); + + if (my $field = $DispatchField{$class}) { + if ( + my $subclass = $DispatchClass{$class}{ $self->{struct}{$field} } + ||= $self->dispatch_class( $self->{struct}{$field}) + ) { + $self->require($subclass); + bless($self, $subclass); + $self->load($data, $attr); + } + } + + return $self; +} + +my (%classname, %fill_cache); +sub spawn { + my ($self, %args) = @_; + my $class = ref($self) || $self; + + no strict 'refs'; + + if (my $subclass = delete($args{Class})) { + $class = $classname{$subclass} ||= do { + my $name = $self->classname($subclass); + $self->require($name); + $name->init; + $name; + }; + } + + bless({ + struct => { + %args, + @{ $DefaultArgs{$class} }, + %{ $fill_cache{$class} ||= $class->fill_in }, + }, + }, $class); +} + +sub fill_in { + my $class = shift; + my $entries = {}; + + foreach my $super_class ($class->superclasses) { + my $field = $DispatchField{$super_class} or next; + my $table = $DispatchTable{$super_class} or next; + foreach my $code (reverse sort keys %$table) { + $class->is_type($table->{$code}) or next; + $entries->{$field} = $code; + last; + } + } + + return $entries; +} + +sub spawn_sibling { + my ($self, %args) = @_; + my $parent = $self->{parent} or die "$self has no parent"; + + my $obj = $self->spawn(%args); + @{$obj}{qw( lazy parent output siblings )} = + @{$self}{qw( lazy parent output siblings )}; + $obj->{size} = length($obj->dump); + $obj->refresh_parent; + $obj->initialize; + + return $obj; +} + +sub sibling_index { + my ($self, $obj) = @_; + $obj ||= $self; + + my @siblings = @{$self->{siblings}}; + foreach my $index (($obj->{index}||0) .. $#siblings) { + return $index if $obj == $siblings[$index]; + } + + return undef; +} + +sub gone { + my ($self, $obj) = @_; + $self->{parent}{struct}{Data} .= ($obj || $self)->dump; +} + +sub prepend_obj { + my ($self, %args) = @_; + if ($self->{lazy}) { + my $obj = $self->spawn(%args); + $self->gone($obj); + return; + } + my $obj = $self->spawn_sibling(%args); + my $siblings = $self->{siblings}; + my $index = $self->{index} ? $self->{index}++ : $self->sibling_index; + $obj->{index} = $index; + + splice(@$siblings, $index, 0, $obj); + return $obj; +} + +sub append_obj { + my ($self, %args) = @_; + my $obj = $self->spawn_sibling(%args); + + @{$self->{siblings}} = ( + map { $_, (($_ == $self) ? $obj : ()) } @{$self->{siblings}} + ); + return $obj; +} + +sub remove { + my ($self, %args) = @_; + my $siblings = $self->{siblings}; + splice(@$siblings, $self->sibling_index, 1, undef); + + Scalar::Util::weaken($self->{parent}); + Scalar::Util::weaken($self); +} + +sub read_data { + my ($self, $data) = @_; + return undef unless defined $data; + return \($data->dump) if UNIVERSAL::can($data, 'dump'); + return $data if UNIVERSAL::isa($data, 'SCALAR'); + return \($self->read_file($data)); +} + +sub read_file { + my ($self, $file) = @_; + + local *FH; local $/; + open FH, "< $file" or die "Cannot open $file for reading: $!"; + binmode(FH); + + return scalar <FH>; +} + +sub make_members { + my ($self) = @_; + + $HasMembers{ref $self} or return; + %{$self->{children}} = (); + + foreach my $field (@{$MemberFields{ref $self}}) { + my ($format) = $self->eval_format( + $self->{struct}, + $FieldPackFormat{ref $self}{$field}, + ); + + my $members = [ map { + $self->new_member( $field, \pack($format, @$_) ) + } $self->validate_memberdata($field) ]; + $self->set_field_children( $field, $members ); + } +} + +sub set_members { + my ($self, $field, $members) = @_; + $field =~ s/:/_/g; + $self->set_field_children( + $field, + [ map { $self->new_member( $field, $_ ) } @$members ], + ); +} + +sub set_field_children { + my ($self, $field, $data) = @_; + my $children = $self->field_children($field); + @$children = @$data; + return $children; +} + +sub field_children { + my ($self, $field) = @_; + my $children = ($self->{children}{$field} ||= []); + # $_->lazy_load for @$children; + return(wantarray ? @$children : $children); +} + +sub validate_memberdata { + my ($self, $field) = @_; + return @{$self->{struct}{$field}||[]}; +} + +sub first_member { + my ($self, $type) = @_; + $self->lazy_load; + + return undef unless $HasMembers{ref $self}; + + no strict 'refs'; + foreach my $field (@{$MemberFields{ref $self}}) { + foreach my $member ($self->field_children($field)) { + return $member if $member->is_type($type); + } + } + return undef; +} + +sub next_member { + my ($self, $type) = @_; + return undef unless $HasMembers{ref $self}; + + if ($self->{lazy} and !$self->{iterated}) { + if (ref($self->{lazy})) { + %{$self->{children}} = (); + $self->{iterator} = $self->make_next_member; + $self->lazy_load; + } + + while (my $member = &{$self->{iterator}}) { + return $member if $member->is_type($type); + } + $self->{iterated} = 1; + return; + } + + $self->{_next_member}{$type} ||= $self->members($type); + + shift(@{$self->{_next_member}{$type}}) + || undef($self->{_next_member}{$type}); +} + +sub make_next_member { + my $self = shift; + my $class = ref($self); + my ($field_idx, $item_idx, $format) = (0, 0, undef); + my @fields = @{$MemberFields{$class}}; + my $struct = $self->{struct}; + my $formats = $FieldPackFormat{$class}; + + sub { LOOP: { + my $field = $fields[$field_idx] or return; + + my $items = $struct->{$field}; + if ($item_idx > $#$items) { + $field_idx++; + $item_idx = 0; + undef $format; + redo; + } + + $format ||= ($self->eval_format( $struct, $formats->{$field} ))[0]; + + my $item = $items->[$item_idx++]; + $item = $item->($self, $items) if UNIVERSAL::isa($item, 'CODE'); + $self->valid_memberdata($item) or redo; + + my $member = $self->new_member( $field, \pack($format, @$item) ); + $member->{index} = (push @{$self->{children}{$field}}, $member) - 1; + return $member; + } }; +} + +sub members { + my ($self, $type) = @_; + $self->lazy_load; + + no strict 'refs'; + my @members = map { + grep { $type ? $_->is_type($type) : 1 } $self->field_children($_) + } @{$MemberFields{ref $self}}; + wantarray ? @members : \@members; +} + +sub members_recursive { + my ($self, $type) = @_; + my @members = ( + ( $self->is_type($type) ? $self : () ), + map { $_->members_recursive($type) } $self->members + ); + wantarray ? @members : \@members; +} + +sub new_member { + my ($self, $field, $data) = @_; + my $obj = $MemberClass{ref $self}{$field}->new( + $data, { lazy => $self->{lazy}, parent => $self } + ); + + $obj->{output} = $self->{output}; + $obj->{siblings} = $self->{children}{$field}||=[]; + $obj->initialize; + + return $obj; +} + +sub valid_memberdata { + length($_[-1][0]) +} + +sub dump_members { + my ($self) = @_; + return $Packer{ref $self}->format($self->{struct}); +} + +sub dump { + my ($self) = @_; + return $self->dump_members if $HasMembers{ref $self}; + return $Packer{ref $self}->format($self->{struct}); +} + +sub write { + my ($self, $file) = @_; + + if (ref($file)) { + $$file = $self->dump; + } + elsif (!defined($file) and my $fh = $self->{output}) { + print $fh $self->dump; + } + else { + $file = $self->{filename} unless defined $file; + $self->write_file($file, $self->dump) if defined $file; + } +} + +sub write_file { + my ($self, $file, $data) = @_; + local *FH; + open FH, "> $file" or die "Cannot open $file for writing: $!"; + binmode(FH); + print FH $data; +}; + +sub superclasses { + my ($self) = @_; + my $class = $self->class; + + no strict 'refs'; + return @{"$class\::ISA"}; +} + +my %type_cache; +sub is_type { + my ($self, $type) = @_; + return 1 unless defined $type; + + my $class = ref($self) || $self; + + if (exists $type_cache{$class}{$type}) { + return $type_cache{$class}{$type}; + } + + $type_cache{$class}{$type} = 1; + + + $type =~ s/__/::/g; + $type =~ s/[^\w:]//g; + return 1 if ($class =~ /::$type$/); + + no strict 'refs'; + foreach my $super_class ($class->superclasses) { + return 1 if $super_class->is_type($type); + }; + + $type_cache{$class}{$type} = 0; +} + +sub refresh { + my ($self) = @_; + + foreach my $field (@{$MemberFields{ref $self}}) { + my $parser = $self->field_parser($field); + my $padding = $self->padding; + + local $SIG{__WARN__} = sub {}; + @{$self->{struct}{$field}} = map { + $parser->unformat( $_->dump . $padding, 0, $self)->{$field}[0] + } grep defined, @{$self->{children}{$field}||[]}; + + $self->validate_memberdata; + } + + $self->refresh_parent; +} + +sub refresh_parent { + my ($self) = @_; + my $parent = $self->{parent} or return; + $parent->refresh unless !Scalar::Util::blessed($parent) or $parent->{lazy}; +} + +sub first_parent { + my ($self, $type) = @_; + return $self if $self->is_type($type); + my $parent = $self->{parent} or return; + return $parent->first_parent($type); +} + +sub substr { + my $self = shift; + my $data = $self->Data; + my $offset = shift(@_) - ($self->{size} - length($data)); + my $length = @_ ? shift(@_) : (length($data) - $offset); + my $replace = shift; + + # XXX - Check for "substr outside string" + return if $offset > length($data); + + # Fetch a range + return substr($data, $offset, $length) if !defined $replace; + + # Substitute a range + substr($data, $offset, $length, $replace); + $self->{struct}{Data} = $data; +} + +sub set_output_file { + my ($self, $file) = @_; + + open my $fh, '>', $file or die $!; + binmode($fh); + $self->{output} = $fh; +} + +my %callback_map; +sub callback { + my $self = shift; + my $pkg = shift || caller; + my $types = shift or return; + + my $map = $callback_map{"@$types"} ||= $self->callback_map($pkg, $types); + my $sub = $map->{ref $self} || $map->{'*'} or return; + unshift @_, $self; + goto &$sub; +} + +sub callback_map { + my ($self, $pkg, $types) = @_; + my %map; + my $base = $self->BASE_CLASS; + foreach my $type (map "$_", @$types) { + no strict 'refs'; + my $method = $type; + $method =~ s/::/_/g; + $method =~ s/\*/__/g; + + defined &{"$pkg\::$method"} or next; + + $type = "$base\::$type" unless $type eq '*'; + $map{$type} = \&{"$pkg\::$method"}; + } + return \%map; +} + +sub callback_members { + my $self = shift; + $self->{callback_members} = { map { ($_ => 1) } @{$_[0]} }; + + while (my $member = $self->next_member) { + $member->callback(scalar caller, @_); + } +} + +sub done { + my $self = shift; + return unless $self->{lazy}; + $self->write; + $self->remove; +} + +1; + +__END__ + +=head1 AUTHORS + +Audrey Tang E<lt>cpan@audreyt.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2004-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat.pm b/Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat.pm new file mode 100755 index 00000000000..a06715bbd9c --- /dev/null +++ b/Master/tlpkg/tlperl/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 diff --git a/Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat/Variants.pm b/Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat/Variants.pm new file mode 100755 index 00000000000..66ca74fa11e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat/Variants.pm @@ -0,0 +1,149 @@ +package Parse::Binary::FixedFormat::Variants; + +use strict; +our $VERSION = "0.03"; + +sub new { + my ($class,$recfmt) = @_; + my $self; + $self = { Layouts=>[], Chooser=>$recfmt->{Chooser}, Formats => $recfmt->{Formats} }; + bless $self, $class; + foreach my $fmt (@{$recfmt->{Formats}}) { + push @{$self->{Layouts}},new Parse::Binary::FixedFormat $fmt; + } + return $self; +} + +sub unformat { + my ($self,$frec) = @_; + my $rec = $self->{Layouts}[0]->unformat($frec); + if ($self->{Chooser}) { + my $w = &{$self->{Chooser}}($rec, $self, 'unformat'); + $rec = $self->{Layouts}[$w]->unformat($frec) if $w; + } + return $rec; +} + +sub format { + my ($self,$rec) = @_; + my $w = 0; + if ($self->{Chooser}) { + $w = &{$self->{Chooser}}($rec, $self, 'format'); + } + my $frec = $self->{Layouts}[$w]->format($rec); + return $frec; +} + +sub blank { + my ($self,$w) = @_; + $w = 0 unless $w; + my $rec = $self->{Layouts}[$w]->blank(); + return $rec; +} + +1; + +=head1 NAME + +Parse::Binary::FixedFormat::Variants - Convert between variant records and hashes + +=head1 DESCRIPTION + +B<Parse::Binary::FixedFormat> supports variant record formats. To describe a +variant structure, pass a hash reference containing the following +elements to B<new>. The object returned to handle variant records +will be a B<Parse::Binary::FixedFormat::Variants>. + +=over 4 + +=item Chooser + +When converting a buffer to a hash, this subroutine is invoked after +applying the first format to the buffer. The generated hash reference +is passed to this routine. Any field names specified in the first +format are available to be used in making a decision on which format +to use to decipher the buffer. This routine should return the index +of the proper format specification. + +When converting a hash to a buffer, this subroutine is invoked first +to choose a packing format. Since the same function is used for both +conversions, this function should restrict itself to field names that +exist in format 0 and those fields should exist in the same place in +all formats. + +=item Formats + +This is a reference to a list of formats. Each format contains a list +of field specifications. + +=back + +For example: + + my $cvt = new Parse::Binary::FixedFormat { + Chooser => sub { my $rec=shift; + $rec->{RecordType} eq '0' ? 1 : 2 + }, + Formats => [ [ 'RecordType:A1' ], + [ 'RecordType:A1', 'FieldA:A6', 'FieldB:A4:4' ], + [ 'RecordType:A1', 'FieldC:A4', 'FieldD:A18' ] ] + }; + my $rec0 = $cvt->unformat("0FieldAB[0]B[1]B[2]B[3]"); + my $rec1 = $cvt->unformat("1FldC<-----FieldD----->"); + +In the above example, the C<Chooser> function looks at the contents of +the C<RecordType> field. If it contains a '0', format 1 is used. +Otherwise, format 2 is used. + +B<Parse::Binary::FixedFormat::Variants> can be used is if it were a +B<Parse::Binary::FixedFormat>. The C<format> and C<unformat> methods will +determine which variant to use automatically. The C<blank> method +requires an argument that specifies the variant number. + +=head1 ATTRIBUTES + +Each Parse::Binary::FixedFormat::Variants instance contains the following +attributes. + +=over 4 + +=item Layouts + +Contains an array of Parse::Binary::FixedFormat objects. Each of these objects +is responsible for converting a single record format variant. + +=item Chooser + +This attribute contains the function that chooses which variant to +apply to the record. + +=back + +=head1 AUTHORS + +Audrey Tang E<lt>cpan@audreyt.orgE<gt> + +Based on Data::FixedFormat::Variants, 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 diff --git a/Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm b/Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm new file mode 100755 index 00000000000..e7d585170b1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm @@ -0,0 +1,437 @@ +package Parse::CPAN::Meta; + +use strict; +use Carp 'croak'; + +# UTF Support? +sub HAVE_UTF8 () { $] >= 5.007003 } +BEGIN { + if ( HAVE_UTF8 ) { + # The string eval helps hide this from Test::MinimumVersion + eval "require utf8;"; + die "Failed to load UTF-8 support" if $@; + } + + # Class structure + require 5.004; + require Exporter; + $Parse::CPAN::Meta::VERSION = '1.40'; + @Parse::CPAN::Meta::ISA = qw{ Exporter }; + @Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile }; +} + +# Prototypes +sub LoadFile ($); +sub Load ($); +sub _scalar ($$$); +sub _array ($$$); +sub _hash ($$$); + +# Printable characters for escapes +my %UNESCAPES = ( + z => "\x00", a => "\x07", t => "\x09", + n => "\x0a", v => "\x0b", f => "\x0c", + r => "\x0d", e => "\x1b", '\\' => '\\', +); + + + + + +##################################################################### +# Implementation + +# Create an object from a file +sub LoadFile ($) { + # Check the file + my $file = shift; + croak('You did not specify a file name') unless $file; + croak( "File '$file' does not exist" ) unless -e $file; + croak( "'$file' is a directory, not a file" ) unless -f _; + croak( "Insufficient permissions to read '$file'" ) unless -r _; + + # Slurp in the file + local $/ = undef; + local *CFG; + unless ( open( CFG, $file ) ) { + croak("Failed to open file '$file': $!"); + } + my $yaml = <CFG>; + unless ( close(CFG) ) { + croak("Failed to close file '$file': $!"); + } + + # Hand off to the actual parser + Load( $yaml ); +} + +# Parse a document from a string. +# Doing checks on $_[0] prevents us having to do a string copy. +sub Load ($) { + my $string = $_[0]; + unless ( defined $string ) { + croak("Did not provide a string to load"); + } + + # Byte order marks + if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) { + croak("Stream has a non UTF-8 Unicode Byte Order Mark"); + } else { + # Strip UTF-8 bom if found, we'll just ignore it + $string =~ s/^\357\273\277//; + } + + # Try to decode as utf8 + utf8::decode($string) if HAVE_UTF8; + + # Check for some special cases + return () unless length $string; + unless ( $string =~ /[\012\015]+\z/ ) { + croak("Stream does not end with newline character"); + } + + # Split the file into lines + my @lines = grep { ! /^\s*(?:\#.*)?\z/ } + split /(?:\015{1,2}\012|\015|\012)/, $string; + + # Strip the initial YAML header + @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; + + # A nibbling parser + my @documents = (); + while ( @lines ) { + # Do we have a document header? + if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { + # Handle scalar documents + shift @lines; + if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { + push @documents, _scalar( "$1", [ undef ], \@lines ); + next; + } + } + + if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { + # A naked document + push @documents, undef; + while ( @lines and $lines[0] !~ /^---/ ) { + shift @lines; + } + + } elsif ( $lines[0] =~ /^\s*\-/ ) { + # An array at the root + my $document = [ ]; + push @documents, $document; + _array( $document, [ 0 ], \@lines ); + + } elsif ( $lines[0] =~ /^(\s*)\S/ ) { + # A hash at the root + my $document = { }; + push @documents, $document; + _hash( $document, [ length($1) ], \@lines ); + + } else { + croak("Parse::CPAN::Meta failed to classify line '$lines[0]'"); + } + } + + if ( wantarray ) { + return @documents; + } else { + return $documents[-1]; + } +} + +# Deparse a scalar string to the actual scalar +sub _scalar ($$$) { + my ($string, $indent, $lines) = @_; + + # Trim trailing whitespace + $string =~ s/\s*\z//; + + # Explitic null/undef + return undef if $string eq '~'; + + # Quotes + if ( $string =~ /^\'(.*?)\'\z/ ) { + return '' unless defined $1; + $string = $1; + $string =~ s/\'\'/\'/g; + return $string; + } + if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) { + # Reusing the variable is a little ugly, + # but avoids a new variable and a string copy. + $string = $1; + $string =~ s/\\"/"/g; + $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex; + return $string; + } + + # Special cases + if ( $string =~ /^[\'\"!&]/ ) { + croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'"); + } + return {} if $string eq '{}'; + return [] if $string eq '[]'; + + # Regular unquoted string + return $string unless $string =~ /^[>|]/; + + # Error + croak("Parse::CPAN::Meta failed to find multi-line scalar content") unless @$lines; + + # Check the indent depth + $lines->[0] =~ /^(\s*)/; + $indent->[-1] = length("$1"); + if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { + croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'"); + } + + # Pull the lines + my @multiline = (); + while ( @$lines ) { + $lines->[0] =~ /^(\s*)/; + last unless length($1) >= $indent->[-1]; + push @multiline, substr(shift(@$lines), length($1)); + } + + my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; + my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; + return join( $j, @multiline ) . $t; +} + +# Parse an array +sub _array ($$$) { + my ($array, $indent, $lines) = @_; + + while ( @$lines ) { + # Check for a new document + if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { + while ( @$lines and $lines->[0] !~ /^---/ ) { + shift @$lines; + } + return 1; + } + + # Check the indent level + $lines->[0] =~ /^(\s*)/; + if ( length($1) < $indent->[-1] ) { + return 1; + } elsif ( length($1) > $indent->[-1] ) { + croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'"); + } + + if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { + # Inline nested hash + my $indent2 = length("$1"); + $lines->[0] =~ s/-/ /; + push @$array, { }; + _hash( $array->[-1], [ @$indent, $indent2 ], $lines ); + + } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { + # Array entry with a value + shift @$lines; + push @$array, _scalar( "$2", [ @$indent, undef ], $lines ); + + } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { + shift @$lines; + unless ( @$lines ) { + push @$array, undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)\-/ ) { + my $indent2 = length("$1"); + if ( $indent->[-1] == $indent2 ) { + # Null array entry + push @$array, undef; + } else { + # Naked indenter + push @$array, [ ]; + _array( $array->[-1], [ @$indent, $indent2 ], $lines ); + } + + } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { + push @$array, { }; + _hash( $array->[-1], [ @$indent, length("$1") ], $lines ); + + } else { + croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'"); + } + + } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { + # This is probably a structure like the following... + # --- + # foo: + # - list + # bar: value + # + # ... so lets return and let the hash parser handle it + return 1; + + } else { + croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'"); + } + } + + return 1; +} + +# Parse an array +sub _hash ($$$) { + my ($hash, $indent, $lines) = @_; + + while ( @$lines ) { + # Check for a new document + if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { + while ( @$lines and $lines->[0] !~ /^---/ ) { + shift @$lines; + } + return 1; + } + + # Check the indent level + $lines->[0] =~ /^(\s*)/; + if ( length($1) < $indent->[-1] ) { + return 1; + } elsif ( length($1) > $indent->[-1] ) { + croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'"); + } + + # Get the key + unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) { + if ( $lines->[0] =~ /^\s*[?\'\"]/ ) { + croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'"); + } + croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'"); + } + my $key = $1; + + # Do we have a value? + if ( length $lines->[0] ) { + # Yes + $hash->{$key} = _scalar( shift(@$lines), [ @$indent, undef ], $lines ); + } else { + # An indent + shift @$lines; + unless ( @$lines ) { + $hash->{$key} = undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)-/ ) { + $hash->{$key} = []; + _array( $hash->{$key}, [ @$indent, length($1) ], $lines ); + } elsif ( $lines->[0] =~ /^(\s*)./ ) { + my $indent2 = length("$1"); + if ( $indent->[-1] >= $indent2 ) { + # Null hash entry + $hash->{$key} = undef; + } else { + $hash->{$key} = {}; + _hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); + } + } + } + } + + return 1; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Parse::CPAN::Meta - Parse META.yml and other similar CPAN metadata files + +=head1 SYNOPSIS + + ############################################# + # In your file + + --- + rootproperty: blah + section: + one: two + three: four + Foo: Bar + empty: ~ + + + + ############################################# + # In your program + + use Parse::CPAN::Meta; + + # Create a YAML file + my @yaml = Parse::CPAN::Meta::LoadFile( 'Meta.yml' ); + + # Reading properties + my $root = $yaml[0]->{rootproperty}; + my $one = $yaml[0]->{section}->{one}; + my $Foo = $yaml[0]->{section}->{Foo}; + +=head1 DESCRIPTION + +B<Parse::CPAN::Meta> is a parser for F<META.yml> files, based on the +parser half of L<YAML::Tiny>. + +It supports a basic subset of the full YAML specification, enough to +implement parsing of typical F<META.yml> files, and other similarly simple +YAML files. + +If you need something with more power, move up to a full YAML parser such +as L<YAML>, L<YAML::Syck> or L<YAML::LibYAML>. + +B<Parse::CPAN::Meta> provides a very simply API of only two functions, +based on the YAML functions of the same name. Wherever possible, +identical calling semantics are used. + +All error reporting is done with exceptions (die'ing). + +=head1 FUNCTIONS + +For maintenance clarity, no functions are exported. + +=head2 Load + + my @yaml = Load( $string ); + +Parses a string containing a valid YAML stream into a list of Perl data +structures. + +=head2 LoadFile + + my @yaml = LoadFile( 'META.yml' ); + +Reads the YAML stream from a file instead of a string. + +=head1 SUPPORT + +Bugs should be reported via the CPAN bug tracker at + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Parse-CPAN-Meta> + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>, +L<http://use.perl.org/~Alias/journal/29427>, L<http://ali.as/> + +=head1 COPYRIGHT + +Copyright 2006 - 2009 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut |