diff options
author | Norbert Preining <preining@logic.at> | 2010-03-01 01:54:19 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-03-01 01:54:19 +0000 |
commit | 904fd0757fe037dbfbf156b31f72e5ff5c7cd796 (patch) | |
tree | 36f000ab754854574aad17c01d9cd9ac739f1053 /Master/tlpkg/tlperl.straw/lib/YAML | |
parent | 402bd194f686177d2dfca24f7c4766434c514141 (diff) |
commit more files of the tlperl.straw dir, still not complete
git-svn-id: svn://tug.org/texlive/trunk@17244 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/YAML')
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Any.pm | 202 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Base.pm | 204 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Dumper.pm | 591 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Dumper/Base.pm | 142 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Error.pm | 226 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Loader.pm | 790 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Loader/Base.pm | 68 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Marshall.pm | 81 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Node.pm | 305 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Tag.pm | 52 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Tiny.pm | 1132 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/YAML/Types.pm | 265 |
12 files changed, 4058 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Any.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Any.pm new file mode 100755 index 00000000000..ad8f496fa68 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Any.pm @@ -0,0 +1,202 @@ +package YAML::Any; + +use 5.005003; +use strict; +use Exporter (); + +$YAML::Any::VERSION = '0.71'; +@YAML::Any::ISA = 'Exporter'; +@YAML::Any::EXPORT = qw(Dump Load); +@YAML::Any::EXPORT_OK = qw(DumpFile LoadFile); + +my @dump_options = qw( + UseCode + DumpCode + SpecVersion + Indent + UseHeader + UseVersion + SortKeys + AnchorPrefix + UseBlock + UseFold + CompressSeries + InlineSeries + UseAliases + Purity + Stringify +); + +my @load_options = qw( + UseCode + LoadCode +); + +my @implementations = qw( + YAML::XS + YAML::Syck + YAML::Old + YAML + YAML::Tiny +); + +sub import { + __PACKAGE__->implementation; + goto &Exporter::import; +} + +sub Dump { + no strict 'refs'; + my $implementation = __PACKAGE__->implementation; + for my $option (@dump_options) { + my $var = "$implementation\::$option"; + my $value = $$var; + local $$var; + $$var = defined $value ? $value : ${"YAML::$option"}; + } + return &{"$implementation\::Dump"}(@_); +} + +sub DumpFile { + no strict 'refs'; + my $implementation = __PACKAGE__->implementation; + for my $option (@dump_options) { + my $var = "$implementation\::$option"; + my $value = $$var; + local $$var; + $$var = defined $value ? $value : ${"YAML::$option"}; + } + return &{"$implementation\::DumpFile"}(@_); +} + +sub Load { + no strict 'refs'; + my $implementation = __PACKAGE__->implementation; + for my $option (@load_options) { + my $var = "$implementation\::$option"; + my $value = $$var; + local $$var; + $$var = defined $value ? $value : ${"YAML::$option"}; + } + return &{"$implementation\::Load"}(@_); +} + +sub LoadFile { + no strict 'refs'; + my $implementation = __PACKAGE__->implementation; + for my $option (@load_options) { + my $var = "$implementation\::$option"; + my $value = $$var; + local $$var; + $$var = defined $value ? $value : ${"YAML::$option"}; + } + return &{"$implementation\::LoadFile"}(@_); +} + +sub order { + return @YAML::Any::_TEST_ORDER + if defined @YAML::Any::_TEST_ORDER; + return @implementations; +} + +sub implementation { + my @order = __PACKAGE__->order; + for my $module (@order) { + my $path = $module; + $path =~ s/::/\//g; + $path .= '.pm'; + return $module if exists $INC{$path}; + eval "require $module; 1" and return $module; + } + croak("YAML::Any couldn't find any of these YAML implementations: @order"); +} + +sub croak { + require Carp; + Carp::Croak(@_); +} + +1; + +=head1 NAME + +YAML::Any - Pick a YAML implementation and use it. + +=head1 SYNOPSIS + + use YAML::Any; + $YAML::Indent = 3; + my $yaml = Dump(@objects); + +=head1 DESCRIPTION + +There are several YAML implementations that support the Dump/Load API. +This module selects the best one available and uses it. + +=head1 ORDER + +Currently, YAML::Any will choose the first one of these YAML +implementations that is installed on your system: + + YAML::XS + YAML::Syck + YAML::Old + YAML + YAML::Tiny + +=head1 OPTIONS + +If you specify an option like: + + $YAML::Indent = 4; + +And YAML::Any is using YAML::XS, it will use the proper variable: +$YAML::XS::Indent. + +=head1 SUBROUTINES + +Like all the YAML modules that YAML::Any uses, the following subroutines +are exported by default: + + Dump + Load + +and the following subroutines are exportable by request: + + DumpFile + LoadFile + +=head1 METHODS + +YAML::Any provides the following class methods. + +=over + +=item YAML::Any->order; + +This method returns a list of the current possible implementations that +YAML::Any will search for. + +=item YAML::Any->implementation; + +This method returns the implementation the YAML::Any will use. This +result is obtained by finding the first member of YAML::Any->order that +is either already loaded in C<%INC> or that can be loaded using +C<require>. If no implementation is found, an error will be thrown. + +=back + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2008. Ingy döt Net. + +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.straw/lib/YAML/Base.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Base.pm new file mode 100755 index 00000000000..2899f87238f --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Base.pm @@ -0,0 +1,204 @@ +package YAML::Base; + +use strict; +use warnings; +use Exporter (); + +our $VERSION = '0.71'; +our @ISA = 'Exporter'; +our @EXPORT = qw(field XXX); + +sub new { + my $class = shift; + $class = ref($class) || $class; + my $self = bless {}, $class; + while (@_) { + my $method = shift; + $self->$method(shift); + } + return $self; +} + +# Use lexical subs to reduce pollution of private methods by base class. +my ($_new_error, $_info, $_scalar_info, $parse_arguments, $default_as_code); + +sub XXX { + require Data::Dumper; + CORE::die(Data::Dumper::Dumper(@_)); +} + +my %code = ( + sub_start => + "sub {\n", + set_default => + " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", + init => + " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . + " unless \$#_ > 0 or defined \$_[0]->{%s};\n", + return_if_get => + " return \$_[0]->{%s} unless \$#_ > 0;\n", + set => + " \$_[0]->{%s} = \$_[1];\n", + sub_end => + " return \$_[0]->{%s};\n}\n", +); + +sub field { + my $package = caller; + my ($args, @values) = &$parse_arguments( + [ qw(-package -init) ], + @_, + ); + my ($field, $default) = @values; + $package = $args->{-package} if defined $args->{-package}; + return if defined &{"${package}::$field"}; + my $default_string = + ( ref($default) eq 'ARRAY' and not @$default ) + ? '[]' + : (ref($default) eq 'HASH' and not keys %$default ) + ? '{}' + : &$default_as_code($default); + + my $code = $code{sub_start}; + if ($args->{-init}) { + my $fragment = $code{init}; + $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4; + } + $code .= sprintf $code{set_default}, $field, $default_string, $field + if defined $default; + $code .= sprintf $code{return_if_get}, $field; + $code .= sprintf $code{set}, $field; + $code .= sprintf $code{sub_end}, $field; + + my $sub = eval $code; + die $@ if $@; + no strict 'refs'; + *{"${package}::$field"} = $sub; + return $code if defined wantarray; +} + +sub die { + my $self = shift; + my $error = $self->$_new_error(@_); + $error->type('Error'); + Carp::croak($error->format_message); +} + +sub warn { + my $self = shift; + return unless $^W; + my $error = $self->$_new_error(@_); + $error->type('Warning'); + Carp::cluck($error->format_message); +} + +# This code needs to be refactored to be simpler and more precise, and no, +# Scalar::Util doesn't DWIM. +# +# Can't handle: +# * blessed regexp +sub node_info { + my $self = shift; + my $stringify = $_[1] || 0; + my ($class, $type, $id) = + ref($_[0]) + ? $stringify + ? &$_info("$_[0]") + : do { + require overload; + my @info = &$_info(overload::StrVal($_[0])); + if (ref($_[0]) eq 'Regexp') { + @info[0, 1] = (undef, 'REGEXP'); + } + @info; + } + : &$_scalar_info($_[0]); + ($class, $type, $id) = &$_scalar_info("$_[0]") + unless $id; + return wantarray ? ($class, $type, $id) : $id; +} + +#------------------------------------------------------------------------------- +$_info = sub { + return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o); +}; + +$_scalar_info = sub { + my $id = 'undef'; + if (defined $_[0]) { + \$_[0] =~ /\((\w+)\)$/o or CORE::die(); + $id = "$1-S"; + } + return (undef, undef, $id); +}; + +$_new_error = sub { + require Carp; + my $self = shift; + require YAML::Error; + + my $code = shift || 'unknown error'; + my $error = YAML::Error->new(code => $code); + $error->line($self->line) if $self->can('line'); + $error->document($self->document) if $self->can('document'); + $error->arguments([@_]); + return $error; +}; + +$parse_arguments = sub { + my $paired_arguments = shift || []; + my ($args, @values) = ({}, ()); + my %pairs = map { ($_, 1) } @$paired_arguments; + while (@_) { + my $elem = shift; + if (defined $elem and defined $pairs{$elem} and @_) { + $args->{$elem} = shift; + } + else { + push @values, $elem; + } + } + return wantarray ? ($args, @values) : $args; +}; + +$default_as_code = sub { + no warnings 'once'; + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + my $code = Data::Dumper::Dumper(shift); + $code =~ s/^\$VAR1 = //; + $code =~ s/;$//; + return $code; +}; + +1; + +__END__ + +=head1 NAME + +YAML::Base - Base class for YAML classes + +=head1 SYNOPSIS + + package YAML::Something; + use YAML::Base -base; + +=head1 DESCRIPTION + +YAML::Base is the parent of all YAML classes. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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.straw/lib/YAML/Dumper.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Dumper.pm new file mode 100755 index 00000000000..8ece98931d2 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Dumper.pm @@ -0,0 +1,591 @@ +package YAML::Dumper; + +use strict; +use warnings; +use YAML::Base; +use YAML::Dumper::Base; +use YAML::Node; +use YAML::Types; + +our $VERSION = '0.71'; +our @ISA = 'YAML::Dumper::Base'; + +# Context constants +use constant KEY => 3; +use constant BLESSED => 4; +use constant FROMARRAY => 5; +use constant VALUE => "\x07YAML\x07VALUE\x07"; + +# Common YAML character sets +my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; +my $LIT_CHAR = '|'; + +#============================================================================== +# OO version of Dump. YAML->new->dump($foo); +sub dump { + my $self = shift; + $self->stream(''); + $self->document(0); + for my $document (@_) { + $self->{document}++; + $self->transferred({}); + $self->id_refcnt({}); + $self->id_anchor({}); + $self->anchor(1); + $self->level(0); + $self->offset->[0] = 0 - $self->indent_width; + $self->_prewalk($document); + $self->_emit_header($document); + $self->_emit_node($document); + } + return $self->stream; +} + +# Every YAML document in the stream must begin with a YAML header, unless +# there is only a single document and the user requests "no header". +sub _emit_header { + my $self = shift; + my ($node) = @_; + if (not $self->use_header and + $self->document == 1 + ) { + $self->die('YAML_DUMP_ERR_NO_HEADER') + unless ref($node) =~ /^(HASH|ARRAY)$/; + $self->die('YAML_DUMP_ERR_NO_HEADER') + if ref($node) eq 'HASH' and keys(%$node) == 0; + $self->die('YAML_DUMP_ERR_NO_HEADER') + if ref($node) eq 'ARRAY' and @$node == 0; + # XXX Also croak if aliased, blessed, or ynode + $self->headless(1); + return; + } + $self->{stream} .= '---'; +# XXX Consider switching to 1.1 style + if ($self->use_version) { +# $self->{stream} .= " #YAML:1.0"; + } +} + +# Walk the tree to be dumped and keep track of its reference counts. +# This function is where the Dumper does all its work. All type +# transfers happen here. +sub _prewalk { + my $self = shift; + my $stringify = $self->stringify; + my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify); + + # Handle typeglobs + if ($type eq 'GLOB') { + $self->transferred->{$node_id} = + YAML::Type::glob->yaml_dump($_[0]); + $self->_prewalk($self->transferred->{$node_id}); + return; + } + + # Handle regexps + if (ref($_[0]) eq 'Regexp') { + return; + } + + # Handle Purity for scalars. + # XXX can't find a use case yet. Might be YAGNI. + if (not ref $_[0]) { + $self->{id_refcnt}{$node_id}++ if $self->purity; + return; + } + + # Make a copy of original + my $value = $_[0]; + ($class, $type, $node_id) = $self->node_info($value, $stringify); + + # Must be a stringified object. + return if (ref($value) and not $type); + + # Look for things already transferred. + if ($self->transferred->{$node_id}) { + (undef, undef, $node_id) = (ref $self->transferred->{$node_id}) + ? $self->node_info($self->transferred->{$node_id}, $stringify) + : $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + + # Handle code refs + if ($type eq 'CODE') { + $self->transferred->{$node_id} = 'placeholder'; + YAML::Type::code->yaml_dump( + $self->dump_code, + $_[0], + $self->transferred->{$node_id} + ); + ($class, $type, $node_id) = + $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + + # Handle blessed things + if (defined $class) { + if ($value->can('yaml_dump')) { + $value = $value->yaml_dump; + } + elsif ($type eq 'SCALAR') { + $self->transferred->{$node_id} = 'placeholder'; + YAML::Type::blessed->yaml_dump + ($_[0], $self->transferred->{$node_id}); + ($class, $type, $node_id) = + $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + else { + $value = YAML::Type::blessed->yaml_dump($value); + } + $self->transferred->{$node_id} = $value; + (undef, $type, $node_id) = $self->node_info($value, $stringify); + } + + # Handle YAML Blessed things + if (defined YAML->global_object()->{blessed_map}{$node_id}) { + $value = YAML->global_object()->{blessed_map}{$node_id}; + $self->transferred->{$node_id} = $value; + ($class, $type, $node_id) = $self->node_info($value, $stringify); + $self->_prewalk($value); + return; + } + + # Handle hard refs + if ($type eq 'REF' or $type eq 'SCALAR') { + $value = YAML::Type::ref->yaml_dump($value); + $self->transferred->{$node_id} = $value; + (undef, $type, $node_id) = $self->node_info($value, $stringify); + } + + # Handle ref-to-glob's + elsif ($type eq 'GLOB') { + my $ref_ynode = $self->transferred->{$node_id} = + YAML::Type::ref->yaml_dump($value); + + my $glob_ynode = $ref_ynode->{&VALUE} = + YAML::Type::glob->yaml_dump($$value); + + (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify); + $self->transferred->{$node_id} = $glob_ynode; + $self->_prewalk($glob_ynode); + return; + } + + # Increment ref count for node + return if ++($self->{id_refcnt}{$node_id}) > 1; + + # Keep on walking + if ($type eq 'HASH') { + $self->_prewalk($value->{$_}) + for keys %{$value}; + return; + } + elsif ($type eq 'ARRAY') { + $self->_prewalk($_) + for @{$value}; + return; + } + + # Unknown type. Need to know about it. + $self->warn(<<"..."); +YAML::Dumper can't handle dumping this type of data. +Please report this to the author. + +id: $node_id +type: $type +class: $class +value: $value + +... + + return; +} + +# Every data element and sub data element is a node. +# Everything emitted goes through this function. +sub _emit_node { + my $self = shift; + my ($type, $node_id); + my $ref = ref($_[0]); + if ($ref) { + if ($ref eq 'Regexp') { + $self->_emit(' !!perl/regexp'); + $self->_emit_str("$_[0]"); + return; + } + (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify); + } + else { + $type = $ref || 'SCALAR'; + (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify); + } + + my ($ynode, $tag) = ('') x 2; + my ($value, $context) = (@_, 0); + + if (defined $self->transferred->{$node_id}) { + $value = $self->transferred->{$node_id}; + $ynode = ynode($value); + if (ref $value) { + $tag = defined $ynode ? $ynode->tag->short : ''; + (undef, $type, $node_id) = + $self->node_info($value, $self->stringify); + } + else { + $ynode = ynode($self->transferred->{$node_id}); + $tag = defined $ynode ? $ynode->tag->short : ''; + $type = 'SCALAR'; + (undef, undef, $node_id) = + $self->node_info( + \ $self->transferred->{$node_id}, + $self->stringify + ); + } + } + elsif ($ynode = ynode($value)) { + $tag = $ynode->tag->short; + } + + if ($self->use_aliases) { + $self->{id_refcnt}{$node_id} ||= 0; + if ($self->{id_refcnt}{$node_id} > 1) { + if (defined $self->{id_anchor}{$node_id}) { + $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n"; + return; + } + my $anchor = $self->anchor_prefix . $self->{anchor}++; + $self->{stream} .= ' &' . $anchor; + $self->{id_anchor}{$node_id} = $anchor; + } + } + + return $self->_emit_str("$value") # Stringified object + if ref($value) and not $type; + return $self->_emit_scalar($value, $tag) + if $type eq 'SCALAR' and $tag; + return $self->_emit_str($value) + if $type eq 'SCALAR'; + return $self->_emit_mapping($value, $tag, $node_id, $context) + if $type eq 'HASH'; + return $self->_emit_sequence($value, $tag) + if $type eq 'ARRAY'; + $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type); + return $self->_emit_str("$value"); +} + +# A YAML mapping is akin to a Perl hash. +sub _emit_mapping { + my $self = shift; + my ($value, $tag, $node_id, $context) = @_; + $self->{stream} .= " !$tag" if $tag; + + # Sometimes 'keys' fails. Like on a bad tie implementation. + my $empty_hash = not(eval {keys %$value}); + $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@; + return ($self->{stream} .= " {}\n") if $empty_hash; + + # If CompressSeries is on (default) and legal is this context, then + # use it and make the indent level be 2 for this node. + if ($context == FROMARRAY and + $self->compress_series and + not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash) + ) { + $self->{stream} .= ' '; + $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2; + } + else { + $context = 0; + $self->{stream} .= "\n" + unless $self->headless && not($self->headless(0)); + $self->offset->[$self->level+1] = + $self->offset->[$self->level] + $self->indent_width; + } + + $self->{level}++; + my @keys; + if ($self->sort_keys == 1) { + if (ynode($value)) { + @keys = keys %$value; + } + else { + @keys = sort keys %$value; + } + } + elsif ($self->sort_keys == 2) { + @keys = sort keys %$value; + } + # XXX This is hackish but sometimes handy. Not sure whether to leave it in. + elsif (ref($self->sort_keys) eq 'ARRAY') { + my $i = 1; + my %order = map { ($_, $i++) } @{$self->sort_keys}; + @keys = sort { + (defined $order{$a} and defined $order{$b}) + ? ($order{$a} <=> $order{$b}) + : ($a cmp $b); + } keys %$value; + } + else { + @keys = keys %$value; + } + # Force the YAML::VALUE ('=') key to sort last. + if (exists $value->{&VALUE}) { + for (my $i = 0; $i < @keys; $i++) { + if ($keys[$i] eq &VALUE) { + splice(@keys, $i, 1); + push @keys, &VALUE; + last; + } + } + } + + for my $key (@keys) { + $self->_emit_key($key, $context); + $context = 0; + $self->{stream} .= ':'; + $self->_emit_node($value->{$key}); + } + $self->{level}--; +} + +# A YAML series is akin to a Perl array. +sub _emit_sequence { + my $self = shift; + my ($value, $tag) = @_; + $self->{stream} .= " !$tag" if $tag; + + return ($self->{stream} .= " []\n") if @$value == 0; + + $self->{stream} .= "\n" + unless $self->headless && not($self->headless(0)); + + # XXX Really crufty feature. Better implemented by ynodes. + if ($self->inline_series and + @$value <= $self->inline_series and + not (scalar grep {ref or /\n/} @$value) + ) { + $self->{stream} =~ s/\n\Z/ /; + $self->{stream} .= '['; + for (my $i = 0; $i < @$value; $i++) { + $self->_emit_str($value->[$i], KEY); + last if $i == $#{$value}; + $self->{stream} .= ', '; + } + $self->{stream} .= "]\n"; + return; + } + + $self->offset->[$self->level + 1] = + $self->offset->[$self->level] + $self->indent_width; + $self->{level}++; + for my $val (@$value) { + $self->{stream} .= ' ' x $self->offset->[$self->level]; + $self->{stream} .= '-'; + $self->_emit_node($val, FROMARRAY); + } + $self->{level}--; +} + +# Emit a mapping key +sub _emit_key { + my $self = shift; + my ($value, $context) = @_; + $self->{stream} .= ' ' x $self->offset->[$self->level] + unless $context == FROMARRAY; + $self->_emit_str($value, KEY); +} + +# Emit a blessed SCALAR +sub _emit_scalar { + my $self = shift; + my ($value, $tag) = @_; + $self->{stream} .= " !$tag"; + $self->_emit_str($value, BLESSED); +} + +sub _emit { + my $self = shift; + $self->{stream} .= join '', @_; +} + +# Emit a string value. YAML has many scalar styles. This routine attempts to +# guess the best style for the text. +sub _emit_str { + my $self = shift; + my $type = $_[1] || 0; + + # Use heuristics to find the best scalar emission style. + $self->offset->[$self->level + 1] = + $self->offset->[$self->level] + $self->indent_width; + $self->{level}++; + + my $sf = $type == KEY ? '' : ' '; + my $sb = $type == KEY ? '? ' : ' '; + my $ef = $type == KEY ? '' : "\n"; + my $eb = "\n"; + + while (1) { + $self->_emit($sf), + $self->_emit_plain($_[0]), + $self->_emit($ef), last + if not defined $_[0]; + $self->_emit($sf, '=', $ef), last + if $_[0] eq VALUE; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] =~ /$ESCAPE_CHAR/; + if ($_[0] =~ /\n/) { + $self->_emit($sb), + $self->_emit_block($LIT_CHAR, $_[0]), + $self->_emit($eb), last + if $self->use_block; + Carp::cluck "[YAML] \$UseFold is no longer supported" + if $self->use_fold; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if length $_[0] <= 30; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] !~ /\n\s*\S/; + $self->_emit($sb), + $self->_emit_block($LIT_CHAR, $_[0]), + $self->_emit($eb), last; + } + $self->_emit($sf), + $self->_emit_plain($_[0]), + $self->_emit($ef), last + if $self->is_valid_plain($_[0]); + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] =~ /'/; + $self->_emit($sf), + $self->_emit_single($_[0]), + $self->_emit($ef); + last; + } + + $self->{level}--; + + return; +} + +# Check whether or not a scalar should be emitted as an plain scalar. +sub is_valid_plain { + my $self = shift; + return 0 unless length $_[0]; + # refer to YAML::Loader::parse_inline_simple() + return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/; + return 0 if $_[0] =~ /[\{\[\]\},]/; + return 0 if $_[0] =~ /[:\-\?]\s/; + return 0 if $_[0] =~ /\s#/; + return 0 if $_[0] =~ /\:(\s|$)/; + return 0 if $_[0] =~ /[\s\|\>]$/; + return 1; +} + +sub _emit_block { + my $self = shift; + my ($indicator, $value) = @_; + $self->{stream} .= $indicator; + $value =~ /(\n*)\Z/; + my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-'; + $value = '~' if not defined $value; + $self->{stream} .= $chomp; + $self->{stream} .= $self->indent_width if $value =~ /^\s/; + $self->{stream} .= $self->indent($value); +} + +# Plain means that the scalar is unquoted. +sub _emit_plain { + my $self = shift; + $self->{stream} .= defined $_[0] ? $_[0] : '~'; +} + +# Double quoting is for single lined escaped strings. +sub _emit_double { + my $self = shift; + (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g; + $self->{stream} .= qq{"$escaped"}; +} + +# Single quoting is for single lined unescaped strings. +sub _emit_single { + my $self = shift; + my $item = shift; + $item =~ s{'}{''}g; + $self->{stream} .= "'$item'"; +} + +#============================================================================== +# Utility subroutines. +#============================================================================== + +# Indent a scalar to the current indentation level. +sub indent { + my $self = shift; + my ($text) = @_; + return $text unless length $text; + $text =~ s/\n\Z//; + my $indent = ' ' x $self->offset->[$self->level]; + $text =~ s/^/$indent/gm; + $text = "\n$text"; + return $text; +} + +# Escapes for unprintable characters +my @escapes = qw(\0 \x01 \x02 \x03 \x04 \x05 \x06 \a + \x08 \t \n \v \f \r \x0e \x0f + \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17 + \x18 \x19 \x1a \e \x1c \x1d \x1e \x1f + ); + +# Escape the unprintable characters +sub escape { + my $self = shift; + my ($text) = @_; + $text =~ s/\\/\\\\/g; + $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge; + return $text; +} + +1; + +__END__ + +=head1 NAME + +YAML::Dumper - YAML class for dumping Perl objects to YAML + +=head1 SYNOPSIS + + use YAML::Dumper; + my $dumper = YAML::Dumper->new; + $dumper->indent_width(4); + print $dumper->dump({foo => 'bar'}); + +=head1 DESCRIPTION + +YAML::Dumper is the module that YAML.pm used to serialize Perl objects to +YAML. It is fully object oriented and usable on its own. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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.straw/lib/YAML/Dumper/Base.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Dumper/Base.pm new file mode 100755 index 00000000000..70b1e587a3a --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Dumper/Base.pm @@ -0,0 +1,142 @@ +package YAML::Dumper::Base; + +use strict; +use warnings; +use YAML::Base; +use YAML::Node; + +our $VERSION = '0.71'; +our @ISA = 'YAML::Base'; + +# YAML Dumping options +field spec_version => '1.0'; +field indent_width => 2; +field use_header => 1; +field use_version => 0; +field sort_keys => 1; +field anchor_prefix => ''; +field dump_code => 0; +field use_block => 0; +field use_fold => 0; +field compress_series => 1; +field inline_series => 0; +field use_aliases => 1; +field purity => 0; +field stringify => 0; + +# Properties +field stream => ''; +field document => 0; +field transferred => {}; +field id_refcnt => {}; +field id_anchor => {}; +field anchor => 1; +field level => 0; +field offset => []; +field headless => 0; +field blessed_map => {}; + +# Global Options are an idea taken from Data::Dumper. Really they are just +# sugar on top of real OO properties. They make the simple Dump/Load API +# easy to configure. +sub set_global_options { + my $self = shift; + $self->spec_version($YAML::SpecVersion) + if defined $YAML::SpecVersion; + $self->indent_width($YAML::Indent) + if defined $YAML::Indent; + $self->use_header($YAML::UseHeader) + if defined $YAML::UseHeader; + $self->use_version($YAML::UseVersion) + if defined $YAML::UseVersion; + $self->sort_keys($YAML::SortKeys) + if defined $YAML::SortKeys; + $self->anchor_prefix($YAML::AnchorPrefix) + if defined $YAML::AnchorPrefix; + $self->dump_code($YAML::DumpCode || $YAML::UseCode) + if defined $YAML::DumpCode or defined $YAML::UseCode; + $self->use_block($YAML::UseBlock) + if defined $YAML::UseBlock; + $self->use_fold($YAML::UseFold) + if defined $YAML::UseFold; + $self->compress_series($YAML::CompressSeries) + if defined $YAML::CompressSeries; + $self->inline_series($YAML::InlineSeries) + if defined $YAML::InlineSeries; + $self->use_aliases($YAML::UseAliases) + if defined $YAML::UseAliases; + $self->purity($YAML::Purity) + if defined $YAML::Purity; + $self->stringify($YAML::Stringify) + if defined $YAML::Stringify; +} + +sub dump { + my $self = shift; + $self->die('dump() not implemented in this class.'); +} + +sub blessed { + my $self = shift; + my ($ref) = @_; + $ref = \$_[0] unless ref $ref; + my (undef, undef, $node_id) = YAML::Base->node_info($ref); + $self->{blessed_map}->{$node_id}; +} + +sub bless { + my $self = shift; + my ($ref, $blessing) = @_; + my $ynode; + $ref = \$_[0] unless ref $ref; + my (undef, undef, $node_id) = YAML::Base->node_info($ref); + if (not defined $blessing) { + $ynode = YAML::Node->new($ref); + } + elsif (ref $blessing) { + $self->die() unless ynode($blessing); + $ynode = $blessing; + } + else { + no strict 'refs'; + my $transfer = $blessing . "::yaml_dump"; + $self->die() unless defined &{$transfer}; + $ynode = &{$transfer}($ref); + $self->die() unless ynode($ynode); + } + $self->{blessed_map}->{$node_id} = $ynode; + my $object = ynode($ynode) or $self->die(); + return $object; +} + +1; + +__END__ + +=head1 NAME + +YAML::Dumper::Base - Base class for YAML Dumper classes + +=head1 SYNOPSIS + + package YAML::Dumper::Something; + use YAML::Dumper::Base -base; + +=head1 DESCRIPTION + +YAML::Dumper::Base is a base class for creating YAML dumper classes. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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.straw/lib/YAML/Error.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Error.pm new file mode 100755 index 00000000000..eb2a4be531d --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Error.pm @@ -0,0 +1,226 @@ +package YAML::Error; + +use strict; +use warnings; +use YAML::Base; + +our $VERSION = '0.71'; +our @ISA = 'YAML::Base'; + +field 'code'; +field 'type' => 'Error'; +field 'line'; +field 'document'; +field 'arguments' => []; + +my ($error_messages, %line_adjust); + +sub format_message { + my $self = shift; + my $output = 'YAML ' . $self->type . ': '; + my $code = $self->code; + if ($error_messages->{$code}) { + $code = sprintf($error_messages->{$code}, @{$self->arguments}); + } + $output .= $code . "\n"; + + $output .= ' Code: ' . $self->code . "\n" + if defined $self->code; + $output .= ' Line: ' . $self->line . "\n" + if defined $self->line; + $output .= ' Document: ' . $self->document . "\n" + if defined $self->document; + return $output; +} + +sub error_messages { + $error_messages; +} + +%$error_messages = map {s/^\s+//;$_} split "\n", <<'...'; +YAML_PARSE_ERR_BAD_CHARS + Invalid characters in stream. This parser only supports printable ASCII +YAML_PARSE_ERR_NO_FINAL_NEWLINE + Stream does not end with newline character +YAML_PARSE_ERR_BAD_MAJOR_VERSION + Can't parse a %s document with a 1.0 parser +YAML_PARSE_WARN_BAD_MINOR_VERSION + Parsing a %s document with a 1.0 parser +YAML_PARSE_WARN_MULTIPLE_DIRECTIVES + '%s directive used more than once' +YAML_PARSE_ERR_TEXT_AFTER_INDICATOR + No text allowed after indicator +YAML_PARSE_ERR_NO_ANCHOR + No anchor for alias '*%s' +YAML_PARSE_ERR_NO_SEPARATOR + Expected separator '---' +YAML_PARSE_ERR_SINGLE_LINE + Couldn't parse single line value +YAML_PARSE_ERR_BAD_ANCHOR + Invalid anchor +YAML_DUMP_ERR_INVALID_INDENT + Invalid Indent width specified: '%s' +YAML_LOAD_USAGE + usage: YAML::Load($yaml_stream_scalar) +YAML_PARSE_ERR_BAD_NODE + Can't parse node +YAML_PARSE_ERR_BAD_EXPLICIT + Unsupported explicit transfer: '%s' +YAML_DUMP_USAGE_DUMPCODE + Invalid value for DumpCode: '%s' +YAML_LOAD_ERR_FILE_INPUT + Couldn't open %s for input:\n%s +YAML_DUMP_ERR_FILE_CONCATENATE + Can't concatenate to YAML file %s +YAML_DUMP_ERR_FILE_OUTPUT + Couldn't open %s for output:\n%s +YAML_DUMP_ERR_NO_HEADER + With UseHeader=0, the node must be a plain hash or array +YAML_DUMP_WARN_BAD_NODE_TYPE + Can't perform serialization for node type: '%s' +YAML_EMIT_WARN_KEYS + Encountered a problem with 'keys':\n%s +YAML_DUMP_WARN_DEPARSE_FAILED + Deparse failed for CODE reference +YAML_DUMP_WARN_CODE_DUMMY + Emitting dummy subroutine for CODE reference +YAML_PARSE_ERR_MANY_EXPLICIT + More than one explicit transfer +YAML_PARSE_ERR_MANY_IMPLICIT + More than one implicit request +YAML_PARSE_ERR_MANY_ANCHOR + More than one anchor +YAML_PARSE_ERR_ANCHOR_ALIAS + Can't define both an anchor and an alias +YAML_PARSE_ERR_BAD_ALIAS + Invalid alias +YAML_PARSE_ERR_MANY_ALIAS + More than one alias +YAML_LOAD_ERR_NO_CONVERT + Can't convert implicit '%s' node to explicit '%s' node +YAML_LOAD_ERR_NO_DEFAULT_VALUE + No default value for '%s' explicit transfer +YAML_LOAD_ERR_NON_EMPTY_STRING + Only the empty string can be converted to a '%s' +YAML_LOAD_ERR_BAD_MAP_TO_SEQ + Can't transfer map as sequence. Non numeric key '%s' encountered. +YAML_DUMP_ERR_BAD_GLOB + '%s' is an invalid value for Perl glob +YAML_DUMP_ERR_BAD_REGEXP + '%s' is an invalid value for Perl Regexp +YAML_LOAD_ERR_BAD_MAP_ELEMENT + Invalid element in map +YAML_LOAD_WARN_DUPLICATE_KEY + Duplicate map key found. Ignoring. +YAML_LOAD_ERR_BAD_SEQ_ELEMENT + Invalid element in sequence +YAML_PARSE_ERR_INLINE_MAP + Can't parse inline map +YAML_PARSE_ERR_INLINE_SEQUENCE + Can't parse inline sequence +YAML_PARSE_ERR_BAD_DOUBLE + Can't parse double quoted string +YAML_PARSE_ERR_BAD_SINGLE + Can't parse single quoted string +YAML_PARSE_ERR_BAD_INLINE_IMPLICIT + Can't parse inline implicit value '%s' +YAML_PARSE_ERR_BAD_IMPLICIT + Unrecognized implicit value '%s' +YAML_PARSE_ERR_INDENTATION + Error. Invalid indentation level +YAML_PARSE_ERR_INCONSISTENT_INDENTATION + Inconsistent indentation level +YAML_LOAD_WARN_UNRESOLVED_ALIAS + Can't resolve alias *%s +YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP + No 'REGEXP' element for Perl regexp +YAML_LOAD_WARN_BAD_REGEXP_ELEM + Unknown element '%s' in Perl regexp +YAML_LOAD_WARN_GLOB_NAME + No 'NAME' element for Perl glob +YAML_LOAD_WARN_PARSE_CODE + Couldn't parse Perl code scalar: %s +YAML_LOAD_WARN_CODE_DEPARSE + Won't parse Perl code unless $YAML::LoadCode is set +YAML_EMIT_ERR_BAD_LEVEL + Internal Error: Bad level detected +YAML_PARSE_WARN_AMBIGUOUS_TAB + Amibiguous tab converted to spaces +YAML_LOAD_WARN_BAD_GLOB_ELEM + Unknown element '%s' in Perl glob +YAML_PARSE_ERR_ZERO_INDENT + Can't use zero as an indentation width +YAML_LOAD_WARN_GLOB_IO + Can't load an IO filehandle. Yet!!! +... + +%line_adjust = map {($_, 1)} + qw(YAML_PARSE_ERR_BAD_MAJOR_VERSION + YAML_PARSE_WARN_BAD_MINOR_VERSION + YAML_PARSE_ERR_TEXT_AFTER_INDICATOR + YAML_PARSE_ERR_NO_ANCHOR + YAML_PARSE_ERR_MANY_EXPLICIT + YAML_PARSE_ERR_MANY_IMPLICIT + YAML_PARSE_ERR_MANY_ANCHOR + YAML_PARSE_ERR_ANCHOR_ALIAS + YAML_PARSE_ERR_BAD_ALIAS + YAML_PARSE_ERR_MANY_ALIAS + YAML_LOAD_ERR_NO_CONVERT + YAML_LOAD_ERR_NO_DEFAULT_VALUE + YAML_LOAD_ERR_NON_EMPTY_STRING + YAML_LOAD_ERR_BAD_MAP_TO_SEQ + YAML_LOAD_ERR_BAD_STR_TO_INT + YAML_LOAD_ERR_BAD_STR_TO_DATE + YAML_LOAD_ERR_BAD_STR_TO_TIME + YAML_LOAD_WARN_DUPLICATE_KEY + YAML_PARSE_ERR_INLINE_MAP + YAML_PARSE_ERR_INLINE_SEQUENCE + YAML_PARSE_ERR_BAD_DOUBLE + YAML_PARSE_ERR_BAD_SINGLE + YAML_PARSE_ERR_BAD_INLINE_IMPLICIT + YAML_PARSE_ERR_BAD_IMPLICIT + YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP + YAML_LOAD_WARN_BAD_REGEXP_ELEM + YAML_LOAD_WARN_REGEXP_CREATE + YAML_LOAD_WARN_GLOB_NAME + YAML_LOAD_WARN_PARSE_CODE + YAML_LOAD_WARN_CODE_DEPARSE + YAML_LOAD_WARN_BAD_GLOB_ELEM + YAML_PARSE_ERR_ZERO_INDENT + ); + +package YAML::Warning; + +our @ISA = 'YAML::Error'; + +1; + +__END__ + +=head1 NAME + +YAML::Error - Error formatting class for YAML modules + +=head1 SYNOPSIS + + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias); + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + +=head1 DESCRIPTION + +This module provides a C<die> and a C<warn> facility. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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.straw/lib/YAML/Loader.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Loader.pm new file mode 100755 index 00000000000..258ddd50335 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Loader.pm @@ -0,0 +1,790 @@ +package YAML::Loader; + +use strict; +use warnings; +use YAML::Base; +use YAML::Loader::Base; +use YAML::Types; + +our $VERSION = '0.71'; +our @ISA = 'YAML::Loader::Base'; + +# Context constants +use constant LEAF => 1; +use constant COLLECTION => 2; +use constant VALUE => "\x07YAML\x07VALUE\x07"; +use constant COMMENT => "\x07YAML\x07COMMENT\x07"; + +# Common YAML character sets +my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; +my $FOLD_CHAR = '>'; +my $LIT_CHAR = '|'; +my $LIT_CHAR_RX = "\\$LIT_CHAR"; + +sub load { + my $self = shift; + $self->stream($_[0] || ''); + return $self->_parse(); +} + +# Top level function for parsing. Parse each document in order and +# handle processing for YAML headers. +sub _parse { + my $self = shift; + my (%directives, $preface); + $self->{stream} =~ s|\015\012|\012|g; + $self->{stream} =~ s|\015|\012|g; + $self->line(0); + $self->die('YAML_PARSE_ERR_BAD_CHARS') + if $self->stream =~ /$ESCAPE_CHAR/; + $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE') + if length($self->stream) and + $self->{stream} !~ s/(.)\n\Z/$1/s; + $self->lines([split /\x0a/, $self->stream, -1]); + $self->line(1); + # Throw away any comments or blanks before the header (or start of + # content for headerless streams) + $self->_parse_throwaway_comments(); + $self->document(0); + $self->documents([]); + # Add an "assumed" header if there is no header and the stream is + # not empty (after initial throwaways). + if (not $self->eos) { + if ($self->lines->[0] !~ /^---(\s|$)/) { + unshift @{$self->lines}, '---'; + $self->{line}--; + } + } + + # Main Loop. Parse out all the top level nodes and return them. + while (not $self->eos) { + $self->anchor2node({}); + $self->{document}++; + $self->done(0); + $self->level(0); + $self->offset->[0] = -1; + + if ($self->lines->[0] =~ /^---\s*(.*)$/) { + my @words = split /\s+/, $1; + %directives = (); + while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) { + my ($key, $value) = ($1, $2); + shift(@words); + if (defined $directives{$key}) { + $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES', + $key, $self->document); + next; + } + $directives{$key} = $value; + } + $self->preface(join ' ', @words); + } + else { + $self->die('YAML_PARSE_ERR_NO_SEPARATOR'); + } + + if (not $self->done) { + $self->_parse_next_line(COLLECTION); + } + if ($self->done) { + $self->{indent} = -1; + $self->content(''); + } + + $directives{YAML} ||= '1.0'; + $directives{TAB} ||= 'NONE'; + ($self->{major_version}, $self->{minor_version}) = + split /\./, $directives{YAML}, 2; + $self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML}) + if $self->major_version ne '1'; + $self->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML}) + if $self->minor_version ne '0'; + $self->die('Unrecognized TAB policy') + unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/; + + push @{$self->documents}, $self->_parse_node(); + } + return wantarray ? @{$self->documents} : $self->documents->[-1]; +} + +# This function is the dispatcher for parsing each node. Every node +# recurses back through here. (Inlines are an exception as they have +# their own sub-parser.) +sub _parse_node { + my $self = shift; + my $preface = $self->preface; + $self->preface(''); + my ($node, $type, $indicator, $escape, $chomp) = ('') x 5; + my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5; + ($anchor, $alias, $explicit, $implicit, $preface) = + $self->_parse_qualifiers($preface); + if ($anchor) { + $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node'; + } + $self->inline(''); + while (length $preface) { + my $line = $self->line - 1; + if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) { + $indicator = $1; + $chomp = $2 if defined($2); + } + else { + $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator; + $self->inline($preface); + $preface = ''; + } + } + if ($alias) { + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias) + unless defined $self->anchor2node->{$alias}; + if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') { + $node = $self->anchor2node->{$alias}; + } + else { + $node = do {my $sv = "*$alias"}; + push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; + } + } + elsif (length $self->inline) { + $node = $self->_parse_inline(1, $implicit, $explicit); + if (length $self->inline) { + $self->die('YAML_PARSE_ERR_SINGLE_LINE'); + } + } + elsif ($indicator eq $LIT_CHAR) { + $self->{level}++; + $node = $self->_parse_block($chomp); + $node = $self->_parse_implicit($node) if $implicit; + $self->{level}--; + } + elsif ($indicator eq $FOLD_CHAR) { + $self->{level}++; + $node = $self->_parse_unfold($chomp); + $node = $self->_parse_implicit($node) if $implicit; + $self->{level}--; + } + else { + $self->{level}++; + $self->offset->[$self->level] ||= 0; + if ($self->indent == $self->offset->[$self->level]) { + if ($self->content =~ /^-( |$)/) { + $node = $self->_parse_seq($anchor); + } + elsif ($self->content =~ /(^\?|\:( |$))/) { + $node = $self->_parse_mapping($anchor); + } + elsif ($preface =~ /^\s*$/) { + $node = $self->_parse_implicit(''); + } + else { + $self->die('YAML_PARSE_ERR_BAD_NODE'); + } + } + else { + $node = undef; + } + $self->{level}--; + } + $#{$self->offset} = $self->level; + + if ($explicit) { + if ($class) { + if (not ref $node) { + my $copy = $node; + undef $node; + $node = \$copy; + } + CORE::bless $node, $class; + } + else { + $node = $self->_parse_explicit($node, $explicit); + } + } + if ($anchor) { + if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') { + # XXX Can't remember what this code actually does + for my $ref (@{$self->anchor2node->{$anchor}}) { + ${$ref->[0]} = $node; + $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS', + $anchor, $ref->[1]); + } + } + $self->anchor2node->{$anchor} = $node; + } + return $node; +} + +# Preprocess the qualifiers that may be attached to any node. +sub _parse_qualifiers { + my $self = shift; + my ($preface) = @_; + my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5; + $self->inline(''); + while ($preface =~ /^[&*!]/) { + my $line = $self->line - 1; + if ($preface =~ s/^\!(\S+)\s*//) { + $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit; + $explicit = $1; + } + elsif ($preface =~ s/^\!\s*//) { + $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit; + $implicit = 1; + } + elsif ($preface =~ s/^\&([^ ,:]+)\s*//) { + $token = $1; + $self->die('YAML_PARSE_ERR_BAD_ANCHOR') + unless $token =~ /^[a-zA-Z0-9]+$/; + $self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor; + $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias; + $anchor = $token; + } + elsif ($preface =~ s/^\*([^ ,:]+)\s*//) { + $token = $1; + $self->die('YAML_PARSE_ERR_BAD_ALIAS') + unless $token =~ /^[a-zA-Z0-9]+$/; + $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias; + $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor; + $alias = $token; + } + } + return ($anchor, $alias, $explicit, $implicit, $preface); +} + +# Morph a node to it's explicit type +sub _parse_explicit { + my $self = shift; + my ($node, $explicit) = @_; + my ($type, $class); + if ($explicit =~ /^\!?perl\/(hash|array|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) { + ($type, $class) = (($1 || ''), ($2 || '')); + + # FIXME # die unless uc($type) eq ref($node) ? + + if ( $type eq "ref" ) { + $self->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'XXX', $explicit) + unless exists $node->{VALUE()} and scalar(keys %$node) == 1; + + my $value = $node->{VALUE()}; + $node = \$value; + } + + if ( $type eq "scalar" and length($class) and !ref($node) ) { + my $value = $node; + $node = \$value; + } + + if ( length($class) ) { + CORE::bless($node, $class); + } + + return $node; + } + if ($explicit =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) { + ($type, $class) = (($1 || ''), ($2 || '')); + my $type_class = "YAML::Type::$type"; + no strict 'refs'; + if ($type_class->can('yaml_load')) { + return $type_class->yaml_load($node, $class, $self); + } + else { + $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit); + } + } + # This !perl/@Foo and !perl/$Foo are deprecated but still parsed + elsif ($YAML::TagClass->{$explicit} || + $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$} + ) { + $class = $YAML::TagClass->{$explicit} || $2; + if ($class->can('yaml_load')) { + require YAML::Node; + return $class->yaml_load(YAML::Node->new($node, $explicit)); + } + else { + if (ref $node) { + return CORE::bless $node, $class; + } + else { + return CORE::bless \$node, $class; + } + } + } + elsif (ref $node) { + require YAML::Node; + return YAML::Node->new($node, $explicit); + } + else { + # XXX This is likely wrong. Failing test: + # --- !unknown 'scalar value' + return $node; + } +} + +# Parse a YAML mapping into a Perl hash +sub _parse_mapping { + my $self = shift; + my ($anchor) = @_; + my $mapping = {}; + $self->anchor2node->{$anchor} = $mapping; + my $key; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + # If structured key: + if ($self->{content} =~ s/^\?\s*//) { + $self->preface($self->content); + $self->_parse_next_line(COLLECTION); + $key = $self->_parse_node(); + $key = "$key"; + } + # If "default" key (equals sign) + elsif ($self->{content} =~ s/^\=\s*//) { + $key = VALUE; + } + # If "comment" key (slash slash) + elsif ($self->{content} =~ s/^\=\s*//) { + $key = COMMENT; + } + # Regular scalar key: + else { + $self->inline($self->content); + $key = $self->_parse_inline(); + $key = "$key"; + $self->content($self->inline); + $self->inline(''); + } + + unless ($self->{content} =~ s/^:\s*//) { + $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT'); + } + $self->preface($self->content); + my $line = $self->line; + $self->_parse_next_line(COLLECTION); + my $value = $self->_parse_node(); + if (exists $mapping->{$key}) { + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + } + else { + $mapping->{$key} = $value; + } + } + return $mapping; +} + +# Parse a YAML sequence into a Perl array +sub _parse_seq { + my $self = shift; + my ($anchor) = @_; + my $seq = []; + $self->anchor2node->{$anchor} = $seq; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + if ($self->content =~ /^-(?: (.*))?$/) { + $self->preface(defined($1) ? $1 : ''); + } + else { + $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT'); + } + if ($self->preface =~ /^(\s*)(\w.*\:(?: |$).*)$/) { + $self->indent($self->offset->[$self->level] + 2 + length($1)); + $self->content($2); + $self->level($self->level + 1); + $self->offset->[$self->level] = $self->indent; + $self->preface(''); + push @$seq, $self->_parse_mapping(''); + $self->{level}--; + $#{$self->offset} = $self->level; + } + else { + $self->_parse_next_line(COLLECTION); + push @$seq, $self->_parse_node(); + } + } + return $seq; +} + +# Parse an inline value. Since YAML supports inline collections, this is +# the top level of a sub parsing. +sub _parse_inline { + my $self = shift; + my ($top, $top_implicit, $top_explicit) = (@_, '', '', ''); + $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump + my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5; + ($anchor, $alias, $explicit, $implicit, $self->{inline}) = + $self->_parse_qualifiers($self->inline); + if ($anchor) { + $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node'; + } + $implicit ||= $top_implicit; + $explicit ||= $top_explicit; + ($top_implicit, $top_explicit) = ('', ''); + if ($alias) { + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias) + unless defined $self->anchor2node->{$alias}; + if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') { + $node = $self->anchor2node->{$alias}; + } + else { + $node = do {my $sv = "*$alias"}; + push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; + } + } + elsif ($self->inline =~ /^\{/) { + $node = $self->_parse_inline_mapping($anchor); + } + elsif ($self->inline =~ /^\[/) { + $node = $self->_parse_inline_seq($anchor); + } + elsif ($self->inline =~ /^"/) { + $node = $self->_parse_inline_double_quoted(); + $node = $self->_unescape($node); + $node = $self->_parse_implicit($node) if $implicit; + } + elsif ($self->inline =~ /^'/) { + $node = $self->_parse_inline_single_quoted(); + $node = $self->_parse_implicit($node) if $implicit; + } + else { + if ($top) { + $node = $self->inline; + $self->inline(''); + } + else { + $node = $self->_parse_inline_simple(); + } + $node = $self->_parse_implicit($node) unless $explicit; + } + if ($explicit) { + $node = $self->_parse_explicit($node, $explicit); + } + if ($anchor) { + if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') { + for my $ref (@{$self->anchor2node->{$anchor}}) { + ${$ref->[0]} = $node; + $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS', + $anchor, $ref->[1]); + } + } + $self->anchor2node->{$anchor} = $node; + } + return $node; +} + +# Parse the inline YAML mapping into a Perl hash +sub _parse_inline_mapping { + my $self = shift; + my ($anchor) = @_; + my $node = {}; + $self->anchor2node->{$anchor} = $node; + + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\{\s*//; + while (not $self->{inline} =~ s/^\s*\}//) { + my $key = $self->_parse_inline(); + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\: \s*//; + my $value = $self->_parse_inline(); + if (exists $node->{$key}) { + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + } + else { + $node->{$key} = $value; + } + next if $self->inline =~ /^\s*\}/; + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\,\s*//; + } + return $node; +} + +# Parse the inline YAML sequence into a Perl array +sub _parse_inline_seq { + my $self = shift; + my ($anchor) = @_; + my $node = []; + $self->anchor2node->{$anchor} = $node; + + $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') + unless $self->{inline} =~ s/^\[\s*//; + while (not $self->{inline} =~ s/^\s*\]//) { + my $value = $self->_parse_inline(); + push @$node, $value; + next if $self->inline =~ /^\s*\]/; + $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') + unless $self->{inline} =~ s/^\,\s*//; + } + return $node; +} + +# Parse the inline double quoted string. +sub _parse_inline_double_quoted { + my $self = shift; + my $node; + if ($self->inline =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) { + $node = $1; + $self->inline($2); + $node =~ s/\\"/"/g; + } + else { + $self->die('YAML_PARSE_ERR_BAD_DOUBLE'); + } + return $node; +} + + +# Parse the inline single quoted string. +sub _parse_inline_single_quoted { + my $self = shift; + my $node; + if ($self->inline =~ /^'((?:''|[^'])*)'\s*(.*)$/) { + $node = $1; + $self->inline($2); + $node =~ s/''/'/g; + } + else { + $self->die('YAML_PARSE_ERR_BAD_SINGLE'); + } + return $node; +} + +# Parse the inline unquoted string and do implicit typing. +sub _parse_inline_simple { + my $self = shift; + my $value; + if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) { + $value = $1; + substr($self->{inline}, 0, length($1)) = ''; + } + else { + $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value); + } + return $value; +} + +sub _parse_implicit { + my $self = shift; + my ($value) = @_; + $value =~ s/\s*$//; + return $value if $value eq ''; + return undef if $value =~ /^~$/; + return $value + unless $value =~ /^[\@\`\^]/ or + $value =~ /^[\-\?]\s/; + $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value); +} + +# Unfold a YAML multiline scalar into a single string. +sub _parse_unfold { + my $self = shift; + my ($chomp) = @_; + my $node = ''; + my $space = 0; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + $node .= $self->content. "\n"; + $self->_parse_next_line(LEAF); + } + $node =~ s/^(\S.*)\n(?=\S)/$1 /gm; + $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm; + $node =~ s/\n*\Z// unless $chomp eq '+'; + $node .= "\n" unless $chomp; + return $node; +} + +# Parse a YAML block style scalar. This is like a Perl here-document. +sub _parse_block { + my $self = shift; + my ($chomp) = @_; + my $node = ''; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + $node .= $self->content . "\n"; + $self->_parse_next_line(LEAF); + } + return $node if '+' eq $chomp; + $node =~ s/\n*\Z/\n/; + $node =~ s/\n\Z// if $chomp eq '-'; + return $node; +} + +# Handle Perl style '#' comments. Comments must be at the same indentation +# level as the collection line following them. +sub _parse_throwaway_comments { + my $self = shift; + while (@{$self->lines} and + $self->lines->[0] =~ m{^\s*(\#|$)} + ) { + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); +} + +# This is the routine that controls what line is being parsed. It gets called +# once for each line in the YAML stream. +# +# This routine must: +# 1) Skip past the current line +# 2) Determine the indentation offset for a new level +# 3) Find the next _content_ line +# A) Skip over any throwaways (Comments/blanks) +# B) Set $self->indent, $self->content, $self->line +# 4) Expand tabs appropriately +sub _parse_next_line { + my $self = shift; + my ($type) = @_; + my $level = $self->level; + my $offset = $self->offset->[$level]; + $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset; + shift @{$self->lines}; + $self->eos($self->{done} = not @{$self->lines}); + return if $self->eos; + $self->{line}++; + + # Determine the offset for a new leaf node + if ($self->preface =~ + qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/ + ) { + $self->die('YAML_PARSE_ERR_ZERO_INDENT') + if length($1) and $1 == 0; + $type = LEAF; + if (length($1)) { + $self->offset->[$level + 1] = $offset + $1; + } + else { + # First get rid of any comments. + while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) { + $self->lines->[0] =~ /^( *)/ or die; + last unless length($1) <= $offset; + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); + return if $self->eos; + if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) { + $self->offset->[$level+1] = length($1); + } + else { + $self->offset->[$level+1] = $offset + 1; + } + } + $offset = $self->offset->[++$level]; + } + # Determine the offset for a new collection level + elsif ($type == COLLECTION and + $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) { + $self->_parse_throwaway_comments(); + if ($self->eos) { + $self->offset->[$level+1] = $offset + 1; + return; + } + else { + $self->lines->[0] =~ /^( *)\S/ or die; + if (length($1) > $offset) { + $self->offset->[$level+1] = length($1); + } + else { + $self->offset->[$level+1] = $offset + 1; + } + } + $offset = $self->offset->[++$level]; + } + + if ($type == LEAF) { + while (@{$self->lines} and + $self->lines->[0] =~ m{^( *)(\#)} and + length($1) < $offset + ) { + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); + } + else { + $self->_parse_throwaway_comments(); + } + return if $self->eos; + + if ($self->lines->[0] =~ /^---(\s|$)/) { + $self->done(1); + return; + } + if ($type == LEAF and + $self->lines->[0] =~ /^ {$offset}(.*)$/ + ) { + $self->indent($offset); + $self->content($1); + } + elsif ($self->lines->[0] =~ /^\s*$/) { + $self->indent($offset); + $self->content(''); + } + else { + $self->lines->[0] =~ /^( *)(\S.*)$/; + while ($self->offset->[$level] > length($1)) { + $level--; + } + $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION') + if $self->offset->[$level] != length($1); + $self->indent(length($1)); + $self->content($2); + } + $self->die('YAML_PARSE_ERR_INDENTATION') + if $self->indent - $offset > 1; +} + +#============================================================================== +# Utility subroutines. +#============================================================================== + +# Printable characters for escapes +my %unescapes = ( + 0 => "\x00", + a => "\x07", + t => "\x09", + n => "\x0a", + 'v' => "\x0b", # Potential v-string error on 5.6.2 if not quoted + f => "\x0c", + r => "\x0d", + e => "\x1b", + '\\' => '\\', + ); + +# Transform all the backslash style escape characters to their literal meaning +sub _unescape { + my $self = shift; + my ($node) = @_; + $node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/ + (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex; + return $node; +} + +1; + +__END__ + +=head1 NAME + +YAML::Loader - YAML class for loading Perl objects to YAML + +=head1 SYNOPSIS + + use YAML::Loader; + my $loader = YAML::Loader->new; + my $hash = $loader->load(<<'...'); + foo: bar + ... + +=head1 DESCRIPTION + +YAML::Loader is the module that YAML.pm used to deserialize YAML to Perl +objects. It is fully object oriented and usable on its own. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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.straw/lib/YAML/Loader/Base.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Loader/Base.pm new file mode 100755 index 00000000000..6733ad6e313 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Loader/Base.pm @@ -0,0 +1,68 @@ +package YAML::Loader::Base; + +use strict; +use warnings; +use YAML::Base; + +our $VERSION = '0.71'; +our @ISA = 'YAML::Base'; + +field load_code => 0; +field stream => ''; +field document => 0; +field line => 0; +field documents => []; +field lines => []; +field eos => 0; +field done => 0; +field anchor2node => {}; +field level => 0; +field offset => []; +field preface => ''; +field content => ''; +field indent => 0; +field major_version => 0; +field minor_version => 0; +field inline => ''; + +sub set_global_options { + my $self = shift; + $self->load_code($YAML::LoadCode || $YAML::UseCode) + if defined $YAML::LoadCode or defined $YAML::UseCode; +} + +sub load { + die 'load() not implemented in this class.'; +} + +1; + +__END__ + +=head1 NAME + +YAML::Loader::Base - Base class for YAML Loader classes + +=head1 SYNOPSIS + + package YAML::Loader::Something; + use YAML::Loader::Base -base; + +=head1 DESCRIPTION + +YAML::Loader::Base is a base class for creating YAML loader classes. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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.straw/lib/YAML/Marshall.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Marshall.pm new file mode 100755 index 00000000000..1986f58df61 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Marshall.pm @@ -0,0 +1,81 @@ +package YAML::Marshall; + +use strict; +use warnings; +use YAML::Node (); + +our $VERSION = '0.71'; + +sub import { + my $class = shift; + no strict 'refs'; + my $package = caller; + unless (grep { $_ eq $class} @{$package . '::ISA'}) { + push @{$package . '::ISA'}, $class; + } + + my $tag = shift; + if ( $tag ) { + no warnings 'once'; + $YAML::TagClass->{$tag} = $package; + ${$package . "::YamlTag"} = $tag; + } +} + +sub yaml_dump { + my $self = shift; + no strict 'refs'; + my $tag = ${ref($self) . "::YamlTag"} || 'perl/' . ref($self); + $self->yaml_node($self, $tag); +} + +sub yaml_load { + my ($class, $node) = @_; + if (my $ynode = $class->yaml_ynode($node)) { + $node = $ynode->{NODE}; + } + bless $node, $class; +} + +sub yaml_node { + shift; + YAML::Node->new(@_); +} + +sub yaml_ynode { + shift; + YAML::Node::ynode(@_); +} + +1; + +__END__ + +=head1 NAME + +YAML::Marshall - YAML marshalling class you can mixin to your classes + +=head1 SYNOPSIS + + package Bar; + use Foo -base; + use YAML::Marshall -mixin; + +=head1 DESCRIPTION + +For classes that want to handle their own YAML serialization. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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.straw/lib/YAML/Node.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Node.pm new file mode 100755 index 00000000000..afb11870310 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Node.pm @@ -0,0 +1,305 @@ +package YAML::Node; + +use strict; +use warnings; + +use YAML::Base; +use YAML::Tag; + +our $VERSION = '0.71'; +our @ISA = 'YAML::Base'; +our @EXPORT = qw(ynode); + +sub ynode { + my $self; + if (ref($_[0]) eq 'HASH') { + $self = tied(%{$_[0]}); + } + elsif (ref($_[0]) eq 'ARRAY') { + $self = tied(@{$_[0]}); + } + else { + $self = tied($_[0]); + } + return (ref($self) =~ /^yaml_/) ? $self : undef; +} + +sub new { + my ($class, $node, $tag) = @_; + my $self; + $self->{NODE} = $node; + my (undef, $type) = $class->node_info($node); + $self->{KIND} = (not defined $type) ? 'scalar' : + ($type eq 'ARRAY') ? 'sequence' : + ($type eq 'HASH') ? 'mapping' : + $class->die("Can't create YAML::Node from '$type'"); + tag($self, ($tag || '')); + if ($self->{KIND} eq 'scalar') { + yaml_scalar->new($self, $_[1]); + return \ $_[1]; + } + my $package = "yaml_" . $self->{KIND}; + $package->new($self) +} + +sub node { $_->{NODE} } +sub kind { $_->{KIND} } +sub tag { + my ($self, $value) = @_; + if (defined $value) { + $self->{TAG} = YAML::Tag->new($value); + return $self; + } + else { + return $self->{TAG}; + } +} +sub keys { + my ($self, $value) = @_; + if (defined $value) { + $self->{KEYS} = $value; + return $self; + } + else { + return $self->{KEYS}; + } +} + +#============================================================================== +package yaml_scalar; + +@yaml_scalar::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + tie $_[2], $class, $self; +} + +sub TIESCALAR { + my ($class, $self) = @_; + bless $self, $class; + $self +} + +sub FETCH { + my ($self) = @_; + $self->{NODE} +} + +sub STORE { + my ($self, $value) = @_; + $self->{NODE} = $value +} + +#============================================================================== +package yaml_sequence; + +@yaml_sequence::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + my $new; + tie @$new, $class, $self; + $new +} + +sub TIEARRAY { + my ($class, $self) = @_; + bless $self, $class +} + +sub FETCHSIZE { + my ($self) = @_; + scalar @{$self->{NODE}}; +} + +sub FETCH { + my ($self, $index) = @_; + $self->{NODE}[$index] +} + +sub STORE { + my ($self, $index, $value) = @_; + $self->{NODE}[$index] = $value +} + +sub undone { + die "Not implemented yet"; # XXX +} + +*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = +*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = +*undone; # XXX Must implement before release + +#============================================================================== +package yaml_mapping; + +@yaml_mapping::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + @{$self->{KEYS}} = sort keys %{$self->{NODE}}; + my $new; + tie %$new, $class, $self; + $new +} + +sub TIEHASH { + my ($class, $self) = @_; + bless $self, $class +} + +sub FETCH { + my ($self, $key) = @_; + if (exists $self->{NODE}{$key}) { + return (grep {$_ eq $key} @{$self->{KEYS}}) + ? $self->{NODE}{$key} : undef; + } + return $self->{HASH}{$key}; +} + +sub STORE { + my ($self, $key, $value) = @_; + if (exists $self->{NODE}{$key}) { + $self->{NODE}{$key} = $value; + } + elsif (exists $self->{HASH}{$key}) { + $self->{HASH}{$key} = $value; + } + else { + if (not grep {$_ eq $key} @{$self->{KEYS}}) { + push(@{$self->{KEYS}}, $key); + } + $self->{HASH}{$key} = $value; + } + $value +} + +sub DELETE { + my ($self, $key) = @_; + my $return; + if (exists $self->{NODE}{$key}) { + $return = $self->{NODE}{$key}; + } + elsif (exists $self->{HASH}{$key}) { + $return = delete $self->{NODE}{$key}; + } + for (my $i = 0; $i < @{$self->{KEYS}}; $i++) { + if ($self->{KEYS}[$i] eq $key) { + splice(@{$self->{KEYS}}, $i, 1); + } + } + return $return; +} + +sub CLEAR { + my ($self) = @_; + @{$self->{KEYS}} = (); + %{$self->{HASH}} = (); +} + +sub FIRSTKEY { + my ($self) = @_; + $self->{ITER} = 0; + $self->{KEYS}[0] +} + +sub NEXTKEY { + my ($self) = @_; + $self->{KEYS}[++$self->{ITER}] +} + +sub EXISTS { + my ($self, $key) = @_; + exists $self->{NODE}{$key} +} + +1; + +__END__ + +=head1 NAME + +YAML::Node - A generic data node that encapsulates YAML information + +=head1 SYNOPSIS + + use YAML; + use YAML::Node; + + my $ynode = YAML::Node->new({}, 'ingerson.com/fruit'); + %$ynode = qw(orange orange apple red grape green); + print Dump $ynode; + +yields: + + --- !ingerson.com/fruit + orange: orange + apple: red + grape: green + +=head1 DESCRIPTION + +A generic node in YAML is similar to a plain hash, array, or scalar node +in Perl except that it must also keep track of its type. The type is a +URI called the YAML type tag. + +YAML::Node is a class for generating and manipulating these containers. +A YAML node (or ynode) is a tied hash, array or scalar. In most ways it +behaves just like the plain thing. But you can assign and retrieve and +YAML type tag URI to it. For the hash flavor, you can also assign the +order that the keys will be retrieved in. By default a ynode will offer +its keys in the same order that they were assigned. + +YAML::Node has a class method call new() that will return a ynode. You +pass it a regular node and an optional type tag. After that you can +use it like a normal Perl node, but when you YAML::Dump it, the magical +properties will be honored. + +This is how you can control the sort order of hash keys during a YAML +serialization. By default, YAML sorts keys alphabetically. But notice +in the above example that the keys were Dumped in the same order they +were assigned. + +YAML::Node exports a function called ynode(). This function returns the tied object so that you can call special methods on it like ->keys(). + +keys() works like this: + + use YAML; + use YAML::Node; + + %$node = qw(orange orange apple red grape green); + $ynode = YAML::Node->new($node); + ynode($ynode)->keys(['grape', 'apple']); + print Dump $ynode; + +produces: + + --- + grape: green + apple: red + +It tells the ynode which keys and what order to use. + +ynodes will play a very important role in how programs use YAML. They +are the foundation of how a Perl class can marshall the Loading and +Dumping of its objects. + +The upcoming versions of YAML.pm will have much more information on this. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +Copyright (c) 2002. Brian Ingerson. All rights reserved. + +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.straw/lib/YAML/Tag.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Tag.pm new file mode 100755 index 00000000000..8a598a867e0 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Tag.pm @@ -0,0 +1,52 @@ +package YAML::Tag; + +use strict; +use warnings; + +our $VERSION = '0.71'; + +use overload '""' => sub { ${$_[0]} }; + +sub new { + my ($class, $self) = @_; + bless \$self, $class +} + +sub short { + ${$_[0]} +} + +sub canonical { + ${$_[0]} +} + +1; + +__END__ + +=head1 NAME + +YAML::Tag - Tag URI object class for YAML + +=head1 SYNOPSIS + + use YAML::Tag; + +=head1 DESCRIPTION + +Used by YAML::Node. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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.straw/lib/YAML/Tiny.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Tiny.pm new file mode 100755 index 00000000000..a3f36c67687 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Tiny.pm @@ -0,0 +1,1132 @@ +package YAML::Tiny; + +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; + $YAML::Tiny::VERSION = '1.41'; + @YAML::Tiny::ISA = qw{ Exporter }; + @YAML::Tiny::EXPORT = qw{ Load Dump }; + @YAML::Tiny::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; + + # Error storage + $YAML::Tiny::errstr = ''; +} + +# The character class of all characters we need to escape +# NOTE: Inlined, since it's only used once +# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]'; + +# Printed form of the unprintable characters in the lowest range +# of ASCII characters, listed by ASCII ordinal position. +my @UNPRINTABLE = qw( + z x01 x02 x03 x04 x05 x06 a + x08 t n v f r x0e x0f + x10 x11 x12 x13 x14 x15 x16 x17 + x18 x19 x1a e x1c x1d x1e x1f +); + +# Printable characters for escapes +my %UNESCAPES = ( + z => "\x00", a => "\x07", t => "\x09", + n => "\x0a", v => "\x0b", f => "\x0c", + r => "\x0d", e => "\x1b", '\\' => '\\', +); + +# Special magic boolean words +my %QUOTE = map { $_ => 1 } qw{ + null Null NULL + y Y yes Yes YES n N no No NO + true True TRUE false False FALSE + on On ON off Off OFF +}; + + + + + +##################################################################### +# Implementation + +# Create an empty YAML::Tiny object +sub new { + my $class = shift; + bless [ @_ ], $class; +} + +# Create an object from a file +sub read { + my $class = ref $_[0] ? ref shift : shift; + + # Check the file + my $file = shift or return $class->_error( 'You did not specify a file name' ); + return $class->_error( "File '$file' does not exist" ) unless -e $file; + return $class->_error( "'$file' is a directory, not a file" ) unless -f _; + return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; + + # Slurp in the file + local $/ = undef; + local *CFG; + unless ( open(CFG, $file) ) { + return $class->_error("Failed to open file '$file': $!"); + } + my $contents = <CFG>; + unless ( close(CFG) ) { + return $class->_error("Failed to close file '$file': $!"); + } + + $class->read_string( $contents ); +} + +# Create an object from a string +sub read_string { + my $class = ref $_[0] ? ref shift : shift; + my $self = bless [], $class; + my $string = $_[0]; + unless ( defined $string ) { + return $self->_error("Did not provide a string to load"); + } + + # Byte order marks + # NOTE: Keeping this here to educate maintainers + # my %BOM = ( + # "\357\273\277" => 'UTF-8', + # "\376\377" => 'UTF-16BE', + # "\377\376" => 'UTF-16LE', + # "\377\376\0\0" => 'UTF-32LE' + # "\0\0\376\377" => 'UTF-32BE', + # ); + if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) { + return $self->_error("Stream has a non UTF-8 BOM"); + } 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 $self unless length $string; + unless ( $string =~ /[\012\015]+\z/ ) { + return $self->_error("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 + 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 @$self, $self->_read_scalar( "$1", [ undef ], \@lines ); + next; + } + } + + if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { + # A naked document + push @$self, undef; + while ( @lines and $lines[0] !~ /^---/ ) { + shift @lines; + } + + } elsif ( $lines[0] =~ /^\s*\-/ ) { + # An array at the root + my $document = [ ]; + push @$self, $document; + $self->_read_array( $document, [ 0 ], \@lines ); + + } elsif ( $lines[0] =~ /^(\s*)\S/ ) { + # A hash at the root + my $document = { }; + push @$self, $document; + $self->_read_hash( $document, [ length($1) ], \@lines ); + + } else { + croak("YAML::Tiny failed to classify the line '$lines[0]'"); + } + } + + $self; +} + +# Deparse a scalar string to the actual scalar +sub _read_scalar { + my ($self, $string, $indent, $lines) = @_; + + # Trim trailing whitespace + $string =~ s/\s*\z//; + + # Explitic null/undef + return undef if $string eq '~'; + + # Single quote + if ( $string =~ /^\'(.*?)\'\z/ ) { + return '' unless defined $1; + $string = $1; + $string =~ s/\'\'/\'/g; + return $string; + } + + # Double quote. + # The commented out form is simpler, but overloaded the Perl regex + # engine due to recursion and backtracking problems on strings + # larger than 32,000ish characters. Keep it for reference purposes. + # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) { + 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("YAML::Tiny 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("YAML::Tiny 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("YAML::Tiny 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 _read_array { + my ($self, $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("YAML::Tiny 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, { }; + $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); + + } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { + # Array entry with a value + shift @$lines; + push @$array, $self->_read_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, [ ]; + $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines ); + } + + } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { + push @$array, { }; + $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines ); + + } else { + croak("YAML::Tiny 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("YAML::Tiny failed to classify line '$lines->[0]'"); + } + } + + return 1; +} + +# Parse an array +sub _read_hash { + my ($self, $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("YAML::Tiny found bad indenting in line '$lines->[0]'"); + } + + # Get the key + unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) { + if ( $lines->[0] =~ /^\s*[?\'\"]/ ) { + croak("YAML::Tiny does not support a feature in line '$lines->[0]'"); + } + croak("YAML::Tiny failed to classify line '$lines->[0]'"); + } + my $key = $1; + + # Do we have a value? + if ( length $lines->[0] ) { + # Yes + $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines ); + } else { + # An indent + shift @$lines; + unless ( @$lines ) { + $hash->{$key} = undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)-/ ) { + $hash->{$key} = []; + $self->_read_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} = {}; + $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); + } + } + } + } + + return 1; +} + +# Save an object to a file +sub write { + my $self = shift; + my $file = shift or return $self->_error('No file name provided'); + + # Write it to the file + open( CFG, '>' . $file ) or return $self->_error( + "Failed to open file '$file' for writing: $!" + ); + print CFG $self->write_string; + close CFG; + + return 1; +} + +# Save an object to a string +sub write_string { + my $self = shift; + return '' unless @$self; + + # Iterate over the documents + my $indent = 0; + my @lines = (); + foreach my $cursor ( @$self ) { + push @lines, '---'; + + # An empty document + if ( ! defined $cursor ) { + # Do nothing + + # A scalar document + } elsif ( ! ref $cursor ) { + $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent ); + + # A list at the root + } elsif ( ref $cursor eq 'ARRAY' ) { + unless ( @$cursor ) { + $lines[-1] .= ' []'; + next; + } + push @lines, $self->_write_array( $cursor, $indent, {} ); + + # A hash at the root + } elsif ( ref $cursor eq 'HASH' ) { + unless ( %$cursor ) { + $lines[-1] .= ' {}'; + next; + } + push @lines, $self->_write_hash( $cursor, $indent, {} ); + + } else { + croak("Cannot serialize " . ref($cursor)); + } + } + + join '', map { "$_\n" } @lines; +} + +sub _write_scalar { + my $string = $_[1]; + return '~' unless defined $string; + return "''" unless length $string; + if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) { + $string =~ s/\\/\\\\/g; + $string =~ s/"/\\"/g; + $string =~ s/\n/\\n/g; + $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; + return qq|"$string"|; + } + if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) { + return "'$string'"; + } + return $string; +} + +sub _write_array { + my ($self, $array, $indent, $seen) = @_; + if ( $seen->{refaddr($array)}++ ) { + die "YAML::Tiny does not support circular references"; + } + my @lines = (); + foreach my $el ( @$array ) { + my $line = (' ' x $indent) . '-'; + my $type = ref $el; + if ( ! $type ) { + $line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); + push @lines, $line; + + } elsif ( $type eq 'ARRAY' ) { + if ( @$el ) { + push @lines, $line; + push @lines, $self->_write_array( $el, $indent + 1, $seen ); + } else { + $line .= ' []'; + push @lines, $line; + } + + } elsif ( $type eq 'HASH' ) { + if ( keys %$el ) { + push @lines, $line; + push @lines, $self->_write_hash( $el, $indent + 1, $seen ); + } else { + $line .= ' {}'; + push @lines, $line; + } + + } else { + die "YAML::Tiny does not support $type references"; + } + } + + @lines; +} + +sub _write_hash { + my ($self, $hash, $indent, $seen) = @_; + if ( $seen->{refaddr($hash)}++ ) { + die "YAML::Tiny does not support circular references"; + } + my @lines = (); + foreach my $name ( sort keys %$hash ) { + my $el = $hash->{$name}; + my $line = (' ' x $indent) . "$name:"; + my $type = ref $el; + if ( ! $type ) { + $line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); + push @lines, $line; + + } elsif ( $type eq 'ARRAY' ) { + if ( @$el ) { + push @lines, $line; + push @lines, $self->_write_array( $el, $indent + 1, $seen ); + } else { + $line .= ' []'; + push @lines, $line; + } + + } elsif ( $type eq 'HASH' ) { + if ( keys %$el ) { + push @lines, $line; + push @lines, $self->_write_hash( $el, $indent + 1, $seen ); + } else { + $line .= ' {}'; + push @lines, $line; + } + + } else { + die "YAML::Tiny does not support $type references"; + } + } + + @lines; +} + +# Set error +sub _error { + $YAML::Tiny::errstr = $_[1]; + undef; +} + +# Retrieve error +sub errstr { + $YAML::Tiny::errstr; +} + + + + + +##################################################################### +# YAML Compatibility + +sub Dump { + YAML::Tiny->new(@_)->write_string; +} + +sub Load { + my $self = YAML::Tiny->read_string(@_); + unless ( $self ) { + croak("Failed to load YAML document from string"); + } + if ( wantarray ) { + return @$self; + } else { + # To match YAML.pm, return the last document + return $self->[-1]; + } +} + +BEGIN { + *freeze = *Dump; + *thaw = *Load; +} + +sub DumpFile { + my $file = shift; + YAML::Tiny->new(@_)->write($file); +} + +sub LoadFile { + my $self = YAML::Tiny->read($_[0]); + unless ( $self ) { + croak("Failed to load YAML document from '" . ($_[0] || '') . "'"); + } + if ( wantarray ) { + return @$self; + } else { + # Return only the last document to match YAML.pm, + return $self->[-1]; + } +} + + + + + +##################################################################### +# Use Scalar::Util if possible, otherwise emulate it + +BEGIN { + eval { + require Scalar::Util; + }; + if ( $@ ) { + # Failed to load Scalar::Util + eval <<'END_PERL'; +sub refaddr { + my $pkg = ref($_[0]) or return undef; + if (!!UNIVERSAL::can($_[0], 'can')) { + bless $_[0], 'Scalar::Util::Fake'; + } else { + $pkg = undef; + } + "$_[0]" =~ /0x(\w+)/; + my $i = do { local $^W; hex $1 }; + bless $_[0], $pkg if defined $pkg; + $i; +} +END_PERL + } else { + Scalar::Util->import('refaddr'); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +YAML::Tiny - Read/Write YAML files with as little code as possible + +=head1 PREAMBLE + +The YAML specification is huge. Really, B<really> huge. It contains all the +functionality of XML, except with flexibility and choice, which makes it +easier to read, but with a formal specification that is more complex than +XML. + +The original pure-Perl implementation L<YAML> costs just over 4 megabytes of +memory to load. Just like with Windows .ini files (3 meg to load) and CSS +(3.5 meg to load) the situation is just asking for a B<YAML::Tiny> module, an +incomplete but correct and usable subset of the functionality, in as little +code as possible. + +Like the other C<::Tiny> modules, YAML::Tiny will have no non-core +dependencies, not require a compiler, and be back-compatible to at least +perl 5.005_03, and ideally 5.004. + +=head1 SYNOPSIS + + ############################################# + # In your file + + --- + rootproperty: blah + section: + one: two + three: four + Foo: Bar + empty: ~ + + + + ############################################# + # In your program + + use YAML::Tiny; + + # Create a YAML file + my $yaml = YAML::Tiny->new; + + # Open the config + $yaml = YAML::Tiny->read( 'file.yml' ); + + # Reading properties + my $root = $yaml->[0]->{rootproperty}; + my $one = $yaml->[0]->{section}->{one}; + my $Foo = $yaml->[0]->{section}->{Foo}; + + # Changing data + $yaml->[0]->{newsection} = { this => 'that' }; # Add a section + $yaml->[0]->{section}->{Foo} = 'Not Bar!'; # Change a value + delete $yaml->[0]->{section}; # Delete a value or section + + # Add an entire document + $yaml->[1] = [ 'foo', 'bar', 'baz' ]; + + # Save the file + $yaml->write( 'file.conf' ); + +=head1 DESCRIPTION + +B<YAML::Tiny> is a perl class for reading and writing YAML-style files, +written with as little code as possible, reducing load time and memory +overhead. + +Most of the time it is accepted that Perl applications use a lot +of memory and modules. The B<::Tiny> family of modules is specifically +intended to provide an ultralight and zero-dependency alternative to +many more-thorough standard modules. + +This module is primarily for reading human-written files (like simple +config files) and generating very simple human-readable files. Note that +I said B<human-readable> and not B<geek-readable>. The sort of files that +your average manager or secretary should be able to look at and make +sense of. + +L<YAML::Tiny> does not generate comments, it won't necesarily preserve the +order of your hashes, and it will normalise if reading in and writing out +again. + +It only supports a very basic subset of the full YAML specification. + +Usage is targetted at files like Perl's META.yml, for which a small and +easily-embeddable module is extremely attractive. + +Features will only be added if they are human readable, and can be written +in a few lines of code. Please don't be offended if your request is +refused. Someone has to draw the line, and for YAML::Tiny that someone is me. + +If you need something with more power move up to L<YAML> (4 megabytes of +memory overhead) or L<YAML::Syck> (275k, but requires libsyck and a C +compiler). + +To restate, L<YAML::Tiny> does B<not> preserve your comments, whitespace, or +the order of your YAML data. But it should round-trip from Perl structure +to file and back again just fine. + +=head1 YAML TINY SPECIFICATION + +This section of the documentation provides a specification for "YAML Tiny", +a subset of the YAML specification. + +It is based on and described comparatively to the YAML 1.1 Working Draft +2004-12-28 specification, located at L<http://yaml.org/spec/current.html>. + +Terminology and chapter numbers are based on that specification. + +=head2 1. Introduction and Goals + +The purpose of the YAML Tiny specification is to describe a useful subset of +the YAML specification that can be used for typical document-oriented +uses such as configuration files and simple data structure dumps. + +Many specification elements that add flexibility or extensibility are +intentionally removed, as is support for complex datastructures, class +and object-orientation. + +In general, YAML Tiny targets only those data structures available in +JSON, with the additional limitation that only simple keys are supported. + +As a result, all possible YAML Tiny documents should be able to be +transformed into an equivalent JSON document, although the reverse is +not necesarily true (but will be true in simple cases). + +As a result of these simplifications the YAML Tiny specification should +be implementable in a relatively small amount of code in any language +that supports Perl Compatible Regular Expressions (PCRE). + +=head2 2. Introduction + +YAML Tiny supports three data structures. These are scalars (in a variety +of forms), block-form sequences and block-form mappings. Flow-style +sequences and mappings are not supported, with some minor exceptions +detailed later. + +The use of three dashes "---" to indicate the start of a new document is +supported, and multiple documents per file/stream is allowed. + +Both line and inline comments are supported. + +Scalars are supported via the plain style, single quote and double quote, +as well as literal-style and folded-style multi-line scalars. + +The use of tags is not supported. + +The use of anchors and aliases is not supported. + +The use of directives is supported only for the %YAML directive. + +=head2 3. Processing YAML Tiny Information + +B<Processes> + +The YAML specification dictates three-phase serialization and three-phase +deserialization. + +The YAML Tiny specification does not mandate any particular methodology +or mechanism for parsing. + +Any compliant parser is only required to parse a single document at a +time. The ability to support streaming documents is optional and most +likely non-typical. + +Because anchors and aliases are not supported, the resulting representation +graph is thus directed but (unlike the main YAML specification) B<acyclic>. + +Circular references/pointers are not possible, and any YAML Tiny serializer +detecting a circulars should error with an appropriate message. + +B<Presentation Stream> + +YAML Tiny is notionally unicode, but support for unicode is required if the +underlying language or system being used to implement a parser does not +support Unicode. If unicode is encountered in this case an error should be +returned. + +B<Loading Failure Points> + +YAML Tiny parsers and emitters are not expected to recover from adapt to +errors. The specific error modality of any implementation is not dictated +(return codes, exceptions, etc) but is expected to be consistant. + +=head2 4. Syntax + +B<Character Set> + +YAML Tiny streams are implemented primarily using the ASCII character set, +although the use of Unicode inside strings is allowed if support by the +implementation. + +Specific YAML Tiny encoded document types aiming for maximum compatibility +should restrict themselves to ASCII. + +The escaping and unescaping of the 8-bit YAML escapes is required. + +The escaping and unescaping of 16-bit and 32-bit YAML escapes is not +required. + +B<Indicator Characters> + +Support for the "~" null/undefined indicator is required. + +Implementations may represent this as appropriate for the underlying +language. + +Support for the "-" block sequence indicator is required. + +Support for the "?" mapping key indicator is B<not> required. + +Support for the ":" mapping value indicator is required. + +Support for the "," flow collection indicator is B<not> required. + +Support for the "[" flow sequence indicator is B<not> required, with +one exception (detailed below). + +Support for the "]" flow sequence indicator is B<not> required, with +one exception (detailed below). + +Support for the "{" flow mapping indicator is B<not> required, with +one exception (detailed below). + +Support for the "}" flow mapping indicator is B<not> required, with +one exception (detailed below). + +Support for the "#" comment indicator is required. + +Support for the "&" anchor indicator is B<not> required. + +Support for the "*" alias indicator is B<not> required. + +Support for the "!" tag indicator is B<not> required. + +Support for the "|" literal block indicator is required. + +Support for the ">" folded block indicator is required. + +Support for the "'" single quote indicator is required. + +Support for the """ double quote indicator is required. + +Support for the "%" directive indicator is required, but only +for the special case of a %YAML version directive before the +"---" document header, or on the same line as the document header. + +For example: + + %YAML 1.1 + --- + - A sequence with a single element + +Special Exception: + +To provide the ability to support empty sequences +and mappings, support for the constructs [] (empty sequence) and {} +(empty mapping) are required. + +For example, + + %YAML 1.1 + # A document consisting of only an empty mapping + --- {} + # A document consisting of only an empty sequence + --- [] + # A document consisting of an empty mapping within a sequence + - foo + - {} + - bar + +B<Syntax Primitives> + +Other than the empty sequence and mapping cases described above, YAML Tiny +supports only the indentation-based block-style group of contexts. + +All five scalar contexts are supported. + +Indentation spaces work as per the YAML specification in all cases. + +Comments work as per the YAML specification in all simple cases. +Support for indented multi-line comments is B<not> required. + +Seperation spaces work as per the YAML specification in all cases. + +B<YAML Tiny Character Stream> + +The only directive supported by the YAML Tiny specification is the +%YAML language/version identifier. Although detected, this directive +will have no control over the parsing itself. + +The parser must recognise both the YAML 1.0 and YAML 1.1+ formatting +of this directive (as well as the commented form, although no explicit +code should be needed to deal with this case, being a comment anyway) + +That is, all of the following should be supported. + + --- #YAML:1.0 + - foo + + %YAML:1.0 + --- + - foo + + % YAML 1.1 + --- + - foo + +Support for the %TAG directive is B<not> required. + +Support for additional directives is B<not> required. + +Support for the document boundary marker "---" is required. + +Support for the document boundary market "..." is B<not> required. + +If necesary, a document boundary should simply by indicated with a +"---" marker, with not preceding "..." marker. + +Support for empty streams (containing no documents) is required. + +Support for implicit document starts is required. + +That is, the following must be equivalent. + + # Full form + %YAML 1.1 + --- + foo: bar + + # Implicit form + foo: bar + +B<Nodes> + +Support for nodes optional anchor and tag properties are B<not> required. + +Support for node anchors is B<not> required. + +Supprot for node tags is B<not> required. + +Support for alias nodes is B<not> required. + +Support for flow nodes is B<not> required. + +Support for block nodes is required. + +B<Scalar Styles> + +Support for all five scalar styles are required as per the YAML +specification, although support for quoted scalars spanning more +than one line is B<not> required. + +Support for the chomping indicators on multi-line scalar styles +is required. + +B<Collection Styles> + +Support for block-style sequences is required. + +Support for flow-style sequences is B<not> required. + +Support for block-style mappings is required. + +Support for flow-style mappings is B<not> required. + +Both sequences and mappings should be able to be arbitrarily +nested. + +Support for plain-style mapping keys is required. + +Support for quoted keys in mappings is B<not> required. + +Support for "?"-indicated explicit keys is B<not> required. + +Here endeth the specification. + +=head2 Additional Perl-Specific Notes + +For some Perl applications, it's important to know if you really have a +number and not a string. + +That is, in some contexts is important that 3 the number is distinctive +from "3" the string. + +Because even Perl itself is not trivially able to understand the difference +(certainly without XS-based modules) Perl implementations of the YAML Tiny +specification are not required to retain the distinctiveness of 3 vs "3". + +=head1 METHODS + +=head2 new + +The constructor C<new> creates and returns an empty C<YAML::Tiny> object. + +=head2 read $filename + +The C<read> constructor reads a YAML file, and returns a new +C<YAML::Tiny> object containing the contents of the file. + +Returns the object on success, or C<undef> on error. + +When C<read> fails, C<YAML::Tiny> sets an error message internally +you can recover via C<YAML::Tiny-E<gt>errstr>. Although in B<some> +cases a failed C<read> will also set the operating system error +variable C<$!>, not all errors do and you should not rely on using +the C<$!> variable. + +=head2 read_string $string; + +The C<read_string> method takes as argument the contents of a YAML file +(a YAML document) as a string and returns the C<YAML::Tiny> object for +it. + +=head2 write $filename + +The C<write> method generates the file content for the properties, and +writes it to disk to the filename specified. + +Returns true on success or C<undef> on error. + +=head2 write_string + +Generates the file content for the object and returns it as a string. + +=head2 errstr + +When an error occurs, you can retrieve the error message either from the +C<$YAML::Tiny::errstr> variable, or using the C<errstr()> method. + +=head1 FUNCTIONS + +YAML::Tiny implements a number of functions to add compatibility with +the L<YAML> API. These should be a drop-in replacement, except that +YAML::Tiny will B<not> export functions by default, and so you will need +to explicitly import the functions. + +=head2 Dump + + my $string = Dump(list-of-Perl-data-structures); + +Turn Perl data into YAML. This function works very much like Data::Dumper::Dumper(). + +It takes a list of Perl data strucures and dumps them into a serialized form. + +It returns a string containing the YAML stream. + +The structures can be references or plain scalars. + +=head2 Load + + my @documents = Load(string-containing-a-YAML-stream); + +Turn YAML into Perl data. This is the opposite of Dump. + +Just like L<Storable>'s thaw() function or the eval() function in relation +to L<Data::Dumper>. + +It parses a string containing a valid YAML stream into a list of Perl data +structures. + +=head2 freeze() and thaw() + +Aliases to Dump() and Load() for L<Storable> fans. This will also allow +YAML::Tiny to be plugged directly into modules like POE.pm, that use the +freeze/thaw API for internal serialization. + +=head2 DumpFile(filepath, list) + +Writes the YAML stream to a file instead of just returning a string. + +=head2 LoadFile(filepath) + +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=YAML-Tiny> + +=begin html + +For other issues, or commercial enhancement or support, please contact +<a href="http://ali.as/">Adam Kennedy</a> directly. + +=end html + +=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 diff --git a/Master/tlpkg/tlperl.straw/lib/YAML/Types.pm b/Master/tlpkg/tlperl.straw/lib/YAML/Types.pm new file mode 100755 index 00000000000..16cbaccadaa --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/YAML/Types.pm @@ -0,0 +1,265 @@ +package YAML::Types; + +use strict; +use warnings; +use YAML::Base; +use YAML::Node; + +our $VERSION = '0.71'; +our @ISA = 'YAML::Base'; + +# XXX These classes and their APIs could still use some refactoring, +# but at least they work for now. +#------------------------------------------------------------------------------- +package YAML::Type::blessed; + +use YAML::Base; # XXX + +sub yaml_dump { + my $self = shift; + my ($value) = @_; + my ($class, $type) = YAML::Base->node_info($value); + no strict 'refs'; + my $kind = lc($type) . ':'; + my $tag = ${$class . '::ClassTag'} || + "!perl/$kind$class"; + if ($type eq 'REF') { + YAML::Node->new( + {(&YAML::VALUE, ${$_[0]})}, $tag + ); + } + elsif ($type eq 'SCALAR') { + $_[1] = $$value; + YAML::Node->new($_[1], $tag); + } else { + YAML::Node->new($value, $tag); + } +} + +#------------------------------------------------------------------------------- +package YAML::Type::undef; + +sub yaml_dump { + my $self = shift; +} + +sub yaml_load { + my $self = shift; +} + +#------------------------------------------------------------------------------- +package YAML::Type::glob; + +sub yaml_dump { + my $self = shift; + my $ynode = YAML::Node->new({}, '!perl/glob:'); + for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) { + my $value = *{$_[0]}{$type}; + $value = $$value if $type eq 'SCALAR'; + if (defined $value) { + if ($type eq 'IO') { + my @stats = qw(device inode mode links uid gid rdev size + atime mtime ctime blksize blocks); + undef $value; + $value->{stat} = YAML::Node->new({}); + map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]}); + $value->{fileno} = fileno(*{$_[0]}); + { + local $^W; + $value->{tell} = tell(*{$_[0]}); + } + } + $ynode->{$type} = $value; + } + } + return $ynode; +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + my ($name, $package); + if (defined $node->{NAME}) { + $name = $node->{NAME}; + delete $node->{NAME}; + } + else { + $loader->warn('YAML_LOAD_WARN_GLOB_NAME'); + return undef; + } + if (defined $node->{PACKAGE}) { + $package = $node->{PACKAGE}; + delete $node->{PACKAGE}; + } + else { + $package = 'main'; + } + no strict 'refs'; + if (exists $node->{SCALAR}) { + *{"${package}::$name"} = \$node->{SCALAR}; + delete $node->{SCALAR}; + } + for my $elem (qw(ARRAY HASH CODE IO)) { + if (exists $node->{$elem}) { + if ($elem eq 'IO') { + $loader->warn('YAML_LOAD_WARN_GLOB_IO'); + delete $node->{IO}; + next; + } + *{"${package}::$name"} = $node->{$elem}; + delete $node->{$elem}; + } + } + for my $elem (sort keys %$node) { + $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem); + } + return *{"${package}::$name"}; +} + +#------------------------------------------------------------------------------- +package YAML::Type::code; + +my $dummy_warned = 0; +my $default = '{ "DUMMY" }'; + +sub yaml_dump { + my $self = shift; + my $code; + my ($dumpflag, $value) = @_; + my ($class, $type) = YAML::Base->node_info($value); + my $tag = "!perl/code"; + $tag .= ":$class" if defined $class; + if (not $dumpflag) { + $code = $default; + } + else { + bless $value, "CODE" if $class; + eval { use B::Deparse }; + return if $@; + my $deparse = B::Deparse->new(); + eval { + local $^W = 0; + $code = $deparse->coderef2text($value); + }; + if ($@) { + warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W; + $code = $default; + } + bless $value, $class if $class; + chomp $code; + $code .= "\n"; + } + $_[2] = $code; + YAML::Node->new($_[2], $tag); +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + if ($loader->load_code) { + my $code = eval "package main; sub $node"; + if ($@) { + $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@); + return sub {}; + } + else { + CORE::bless $code, $class if $class; + return $code; + } + } + else { + return CORE::bless sub {}, $class if $class; + return sub {}; + } +} + +#------------------------------------------------------------------------------- +package YAML::Type::ref; + +sub yaml_dump { + my $self = shift; + YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref') +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr') + unless exists $node->{&YAML::VALUE}; + return \$node->{&YAML::VALUE}; +} + +#------------------------------------------------------------------------------- +package YAML::Type::regexp; + +# XXX Be sure to handle blessed regexps (if possible) +sub yaml_dump { + die "YAML::Type::regexp::yaml_dump not currently implemented"; +} + +use constant _QR_TYPES => { + '' => sub { qr{$_[0]} }, + x => sub { qr{$_[0]}x }, + i => sub { qr{$_[0]}i }, + s => sub { qr{$_[0]}s }, + m => sub { qr{$_[0]}m }, + ix => sub { qr{$_[0]}ix }, + sx => sub { qr{$_[0]}sx }, + mx => sub { qr{$_[0]}mx }, + si => sub { qr{$_[0]}si }, + mi => sub { qr{$_[0]}mi }, + ms => sub { qr{$_[0]}sm }, + six => sub { qr{$_[0]}six }, + mix => sub { qr{$_[0]}mix }, + msx => sub { qr{$_[0]}msx }, + msi => sub { qr{$_[0]}msi }, + msix => sub { qr{$_[0]}msix }, +}; + +sub yaml_load { + my $self = shift; + my ($node, $class) = @_; + return qr{$node} unless $node =~ /^\(\?([\-xism]*):(.*)\)\z/s; + my ($flags, $re) = ($1, $2); + $flags =~ s/-.*//; + my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} }; + my $qr = &$sub($re); + bless $qr, $class if length $class; + return $qr; +} + +1; + +__END__ + +=head1 NAME + +YAML::Types - Marshall Perl internal data types to/from YAML + +=head1 SYNOPSIS + + $::foo = 42; + print YAML::Dump(*::foo); + + print YAML::Dump(qr{match me}); + +=head1 DESCRIPTION + +This module has the helper classes for transferring objects, +subroutines, references, globs, regexps and file handles to and +from YAML. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +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 |