From: Moritz Bunkus Date: Tue, 29 May 2007 14:36:14 +0000 (+0000) Subject: Import der aktuellen Version des YAML-Moduls 0.62 in Lx-Office. Unsere eigene Version... X-Git-Tag: release-2.4.3^2~238 X-Git-Url: http://wagnertech.de/git?a=commitdiff_plain;h=99ed8abf161b15ba5456c34f59a6155281cb2eea;p=kivitendo-erp.git Import der aktuellen Version des YAML-Moduls 0.62 in Lx-Office. Unsere eigene Version wird der im System installierten bevorzugt. Grund sind Bugs in älteren Versionen, die sich nicht anders umgehen lassen. Beispiel eines Bugs in Version 0.3x: YAML::Load(YAML::Dump('>test.pdf')); --- diff --git a/am.pl b/am.pl index b54599e49..2d1605253 100755 --- a/am.pl +++ b/am.pl @@ -31,7 +31,8 @@ ####################################################################### BEGIN { - push(@INC, "modules"); + unshift @INC, "modules/YAML"; # Use our own version of YAML. + push @INC, "modules"; # Only use our own versions of modules if there's no system version. } # setup defaults, DO NOT CHANGE diff --git a/login.pl b/login.pl index 7cca68aa7..a01fc10f8 100755 --- a/login.pl +++ b/login.pl @@ -31,7 +31,8 @@ ####################################################################### BEGIN { - push(@INC, "modules"); + unshift @INC, "modules/YAML"; # Use our own version of YAML. + push @INC, "modules"; # Only use our own versions of modules if there's no system version. } # setup defaults, DO NOT CHANGE diff --git a/modules/YAML/README b/modules/YAML/README new file mode 100644 index 000000000..0fbb2fd09 --- /dev/null +++ b/modules/YAML/README @@ -0,0 +1,611 @@ +NAME + YAML - YAML Ain't Markup Language (tm) + +SYNOPSIS + use YAML; + + # Load a YAML stream of 3 YAML documents into Perl data structures. + my ($hashref, $arrayref, $string) = Load(<<'...'); + --- + name: ingy + age: old + weight: heavy + # I should comment that I also like pink, but don't tell anybody. + favorite colors: + - red + - green + - blue + --- + - Clark Evans + - Oren Ben-Kiki + - Ingy döt Net + --- > + You probably think YAML stands for "Yet Another Markup Language". It + ain't! YAML is really a data serialization language. But if you want + to think of it as a markup, that's OK with me. A lot of people try + to use XML as a serialization format. + + "YAML" is catchy and fun to say. Try it. "YAML, YAML, YAML!!!" + ... + + # Dump the Perl data structures back into YAML. + print Dump($string, $arrayref, $hashref); + + # YAML::Dump is used the same way you'd use Data::Dumper::Dumper + use Data::Dumper; + print Dumper($string, $arrayref, $hashref); + +DESCRIPTION + The YAML.pm module implements a YAML Loader and Dumper based on the YAML + 1.0 specification. + + YAML is a generic data serialization language that is optimized for + human readability. It can be used to express the data structures of most + modern programming languages. (Including Perl!!!) + + For information on the YAML syntax, please refer to the YAML + specification. + +WHY YAML IS COOL + YAML is readable for people. + It makes clear sense out of complex data structures. You should find + that YAML is an exceptional data dumping tool. Structure is shown + through indentation, YAML supports recursive data, and hash keys are + sorted by default. In addition, YAML supports several styles of + scalar formatting for different types of data. + + YAML is editable. + YAML was designed from the ground up to be an excellent syntax for + configuration files. Almost all programs need configuration files, + so why invent a new syntax for each one? And why subject users to + the complexities of XML or native Perl code? + + YAML is multilingual. + Yes, YAML supports Unicode. But I'm actually referring to + programming languages. YAML was designed to meet the serialization + needs of Perl, Python, Ruby, Tcl, PHP, Javascript and Java. It was + also designed to be interoperable between those languages. That + means YAML serializations produced by Perl can be processed by + Python. + + YAML is taint safe. + Using modules like Data::Dumper for serialization is fine as long as + you can be sure that nobody can tamper with your data files or + transmissions. That's because you need to use Perl's "eval()" + built-in to deserialize the data. Somebody could add a snippet of + Perl to erase your files. + + YAML's parser does not need to eval anything. + + YAML is full featured. + YAML can accurately serialize all of the common Perl data structures + and deserialize them again without losing data relationships. + Although it is not 100% perfect (no serializer is or can be + perfect), it fares as well as the popular current modules: + Data::Dumper, Storable, XML::Dumper and Data::Denter. + + YAML.pm also has the ability to handle code (subroutine) references + and typeglobs. (Still experimental) These features are not found in + Perl's other serialization modules. + + YAML is extensible. + The YAML language has been designed to be flexible enough to solve + it's own problems. The markup itself has 3 basic construct which + resemble Perl's hash, array and scalar. By default, these map to + their Perl equivalents. But each YAML node also supports a tagging + mechanism (type system) which can cause that node to be interpreted + in a completely different manner. That's how YAML can support object + serialization and oddball structures like Perl's typeglob. + +YAML IMPLEMENTATIONS IN PERL + This module, YAML.pm, is really just the interface module for YAML + modules written in Perl. The basic interface for YAML consists of two + functions: "Dump" and "Load". The real work is done by the modules + YAML::Dumper and YAML::Loader. + + Different YAML module distributions can be created by subclassing + YAML.pm and YAML::Loader and YAML::Dumper. For example, YAML-Simple + consists of YAML::Simple YAML::Dumper::Simple and YAML::Loader::Simple. + + Why would there be more than one implementation of YAML? Well, despite + YAML's offering of being a simple data format, YAML is actually very + deep and complex. Implementing the entirety of the YAML specification is + a daunting task. + + For this reason I am currently working on 3 different YAML + implementations. + + YAML + The main YAML distribution will keeping evolving to support the + entire YAML specification in pure Perl. This may not be the fastest + or most stable module though. Currently, YAML.pm has lots of known + bugs. It is mostly a great tool for dumping Perl data structures to + a readable form. + + YAML::Lite + The point of YAML::Lite is to strip YAML down to the 90% that people + use most and offer that in a small, fast, stable, pure Perl form. + YAML::Lite will simply die when it is asked to do something it + can't. + + YAML::Syck + "libsyck" is the C based YAML processing library used by the Ruby + programming language (and also Python, PHP and Pugs). YAML::Syck is + the Perl binding to "libsyck". It should be very fast, but may have + problems of its own. It will also require C compilation. + + NOTE: Audrey Tang has actually completed this module and it works + great and is 10 times faster than YAML.pm. + + In the future, there will likely be even more YAML modules. Remember, + people other than Ingy are allowed to write YAML modules! + +FUNCTIONAL USAGE + YAML is completely OO under the hood. Still it exports a few useful top + level functions so that it is dead simple to use. These functions just + do the OO stuff for you. If you want direct access to the OO API see the + documentation for YAML::Dumper and YAML::Loader. + + Exported Functions + The following functions are exported by YAML.pm by default. The reason + they are exported is so that YAML works much like Data::Dumper. If you + don't want functions to be imported, just use YAML with an empty import + list: + + use YAML (); + + 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. + + Load(string-containing-a-YAML-stream) + Turn YAML into Perl data. This is the opposite of Dump. Just like + Storable's thaw() function or the eval() function in relation to + Data::Dumper. It parses a string containing a valid YAML stream into + a list of Perl data structures. + + Exportable Functions + These functions are not exported by default but you can request them in + an import list like this: + + use YAML qw'freeze thaw Bless'; + + freeze() and thaw() + Aliases to Dump() and Load() for Storable fans. This will also allow + YAML.pm to be plugged directly into modules like POE.pm, that use + the freeze/thaw API for internal serialization. + + DumpFile(filepath, list) + Writes the YAML stream to a file instead of just returning a string. + + LoadFile(filepath) + Reads the YAML stream from a file instead of a string. + + Bless(perl-node, [yaml-node | class-name]) + Associate a normal Perl node, with a yaml node. A yaml node is an + object tied to the YAML::Node class. The second argument is either a + yaml node that you've already created or a class (package) name that + supports a yaml_dump() function. A yaml_dump() function should take + a perl node and return a yaml node. If no second argument is + provided, Bless will create a yaml node. This node is not returned, + but can be retrieved with the Blessed() function. + + Here's an example of how to use Bless. Say you have a hash + containing three keys, but you only want to dump two of them. + Furthermore the keys must be dumped in a certain order. Here's how + you do that: + + use YAML qw(Dump Bless); + $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; + print Dump $hash; + Bless($hash)->keys(['banana', 'apple']); + print Dump $hash; + + produces: + + --- + apple: good + banana: bad + cauliflower: ugly + --- + banana: bad + apple: good + + Bless returns the tied part of a yaml-node, so that you can call the + YAML::Node methods. This is the same thing that YAML::Node::ynode() + returns. So another way to do the above example is: + + use YAML qw(Dump Bless); + use YAML::Node; + $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; + print Dump $hash; + Bless($hash); + $ynode = ynode(Blessed($hash)); + $ynode->keys(['banana', 'apple']); + print Dump $hash; + + Note that Blessing a Perl data structure does not change it anyway. + The extra information is stored separately and looked up by the + Blessed node's memory address. + + Blessed(perl-node) + Returns the yaml node that a particular perl node is associated with + (see above). Returns undef if the node is not (YAML) Blessed. + +GLOBAL OPTIONS + YAML options are set using a group of global variables in the YAML + namespace. This is similar to how Data::Dumper works. + + For example, to change the indentation width, do something like: + + local $YAML::Indent = 3; + + The current options are: + + DumperClass + You can override which module/class YAML uses for Dumping data. + + LoaderClass + You can override which module/class YAML uses for Loading data. + + Indent + This is the number of space characters to use for each indentation + level when doing a Dump(). The default is 2. + + By the way, YAML can use any number of characters for indentation at + any level. So if you are editing YAML by hand feel free to do it + anyway that looks pleasing to you; just be consistent for a given + level. + + SortKeys + Default is 1. (true) + + Tells YAML.pm whether or not to sort hash keys when storing a + document. + + YAML::Node objects can have their own sort order, which is usually + what you want. To override the YAML::Node order and sort the keys + anyway, set SortKeys to 2. + + Stringify + Default is 0. (false) + + Objects with string overloading should honor the overloading and + dump the stringification of themselves, rather than the actual + object's guts. + + UseHeader + Default is 1. (true) + + This tells YAML.pm whether to use a separator string for a Dump + operation. This only applies to the first document in a stream. + Subsequent documents must have a YAML header by definition. + + UseVersion + Default is 0. (false) + + Tells YAML.pm whether to include the YAML version on the + separator/header. + + --- %YAML:1.0 + + AnchorPrefix + Default is ''. + + Anchor names are normally numeric. YAML.pm simply starts with '1' + and increases by one for each new anchor. This option allows you to + specify a string to be prepended to each anchor number. + + UseCode + Setting the UseCode option is a shortcut to set both the DumpCode + and LoadCode options at once. Setting UseCode to '1' tells YAML.pm + to dump Perl code references as Perl (using B::Deparse) and to load + them back into memory using eval(). The reason this has to be an + option is that using eval() to parse untrusted code is, well, + untrustworthy. + + DumpCode + Determines if and how YAML.pm should serialize Perl code references. + By default YAML.pm will dump code references as dummy placeholders + (much like Data::Dumper). If DumpCode is set to '1' or 'deparse', + code references will be dumped as actual Perl code. + + DumpCode can also be set to a subroutine reference so that you can + write your own serializing routine. YAML.pm passes you the code ref. + You pass back the serialization (as a string) and a format + indicator. The format indicator is a simple string like: 'deparse' + or 'bytecode'. + + LoadCode + LoadCode is the opposite of DumpCode. It tells YAML if and how to + deserialize code references. When set to '1' or 'deparse' it will + use "eval()". Since this is potentially risky, only use this option + if you know where your YAML has been. + + LoadCode can also be set to a subroutine reference so that you can + write your own deserializing routine. YAML.pm passes the + serialization (as a string) and a format indicator. You pass back + the code reference. + + UseBlock + YAML.pm uses heuristics to guess which scalar style is best for a + given node. Sometimes you'll want all multiline scalars to use the + 'block' style. If so, set this option to 1. + + NOTE: YAML's block style is akin to Perl's here-document. + + UseFold + If you want to force YAML to use the 'folded' style for all + multiline scalars, then set $UseFold to 1. + + NOTE: YAML's folded style is akin to the way HTML folds text, except + smarter. + + UseAliases + YAML has an alias mechanism such that any given structure in memory + gets serialized once. Any other references to that structure are + serialized only as alias markers. This is how YAML can serialize + duplicate and recursive structures. + + Sometimes, when you KNOW that your data is nonrecursive in nature, + you may want to serialize such that every node is expressed in full. + (ie as a copy of the original). Setting $YAML::UseAliases to 0 will + allow you to do this. This also may result in faster processing + because the lookup overhead is by bypassed. + + THIS OPTION CAN BE DANGEROUS. *If* your data is recursive, this + option *will* cause Dump() to run in an endless loop, chewing up + your computers memory. You have been warned. + + CompressSeries + Default is 1. + + Compresses the formatting of arrays of hashes: + + - + foo: bar + - + bar: foo + + becomes: + + - foo: bar + - bar: foo + + Since this output is usually more desirable, this option is turned + on by default. + +YAML TERMINOLOGY + YAML is a full featured data serialization language, and thus has its + own terminology. + + It is important to remember that although YAML is heavily influenced by + Perl and Python, it is a language in its own right, not merely just a + representation of Perl structures. + + YAML has three constructs that are conspicuously similar to Perl's hash, + array, and scalar. They are called mapping, sequence, and string + respectively. By default, they do what you would expect. But each + instance may have an explicit or implicit tag (type) that makes it + behave differently. In this manner, YAML can be extended to represent + Perl's Glob or Python's tuple, or Ruby's Bigint. + + stream + A YAML stream is the full sequence of unicode characters that a YAML + parser would read or a YAML emitter would write. A stream may + contain one or more YAML documents separated by YAML headers. + + --- + a: mapping + foo: bar + --- + - a + - sequence + + document + A YAML document is an independent data structure representation + within a stream. It is a top level node. Each document in a YAML + stream must begin with a YAML header line. Actually the header is + optional on the first document. + + --- + This: top level mapping + is: + - a + - YAML + - document + + header + A YAML header is a line that begins a YAML document. It consists of + three dashes, possibly followed by more info. Another purpose of the + header line is that it serves as a place to put top level tag and + anchor information. + + --- !recursive-sequence &001 + - * 001 + - * 001 + + node + A YAML node is the representation of a particular data stucture. + Nodes may contain other nodes. (In Perl terms, nodes are like + scalars. Strings, arrayrefs and hashrefs. But this refers to the + serialized format, not the in-memory structure.) + + tag This is similar to a type. It indicates how a particular YAML node + serialization should be transferred into or out of memory. For + instance a Foo::Bar object would use the tag 'perl/Foo::Bar': + + - !perl/Foo::Bar + foo: 42 + bar: stool + + collection + A collection is the generic term for a YAML data grouping. YAML has + two types of collections: mappings and sequences. (Similar to hashes + and arrays) + + mapping + A mapping is a YAML collection defined by unordered key/value pairs + with unique keys. By default YAML mappings are loaded into Perl + hashes. + + a mapping: + foo: bar + two: times two is 4 + + sequence + A sequence is a YAML collection defined by an ordered list of + elements. By default YAML sequences are loaded into Perl arrays. + + a sequence: + - one bourbon + - one scotch + - one beer + + scalar + A scalar is a YAML node that is a single value. By default YAML + scalars are loaded into Perl scalars. + + a scalar key: a scalar value + + YAML has many styles for representing scalars. This is important + because varying data will have varying formatting requirements to + retain the optimum human readability. + + plain scalar + A plain sclar is unquoted. All plain scalars are automatic + candidates for "implicit tagging". This means that their tag may be + determined automatically by examination. The typical uses for this + are plain alpha strings, integers, real numbers, dates, times and + currency. + + - a plain string + - -42 + - 3.1415 + - 12:34 + - 123 this is an error + + single quoted scalar + This is similar to Perl's use of single quotes. It means no escaping + except for single quotes which are escaped by using two adjacent + single quotes. + + - 'When I say ''\n'' I mean "backslash en"' + + double quoted scalar + This is similar to Perl's use of double quotes. Character escaping + can be used. + + - "This scalar\nhas two lines, and a bell -->\a" + + folded scalar + This is a multiline scalar which begins on the next line. It is + indicated by a single right angle bracket. It is unescaped like the + single quoted scalar. Line folding is also performed. + + - > + This is a multiline scalar which begins on + the next line. It is indicated by a single + carat. It is unescaped like the single + quoted scalar. Line folding is also + performed. + + block scalar + This final multiline form is akin to Perl's here-document except + that (as in all YAML data) scope is indicated by indentation. + Therefore, no ending marker is required. The data is verbatim. No + line folding. + + - | + QTY DESC PRICE TOTAL + --- ---- ----- ----- + 1 Foo Fighters $19.95 $19.95 + 2 Bar Belles $29.95 $59.90 + + parser + A YAML processor has four stages: parse, load, dump, emit. + + A parser parses a YAML stream. YAML.pm's Load() function contains a + parser. + + loader + The other half of the Load() function is a loader. This takes the + information from the parser and loads it into a Perl data structure. + + dumper + The Dump() function consists of a dumper and an emitter. The dumper + walks through each Perl data structure and gives info to the + emitter. + + emitter + The emitter takes info from the dumper and turns it into a YAML + stream. + + NOTE: In YAML.pm the parser/loader and the dumper/emitter code are + currently very closely tied together. In the future they may be + broken into separate stages. + + For more information please refer to the immensely helpful YAML + specification available at . + +ysh - The YAML Shell + The YAML distribution ships with a script called 'ysh', the YAML shell. + ysh provides a simple, interactive way to play with YAML. If you type in + Perl code, it displays the result in YAML. If you type in YAML it turns + it into Perl code. + + To run ysh, (assuming you installed it along with YAML.pm) simply type: + + ysh [options] + + Please read the "ysh" documentation for the full details. There are lots + of options. + +BUGS & DEFICIENCIES + If you find a bug in YAML, please try to recreate it in the YAML Shell + with logging turned on ('ysh -L'). When you have successfully reproduced + the bug, please mail the LOG file to the author (ingy@cpan.org). + + WARNING: This is still *ALPHA* code. Well, most of this code has been + around for years... + + BIGGER WARNING: YAML.pm has been slow in the making, but I am committed + to having top notch YAML tools in the Perl world. The YAML team is close + to finalizing the YAML 1.1 spec. This version of YAML.pm is based off of + a very old pre 1.0 spec. In actuality there isn't a ton of difference, + and this YAML.pm is still fairly useful. Things will get much better in + the future. + +RESOURCES + is the mailing + list. This is where the language is discussed and designed. + + is the official YAML website. + + is the YAML 1.0 specification. + + is the official YAML wiki. + +SEE ALSO + See YAML::Syck. Fast! + +AUTHOR + Ingy döt Net + + is resonsible for YAML.pm. + + The YAML serialization language is the result of years of collaboration + between Oren Ben-Kiki, Clark Evans and Ingy döt Net. Several others + have added help along the way. + +COPYRIGHT + Copyright (c) 2005, 2006. Ingy döt Net. All rights reserved. Copyright + (c) 2001, 2002, 2005. 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 + diff --git a/modules/YAML/YAML.pm b/modules/YAML/YAML.pm new file mode 100644 index 000000000..3b6aad55a --- /dev/null +++ b/modules/YAML/YAML.pm @@ -0,0 +1,787 @@ +package YAML; +use strict; use warnings; +use YAML::Base; +use base 'YAML::Base'; +use YAML::Node; # XXX This is a temp fix for Module::Build +use 5.006001; +our $VERSION = '0.62'; +our @EXPORT = qw'Dump Load'; +our @EXPORT_OK = qw'freeze thaw DumpFile LoadFile Bless Blessed'; + +# XXX This VALUE nonsense needs to go. +use constant VALUE => "\x07YAML\x07VALUE\x07"; + +# YAML Object Properties +field dumper_class => 'YAML::Dumper'; +field loader_class => 'YAML::Loader'; +field dumper_object => + -init => '$self->init_action_object("dumper")'; +field loader_object => + -init => '$self->init_action_object("loader")'; + +sub Dump { + my $yaml = YAML->new; + $yaml->dumper_class($YAML::DumperClass) + if $YAML::DumperClass; + return $yaml->dumper_object->dump(@_); +} + +sub Load { + my $yaml = YAML->new; + $yaml->loader_class($YAML::LoaderClass) + if $YAML::LoaderClass; + return $yaml->loader_object->load(@_); +} + +{ + no warnings 'once'; + # freeze/thaw is the API for Storable string serialization. Some + # modules make use of serializing packages on if they use freeze/thaw. + *freeze = \ &Dump; + *thaw = \ &Load; +} + +sub DumpFile { + my $OUT; + my $filename = shift; + if (ref $filename eq 'GLOB') { + $OUT = $filename; + } + else { + my $mode = '>'; + if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) { + ($mode, $filename) = ($1, $2); + } + open $OUT, $mode, $filename + or YAML::Base->die('YAML_DUMP_ERR_FILE_OUTPUT', $filename, $!); + } + local $/ = "\n"; # reset special to "sane" + print $OUT Dump(@_); +} + +sub LoadFile { + my $IN; + my $filename = shift; + if (ref $filename eq 'GLOB') { + $IN = $filename; + } + else { + open $IN, $filename + or YAML::Base->die('YAML_LOAD_ERR_FILE_INPUT', $filename, $!); + } + return Load(do { local $/; <$IN> }); +} + +sub init_action_object { + my $self = shift; + my $object_class = (shift) . '_class'; + my $module_name = $self->$object_class; + eval "require $module_name"; + $self->die("Error in require $module_name - $@") + if $@ and "$@" !~ /Can't locate/; + my $object = $self->$object_class->new; + $object->set_global_options; + return $object; +} + +my $global = {}; +sub Bless { + require YAML::Dumper::Base; + YAML::Dumper::Base::bless($global, @_) +} +sub Blessed { + require YAML::Dumper::Base; + YAML::Dumper::Base::blessed($global, @_) +} +sub global_object { $global } + +1; + +__END__ + +=head1 NAME + +YAML - YAML Ain't Markup Language (tm) + +=head1 SYNOPSIS + + use YAML; + + # Load a YAML stream of 3 YAML documents into Perl data structures. + my ($hashref, $arrayref, $string) = Load(<<'...'); + --- + name: ingy + age: old + weight: heavy + # I should comment that I also like pink, but don't tell anybody. + favorite colors: + - red + - green + - blue + --- + - Clark Evans + - Oren Ben-Kiki + - Ingy döt Net + --- > + You probably think YAML stands for "Yet Another Markup Language". It + ain't! YAML is really a data serialization language. But if you want + to think of it as a markup, that's OK with me. A lot of people try + to use XML as a serialization format. + + "YAML" is catchy and fun to say. Try it. "YAML, YAML, YAML!!!" + ... + + # Dump the Perl data structures back into YAML. + print Dump($string, $arrayref, $hashref); + + # YAML::Dump is used the same way you'd use Data::Dumper::Dumper + use Data::Dumper; + print Dumper($string, $arrayref, $hashref); + +=head1 DESCRIPTION + +The YAML.pm module implements a YAML Loader and Dumper based on the YAML +1.0 specification. L + +YAML is a generic data serialization language that is optimized for +human readability. It can be used to express the data structures of most +modern programming languages. (Including Perl!!!) + +For information on the YAML syntax, please refer to the YAML +specification. + +=head1 WHY YAML IS COOL + +=over 4 + +=item YAML is readable for people. + +It makes clear sense out of complex data structures. You should find +that YAML is an exceptional data dumping tool. Structure is shown +through indentation, YAML supports recursive data, and hash keys are +sorted by default. In addition, YAML supports several styles of scalar +formatting for different types of data. + +=item YAML is editable. + +YAML was designed from the ground up to be an excellent syntax for +configuration files. Almost all programs need configuration files, so +why invent a new syntax for each one? And why subject users to the +complexities of XML or native Perl code? + +=item YAML is multilingual. + +Yes, YAML supports Unicode. But I'm actually referring to programming +languages. YAML was designed to meet the serialization needs of Perl, +Python, Ruby, Tcl, PHP, Javascript and Java. It was also designed to be +interoperable between those languages. That means YAML serializations +produced by Perl can be processed by Python. + +=item YAML is taint safe. + +Using modules like Data::Dumper for serialization is fine as long as you +can be sure that nobody can tamper with your data files or +transmissions. That's because you need to use Perl's C built-in +to deserialize the data. Somebody could add a snippet of Perl to erase +your files. + +YAML's parser does not need to eval anything. + +=item YAML is full featured. + +YAML can accurately serialize all of the common Perl data structures and +deserialize them again without losing data relationships. Although it is +not 100% perfect (no serializer is or can be perfect), it fares as well +as the popular current modules: Data::Dumper, Storable, XML::Dumper and +Data::Denter. + +YAML.pm also has the ability to handle code (subroutine) references and +typeglobs. (Still experimental) These features are not found in Perl's +other serialization modules. + +=item YAML is extensible. + +The YAML language has been designed to be flexible enough to solve it's +own problems. The markup itself has 3 basic construct which resemble +Perl's hash, array and scalar. By default, these map to their Perl +equivalents. But each YAML node also supports a tagging mechanism (type +system) which can cause that node to be interpreted in a completely +different manner. That's how YAML can support object serialization and +oddball structures like Perl's typeglob. + +=back + +=head1 YAML IMPLEMENTATIONS IN PERL + +This module, YAML.pm, is really just the interface module for YAML +modules written in Perl. The basic interface for YAML consists of two +functions: C and C. The real work is done by the modules +YAML::Dumper and YAML::Loader. + +Different YAML module distributions can be created by subclassing +YAML.pm and YAML::Loader and YAML::Dumper. For example, YAML-Simple +consists of YAML::Simple YAML::Dumper::Simple and YAML::Loader::Simple. + +Why would there be more than one implementation of YAML? Well, despite +YAML's offering of being a simple data format, YAML is actually very +deep and complex. Implementing the entirety of the YAML specification is +a daunting task. + +For this reason I am currently working on 3 different YAML implementations. + +=over + +=item YAML + +The main YAML distribution will keeping evolving to support the entire +YAML specification in pure Perl. This may not be the fastest or most +stable module though. Currently, YAML.pm has lots of known bugs. It is +mostly a great tool for dumping Perl data structures to a readable form. + +=item YAML::Lite + +The point of YAML::Lite is to strip YAML down to the 90% that people +use most and offer that in a small, fast, stable, pure Perl form. +YAML::Lite will simply die when it is asked to do something it can't. + +=item YAML::Syck + +C is the C based YAML processing library used by the Ruby +programming language (and also Python, PHP and Pugs). YAML::Syck is the +Perl binding to C. It should be very fast, but may have +problems of its own. It will also require C compilation. + +NOTE: Audrey Tang has actually completed this module and it works great + and is 10 times faster than YAML.pm. + +=back + +In the future, there will likely be even more YAML modules. Remember, +people other than Ingy are allowed to write YAML modules! + +=head1 FUNCTIONAL USAGE + +YAML is completely OO under the hood. Still it exports a few useful top +level functions so that it is dead simple to use. These functions just +do the OO stuff for you. If you want direct access to the OO API see the +documentation for YAML::Dumper and YAML::Loader. + +=head2 Exported Functions + +The following functions are exported by YAML.pm by default. The reason +they are exported is so that YAML works much like Data::Dumper. If you +don't want functions to be imported, just use YAML with an empty +import list: + + use YAML (); + +=over 4 + +=item 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. + +=item Load(string-containing-a-YAML-stream) + +Turn YAML into Perl data. This is the opposite of Dump. Just like +Storable's thaw() function or the eval() function in relation to +Data::Dumper. It parses a string containing a valid YAML stream into a +list of Perl data structures. + +=back + +=head2 Exportable Functions + +These functions are not exported by default but you can request them in +an import list like this: + + use YAML qw'freeze thaw Bless'; + +=over 4 + +=item freeze() and thaw() + +Aliases to Dump() and Load() for Storable fans. This will also allow +YAML.pm to be plugged directly into modules like POE.pm, that use the +freeze/thaw API for internal serialization. + +=item DumpFile(filepath, list) + +Writes the YAML stream to a file instead of just returning a string. + +=item LoadFile(filepath) + +Reads the YAML stream from a file instead of a string. + +=item Bless(perl-node, [yaml-node | class-name]) + +Associate a normal Perl node, with a yaml node. A yaml node is an object +tied to the YAML::Node class. The second argument is either a yaml node +that you've already created or a class (package) name that supports a +yaml_dump() function. A yaml_dump() function should take a perl node and +return a yaml node. If no second argument is provided, Bless will create +a yaml node. This node is not returned, but can be retrieved with the +Blessed() function. + +Here's an example of how to use Bless. Say you have a hash containing +three keys, but you only want to dump two of them. Furthermore the keys +must be dumped in a certain order. Here's how you do that: + + use YAML qw(Dump Bless); + $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; + print Dump $hash; + Bless($hash)->keys(['banana', 'apple']); + print Dump $hash; + +produces: + + --- + apple: good + banana: bad + cauliflower: ugly + --- + banana: bad + apple: good + +Bless returns the tied part of a yaml-node, so that you can call the +YAML::Node methods. This is the same thing that YAML::Node::ynode() +returns. So another way to do the above example is: + + use YAML qw(Dump Bless); + use YAML::Node; + $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; + print Dump $hash; + Bless($hash); + $ynode = ynode(Blessed($hash)); + $ynode->keys(['banana', 'apple']); + print Dump $hash; + +Note that Blessing a Perl data structure does not change it anyway. The +extra information is stored separately and looked up by the Blessed +node's memory address. + +=item Blessed(perl-node) + +Returns the yaml node that a particular perl node is associated with +(see above). Returns undef if the node is not (YAML) Blessed. + +=back + +=head1 GLOBAL OPTIONS + +YAML options are set using a group of global variables in the YAML +namespace. This is similar to how Data::Dumper works. + +For example, to change the indentation width, do something like: + + local $YAML::Indent = 3; + +The current options are: + +=over 4 + +=item DumperClass + +You can override which module/class YAML uses for Dumping data. + +=item LoaderClass + +You can override which module/class YAML uses for Loading data. + +=item Indent + +This is the number of space characters to use for each indentation level +when doing a Dump(). The default is 2. + +By the way, YAML can use any number of characters for indentation at any +level. So if you are editing YAML by hand feel free to do it anyway that +looks pleasing to you; just be consistent for a given level. + +=item SortKeys + +Default is 1. (true) + +Tells YAML.pm whether or not to sort hash keys when storing a document. + +YAML::Node objects can have their own sort order, which is usually what +you want. To override the YAML::Node order and sort the keys anyway, set +SortKeys to 2. + +=item Stringify + +Default is 0. (false) + +Objects with string overloading should honor the overloading and dump the +stringification of themselves, rather than the actual object's guts. + +=item UseHeader + +Default is 1. (true) + +This tells YAML.pm whether to use a separator string for a Dump +operation. This only applies to the first document in a stream. +Subsequent documents must have a YAML header by definition. + +=item UseVersion + +Default is 0. (false) + +Tells YAML.pm whether to include the YAML version on the +separator/header. + + --- %YAML:1.0 + +=item AnchorPrefix + +Default is ''. + +Anchor names are normally numeric. YAML.pm simply starts with '1' and +increases by one for each new anchor. This option allows you to specify a +string to be prepended to each anchor number. + +=item UseCode + +Setting the UseCode option is a shortcut to set both the DumpCode and +LoadCode options at once. Setting UseCode to '1' tells YAML.pm to dump +Perl code references as Perl (using B::Deparse) and to load them back +into memory using eval(). The reason this has to be an option is that +using eval() to parse untrusted code is, well, untrustworthy. + +=item DumpCode + +Determines if and how YAML.pm should serialize Perl code references. By +default YAML.pm will dump code references as dummy placeholders (much +like Data::Dumper). If DumpCode is set to '1' or 'deparse', code +references will be dumped as actual Perl code. + +DumpCode can also be set to a subroutine reference so that you can +write your own serializing routine. YAML.pm passes you the code ref. You +pass back the serialization (as a string) and a format indicator. The +format indicator is a simple string like: 'deparse' or 'bytecode'. + +=item LoadCode + +LoadCode is the opposite of DumpCode. It tells YAML if and how to +deserialize code references. When set to '1' or 'deparse' it will use +C. Since this is potentially risky, only use this option if you +know where your YAML has been. + +LoadCode can also be set to a subroutine reference so that you can write +your own deserializing routine. YAML.pm passes the serialization (as a +string) and a format indicator. You pass back the code reference. + +=item UseBlock + +YAML.pm uses heuristics to guess which scalar style is best for a given +node. Sometimes you'll want all multiline scalars to use the 'block' +style. If so, set this option to 1. + +NOTE: YAML's block style is akin to Perl's here-document. + +=item UseFold + +If you want to force YAML to use the 'folded' style for all multiline +scalars, then set $UseFold to 1. + +NOTE: YAML's folded style is akin to the way HTML folds text, + except smarter. + +=item UseAliases + +YAML has an alias mechanism such that any given structure in memory gets +serialized once. Any other references to that structure are serialized +only as alias markers. This is how YAML can serialize duplicate and +recursive structures. + +Sometimes, when you KNOW that your data is nonrecursive in nature, you +may want to serialize such that every node is expressed in full. (ie as +a copy of the original). Setting $YAML::UseAliases to 0 will allow you +to do this. This also may result in faster processing because the lookup +overhead is by bypassed. + +THIS OPTION CAN BE DANGEROUS. *If* your data is recursive, this option +*will* cause Dump() to run in an endless loop, chewing up your computers +memory. You have been warned. + +=item CompressSeries + +Default is 1. + +Compresses the formatting of arrays of hashes: + + - + foo: bar + - + bar: foo + +becomes: + + - foo: bar + - bar: foo + +Since this output is usually more desirable, this option is turned on by +default. + +=back + +=head1 YAML TERMINOLOGY + +YAML is a full featured data serialization language, and thus has its +own terminology. + +It is important to remember that although YAML is heavily influenced by +Perl and Python, it is a language in its own right, not merely just a +representation of Perl structures. + +YAML has three constructs that are conspicuously similar to Perl's hash, +array, and scalar. They are called mapping, sequence, and string +respectively. By default, they do what you would expect. But each +instance may have an explicit or implicit tag (type) that makes it +behave differently. In this manner, YAML can be extended to represent +Perl's Glob or Python's tuple, or Ruby's Bigint. + +=over 4 + +=item stream + +A YAML stream is the full sequence of unicode characters that a YAML +parser would read or a YAML emitter would write. A stream may contain +one or more YAML documents separated by YAML headers. + + --- + a: mapping + foo: bar + --- + - a + - sequence + +=item document + +A YAML document is an independent data structure representation within a +stream. It is a top level node. Each document in a YAML stream must +begin with a YAML header line. Actually the header is optional on the +first document. + + --- + This: top level mapping + is: + - a + - YAML + - document + +=item header + +A YAML header is a line that begins a YAML document. It consists of +three dashes, possibly followed by more info. Another purpose of the +header line is that it serves as a place to put top level tag and anchor +information. + + --- !recursive-sequence &001 + - * 001 + - * 001 + +=item node + +A YAML node is the representation of a particular data stucture. Nodes +may contain other nodes. (In Perl terms, nodes are like scalars. +Strings, arrayrefs and hashrefs. But this refers to the serialized +format, not the in-memory structure.) + +=item tag + +This is similar to a type. It indicates how a particular YAML node +serialization should be transferred into or out of memory. For instance +a Foo::Bar object would use the tag 'perl/Foo::Bar': + + - !perl/Foo::Bar + foo: 42 + bar: stool + +=item collection + +A collection is the generic term for a YAML data grouping. YAML has two +types of collections: mappings and sequences. (Similar to hashes and arrays) + +=item mapping + +A mapping is a YAML collection defined by unordered key/value pairs with +unique keys. By default YAML mappings are loaded into Perl hashes. + + a mapping: + foo: bar + two: times two is 4 + +=item sequence + +A sequence is a YAML collection defined by an ordered list of elements. By +default YAML sequences are loaded into Perl arrays. + + a sequence: + - one bourbon + - one scotch + - one beer + +=item scalar + +A scalar is a YAML node that is a single value. By default YAML scalars +are loaded into Perl scalars. + + a scalar key: a scalar value + +YAML has many styles for representing scalars. This is important because +varying data will have varying formatting requirements to retain the +optimum human readability. + +=item plain scalar + +A plain sclar is unquoted. All plain scalars are automatic candidates +for "implicit tagging". This means that their tag may be determined +automatically by examination. The typical uses for this are plain alpha +strings, integers, real numbers, dates, times and currency. + + - a plain string + - -42 + - 3.1415 + - 12:34 + - 123 this is an error + +=item single quoted scalar + +This is similar to Perl's use of single quotes. It means no escaping +except for single quotes which are escaped by using two adjacent +single quotes. + + - 'When I say ''\n'' I mean "backslash en"' + +=item double quoted scalar + +This is similar to Perl's use of double quotes. Character escaping can +be used. + + - "This scalar\nhas two lines, and a bell -->\a" + +=item folded scalar + +This is a multiline scalar which begins on the next line. It is +indicated by a single right angle bracket. It is unescaped like the +single quoted scalar. Line folding is also performed. + + - > + This is a multiline scalar which begins on + the next line. It is indicated by a single + carat. It is unescaped like the single + quoted scalar. Line folding is also + performed. + +=item block scalar + +This final multiline form is akin to Perl's here-document except that +(as in all YAML data) scope is indicated by indentation. Therefore, no +ending marker is required. The data is verbatim. No line folding. + + - | + QTY DESC PRICE TOTAL + --- ---- ----- ----- + 1 Foo Fighters $19.95 $19.95 + 2 Bar Belles $29.95 $59.90 + +=item parser + +A YAML processor has four stages: parse, load, dump, emit. + +A parser parses a YAML stream. YAML.pm's Load() function contains a +parser. + +=item loader + +The other half of the Load() function is a loader. This takes the +information from the parser and loads it into a Perl data structure. + +=item dumper + +The Dump() function consists of a dumper and an emitter. The dumper +walks through each Perl data structure and gives info to the emitter. + +=item emitter + +The emitter takes info from the dumper and turns it into a YAML stream. + +NOTE: +In YAML.pm the parser/loader and the dumper/emitter code are currently +very closely tied together. In the future they may be broken into +separate stages. + +=back + +For more information please refer to the immensely helpful YAML +specification available at L. + +=head1 ysh - The YAML Shell + +The YAML distribution ships with a script called 'ysh', the YAML shell. +ysh provides a simple, interactive way to play with YAML. If you type in +Perl code, it displays the result in YAML. If you type in YAML it turns +it into Perl code. + +To run ysh, (assuming you installed it along with YAML.pm) simply type: + + ysh [options] + +Please read the C documentation for the full details. There are +lots of options. + +=head1 BUGS & DEFICIENCIES + +If you find a bug in YAML, please try to recreate it in the YAML Shell +with logging turned on ('ysh -L'). When you have successfully reproduced +the bug, please mail the LOG file to the author (ingy@cpan.org). + +WARNING: This is still *ALPHA* code. Well, most of this code has been +around for years... + +BIGGER WARNING: YAML.pm has been slow in the making, but I am committed +to having top notch YAML tools in the Perl world. The YAML team is close +to finalizing the YAML 1.1 spec. This version of YAML.pm is based off of +a very old pre 1.0 spec. In actuality there isn't a ton of difference, +and this YAML.pm is still fairly useful. Things will get much better in +the future. + +=head1 RESOURCES + +L is the mailing +list. This is where the language is discussed and designed. + +L is the official YAML website. + +L is the YAML 1.0 specification. + +L is the official YAML wiki. + +=head1 SEE ALSO + +See YAML::Syck. Fast! + +=head1 AUTHOR + +Ingy döt Net + +is resonsible for YAML.pm. + +The YAML serialization language is the result of years of collaboration +between Oren Ben-Kiki, Clark Evans and Ingy döt Net. Several others +have added help along the way. + +=head1 COPYRIGHT + +Copyright (c) 2005, 2006. Ingy döt Net. All rights reserved. +Copyright (c) 2001, 2002, 2005. 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 + +=cut diff --git a/modules/YAML/YAML/Base.pm b/modules/YAML/YAML/Base.pm new file mode 100644 index 000000000..f97f28660 --- /dev/null +++ b/modules/YAML/YAML/Base.pm @@ -0,0 +1,200 @@ +package YAML::Base; +use strict; use warnings; +use base '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 + +=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 + +=cut diff --git a/modules/YAML/YAML/Dumper.pm b/modules/YAML/YAML/Dumper.pm new file mode 100644 index 000000000..5521f8c33 --- /dev/null +++ b/modules/YAML/YAML/Dumper.pm @@ -0,0 +1,584 @@ +package YAML::Dumper; +use strict; use warnings; +use YAML::Base; +use base 'YAML::Dumper::Base'; + +use YAML::Node; +use YAML::Types; + +# 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') { + $self->transferred->{$node_id} = + YAML::Type::regexp->yaml_dump($_[0], $class, $self); + 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 and $ref ne 'Regexp') { + (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(\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 + ); + +# 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 + +=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 + +=cut diff --git a/modules/YAML/YAML/Dumper/Base.pm b/modules/YAML/YAML/Dumper/Base.pm new file mode 100644 index 000000000..8e4de0c87 --- /dev/null +++ b/modules/YAML/YAML/Dumper/Base.pm @@ -0,0 +1,137 @@ +package YAML::Dumper::Base; +use strict; use warnings; +use YAML::Base; use base 'YAML::Base'; +use YAML::Node; + +# 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 + +=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 + +=cut diff --git a/modules/YAML/YAML/Error.pm b/modules/YAML/YAML/Error.pm new file mode 100644 index 000000000..23b9c5ca5 --- /dev/null +++ b/modules/YAML/YAML/Error.pm @@ -0,0 +1,220 @@ +package YAML::Error; +use strict; use warnings; +use YAML::Base; use base '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; +use base '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 and a C facility. + +=head1 AUTHOR + +Ingy döt Net + +=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 + +=cut diff --git a/modules/YAML/YAML/Loader.pm b/modules/YAML/YAML/Loader.pm new file mode 100644 index 000000000..969867d90 --- /dev/null +++ b/modules/YAML/YAML/Loader.pm @@ -0,0 +1,766 @@ +package YAML::Loader; +use strict; use warnings; +use YAML::Base; +use base 'YAML::Loader::Base'; +use YAML::Types; + +# 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|scalar)\:(\w(\w|\:\:)*)?$/) { + ($type, $class) = (($1 || ''), ($2 || '')); + if (ref $node) { + return CORE::bless $node, $class; + } + else { + return CORE::bless \$node, $class; + } + } + if ($explicit =~ + /^\!?perl\/(undef|glob|regexp|code|ref)\:(\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 = + ( + z => "\x00", a => "\x07", t => "\x09", + n => "\x0a", v => "\x0b", 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\\fartz]|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 + +=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 + +=cut diff --git a/modules/YAML/YAML/Loader/Base.pm b/modules/YAML/YAML/Loader/Base.pm new file mode 100644 index 000000000..4d5b02dd0 --- /dev/null +++ b/modules/YAML/YAML/Loader/Base.pm @@ -0,0 +1,64 @@ +package YAML::Loader::Base; +use strict; use warnings; +use YAML::Base; use base '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 + +=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 + +=cut diff --git a/modules/YAML/YAML/Marshall.pm b/modules/YAML/YAML/Marshall.pm new file mode 100644 index 000000000..5985ecea8 --- /dev/null +++ b/modules/YAML/YAML/Marshall.pm @@ -0,0 +1,77 @@ +package YAML::Marshall; +use strict; use warnings; +use YAML::Node(); + +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 + +=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 + +=cut diff --git a/modules/YAML/YAML/Node.pm b/modules/YAML/YAML/Node.pm new file mode 100644 index 000000000..69affcf67 --- /dev/null +++ b/modules/YAML/YAML/Node.pm @@ -0,0 +1,296 @@ +package YAML::Node; +use strict; use warnings; +use YAML::Base; use base 'YAML::Base'; +use YAML::Tag; + +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 + +=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 + +=cut diff --git a/modules/YAML/YAML/Tag.pm b/modules/YAML/YAML/Tag.pm new file mode 100644 index 000000000..a6826fd94 --- /dev/null +++ b/modules/YAML/YAML/Tag.pm @@ -0,0 +1,48 @@ +package YAML::Tag; +use strict; use warnings; + +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 + +=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 + +=cut diff --git a/modules/YAML/YAML/Types.pm b/modules/YAML/YAML/Types.pm new file mode 100644 index 000000000..4d737baee --- /dev/null +++ b/modules/YAML/YAML/Types.pm @@ -0,0 +1,262 @@ +package YAML::Types; +use strict; use warnings; +use YAML::Base; use base 'YAML::Base'; +use YAML::Node; + +# 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); + $class ||= ''; + my $tag = "!perl/code:$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 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 { + my $self = shift; + my ($node, $class, $dumper) = @_; + my ($regexp, $modifiers); + if ("$node" =~ /^\(\?(\w*)(?:\-\w+)?\:(.*)\)$/) { + $regexp = $2; + $modifiers = $1 || ''; + } + else { + $dumper->die('YAML_DUMP_ERR_BAD_REGEXP', $node); + } + my $tag = '!perl/regexp:'; + $tag .= $class if $class; + my $ynode = YAML::Node->new({}, $tag); + $ynode->{REGEXP} = $regexp; + $ynode->{MODIFIERS} = $modifiers if $modifiers; + return $ynode; +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + my ($regexp, $modifiers); + if (defined $node->{REGEXP}) { + $regexp = $node->{REGEXP}; + delete $node->{REGEXP}; + } + else { + $loader->warn('YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP'); + return undef; + } + if (defined $node->{MODIFIERS}) { + $modifiers = $node->{MODIFIERS}; + delete $node->{MODIFIERS}; + } + else { + $modifiers = ''; + } + for my $elem (sort keys %$node) { + $loader->warn('YAML_LOAD_WARN_BAD_REGEXP_ELEM', $elem); + } + my $qr = $regexp; + $qr = "(?$modifiers:$qr)"; + return qr{$qr}; +} + +1; + +__END__ + +=head1 NAME + +YAML::Transfer - 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 + +=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 + +=cut diff --git a/scripts/dbupgrade2_tool.pl b/scripts/dbupgrade2_tool.pl index 0e1194dc8..8a90c7eb4 100755 --- a/scripts/dbupgrade2_tool.pl +++ b/scripts/dbupgrade2_tool.pl @@ -6,7 +6,8 @@ BEGIN { exit(1); } - push(@INC, "modules"); + unshift @INC, "modules/YAML"; # Use our own version of YAML. + push @INC, "modules"; # Only use our own versions of modules if there's no system version. } use English '-no_match_vars'; diff --git a/scripts/installation_check.pl b/scripts/installation_check.pl index bddb2d92a..2022c1665 100755 --- a/scripts/installation_check.pl +++ b/scripts/installation_check.pl @@ -1,7 +1,8 @@ #!/usr/bin/perl -w BEGIN { - push(@INC, "modules"); + unshift @INC, "modules/YAML"; # Use our own version of YAML. + push @INC, "modules"; # Only use our own versions of modules if there's no system version. } use SL::InstallationCheck; diff --git a/scripts/spawn_oo.pl b/scripts/spawn_oo.pl index 9e2f80739..b192a9318 100755 --- a/scripts/spawn_oo.pl +++ b/scripts/spawn_oo.pl @@ -1,7 +1,8 @@ #!/usr/bin/perl BEGIN { - push(@INC, "modules"); + unshift @INC, "modules/YAML"; # Use our own version of YAML. + push @INC, "modules"; # Only use our own versions of modules if there's no system version. } use DBI;