Initial Commit

database/perl/vendor/lib/Parse/Binary.pm

@@ -0,0 +1,960 @@
+package Parse::Binary;
+$Parse::Binary::VERSION = '0.11';
+
+use 5.005;
+use bytes;
+use strict;
+use integer;
+use Parse::Binary::FixedFormat;
+
+=head1 NAME
+
+Parse::Binary - Unpack binary data structures into object hierarchies
+
+=head1 VERSION
+
+This document describes version 0.11 of Parse::Binary, released
+January 25, 2009.
+
+=head1 SYNOPSIS
+
+# This class represents a Win32 F<.ico> file:
+
+    package IconFile;
+    use base 'Parse::Binary';
+    use constant FORMAT => (
+	Magic		=> 'a2',
+	Type		=> 'v',
+	Count		=> 'v',
+	'Icon'		=> [ 'a16', '{$Count}', 1 ],
+	Data		=> 'a*',
+    );
+
+# An individual icon resource:
+
+    package Icon;
+    use base 'Parse::Binary';
+    use constant FORMAT => (
+	Width		=> 'C',
+	Height		=> 'C',
+	ColorCount	=> 'C',
+	Reserved	=> 'C',
+	Planes		=> 'v',
+	BitCount	=> 'v',
+	ImageSize	=> 'V',
+	ImageOffset	=> 'v',
+    );
+    sub Data {
+	my ($self) = @_;
+	return $self->parent->substr($self->ImageOffset, $self->ImageSize);
+    }
+
+# Simple F<.ico> file dumper that uses them:
+
+    use IconFile;
+    my $icon_file = IconFile->new('input.ico');
+    foreach my $icon ($icon_file->members) {
+	print "Dimension: ", $icon->Width, "x", $icon->Height, $/;
+	print "Colors: ", 2 ** $icon->BitCount, $/;
+	print "Image Size: ", $icon->ImageSize, " bytes", $/;
+	print "Actual Size: ", length($icon->Data), " bytes", $/, $/;
+    }
+    $icon_file->write('output.ico'); # save as another .ico file
+
+=head1 DESCRIPTION
+
+This module makes parsing binary data structures much easier, by serving
+as a base class for classes that represents the binary data, which may
+contain objects of other classes to represent parts of itself.
+
+Documentation is unfortunately a bit lacking at this moment.  Please read
+the tests and source code of L<Parse::AFP> and L<Win32::Exe> for examples
+of using this module.
+
+=cut
+
+use constant PROPERTIES	    => qw(
+    %struct $filename $size $parent @siblings %children
+    $output $lazy $iterator $iterated
+);
+use constant ENCODED_FIELDS => ( 'Data' );
+use constant FORMAT	    => ( Data => 'a*' );
+use constant SUBFORMAT	    => ();
+use constant DEFAULT_ARGS   => ();
+use constant DELEGATE_SUBS  => ();
+use constant DISPATCH_TABLE => ();
+
+use constant DISPATCH_FIELD => undef;
+use constant BASE_CLASS	    => undef;
+use constant ENCODING	    => undef;
+use constant PADDING	    => undef;
+
+unless (eval { require Scalar::Util; 1 }) {
+    *Scalar::Util::weaken = sub { 1 };
+    *Scalar::Util::blessed = sub { UNIVERSAL::can($_[0], 'can') };
+}
+
+### Constructors ###
+
+sub new {
+    my ($self, $input, $attr) = @_;
+
+    no strict 'refs';
+    my $class = $self->class;
+    $class->init unless ${"$class\::init_done"};
+
+    $attr ||= {};
+    $attr->{filename} ||= $input unless ref $input;
+
+    my $obj = $class->spawn;
+    %$obj = (%$obj, %$attr);
+
+    my $data = $obj->read_data($input);
+    $obj->load($data, $attr);
+
+    if ($obj->{lazy}) {
+	$obj->{lazy} = $obj;
+    }
+    elsif (!$obj->{iterator}) {
+	$obj->make_members;
+    }
+
+    return $obj;
+}
+
+sub dispatch_field {
+    return undef;
+}
+
+use vars qw(%HasMembers %DefaultArgs);
+use vars qw(%Fields %MemberFields %MemberClass %Packer %Parser %FieldPackFormat);
+use vars qw(%DispatchField %DispatchTable);
+
+sub init {
+    no strict 'refs';
+    return if ${"$_[0]\::init_done"};
+
+    my $class = shift;
+
+    *{"$class\::class"} = sub { ref($_[0]) || $_[0] };
+    *{"$class\::is_type"} = \&is_type;
+
+    foreach my $item ($class->PROPERTIES) {
+	no strict 'refs';
+	my ($sigil, $name) = split(//, $item, 2);
+	*{"$class\::$name"} =
+	    ($sigil eq '$') ? sub { $_[0]{$name} } :
+	    ($sigil eq '@') ? sub { wantarray ? @{$_[0]{$name}||=[]} : ($_[0]{$name}||=[]) } :
+	    ($sigil eq '%') ? sub { $_[0]{$name}||={} } :
+	    die "Unknown sigil: $sigil";
+	*{"$class\::set_$name"} =
+	    ($sigil eq '$') ? sub { $_[0]->{$name} = $_[1] } :
+	    ($sigil eq '@') ? sub { @{$_[0]->{$name}||=$_[1]||[]} = @{$_[1]||[]} } :
+	    ($sigil eq '%') ? sub { %{$_[0]->{$name}||=$_[1]||{}} = %{$_[1]||{}} } :
+	    die "Unknown sigil: $sigil";
+    }
+
+    my @args = $class->default_args;
+    *{"$class\::default_args"} = \@args;
+    *{"$class\::default_args"} = sub { @args };
+    my $delegate_subs = $class->delegate_subs;
+    if (defined(&{"$class\::DELEGATE_SUBS"})) {
+	$delegate_subs = { $class->DELEGATE_SUBS };
+    }
+    *{"$class\::delegate_subs"} = sub { $delegate_subs };
+    while (my ($subclass, $methods) = each %$delegate_subs) {
+	$methods = [ $methods ] unless ref $methods;
+	foreach my $method (grep length, @$methods) {
+	    *{"$class\::$method"} = sub {
+		goto &{$_[0]->require_class($subclass)->can($method)};
+	    };
+	}
+    }
+    my $dispatch_table = $class->dispatch_table;
+    if (defined(&{"$class\::DISPATCH_TABLE"})) {
+	$dispatch_table = { $class->DISPATCH_TABLE };
+    }
+    $DispatchTable{$class} = $dispatch_table;
+    *{"$class\::dispatch_table"} = sub { $dispatch_table };
+
+    my $dispatch_field = undef;
+    if (defined(&{"$class\::DISPATCH_FIELD"})) {
+	$dispatch_field = $class->DISPATCH_FIELD;
+    }
+    $DispatchField{$class} = $dispatch_field;
+    *{"$class\::dispatch_field"} = sub { $dispatch_field };
+
+    my @format = $class->format_list;
+    if (my @subformat = $class->subformat_list) {
+	my @new_format;
+	while (my ($field, $format) = splice(@format, 0, 2)) {
+	    if ($field eq 'Data') {
+		push @new_format, @subformat;
+	    }
+	    else {
+		push @new_format, ($field => $format);
+	    }
+	}
+	@format = @new_format;
+    }
+    my @format_list = @format;
+    *{"$class\::format_list"} = sub { @format_list };
+
+    my (@fields, @formats, @pack_formats, $underscore_count);
+    my (%field_format, %field_pack_format);
+    my (%field_parser, %field_packer, %field_length);
+    my (@member_fields, %member_class);
+    while (my ($field, $format) = splice(@format, 0, 2)) {
+	if ($field eq '_') {
+	    # "we don't care" fields 
+	    $underscore_count++;
+	    $field = "_${underscore_count}_$class";
+	    $field =~ s/:/_/g;
+	}
+
+	if (ref $format) {
+	    $member_class{$field} = $class->classname($field);
+	    $field =~ s/:/_/g;
+	    $member_class{$field} = $class->classname($field);
+	    $class->require($member_class{$field});
+	    push @member_fields, $field;
+	}
+	else {
+	    $format = [ $format ];
+	}
+
+	push @fields, $field;
+
+	my $string = join(':', $field, @$format);
+	$field_format{$field} = [ @$format ];
+	if (!grep /\{/, @$format) {
+	    $field_length{$field} = length(pack($format->[0], 0));
+	    $field_parser{$field} = Parse::Binary::FixedFormat->new( [ $string ] );
+	}
+	push @formats, $string;
+
+	s/\s*X\s*//g for @$format;
+	my $pack_string = join(':', $field, @$format);
+	$field_pack_format{$field} = [ @$format ];
+	$field_packer{$field} = Parse::Binary::FixedFormat->new( [ $pack_string ] );
+	push @pack_formats, $pack_string;
+    }
+
+    my $parser = $class->make_formatter(@formats);
+    my $packer = $class->make_formatter(@pack_formats);
+
+    $Packer{$class} = $packer;
+    $Parser{$class} = $parser;
+    $Fields{$class} = \@fields;
+    $HasMembers{$class} = @member_fields ? 1 : 0;
+    $DefaultArgs{$class} = \@args;
+    $MemberClass{$class} = \%member_class;
+    $MemberFields{$class} = \@member_fields;
+    $FieldPackFormat{$class} = { map { ref($_) ? $_->[0] : $_ } %field_pack_format };
+
+    *{"$class\::fields"} = \@fields;
+    *{"$class\::member_fields"} = \@member_fields;
+    *{"$class\::has_members"} = @member_fields ? sub { 1 } : sub { 0 };
+    *{"$class\::fields"} = sub { @fields };
+    *{"$class\::formats"} = sub { @formats };
+    *{"$class\::member_fields"} = sub { @member_fields };
+    *{"$class\::member_class"} = sub { $member_class{$_[1]} };
+    *{"$class\::pack_formats"} = sub { @pack_formats };
+    *{"$class\::field_format"} = sub { $field_format{$_[1]}[0] };
+    *{"$class\::field_pack_format"} = sub { $field_pack_format{$_[1]}[0] };
+    *{"$class\::field_length"} = sub { $field_length{$_[1]} };
+
+    *{"$class\::parser"} = sub { $parser };
+    *{"$class\::packer"} = sub { $packer };
+    *{"$class\::field_parser"} = sub {
+	my ($self, $field) = @_;
+	$field_parser{$field} || do {
+	    Parse::Binary::FixedFormat->new( [
+		$self->eval_format(
+		    $self->{struct},
+		    join(':', $field, @{$field_format{$field}}),
+		),
+	    ] );
+	};
+    };
+
+    *{"$class\::field_packer"} = sub { $field_packer{$_[1]} };
+    *{"$class\::has_field"} = sub { $field_packer{$_[1]} };
+
+    my %enc_fields = map { ($_ => 1) } $class->ENCODED_FIELDS;
+
+    foreach my $field (@fields) {
+	next if defined &{"$class\::$field"};
+
+	if ($enc_fields{$field} and my $encoding = $class->ENCODING) {
+	    require Encode;
+
+	    *{"$class\::$field"} = sub {
+		my ($self) = @_;
+		return Encode::decode($encoding => $self->{struct}{$field});
+	    };
+
+	    *{"$class\::Set$field"} = sub {
+		my ($self, $data) = @_;
+		$self->{struct}{$field} = Encode::encode($encoding => $data);
+	    };
+	    next;
+	}
+
+	*{"$class\::$field"} = sub { $_[0]->{struct}{$field} };
+	*{"$class\::Set$field"} = sub { $_[0]->{struct}{$field} = $_[1] };
+    }
+
+    ${"$class\::init_done"} = 1;
+}
+
+sub initialize {
+    return 1;
+}
+
+### Miscellanous ###
+
+sub field {
+    my ($self, $field) = @_;
+    return $self->{struct}{$field};
+}
+
+sub set_field {
+    my ($self, $field, $data) = @_;
+    $self->{struct}{$field} = $data;
+}
+
+sub classname {
+    my ($self, $class) = @_;
+    return undef unless $class;
+
+    $class =~ s/__/::/g;
+
+    my $base_class = $self->BASE_CLASS or return $class;
+    return $base_class if $class eq '::BASE::';
+
+    return "$base_class\::$class";
+}
+
+sub member_fields {
+    return ();
+}
+
+sub dispatch_class {
+    my ($self, $field) = @_;
+    my $table = $DispatchTable{ref $self};
+    my $class = exists($table->{$field}) ? $table->{$field} : $table->{'*'};
+
+    $class = &$class($self, $field) if UNIVERSAL::isa($class, 'CODE');
+    defined $class or return;
+
+    if (my $members = $self->{parent}{callback_members}) {
+	return unless $members->{$class};
+    }
+    my $subclass = $self->classname($class) or return;
+    return if $subclass eq $class;
+    return $subclass;
+}
+
+sub require {
+    my ($class, $module) = @_;
+    return unless defined $module;
+
+    my $file = "$module.pm";
+    $file =~ s{::}{/}g;
+
+    return $module if (eval { require $file; 1 });
+    die $@ unless $@ =~ /^Can't locate /;
+    return;
+}
+
+sub require_class {
+    my ($class, $subclass) = @_;
+    return $class->require($class->classname($subclass));
+}
+
+sub format_list {
+    my ($self) = @_;
+    return $self->FORMAT;
+}
+
+sub subformat_list {
+    my ($self) = @_;
+    $self->SUBFORMAT ? $self->SUBFORMAT : ();
+}
+
+sub default_args {
+    my ($self) = @_;
+    $self->DEFAULT_ARGS ? $self->DEFAULT_ARGS : ();
+}
+
+sub dispatch_table {
+    my ($self) = @_;
+    $self->DISPATCH_TABLE ? { $self->DISPATCH_TABLE } : {};
+}
+
+sub delegate_subs {
+    my ($self) = @_;
+    $self->DELEGATE_SUBS ? { $self->DELEGATE_SUBS } : {};
+}
+
+sub class {
+    my ($self) = @_;
+    return(ref($self) || $self);
+}
+
+sub make_formatter {
+    my ($self, @formats) = @_;
+    return Parse::Binary::FixedFormat->new( $self->make_format(@formats) );
+}
+
+sub make_format {
+    my ($self, @formats) = @_;
+    return \@formats unless grep /\{/, @formats;
+
+    my @prefix;
+    foreach my $format (@formats) {
+	last if $format =~ /\{/;
+	push @prefix, $format;
+    }
+    return {
+	Chooser => sub { $self->chooser(@_) },
+	Formats => [ \@prefix, \@formats ],
+    };
+}
+
+sub chooser {
+    my ($self, $rec, $obj, $mode) = @_;
+    my $idx = @{$obj->{Layouts}};
+    my @format = $self->eval_format($rec, @{$obj->{Formats}[1]});
+    $obj->{Layouts}[$idx] = $self->make_formatter(@format);
+    return $idx;
+}
+
+sub eval_format {
+    my ($self, $rec, @format) = @_;
+    foreach my $key (sort keys %$rec) {
+	s/\$$key\b/$rec->{$key}/ for @format;
+    }
+    !/\$/ and s/\{(.*?)\}/$1/eeg for @format;
+    die $@ if $@;
+    return @format;
+}
+
+sub padding {
+    return '';
+}
+
+sub load_struct {
+    my ($self, $data) = @_;
+    $self->{struct} = $Parser{ref $self}->unformat($$data . $self->padding, $self->{lazy}, $self);
+}
+
+sub load_size {
+    my ($self, $data) = @_;
+    $self->{size} = length($$data);
+    return 1;
+}
+
+sub lazy_load {
+    my ($self) = @_;
+    ref(my $sub = $self->{lazy}) or return;
+    $self->{lazy} = 1;
+    $self->make_members unless $self->{iterator};
+}
+
+my %DispatchClass;
+sub load {
+    my ($self, $data, $attr) = @_;
+    return $self unless defined $data;
+
+    no strict 'refs';
+    my $class = ref($self) || $self;
+    $class->init unless ${"$class\::init_done"};
+
+    $self->load_struct($data);
+    $self->load_size($data);
+
+    if (my $field = $DispatchField{$class}) {
+	if (
+	    my $subclass = $DispatchClass{$class}{ $self->{struct}{$field} }
+		||= $self->dispatch_class( $self->{struct}{$field})
+	) {
+	    $self->require($subclass);
+	    bless($self, $subclass);
+	    $self->load($data, $attr);
+	}
+    }
+
+    return $self;
+}
+
+my (%classname, %fill_cache);
+sub spawn {
+    my ($self, %args) = @_;
+    my $class = ref($self) || $self;
+
+    no strict 'refs';
+
+    if (my $subclass = delete($args{Class})) {
+	$class = $classname{$subclass} ||= do {
+	    my $name = $self->classname($subclass);
+	    $self->require($name);
+	    $name->init;
+	    $name;
+	};
+    }
+
+    bless({
+	struct => {
+	    %args,
+	    @{ $DefaultArgs{$class} },
+	    %{ $fill_cache{$class} ||= $class->fill_in },
+	},
+    }, $class);
+}
+
+sub fill_in {
+    my $class = shift;
+    my $entries = {};
+
+    foreach my $super_class ($class->superclasses) {
+	my $field = $DispatchField{$super_class} or next;
+	my $table = $DispatchTable{$super_class} or next;
+	foreach my $code (reverse sort keys %$table) {
+	    $class->is_type($table->{$code}) or next;
+	    $entries->{$field} = $code;
+	    last;
+	}
+    }
+
+    return $entries;
+}
+
+sub spawn_sibling {
+    my ($self, %args) = @_;
+    my $parent = $self->{parent} or die "$self has no parent";
+
+    my $obj = $self->spawn(%args);
+    @{$obj}{qw( lazy parent output siblings )} =
+	@{$self}{qw( lazy parent output siblings )};
+    $obj->{size} = length($obj->dump);
+    $obj->refresh_parent;
+    $obj->initialize;
+
+    return $obj;
+}
+
+sub sibling_index {
+    my ($self, $obj) = @_;
+    $obj ||= $self;
+
+    my @siblings = @{$self->{siblings}};
+    foreach my $index (($obj->{index}||0) .. $#siblings) {
+	return $index if $obj == $siblings[$index];
+    }
+
+    return undef;
+}
+
+sub gone {
+    my ($self, $obj) = @_;
+    $self->{parent}{struct}{Data} .= ($obj || $self)->dump;
+}
+
+sub prepend_obj {
+    my ($self, %args) = @_;
+    if ($self->{lazy}) {
+	my $obj = $self->spawn(%args);
+	$self->gone($obj);
+	return;
+    }
+    my $obj = $self->spawn_sibling(%args);
+    my $siblings = $self->{siblings};
+    my $index = $self->{index} ? $self->{index}++ : $self->sibling_index;
+    $obj->{index} = $index;
+
+    splice(@$siblings, $index, 0, $obj);
+    return $obj;
+}
+
+sub append_obj {
+    my ($self, %args) = @_;
+    my $obj = $self->spawn_sibling(%args);
+
+    @{$self->{siblings}} = (
+	map { $_, (($_ == $self) ? $obj : ()) } @{$self->{siblings}}
+    );
+    return $obj;
+}
+
+sub remove {
+    my ($self, %args) = @_;
+    my $siblings = $self->{siblings};
+    splice(@$siblings, $self->sibling_index, 1, undef);
+
+    Scalar::Util::weaken($self->{parent});
+    Scalar::Util::weaken($self);
+}
+
+sub read_data {
+    my ($self, $data) = @_;
+    return undef unless defined $data;
+    return \($data->dump) if UNIVERSAL::can($data, 'dump');
+    return $data if UNIVERSAL::isa($data, 'SCALAR');
+    return \($self->read_file($data));
+}
+
+sub read_file {
+    my ($self, $file) = @_;
+
+    local *FH; local $/;
+    open FH, "< $file" or die "Cannot open $file for reading: $!";
+    binmode(FH);
+
+    return scalar <FH>;
+}
+
+sub make_members {
+    my ($self) = @_;
+
+    $HasMembers{ref $self} or return;
+    %{$self->{children}} = ();
+
+    foreach my $field (@{$MemberFields{ref $self}}) {
+	my ($format) = $self->eval_format(
+	    $self->{struct},
+	    $FieldPackFormat{ref $self}{$field},
+	);
+
+	my $members = [ map {
+	    $self->new_member( $field, \pack($format, @$_) )
+	} $self->validate_memberdata($field) ];
+	$self->set_field_children( $field, $members );
+    }
+}
+
+sub set_members {
+    my ($self, $field, $members) = @_;
+    $field =~ s/:/_/g;
+    $self->set_field_children(
+	$field,
+	[ map { $self->new_member( $field, $_ ) } @$members ],
+    );
+}
+
+sub set_field_children {
+    my ($self, $field, $data) = @_;
+    my $children = $self->field_children($field);
+    @$children = @$data;
+    return $children;
+}
+
+sub field_children {
+    my ($self, $field) = @_;
+    my $children = ($self->{children}{$field} ||= []);
+    # $_->lazy_load for @$children;
+    return(wantarray ? @$children : $children);
+}
+
+sub validate_memberdata {
+    my ($self, $field) = @_;
+    return @{$self->{struct}{$field}||[]};
+}
+
+sub first_member {
+    my ($self, $type) = @_;
+    $self->lazy_load;
+
+    return undef unless $HasMembers{ref $self};
+
+    no strict 'refs';
+    foreach my $field (@{$MemberFields{ref $self}}) {
+	foreach my $member ($self->field_children($field)) {
+	    return $member if $member->is_type($type);
+	}
+    }
+    return undef;
+}
+
+sub next_member {
+    my ($self, $type) = @_;
+    return undef unless $HasMembers{ref $self};
+
+    if ($self->{lazy} and !$self->{iterated}) {
+	if (ref($self->{lazy})) {
+	    %{$self->{children}} = ();
+	    $self->{iterator} = $self->make_next_member;
+	    $self->lazy_load;
+	}
+
+	while (my $member = &{$self->{iterator}}) {
+	    return $member if $member->is_type($type);
+	}
+	$self->{iterated} = 1;
+	return;
+    }
+
+    $self->{_next_member}{$type} ||= $self->members($type);
+
+    shift(@{$self->{_next_member}{$type}})
+	|| undef($self->{_next_member}{$type});
+}
+
+sub make_next_member {
+    my $self = shift;
+    my $class = ref($self);
+    my ($field_idx, $item_idx, $format) = (0, 0, undef);
+    my @fields = @{$MemberFields{$class}};
+    my $struct = $self->{struct};
+    my $formats = $FieldPackFormat{$class};
+
+    sub { LOOP: {
+	my $field = $fields[$field_idx] or return;
+
+	my $items = $struct->{$field};
+	if ($item_idx > $#$items) {
+	    $field_idx++;
+	    $item_idx = 0;
+	    undef $format;
+	    redo;
+	}
+
+	$format ||= ($self->eval_format( $struct, $formats->{$field} ))[0];
+
+	my $item = $items->[$item_idx++];
+	$item = $item->($self, $items) if UNIVERSAL::isa($item, 'CODE');
+	$self->valid_memberdata($item) or redo;
+
+	my $member = $self->new_member( $field, \pack($format, @$item) );
+	$member->{index} = (push @{$self->{children}{$field}}, $member) - 1;
+	return $member;
+    } };
+}
+
+sub members {
+    my ($self, $type) = @_;
+    $self->lazy_load;
+
+    no strict 'refs';
+    my @members = map {
+	grep { $type ? $_->is_type($type) : 1 } $self->field_children($_)
+    } @{$MemberFields{ref $self}};
+    wantarray ? @members : \@members;
+}
+
+sub members_recursive {
+    my ($self, $type) = @_;
+    my @members = (
+	( $self->is_type($type) ? $self : () ),
+	map { $_->members_recursive($type) } $self->members
+    );
+    wantarray ? @members : \@members;
+}
+
+sub new_member {
+    my ($self, $field, $data) = @_;
+    my $obj = $MemberClass{ref $self}{$field}->new(
+	$data, { lazy => $self->{lazy}, parent => $self }
+    );
+
+    $obj->{output} = $self->{output};
+    $obj->{siblings} = $self->{children}{$field}||=[];
+    $obj->initialize;
+
+    return $obj;
+}
+
+sub valid_memberdata {
+    length($_[-1][0])
+}
+
+sub dump_members {
+    my ($self) = @_;
+    return $Packer{ref $self}->format($self->{struct});
+}
+
+sub dump {
+    my ($self) = @_;
+    return $self->dump_members if $HasMembers{ref $self};
+    return $Packer{ref $self}->format($self->{struct});
+}
+
+sub write {
+    my ($self, $file) = @_;
+
+    if (ref($file)) {
+	$$file = $self->dump;
+    }
+    elsif (!defined($file) and my $fh = $self->{output}) {
+	print $fh $self->dump;
+    }
+    else {
+	$file = $self->{filename} unless defined $file;
+	$self->write_file($file, $self->dump) if defined $file;
+    }
+}
+
+sub write_file {
+    my ($self, $file, $data) = @_;
+    local *FH;
+    open FH, "> $file" or die "Cannot open $file for writing: $!";
+    binmode(FH);
+    print FH $data;
+};
+
+sub superclasses {
+    my ($self) = @_;
+    my $class = $self->class;
+
+    no strict 'refs';
+    return @{"$class\::ISA"};
+}
+
+my %type_cache;
+sub is_type {
+    my ($self, $type) = @_;
+    return 1 unless defined $type;
+
+    my $class = ref($self) || $self;
+
+    if (exists $type_cache{$class}{$type}) {
+	return $type_cache{$class}{$type};
+    }
+
+    $type_cache{$class}{$type} = 1;
+
+
+    $type =~ s/__/::/g;
+    $type =~ s/[^\w:]//g;
+    return 1 if ($class =~ /::$type$/);
+
+    no strict 'refs';
+    foreach my $super_class ($class->superclasses) {
+	return 1 if $super_class->is_type($type);
+    };
+
+    $type_cache{$class}{$type} = 0;
+}
+
+sub refresh {
+    my ($self) = @_;
+
+    foreach my $field (@{$MemberFields{ref $self}}) {
+	my $parser = $self->field_parser($field);
+	my $padding = $self->padding;
+
+	local $SIG{__WARN__} = sub {};
+	@{$self->{struct}{$field}} = map {
+	    $parser->unformat( $_->dump . $padding, 0, $self)->{$field}[0]
+	} grep defined, @{$self->{children}{$field}||[]};
+
+	$self->validate_memberdata;
+    }
+
+    $self->refresh_parent;
+}
+
+sub refresh_parent {
+    my ($self) = @_;
+    my $parent = $self->{parent} or return;
+    $parent->refresh unless !Scalar::Util::blessed($parent) or $parent->{lazy};
+}
+
+sub first_parent {
+    my ($self, $type) = @_;
+    return $self if $self->is_type($type);
+    my $parent = $self->{parent} or return;
+    return $parent->first_parent($type);
+}
+
+sub substr {
+    my $self    = shift;
+    my $data    = $self->Data;
+    my $offset  = shift(@_) - ($self->{size} - length($data));
+    my $length  = @_ ? shift(@_) : (length($data) - $offset);
+    my $replace = shift;
+
+    # XXX - Check for "substr outside string"
+    return if $offset > length($data);
+
+    # Fetch a range
+    return substr($data, $offset, $length) if !defined $replace;
+
+    # Substitute a range
+    substr($data, $offset, $length, $replace);
+    $self->{struct}{Data} = $data;
+}
+
+sub set_output_file {
+    my ($self, $file) = @_;
+
+    open my $fh, '>', $file or die $!;
+    binmode($fh);
+    $self->{output} = $fh;
+}
+
+my %callback_map;
+sub callback {
+    my $self  = shift;
+    my $pkg   = shift || caller;
+    my $types = shift or return;
+
+    my $map = $callback_map{"@$types"} ||= $self->callback_map($pkg, $types);
+    my $sub = $map->{ref $self} || $map->{'*'} or return;
+    unshift @_, $self;
+    goto &$sub;
+}
+
+sub callback_map {
+    my ($self, $pkg, $types) = @_;
+    my %map;
+    my $base = $self->BASE_CLASS;
+    foreach my $type (map "$_", @$types) {
+	no strict 'refs';
+	my $method = $type;
+	$method =~ s/::/_/g;
+	$method =~ s/\*/__/g;
+
+	defined &{"$pkg\::$method"} or next;
+
+	$type = "$base\::$type" unless $type eq '*';
+	$map{$type} = \&{"$pkg\::$method"};
+    }
+    return \%map;
+}
+
+sub callback_members {
+    my $self = shift;
+    $self->{callback_members} = { map { ($_ => 1) } @{$_[0]} };
+
+    while (my $member = $self->next_member) {
+	$member->callback(scalar caller, @_);
+    }
+}
+
+sub done {
+    my $self = shift;
+    return unless $self->{lazy};
+    $self->write;
+    $self->remove;
+}
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut

database/perl/vendor/lib/Parse/Binary/FixedFormat.pm

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

database/perl/vendor/lib/Parse/Binary/FixedFormat/Variants.pm

@@ -0,0 +1,149 @@
+package Parse::Binary::FixedFormat::Variants;
+
+use strict;
+our $VERSION = "0.03";
+
+sub new {
+    my ($class,$recfmt) = @_;
+    my $self;
+    $self = { Layouts=>[], Chooser=>$recfmt->{Chooser}, Formats => $recfmt->{Formats} };
+    bless $self, $class;
+    foreach my $fmt (@{$recfmt->{Formats}}) {
+	push @{$self->{Layouts}},new Parse::Binary::FixedFormat $fmt;
+    }
+    return $self;
+}
+
+sub unformat {
+    my ($self,$frec) = @_;
+    my $rec = $self->{Layouts}[0]->unformat($frec);
+    if ($self->{Chooser}) {
+	my $w = &{$self->{Chooser}}($rec, $self, 'unformat');
+	$rec = $self->{Layouts}[$w]->unformat($frec) if $w;
+    }
+    return $rec;
+}
+
+sub format {
+    my ($self,$rec) = @_;
+    my $w = 0;
+    if ($self->{Chooser}) {
+	$w = &{$self->{Chooser}}($rec, $self, 'format');
+    }
+    my $frec = $self->{Layouts}[$w]->format($rec);
+    return $frec;
+}
+
+sub blank {
+    my ($self,$w) = @_;
+    $w = 0 unless $w;
+    my $rec = $self->{Layouts}[$w]->blank();
+    return $rec;
+}
+
+1;
+
+=head1 NAME
+
+Parse::Binary::FixedFormat::Variants - Convert between variant records and hashes
+
+=head1 DESCRIPTION
+
+B<Parse::Binary::FixedFormat> supports variant record formats.  To describe a
+variant structure, pass a hash reference containing the following
+elements to B<new>.  The object returned to handle variant records
+will be a B<Parse::Binary::FixedFormat::Variants>.
+
+=over 4
+
+=item Chooser
+
+When converting a buffer to a hash, this subroutine is invoked after
+applying the first format to the buffer.  The generated hash reference
+is passed to this routine.  Any field names specified in the first
+format are available to be used in making a decision on which format
+to use to decipher the buffer.  This routine should return the index
+of the proper format specification.
+
+When converting a hash to a buffer, this subroutine is invoked first
+to choose a packing format.  Since the same function is used for both
+conversions, this function should restrict itself to field names that
+exist in format 0 and those fields should exist in the same place in
+all formats.
+
+=item Formats
+
+This is a reference to a list of formats.  Each format contains a list
+of field specifications.
+
+=back
+
+For example:
+
+    my $cvt = new Parse::Binary::FixedFormat {
+        Chooser => sub { my $rec=shift;
+		         $rec->{RecordType} eq '0' ? 1 : 2
+		       },
+	Formats => [ [ 'RecordType:A1' ],
+		     [ 'RecordType:A1', 'FieldA:A6', 'FieldB:A4:4' ],
+		     [ 'RecordType:A1', 'FieldC:A4', 'FieldD:A18' ] ]
+        };
+    my $rec0 = $cvt->unformat("0FieldAB[0]B[1]B[2]B[3]");
+    my $rec1 = $cvt->unformat("1FldC<-----FieldD----->");
+
+In the above example, the C<Chooser> function looks at the contents of
+the C<RecordType> field.  If it contains a '0', format 1 is used.
+Otherwise, format 2 is used.
+
+B<Parse::Binary::FixedFormat::Variants> can be used is if it were a
+B<Parse::Binary::FixedFormat>.  The C<format> and C<unformat> methods will
+determine which variant to use automatically.  The C<blank> method
+requires an argument that specifies the variant number.
+
+=head1 ATTRIBUTES
+
+Each Parse::Binary::FixedFormat::Variants instance contains the following
+attributes.
+
+=over 4
+
+=item Layouts
+
+Contains an array of Parse::Binary::FixedFormat objects.  Each of these objects
+is responsible for converting a single record format variant.
+
+=item Chooser
+
+This attribute contains the function that chooses which variant to
+apply to the record.
+
+=back
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+Based on Data::FixedFormat::Variants, written by Thomas Pfau <pfau@nbpfaus.net>
+http://nbpfaus.net/~pfau/.
+
+=head1 COPYRIGHT
+
+Copyright 2004-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+Copyright (C) 2000,2002 Thomas Pfau.  All rights reserved.
+
+This module is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2 of the License, or (at your
+option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+=cut

database/perl/vendor/lib/Parse/Method/Signatures/Param.pm

@@ -0,0 +1,201 @@
+package Parse::Method::Signatures::Param;
+
+use Moose;
+use MooseX::Types::Structured qw/Tuple/;
+use MooseX::Types::Moose qw/Bool Str ArrayRef HashRef/;
+
+use namespace::clean -except => 'meta';
+
+with 'MooseX::Traits';
+
+has required => (
+    is       => 'ro',
+    isa      => Bool,
+    required => 1
+);
+
+has sigil => (
+    is       => 'ro',
+    isa      => Str,
+    required => 1,
+);
+
+has type_constraints => (
+    is         => 'ro',
+    isa        => 'Parse::Method::Signatures::TypeConstraint',
+    predicate  => 'has_type_constraints',
+    handles    => {
+        meta_type_constraint => 'tc'
+    },
+);
+
+has default_value => (
+    is        => 'ro',
+    isa       => Str,
+    predicate => 'has_default_value',
+);
+
+has constraints => (
+    is         => 'ro',
+    isa        => ArrayRef[Str],
+    predicate  => 'has_constraints',
+    auto_deref => 1,
+);
+
+has param_traits => (
+    is         => 'ro',
+    isa        => ArrayRef[Tuple[Str, Str]],
+    predicate  => 'has_traits',
+    auto_deref => 1
+);
+
+has '+_trait_namespace' => (
+    default => 'Parse::Method::Signatures::Param',
+);
+
+sub _stringify_type_constraints {
+    my ($self) = @_;
+    return $self->has_type_constraints
+        ? $self->type_constraints->to_string . q{ }
+        : q{};
+}
+
+sub _stringify_default_value {
+    my ($self) = @_;
+    return $self->has_default_value
+        ? q{ = } . $self->default_value
+        : q{};
+}
+
+sub _stringify_constraints {
+    my ($self) = @_;
+    return q{} unless $self->has_constraints;
+    return q{ where } . join(q{ where }, $self->constraints);
+}
+
+sub _stringify_traits {
+    my ($self) = @_;
+    return q{} unless $self->has_traits;
+    return q{ } . join q{ }, map { @{ $_ } } $self->param_traits;
+}
+
+sub to_string {
+    my ($self) = @_;
+    my $ret = q{};
+
+    $ret .= $self->_stringify_type_constraints;
+    $ret .= $self->_stringify_variable_name;
+    $ret .= $self->_stringify_required;
+    $ret .= $self->_stringify_default_value;
+    $ret .= $self->_stringify_constraints;
+    $ret .= $self->_stringify_traits;
+
+    return $ret;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
+=head1 NAME
+
+Parse::Method::Signatures::Param - a parsed parameter from a signature
+
+=head1 ATTRIBUTES
+
+All attributes of this class are read-only.
+
+=head2 required
+
+Is this parameter required (true) or optional (false)?
+
+=head2 sigil
+
+The effective sigil ('$', '@' or '%') of this parameter.
+
+=head2 type_constraints
+
+=over
+
+B<Type:> L<Parse::Method::Signatures::TypeConstraint>
+
+B<Predicate:> has_type_constraints
+
+=back
+
+Representation of the type constraint for this parameter. Most commonly you
+will just call L</meta_type_constraint> and not access this attribute directly.
+
+=head2 default_value
+
+=over
+
+B<Type:> Str
+
+B<Predicate:> has_default_value
+
+=back
+
+A string that should be eval'd or injected to get the default value for this
+parameter. For example:
+
+ $name = 'bar'
+
+Would give a default_value of "'bar'".
+
+=head2 constraints
+
+=over
+
+B<Type:> ArrayRef[Str]
+
+B<Predicate:> has_constraints
+
+=back
+
+C<where> constraints for this type. Each member of the array a the string
+(including enclosing braces) of the where constraint block.
+
+=head2 param_traits
+
+=over
+
+B<Type:> ArrayRef[ Tupple[Str,Str] ]
+
+B<Predicate:> has_traits
+
+=back
+
+Traits that this parameter is declared to have. For instance
+
+ $foo does coerce
+
+would have a trait of
+
+ ['does', 'coerce']
+
+=head1 METHODS
+
+=head2 to_string
+
+=head2 meta_type_constraint
+
+Get the L<Moose::Meta::TypeConstraint> for this parameter. Check first that the
+type has a type constraint:
+
+ $tc = $param->meta_type_constraint if $param->has_type_constraints;
+
+=head1 SEE ALSO
+
+L<Parse::Method::Signatures>.
+
+=head1 AUTHORS
+
+Ash Berlin <ash@cpan.org>.
+
+Florian Ragwitz <rafl@debian.org>.
+
+=head1 LICENSE
+
+Licensed under the same terms as Perl itself.
+

database/perl/vendor/lib/Parse/Method/Signatures/Param/Bindable.pm

@@ -0,0 +1,19 @@
+package Parse::Method::Signatures::Param::Bindable;
+
+use Moose::Role;
+use Parse::Method::Signatures::Types qw/VariableName/;
+
+use namespace::clean -except => 'meta';
+
+has variable_name => (
+    is => 'ro',
+    isa => VariableName,
+    required => 1,
+);
+
+sub _stringify_variable_name {
+    my ($self) = @_;
+    return $self->variable_name;
+}
+
+1;

database/perl/vendor/lib/Parse/Method/Signatures/Param/Named.pm

@@ -0,0 +1,48 @@
+package Parse::Method::Signatures::Param::Named;
+
+use Moose::Role;
+use MooseX::Types::Moose qw/Str/;
+
+use namespace::clean -except => 'meta';
+
+has label => (
+    is         => 'ro',
+    isa        => Str,
+    lazy_build => 1,
+);
+
+sub _label_from_variable_name {
+    my ($self) = @_;
+    # strip sigil
+    return substr($self->variable_name, 1);
+}
+
+sub _build_label {
+    my ($self) = @_;
+    return $self->_label_from_variable_name;
+}
+
+sub _stringify_required {
+    my ($self) = @_;
+    return $self->required ? q{!} : q{};
+}
+
+around _stringify_variable_name => sub {
+    my $orig = shift;
+    my ($self) = @_;
+    my $ret = q{:};
+    my ($before, $after) = (q{}) x 2;
+
+    my $implicit_label = $self->_label_from_variable_name if $self->can('variable_name');
+
+    if (!$implicit_label || $self->label ne $implicit_label) {
+        $before = $self->label . q{(};
+        $after  = q{)};
+    }
+
+    $ret .= $before . $orig->(@_) . $after;
+
+    return $ret;
+};
+
+1;

database/perl/vendor/lib/Parse/Method/Signatures/Param/Placeholder.pm

@@ -0,0 +1,11 @@
+package Parse::Method::Signatures::Param::Placeholder;
+
+use Moose::Role;
+use namespace::clean -except => 'meta';
+
+sub _stringify_variable_name {
+    my ($self) = @_;
+    return $self->sigil;
+}
+
+1;

database/perl/vendor/lib/Parse/Method/Signatures/Param/Positional.pm

@@ -0,0 +1,11 @@
+package Parse::Method::Signatures::Param::Positional;
+
+use Moose::Role;
+use namespace::clean -except => 'meta';
+
+sub _stringify_required {
+    my ($self) = @_;
+    return $self->required ? q{} : q{?};
+}
+
+1;

database/perl/vendor/lib/Parse/Method/Signatures/Param/Unpacked.pm

@@ -0,0 +1,19 @@
+package Parse::Method::Signatures::Param::Unpacked;
+
+use Moose::Role;
+use Parse::Method::Signatures::Types qw/ParamCollection/;
+
+use namespace::clean -except => 'meta';
+
+has _params => (
+    is => 'ro',
+    isa => ParamCollection,
+    init_arg => 'params',
+    predicate => 'has_params',
+    coerce => 1,
+    handles => {
+        params => 'params',
+    },
+);
+
+1;

database/perl/vendor/lib/Parse/Method/Signatures/Param/Unpacked/Array.pm

@@ -0,0 +1,13 @@
+package Parse::Method::Signatures::Param::Unpacked::Array;
+
+use Moose::Role;
+use namespace::clean -except => 'meta';
+
+with 'Parse::Method::Signatures::Param::Unpacked';
+
+sub _stringify_variable_name {
+    my ($self) = @_;
+    return '[' . $self->_params->to_string . ']';
+}
+
+1;

database/perl/vendor/lib/Parse/Method/Signatures/Param/Unpacked/Hash.pm

@@ -0,0 +1,13 @@
+package Parse::Method::Signatures::Param::Unpacked::Hash;
+
+use Moose::Role;
+use namespace::clean -except => 'meta';
+
+with 'Parse::Method::Signatures::Param::Unpacked';
+
+sub _stringify_variable_name {
+    my ($self) = @_;
+    return '{' . $self->_params->to_string . '}';
+}
+
+1;

database/perl/vendor/lib/Parse/Method/Signatures/ParamCollection.pm

@@ -0,0 +1,21 @@
+package Parse::Method::Signatures::ParamCollection;
+
+use Moose;
+use MooseX::Types::Moose qw/ArrayRef/;
+use Parse::Method::Signatures::Types qw/Param/;
+
+use namespace::clean -except => 'meta';
+
+has params => (
+    is         => 'ro',
+    isa        => ArrayRef[Param],
+    required   => 1,
+    auto_deref => 1,
+);
+
+sub to_string {
+    my ($self) = @_;
+    return join(q{, }, map { $_->to_string } $self->params);
+}
+
+1;

database/perl/vendor/lib/Parse/Method/Signatures/Sig.pm

@@ -0,0 +1,154 @@
+package Parse::Method::Signatures::Sig;
+
+use Moose;
+use MooseX::Types::Moose qw/HashRef/;
+use Parse::Method::Signatures::Types qw/Param ParamCollection NamedParam/;
+use List::MoreUtils qw/part/;
+
+use namespace::clean -except => 'meta';
+
+has invocant => (
+    is        => 'ro',
+    does      => Param,
+    predicate => 'has_invocant',
+);
+
+has _positional_params => (
+    is        => 'ro',
+    isa       => ParamCollection,
+    init_arg  => 'positional_params',
+    predicate => 'has_positional_params',
+    coerce    => 1,
+    handles   => {
+        positional_params => 'params',
+    },
+);
+
+has _named_params => (
+    is        => 'ro',
+    isa       => ParamCollection,
+    init_arg  => 'named_params',
+    predicate => 'has_named_params',
+    coerce    => 1,
+    handles   => {
+        named_params => 'params',
+    },
+);
+
+has _named_map => (
+    is         => 'ro',
+    isa        => HashRef[Param],
+    lazy_build => 1,
+);
+
+override BUILDARGS => sub {
+    my $args = super();
+
+    if (my $params = delete $args->{params}) {
+        my ($positional, $named) = part { NamedParam->check($_) ? 1 : 0 } @{ $params };
+        $args->{positional_params} = $positional if $positional;
+        $args->{named_params} = $named if $named;
+    }
+
+    return $args;
+};
+
+sub _build__named_map {
+    my ($self) = @_;
+    return {} unless $self->has_named_params;
+    return { map { $_->label => $_ } @{ $self->named_params } };
+}
+
+sub named_param {
+    my ($self, $name) = @_;
+    return $self->_named_map->{$name};
+}
+
+around has_positional_params => sub {
+    my $orig = shift;
+    my $ret = $orig->(@_);
+    return unless $ret;
+
+    my ($self) = @_;
+    return scalar @{ $self->positional_params };
+};
+
+around has_named_params => sub {
+    my $orig = shift;
+    my $ret = $orig->(@_);
+    return unless $ret;
+
+    my ($self) = @_;
+    return scalar @{ $self->named_params };
+};
+
+sub to_string {
+    my ($self) = @_;
+    my $ret = q{(};
+
+    if ($self->has_invocant) {
+        $ret .= $self->invocant->to_string;
+        $ret .= q{:};
+
+        if ($self->has_positional_params || $self->has_named_params) {
+            $ret .= q{ };
+        }
+    }
+
+    $ret .= $self->_positional_params->to_string if $self->has_positional_params;
+    $ret .= q{, } if $self->has_positional_params && $self->has_named_params;
+    $ret .= $self->_named_params->to_string if $self->has_named_params;
+
+    $ret .= q{)};
+    return $ret;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Parse::Method::Signatures::Sig - Method Signature
+
+=head1 DESCRIPTION
+
+Represents the parsed method signature.
+
+=head1 ATTRIBUTES
+
+=head2 invocant
+
+=head2 named_params
+
+A ParamCollection representing the name parameters of this signature.
+
+=head2 positional_params
+
+A ParamCollection representing the positional parameters of this signature.
+
+=head1 METHODS
+
+=head2 has_named_params
+
+Predicate returning true if this signature has named parameters.
+
+=head2 has_positional_params
+
+Predicate returning true if this signature has positional parameters.
+
+=head2 named_param
+
+Returns the Param with the specified name.
+
+=head2 to_string
+
+Returns a string representation of this signature.
+
+=head1 LICENSE
+
+Licensed under the same terms as Perl itself.
+
+=cut

database/perl/vendor/lib/Parse/Method/Signatures/TypeConstraint.pm

@@ -0,0 +1,218 @@
+package Parse::Method::Signatures::TypeConstraint;
+
+use Carp qw/croak carp/;
+use Moose;
+use MooseX::Types::Util qw/has_available_type_export/;
+use MooseX::Types::Moose qw/Str HashRef CodeRef ClassName/;
+use Parse::Method::Signatures::Types qw/TypeConstraint/;
+
+use namespace::clean -except => 'meta';
+
+has ppi => (
+  is       => 'ro',
+  isa      => 'PPI::Element',
+  required => 1,
+  handles => {
+    'to_string' => 'content'
+  }
+);
+
+has tc => (
+    is => 'ro',
+    isa => TypeConstraint,
+    lazy => 1,
+    builder => '_build_tc',
+);
+
+has from_namespace => (
+    is => 'ro',
+    isa => ClassName,
+    predicate => 'has_from_namespace'
+);
+
+has tc_callback => (
+    is       => 'ro',
+    isa      => CodeRef,
+    default  => sub { \&find_registered_constraint },
+);
+
+sub find_registered_constraint {
+    my ($self, $name) = @_;
+
+    my $type;
+    if ($self->has_from_namespace) {
+        my $pkg = $self->from_namespace;
+
+        if ($type = has_available_type_export($pkg, $name)) {
+            croak "The type '$name' was found in $pkg " .
+                  "but it hasn't yet been defined. Perhaps you need to move the " .
+                  "definition into a type library or a BEGIN block.\n"
+                if $type && $type->isa('MooseX::Types::UndefinedType');
+        }
+        elsif ($name !~ /::/) {
+            my $meta  = Class::MOP::class_of($pkg) || Class::MOP::Class->initialize($pkg);
+            my $func  = $meta->get_package_symbol('&' . $name);
+            my $proto = prototype $func if $func;
+
+            $name = $func->()
+                if $func && defined $proto && !length $proto;
+        }
+    }
+
+    my $registry = Moose::Util::TypeConstraints->get_type_constraint_registry;
+    return $type || $registry->find_type_constraint($name) || $name;
+}
+
+
+sub _build_tc {
+    my ($self) = @_;
+    my $tc = $self->_walk_data($self->ppi);
+
+    # This makes the error appear from the right place
+    local $Carp::Internal{'Class::MOP::Method::Generated'} = 1
+      unless exists $Carp::Internal{'Class::MOP::Method::Generated'};
+
+    croak "'@{[$self->ppi]}' could not be parsed to a type constraint - maybe you need to "
+        . "pre-declare the type with class_type"
+      unless blessed $tc;
+    return $tc;
+}
+
+sub _walk_data {
+    my ($self, $data) = @_;
+
+    my $res = $self->_union_node($data)
+           || $self->_params_node($data)
+           || $self->_str_node($data)
+           || $self->_leaf($data)
+      or confess 'failed to visit tc';
+    return $res->();
+}
+
+sub _leaf {
+    my ($self, $data) = @_;
+
+    sub { $self->_invoke_callback($data->content) };
+}
+
+sub _union_node {
+    my ($self, $data) = @_;
+    return unless $data->isa('PPI::Statement::Expression::TCUnion');
+
+    my @types = map { $self->_walk_data($_) } $data->children;
+    sub {
+      scalar @types == 1 ? @types
+        : Moose::Meta::TypeConstraint::Union->new(type_constraints => \@types)
+    };
+}
+
+sub _params_node {
+    my ($self, $data) = @_;
+    return unless $data->isa('PPI::Statement::Expression::TCParams');
+
+    my @params = map { $self->_walk_data($_) } @{$data->params};
+    my $type = $self->_invoke_callback($data->type);
+    sub { $type->parameterize(@params) }
+}
+
+
+sub _str_node {
+    my ($self, $data) = @_;
+    return unless $data->isa('PPI::Token::StringifiedWord')
+               || $data->isa('PPI::Token::Number')
+               || $data->isa('PPI::Token::Quote');
+
+    sub {
+      $data->isa('PPI::Token::Number')
+          ? $data->content
+          : $data->string
+    };
+}
+
+sub _invoke_callback {
+    my $self = shift;
+    $self->tc_callback->($self, @_);
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Parse::Method::Signatures::TypeConstraint - turn parsed TC data into Moose TC object
+
+=head1 DESCRIPTION
+
+Class used to turn PPI elements into L<Moose::Meta::TypeConstraint> objects.
+
+=head1 ATTRIBUTES
+
+=head2 tc
+
+=over
+
+B<Lazy Build.>
+
+=back
+
+The L<Moose::Meta::TypeConstraint> object for this type constraint, built when
+requested. L</tc_callback> will be called for each individual component type in
+turn.
+
+=head2 tc_callback
+
+=over
+
+B<Type:> CodeRef
+
+B<Default:> L</find_registered_constraint>
+
+=back
+
+Callback used to turn type names into type objects. See
+L<Parse::Method::Signatures/type_constraint_callback> for more details and an
+example.
+
+=head2 from_namespace
+
+=over
+
+B<Type:> ClassName
+
+=back
+
+If provided, then the default C<tc_callback> will search for L<MooseX::Types>
+in this package.
+
+=head1 METHODS
+
+=head2 find_registered_constraint
+
+Will search for an imported L<MooseX::Types> in L</from_namespace> (if
+provided). Failing that it will ask the L<Moose::Meta::TypeConstraint::Registry>
+for a type with the given name.
+
+If all else fails, it will simple return the type as a string, so that Moose's
+auto-vivification of classnames to type will work.
+
+=head2 to_string
+
+String representation of the type constraint, approximately as parsed.
+
+=head1 SEE ALSO
+
+L<Parse::Method::Signatures>, L<MooseX::Types>, L<MooseX::Types::Util>.
+
+=head1 AUTHORS
+
+Florian Ragwitz <rafl@debian.org>.
+
+Ash Berlin <ash@cpan.org>.
+
+=head1 LICENSE
+
+Licensed under the same terms as Perl itself.
+

database/perl/vendor/lib/Parse/Method/Signatures/Types.pm

@@ -0,0 +1,40 @@
+use strict;
+use warnings;
+
+package Parse::Method::Signatures::Types;
+
+use Moose::Util::TypeConstraints;
+use MooseX::Types::Moose qw/Str ArrayRef/;
+use namespace::clean;
+
+use MooseX::Types -declare => [qw/
+    VariableName
+    TypeConstraint
+    Param
+    ParamCollection
+    PositionalParam
+    NamedParam
+    UnpackedParam
+/];
+
+subtype VariableName,
+    as Str,
+    where { /^[\$@%](?:[a-z_][a-z_\d]*)?$/i },
+    message { 'not a valid variable name' };
+
+subtype TypeConstraint,
+    as 'Moose::Meta::TypeConstraint';
+
+class_type Param, { class => 'Parse::Method::Signatures::Param' };
+
+class_type ParamCollection, { class => 'Parse::Method::Signatures::ParamCollection' };
+
+coerce ParamCollection,
+    from ArrayRef,
+    via { Parse::Method::Signatures::ParamCollection->new(params => $_) };
+
+role_type PositionalParam, { role => 'Parse::Method::Signatures::Param::Positional' };
+role_type NamedParam,      { role => 'Parse::Method::Signatures::Param::Named'      };
+role_type UnpackedParam,   { role => 'Parse::Method::Signatures::Param::Unpacked'   };
+
+1;