summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Parse
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/Parse
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (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-xMaster/tlpkg/tlperl/lib/Parse/Binary.pm960
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Parse/Binary/FixedFormat.pm319
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Parse/Binary/FixedFormat/Variants.pm149
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm437
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