diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/Parse | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 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, 0 insertions, 1865 deletions
diff --git a/Master/tlpkg/tlperl/lib/Parse/Binary.pm b/Master/tlpkg/tlperl/lib/Parse/Binary.pm deleted file mode 100755 index 3c1c675915f..00000000000 --- a/Master/tlpkg/tlperl/lib/Parse/Binary.pm +++ /dev/null @@ -1,960 +0,0 @@ -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 deleted file mode 100755 index a06715bbd9c..00000000000 --- a/Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat.pm +++ /dev/null @@ -1,319 +0,0 @@ -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 deleted file mode 100755 index 66ca74fa11e..00000000000 --- a/Master/tlpkg/tlperl/lib/Parse/Binary/FixedFormat/Variants.pm +++ /dev/null @@ -1,149 +0,0 @@ -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 deleted file mode 100755 index e7d585170b1..00000000000 --- a/Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm +++ /dev/null @@ -1,437 +0,0 @@ -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 |