use SL::Locale::String ();
use Scalar::Util qw(weaken);
-use YAML;
use SL::DBUtils;
+use SL::YAML;
sub new {
my ($class, %params) = @_;
my ($self) = @_;
no warnings 'once';
local $YAML::Stringify = 1;
- return YAML::Dump($self->get);
+ return SL::YAML::Dump($self->get);
}
sub _fetch {
sub _parse {
my ($self) = @_;
- $self->{value} = YAML::Load($self->{value}) unless $self->{parsed};
+ $self->{value} = SL::YAML::Load($self->{value}) unless $self->{parsed};
$self->{parsed} = 1;
return $self;
my %params = ( simple => 1 );
eval {
- my $data = YAML::Load($value);
+ my $data = SL::YAML::Load($value);
if (ref $data eq 'HASH') {
map { $params{$_} = $data->{$_} } keys %{ $data };
use parent qw(SL::BackgroundJob::Base);
-use YAML ();
use SL::JSON;
+use SL::YAML;
use SL::DB::CsvImportProfile;
sub create_job {
type => 'once',
active => 1,
package_name => $package,
- data => YAML::Dump(\%data),
+ data => SL::YAML::Dump(\%data),
);
return $job;
my ($self) = @_;
if (!$self->{profile}) {
- my $data = YAML::Load($self->{db_obj}->data);
+ my $data = SL::YAML::Load($self->{db_obj}->data);
$self->{profile} = SL::DB::Manager::CsvImportProfile->find_by(id => $data->{profile_id});
}
use SL::Request;
use SL::DB::Draft;
use SL::DBUtils qw(selectall_hashref_query);
-use YAML;
+use SL::YAML;
use List::Util qw(max);
use Rose::Object::MakeMethods::Generic (
module => $self->module,
submodule => $self->submodule,
description => $description,
- form => YAML::Dump($form),
+ form => SL::YAML::Dump($form),
employee_id => SL::DB::Manager::Employee->current->id,
);
require $allowed_modules{ $self->draft->module };
}
my $params = delete $::form->{form};
- my $new_form = YAML::Load($self->draft->form);
+ my $new_form = SL::YAML::Load($self->draft->form);
$::form->{$_} = $new_form->{$_} for keys %$new_form;
$::form->{"draft_$_"} = $self->draft->$_ for qw(id description);
use SL::Webdav;
use SL::File;
use SL::Util qw(trim);
+use SL::YAML;
use SL::DB::Order;
use SL::DB::Default;
use SL::DB::Unit;
email_body => $::form->{email_body},
};
- my $periodic_invoices_config = YAML::Dump($config);
+ my $periodic_invoices_config = SL::YAML::Dump($config);
my $status = $self->get_periodic_invoices_status($config);
$order->assign_attributes(%{$::form->{order}});
- if (my $periodic_invoices_config_attrs = $form_periodic_invoices_config ? YAML::Load($form_periodic_invoices_config) : undef) {
+ if (my $periodic_invoices_config_attrs = $form_periodic_invoices_config ? SL::YAML::Load($form_periodic_invoices_config) : undef) {
my $periodic_invoices_config = $order->periodic_invoices_config || $order->periodic_invoices_config(SL::DB::PeriodicInvoicesConfig->new);
$periodic_invoices_config->assign_attributes(%$periodic_invoices_config_attrs);
}
my ($yaml_config) = @_;
return if !$yaml_config;
- my $attr = YAML::Load($yaml_config);
+ my $attr = SL::YAML::Load($yaml_config);
return if 'HASH' ne ref $attr;
return SL::DB::PeriodicInvoicesConfig->new(%$attr);
}
use SL::DB::Manager::BackgroundJob;
use SL::System::Process;
+use SL::YAML;
__PACKAGE__->meta->initialize;
sub data_as_hash {
my $self = shift;
- $self->data(YAML::Dump($_[0])) if @_;
+ $self->data(SL::YAML::Dump($_[0])) if @_;
return {} if !$self->data;
return $self->data if ref($self->{data}) eq 'HASH';
- return YAML::Load($self->{data}) if !ref($self->{data});
+ return SL::YAML::Load($self->{data}) if !ref($self->{data});
return {};
}
sub set_data {
my ($self, %data) = @_;
- $self->data(YAML::Dump({
+ $self->data(SL::YAML::Dump({
%{ $self->data_as_hash },
%data,
}));
use Carp;
use List::Util qw(max);
use Text::ParseWords;
-use YAML;
use SL::AM;
use SL::Common;
use SL::TransNumber;
use SL::DB;
use SL::Util qw(trim);
+use SL::YAML;
use strict;
conv_i($sinfo->{bin_id}));
$h_item_stock_id->finish();
# write back the id to the form (important if only transfer was clicked (id fk for invoice)
- $form->{"stock_${in_out}_$i"} = YAML::Dump($stock_info);
+ $form->{"stock_${in_out}_$i"} = SL::YAML::Dump($stock_info);
}
@values = ($form->{"delivery_order_items_id_$i"}, $sinfo->{qty}, $sinfo->{unit}, conv_i($sinfo->{warehouse_id}),
conv_i($sinfo->{bin_id}), $sinfo->{chargenumber}, conv_date($sinfo->{bestbefore}),
push @{ $requests }, $ref;
}
- $doi->{"stock_${in_out}"} = YAML::Dump($requests);
+ $doi->{"stock_${in_out}"} = SL::YAML::Dump($requests);
}
$sth->finish();
my $unpacked;
- eval { $unpacked = $params{packed} ? YAML::Load($params{packed}) : []; };
+ eval { $unpacked = $params{packed} ? SL::YAML::Load($params{packed}) : []; };
$unpacked = [] if (!$unpacked || ('ARRAY' ne ref $unpacked));
use Data::Dumper;
use List::MoreUtils qw(all any uniq);
-use YAML;
use SL::CVar;
use SL::DBUtils;
# Net::SMTP is core since 5.7.3
{ name => "Net::SMTP::SSL", url => "http://search.cpan.org/~cwest/", debian => 'libnet-smtp-ssl-perl' },
{ name => "Net::SSLGlue", url => "http://search.cpan.org/~sullr/", debian => 'libnet-sslglue-perl' },
+ { name => "YAML::XS", url => "https://metacpan.org/pod/distribution/YAML-LibYAML/lib/YAML/LibYAML.pod", debian => 'libyaml-libyaml-perl' },
);
@developer_modules = (
use POSIX qw(strftime getpid);
use Scalar::Util qw(blessed refaddr weaken);
use Time::HiRes qw(gettimeofday tv_interval);
-use YAML;
use SL::Request ();
+use SL::YAML;
use strict;
use utf8;
sub dump_yaml {
my ($self, $level, $name, $variable) = @_;
- $self->message($level, "dumping ${name}:\n" . YAML::Dump($variable));
+ $self->message($level, "dumping ${name}:\n" . SL::YAML::Dump($variable));
}
sub dump_sql_result {
return;
}
- my @texts = map { ref $_ ? YAML::Dump($_) : $_ } ($item1, $item2);
+ my @texts = map { ref $_ ? SL::YAML::Dump($_) : $_ } ($item1, $item2);
$self->message($level, Text::Diff::diff(\$texts[0], \$texts[1], \%params));
}
use strict;
use SL::Auth;
-use YAML ();
use File::Spec;
use SL::MoreCommon qw(uri_encode);
-
-our $yaml_xs;
-BEGIN {
- $yaml_xs = eval { require YAML::XS };
-}
+use SL::YAML;
our %menu_cache;
for my $file (@files) {
my $data;
eval {
- if ($yaml_xs) {
- $data = YAML::XS::LoadFile(File::Spec->catfile($path, $file));
- } else {
- $data = YAML::LoadFile(File::Spec->catfile($path, $file));
- }
+ $data = SL::YAML::LoadFile(File::Spec->catfile($path, $file));
1;
} or do {
die "Error while parsing $file: $@";
use Encode ();
use List::MoreUtils qw(zip);
-use YAML;
+use SL::YAML;
use strict;
delete $main::form->{$key};
}
- my $old_form = YAML::Dump($main::form);
+ my $old_form = SL::YAML::Dump($main::form);
$old_form =~ s|!|!:|g;
$old_form =~ s|\n|!n|g;
$old_form =~ s|\r|!r|g;
$old_form =~ s|!n|\n|g;
$old_form =~ s|![!:]|!|g;
- my $new_form = YAML::Load($old_form);
+ my $new_form = SL::YAML::Load($old_form);
map { $form->{$_} = $new_form->{$_} if (!$keep_vars_map{$_}) } keys %{ $new_form };
$main::lxdebug->leave_sub();
package OE;
use List::Util qw(max first);
-use YAML;
use SL::AM;
use SL::Common;
use SL::TransNumber;
use SL::Util qw(trim);
use SL::DB;
+use SL::YAML;
use Text::ParseWords;
use strict;
return if !$params{oe_id};
- my $config = $params{config_yaml} ? YAML::Load($params{config_yaml}) : undef;
+ my $config = $params{config_yaml} ? SL::YAML::Load($params{config_yaml}) : undef;
return if 'HASH' ne ref $config;
my $obj = SL::DB::Manager::PeriodicInvoicesConfig->find_by(oe_id => $params{oe_id})
if ($config_obj) {
my $config = { map { $_ => $config_obj->$_ } qw(active terminated periodicity order_value_periodicity start_date_as_date end_date_as_date first_billing_date_as_date extend_automatically_by ar_chart_id
print printer_id copies direct_debit send_email email_recipient_contact_id email_recipient_address email_sender email_subject email_body) };
- $form->{periodic_invoices_config} = YAML::Dump($config);
+ $form->{periodic_invoices_config} = SL::YAML::Dump($config);
}
}
}
--- /dev/null
+package SL::YAML;
+
+use strict;
+use warnings;
+
+sub _choose_yaml_module {
+ return 'YAML::XS' if $INC{'YAML/XS.pm'};
+ return 'YAML' if $INC{'YAML.pm'};
+
+ my @err;
+
+ return 'YAML::XS' if eval { require YAML::XS; 1; };
+ push @err, "Error loading YAML::XS: $@";
+
+ return 'YAML' if eval { require YAML; 1; };
+ push @err, "Error loading YAML: $@";
+
+ die join("\n", "Couldn't load a YAML module:", @err);
+}
+
+BEGIN {
+ our $YAML_Class = _choose_yaml_module();
+ $YAML_Class->import(qw(Dump Load DumpFile LoadFile));
+}
+
+sub YAML { our $YAML_Class }
+
+1;
+
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::YAML - A thin wrapper around YAML::XS and YAML
+
+=head1 SYNOPSIS
+
+ use SL::YAML;
+
+ my $menu_data = SL::YAML::LoadFile("menus/user/00-erp.yml");
+
+=head1 OVERVIEW
+
+This is a thin wrapper around the YAML::XS and YAML modules. It'll
+prefer loading YAML::XS if that's found and will fallback to YAML
+otherwise. It only provides the four functions C<Dump>, C<Load>,
+C<DumpFile> and C<LoadFile> — just enough to get by for kivitendo.
+
+The functions are direct imports from the imported module. Please see
+the documentation for YAML::XS or YAML for details.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
use SL::Locale::String qw(t8);
use SL::User;
use Data::Dumper;
-use YAML;
require "bin/mozilla/common.pl";
use List::MoreUtils qw(uniq);
use List::Util qw(max sum);
use POSIX qw(strftime);
-use YAML;
use SL::DB::DeliveryOrder;
use SL::DO;
use SL::MoreCommon qw(ary_diff restore_form save_form);
use SL::ReportGenerator;
use SL::WH;
+use SL::YAML;
use Sort::Naturally ();
require "bin/mozilla/common.pl";
require "bin/mozilla/io.pl";
push @{ $stock_info }, { map { $_ => $form->{"${_}_${i}"} } qw(delivery_order_items_stock_id warehouse_id bin_id chargenumber bestbefore qty unit) };
}
- $form->{stock} = YAML::Dump($stock_info);
+ $form->{stock} = SL::YAML::Dump($stock_info);
_stock_in_out_set_qty_display($stock_info);
my @errors = DO->check_stock_availability('requests' => $stock_info,
'parts_id' => $form->{parts_id});
- $form->{stock} = YAML::Dump($stock_info);
+ $form->{stock} = SL::YAML::Dump($stock_info);
if (@errors) {
$form->{ERRORS} = [];
foreach (@all_requests){
$i++;
next unless scalar(%{ $_ });
- $form->{"stock_${prefix}_$i"} = YAML::Dump([$_]);
+ $form->{"stock_${prefix}_$i"} = SL::YAML::Dump([$_]);
}
save(no_redirect => 1); # Wir können auslagern, deshalb beleg speichern
use SL::IS;
use SL::MoreCommon qw(ary_diff restore_form save_form);
use SL::ReportGenerator;
+use SL::YAML;
use List::MoreUtils qw(uniq any none);
use List::Util qw(min max reduce sum);
use Data::Dumper;
$form->{periodic_invoices_status} = $locale->text('not configured');
} else {
- my $config = YAML::Load($form->{periodic_invoices_config});
+ my $config = SL::YAML::Load($form->{periodic_invoices_config});
$form->{periodic_invoices_status} = $config->{active} ? $locale->text('active') : $locale->text('inactive');
}
}
check_oe_access();
my $config;
- $config = YAML::Load($::form->{periodic_invoices_config}) if $::form->{periodic_invoices_config};
+ $config = SL::YAML::Load($::form->{periodic_invoices_config}) if $::form->{periodic_invoices_config};
if ('HASH' ne ref $config) {
my $lang_id = $::form->{language_id};
email_body => $::form->{email_body},
};
- $::form->{periodic_invoices_config} = YAML::Dump($config);
+ $::form->{periodic_invoices_config} = SL::YAML::Dump($config);
$::form->{title} = $::locale->text('Edit the configuration for periodic invoices');
$::form->header;
+++ /dev/null
-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. <http://www.yaml.org/spec/>
-
- 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 <http://www.yaml.org/spec/>.
-
-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
- <http://lists.sourceforge.net/lists/listinfo/yaml-core> is the mailing
- list. This is where the language is discussed and designed.
-
- <http://www.yaml.org> is the official YAML website.
-
- <http://www.yaml.org/spec/> is the YAML 1.0 specification.
-
- <http://yaml.kwiki.org> is the official YAML wiki.
-
-SEE ALSO
- See YAML::Syck. Fast!
-
-AUTHOR
- Ingy döt Net <ingy@cpan.org>
-
- 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 <http://www.perl.com/perl/misc/Artistic.html>
-
+++ /dev/null
-package YAML;
-our $VERSION = '1.14';
-
-use YAML::Mo;
-
-use Exporter;
-push @YAML::ISA, 'Exporter';
-our @EXPORT = qw{ Dump Load };
-our @EXPORT_OK = qw{ freeze thaw DumpFile LoadFile Bless Blessed };
-
-use YAML::Node; # XXX This is a temp fix for Module::Build
-
-# XXX This VALUE nonsense needs to go.
-use constant VALUE => "\x07YAML\x07VALUE\x07";
-
-# YAML Object Properties
-has dumper_class => default => sub {'YAML::Dumper'};
-has loader_class => default => sub {'YAML::Loader'};
-has dumper_object => default => sub {$_[0]->init_action_object("dumper")};
-has loader_object => default => sub {$_[0]->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::Mo::Object->die('YAML_DUMP_ERR_FILE_OUTPUT', $filename, $!);
- }
- binmode $OUT, ':utf8'; # if $Config{useperlio} eq 'define';
- 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::Mo::Object->die('YAML_LOAD_ERR_FILE_INPUT', $filename, $!);
- }
- binmode $IN, ':utf8'; # if $Config{useperlio} eq 'define';
- 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;
+++ /dev/null
-use strict; use warnings;
-package YAML::Any;
-our $VERSION = '1.14';
-
-use Exporter ();
-
-@YAML::Any::ISA = 'Exporter';
-@YAML::Any::EXPORT = qw(Dump Load);
-@YAML::Any::EXPORT_OK = qw(DumpFile LoadFile);
-
-my @dump_options = qw(
- UseCode
- DumpCode
- SpecVersion
- Indent
- UseHeader
- UseVersion
- SortKeys
- AnchorPrefix
- UseBlock
- UseFold
- CompressSeries
- InlineSeries
- UseAliases
- Purity
- Stringify
-);
-
-my @load_options = qw(
- UseCode
- LoadCode
-);
-
-my @implementations = qw(
- YAML::XS
- YAML::Syck
- YAML::Old
- YAML
- YAML::Tiny
-);
-
-sub import {
- __PACKAGE__->implementation;
- goto &Exporter::import;
-}
-
-sub Dump {
- no strict 'refs';
- no warnings 'once';
- my $implementation = __PACKAGE__->implementation;
- for my $option (@dump_options) {
- my $var = "$implementation\::$option";
- my $value = $$var;
- local $$var;
- $$var = defined $value ? $value : ${"YAML::$option"};
- }
- return &{"$implementation\::Dump"}(@_);
-}
-
-sub DumpFile {
- no strict 'refs';
- no warnings 'once';
- my $implementation = __PACKAGE__->implementation;
- for my $option (@dump_options) {
- my $var = "$implementation\::$option";
- my $value = $$var;
- local $$var;
- $$var = defined $value ? $value : ${"YAML::$option"};
- }
- return &{"$implementation\::DumpFile"}(@_);
-}
-
-sub Load {
- no strict 'refs';
- no warnings 'once';
- my $implementation = __PACKAGE__->implementation;
- for my $option (@load_options) {
- my $var = "$implementation\::$option";
- my $value = $$var;
- local $$var;
- $$var = defined $value ? $value : ${"YAML::$option"};
- }
- return &{"$implementation\::Load"}(@_);
-}
-
-sub LoadFile {
- no strict 'refs';
- no warnings 'once';
- my $implementation = __PACKAGE__->implementation;
- for my $option (@load_options) {
- my $var = "$implementation\::$option";
- my $value = $$var;
- local $$var;
- $$var = defined $value ? $value : ${"YAML::$option"};
- }
- return &{"$implementation\::LoadFile"}(@_);
-}
-
-sub order {
- return @YAML::Any::_TEST_ORDER
- if @YAML::Any::_TEST_ORDER;
- return @implementations;
-}
-
-sub implementation {
- my @order = __PACKAGE__->order;
- for my $module (@order) {
- my $path = $module;
- $path =~ s/::/\//g;
- $path .= '.pm';
- return $module if exists $INC{$path};
- eval "require $module; 1" and return $module;
- }
- croak("YAML::Any couldn't find any of these YAML implementations: @order");
-}
-
-sub croak {
- require Carp;
- Carp::croak(@_);
-}
-
-1;
+++ /dev/null
-package YAML::Dumper;
-
-use YAML::Mo;
-extends 'YAML::Dumper::Base';
-
-use YAML::Dumper::Base;
-use YAML::Node;
-use YAML::Types;
-use Scalar::Util qw();
-
-# Context constants
-use constant KEY => 3;
-use constant BLESSED => 4;
-use constant FROMARRAY => 5;
-use constant VALUE => "\x07YAML\x07VALUE\x07";
-
-# Common YAML character sets
-my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
-my $LIT_CHAR = '|';
-
-#==============================================================================
-# OO version of Dump. YAML->new->dump($foo);
-sub dump {
- my $self = shift;
- $self->stream('');
- $self->document(0);
- for my $document (@_) {
- $self->{document}++;
- $self->transferred({});
- $self->id_refcnt({});
- $self->id_anchor({});
- $self->anchor(1);
- $self->level(0);
- $self->offset->[0] = 0 - $self->indent_width;
- $self->_prewalk($document);
- $self->_emit_header($document);
- $self->_emit_node($document);
- }
- return $self->stream;
-}
-
-# Every YAML document in the stream must begin with a YAML header, unless
-# there is only a single document and the user requests "no header".
-sub _emit_header {
- my $self = shift;
- my ($node) = @_;
- if (not $self->use_header and
- $self->document == 1
- ) {
- $self->die('YAML_DUMP_ERR_NO_HEADER')
- unless ref($node) =~ /^(HASH|ARRAY)$/;
- $self->die('YAML_DUMP_ERR_NO_HEADER')
- if ref($node) eq 'HASH' and keys(%$node) == 0;
- $self->die('YAML_DUMP_ERR_NO_HEADER')
- if ref($node) eq 'ARRAY' and @$node == 0;
- # XXX Also croak if aliased, blessed, or ynode
- $self->headless(1);
- return;
- }
- $self->{stream} .= '---';
-# XXX Consider switching to 1.1 style
- if ($self->use_version) {
-# $self->{stream} .= " #YAML:1.0";
- }
-}
-
-# Walk the tree to be dumped and keep track of its reference counts.
-# This function is where the Dumper does all its work. All type
-# transfers happen here.
-sub _prewalk {
- my $self = shift;
- my $stringify = $self->stringify;
- my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify);
-
- # Handle typeglobs
- if ($type eq 'GLOB') {
- $self->transferred->{$node_id} =
- YAML::Type::glob->yaml_dump($_[0]);
- $self->_prewalk($self->transferred->{$node_id});
- return;
- }
-
- # Handle regexps
- if (ref($_[0]) eq 'Regexp') {
- return;
- }
-
- # Handle Purity for scalars.
- # XXX can't find a use case yet. Might be YAGNI.
- if (not ref $_[0]) {
- $self->{id_refcnt}{$node_id}++ if $self->purity;
- return;
- }
-
- # Make a copy of original
- my $value = $_[0];
- ($class, $type, $node_id) = $self->node_info($value, $stringify);
-
- # Must be a stringified object.
- return if (ref($value) and not $type);
-
- # Look for things already transferred.
- if ($self->transferred->{$node_id}) {
- (undef, undef, $node_id) = (ref $self->transferred->{$node_id})
- ? $self->node_info($self->transferred->{$node_id}, $stringify)
- : $self->node_info(\ $self->transferred->{$node_id}, $stringify);
- $self->{id_refcnt}{$node_id}++;
- return;
- }
-
- # Handle code refs
- if ($type eq 'CODE') {
- $self->transferred->{$node_id} = 'placeholder';
- YAML::Type::code->yaml_dump(
- $self->dump_code,
- $_[0],
- $self->transferred->{$node_id}
- );
- ($class, $type, $node_id) =
- $self->node_info(\ $self->transferred->{$node_id}, $stringify);
- $self->{id_refcnt}{$node_id}++;
- return;
- }
-
- # Handle blessed things
- if (defined $class) {
- if ($value->can('yaml_dump')) {
- $value = $value->yaml_dump;
- }
- elsif ($type eq 'SCALAR') {
- $self->transferred->{$node_id} = 'placeholder';
- YAML::Type::blessed->yaml_dump
- ($_[0], $self->transferred->{$node_id});
- ($class, $type, $node_id) =
- $self->node_info(\ $self->transferred->{$node_id}, $stringify);
- $self->{id_refcnt}{$node_id}++;
- return;
- }
- else {
- $value = YAML::Type::blessed->yaml_dump($value);
- }
- $self->transferred->{$node_id} = $value;
- (undef, $type, $node_id) = $self->node_info($value, $stringify);
- }
-
- # Handle YAML Blessed things
- require YAML;
- if (defined YAML->global_object()->{blessed_map}{$node_id}) {
- $value = YAML->global_object()->{blessed_map}{$node_id};
- $self->transferred->{$node_id} = $value;
- ($class, $type, $node_id) = $self->node_info($value, $stringify);
- $self->_prewalk($value);
- return;
- }
-
- # Handle hard refs
- if ($type eq 'REF' or $type eq 'SCALAR') {
- $value = YAML::Type::ref->yaml_dump($value);
- $self->transferred->{$node_id} = $value;
- (undef, $type, $node_id) = $self->node_info($value, $stringify);
- }
-
- # Handle ref-to-glob's
- elsif ($type eq 'GLOB') {
- my $ref_ynode = $self->transferred->{$node_id} =
- YAML::Type::ref->yaml_dump($value);
-
- my $glob_ynode = $ref_ynode->{&VALUE} =
- YAML::Type::glob->yaml_dump($$value);
-
- (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify);
- $self->transferred->{$node_id} = $glob_ynode;
- $self->_prewalk($glob_ynode);
- return;
- }
-
- # Increment ref count for node
- return if ++($self->{id_refcnt}{$node_id}) > 1;
-
- # Keep on walking
- if ($type eq 'HASH') {
- $self->_prewalk($value->{$_})
- for keys %{$value};
- return;
- }
- elsif ($type eq 'ARRAY') {
- $self->_prewalk($_)
- for @{$value};
- return;
- }
-
- # Unknown type. Need to know about it.
- $self->warn(<<"...");
-YAML::Dumper can't handle dumping this type of data.
-Please report this to the author.
-
-id: $node_id
-type: $type
-class: $class
-value: $value
-
-...
-
- return;
-}
-
-# Every data element and sub data element is a node.
-# Everything emitted goes through this function.
-sub _emit_node {
- my $self = shift;
- my ($type, $node_id);
- my $ref = ref($_[0]);
- if ($ref) {
- if ($ref eq 'Regexp') {
- $self->_emit(' !!perl/regexp');
- $self->_emit_str("$_[0]");
- return;
- }
- (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify);
- }
- else {
- $type = $ref || 'SCALAR';
- (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify);
- }
-
- my ($ynode, $tag) = ('') x 2;
- my ($value, $context) = (@_, 0);
-
- if (defined $self->transferred->{$node_id}) {
- $value = $self->transferred->{$node_id};
- $ynode = ynode($value);
- if (ref $value) {
- $tag = defined $ynode ? $ynode->tag->short : '';
- (undef, $type, $node_id) =
- $self->node_info($value, $self->stringify);
- }
- else {
- $ynode = ynode($self->transferred->{$node_id});
- $tag = defined $ynode ? $ynode->tag->short : '';
- $type = 'SCALAR';
- (undef, undef, $node_id) =
- $self->node_info(
- \ $self->transferred->{$node_id},
- $self->stringify
- );
- }
- }
- elsif ($ynode = ynode($value)) {
- $tag = $ynode->tag->short;
- }
-
- if ($self->use_aliases) {
- $self->{id_refcnt}{$node_id} ||= 0;
- if ($self->{id_refcnt}{$node_id} > 1) {
- if (defined $self->{id_anchor}{$node_id}) {
- $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n";
- return;
- }
- my $anchor = $self->anchor_prefix . $self->{anchor}++;
- $self->{stream} .= ' &' . $anchor;
- $self->{id_anchor}{$node_id} = $anchor;
- }
- }
-
- return $self->_emit_str("$value") # Stringified object
- if ref($value) and not $type;
- return $self->_emit_scalar($value, $tag)
- if $type eq 'SCALAR' and $tag;
- return $self->_emit_str($value)
- if $type eq 'SCALAR';
- return $self->_emit_mapping($value, $tag, $node_id, $context)
- if $type eq 'HASH';
- return $self->_emit_sequence($value, $tag)
- if $type eq 'ARRAY';
- $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type);
- return $self->_emit_str("$value");
-}
-
-# A YAML mapping is akin to a Perl hash.
-sub _emit_mapping {
- my $self = shift;
- my ($value, $tag, $node_id, $context) = @_;
- $self->{stream} .= " !$tag" if $tag;
-
- # Sometimes 'keys' fails. Like on a bad tie implementation.
- my $empty_hash = not(eval {keys %$value});
- $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@;
- return ($self->{stream} .= " {}\n") if $empty_hash;
-
- # If CompressSeries is on (default) and legal is this context, then
- # use it and make the indent level be 2 for this node.
- if ($context == FROMARRAY and
- $self->compress_series and
- not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash)
- ) {
- $self->{stream} .= ' ';
- $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2;
- }
- else {
- $context = 0;
- $self->{stream} .= "\n"
- unless $self->headless && not($self->headless(0));
- $self->offset->[$self->level+1] =
- $self->offset->[$self->level] + $self->indent_width;
- }
-
- $self->{level}++;
- my @keys;
- if ($self->sort_keys == 1) {
- if (ynode($value)) {
- @keys = keys %$value;
- }
- else {
- @keys = sort keys %$value;
- }
- }
- elsif ($self->sort_keys == 2) {
- @keys = sort keys %$value;
- }
- # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
- elsif (ref($self->sort_keys) eq 'ARRAY') {
- my $i = 1;
- my %order = map { ($_, $i++) } @{$self->sort_keys};
- @keys = sort {
- (defined $order{$a} and defined $order{$b})
- ? ($order{$a} <=> $order{$b})
- : ($a cmp $b);
- } keys %$value;
- }
- else {
- @keys = keys %$value;
- }
- # Force the YAML::VALUE ('=') key to sort last.
- if (exists $value->{&VALUE}) {
- for (my $i = 0; $i < @keys; $i++) {
- if ($keys[$i] eq &VALUE) {
- splice(@keys, $i, 1);
- push @keys, &VALUE;
- last;
- }
- }
- }
-
- for my $key (@keys) {
- $self->_emit_key($key, $context);
- $context = 0;
- $self->{stream} .= ':';
- $self->_emit_node($value->{$key});
- }
- $self->{level}--;
-}
-
-# A YAML series is akin to a Perl array.
-sub _emit_sequence {
- my $self = shift;
- my ($value, $tag) = @_;
- $self->{stream} .= " !$tag" if $tag;
-
- return ($self->{stream} .= " []\n") if @$value == 0;
-
- $self->{stream} .= "\n"
- unless $self->headless && not($self->headless(0));
-
- # XXX Really crufty feature. Better implemented by ynodes.
- if ($self->inline_series and
- @$value <= $self->inline_series and
- not (scalar grep {ref or /\n/} @$value)
- ) {
- $self->{stream} =~ s/\n\Z/ /;
- $self->{stream} .= '[';
- for (my $i = 0; $i < @$value; $i++) {
- $self->_emit_str($value->[$i], KEY);
- last if $i == $#{$value};
- $self->{stream} .= ', ';
- }
- $self->{stream} .= "]\n";
- return;
- }
-
- $self->offset->[$self->level + 1] =
- $self->offset->[$self->level] + $self->indent_width;
- $self->{level}++;
- for my $val (@$value) {
- $self->{stream} .= ' ' x $self->offset->[$self->level];
- $self->{stream} .= '-';
- $self->_emit_node($val, FROMARRAY);
- }
- $self->{level}--;
-}
-
-# Emit a mapping key
-sub _emit_key {
- my $self = shift;
- my ($value, $context) = @_;
- $self->{stream} .= ' ' x $self->offset->[$self->level]
- unless $context == FROMARRAY;
- $self->_emit_str($value, KEY);
-}
-
-# Emit a blessed SCALAR
-sub _emit_scalar {
- my $self = shift;
- my ($value, $tag) = @_;
- $self->{stream} .= " !$tag";
- $self->_emit_str($value, BLESSED);
-}
-
-sub _emit {
- my $self = shift;
- $self->{stream} .= join '', @_;
-}
-
-# Emit a string value. YAML has many scalar styles. This routine attempts to
-# guess the best style for the text.
-sub _emit_str {
- my $self = shift;
- my $type = $_[1] || 0;
-
- # Use heuristics to find the best scalar emission style.
- $self->offset->[$self->level + 1] =
- $self->offset->[$self->level] + $self->indent_width;
- $self->{level}++;
-
- my $sf = $type == KEY ? '' : ' ';
- my $sb = $type == KEY ? '? ' : ' ';
- my $ef = $type == KEY ? '' : "\n";
- my $eb = "\n";
-
- while (1) {
- $self->_emit($sf),
- $self->_emit_plain($_[0]),
- $self->_emit($ef), last
- if not defined $_[0];
- $self->_emit($sf, '=', $ef), last
- if $_[0] eq VALUE;
- $self->_emit($sf),
- $self->_emit_double($_[0]),
- $self->_emit($ef), last
- if $_[0] =~ /$ESCAPE_CHAR/;
- if ($_[0] =~ /\n/) {
- $self->_emit($sb),
- $self->_emit_block($LIT_CHAR, $_[0]),
- $self->_emit($eb), last
- if $self->use_block;
- Carp::cluck "[YAML] \$UseFold is no longer supported"
- if $self->use_fold;
- $self->_emit($sf),
- $self->_emit_double($_[0]),
- $self->_emit($ef), last
- if length $_[0] <= 30;
- $self->_emit($sf),
- $self->_emit_double($_[0]),
- $self->_emit($ef), last
- if $_[0] !~ /\n\s*\S/;
- $self->_emit($sb),
- $self->_emit_block($LIT_CHAR, $_[0]),
- $self->_emit($eb), last;
- }
- $self->_emit($sf),
- $self->_emit_number($_[0]),
- $self->_emit($ef), last
- if $self->is_literal_number($_[0]);
- $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;
-}
-
-sub is_literal_number {
- my $self = shift;
- # Stolen from JSON::Tiny
- return B::svref_2object(\$_[0])->FLAGS & (B::SVp_IOK | B::SVp_NOK)
- && 0 + $_[0] eq $_[0];
-}
-
-sub _emit_number {
- my $self = shift;
- return $self->_emit_plain($_[0]);
-}
-
-# 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];
- return 0 if $self->quote_numeric_strings and Scalar::Util::looks_like_number($_[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 0 if $_[0] eq '-';
- return 1;
-}
-
-sub _emit_block {
- my $self = shift;
- my ($indicator, $value) = @_;
- $self->{stream} .= $indicator;
- $value =~ /(\n*)\Z/;
- my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-';
- $value = '~' if not defined $value;
- $self->{stream} .= $chomp;
- $self->{stream} .= $self->indent_width if $value =~ /^\s/;
- $self->{stream} .= $self->indent($value);
-}
-
-# Plain means that the scalar is unquoted.
-sub _emit_plain {
- my $self = shift;
- $self->{stream} .= defined $_[0] ? $_[0] : '~';
-}
-
-# Double quoting is for single lined escaped strings.
-sub _emit_double {
- my $self = shift;
- (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g;
- $self->{stream} .= qq{"$escaped"};
-}
-
-# Single quoting is for single lined unescaped strings.
-sub _emit_single {
- my $self = shift;
- my $item = shift;
- $item =~ s{'}{''}g;
- $self->{stream} .= "'$item'";
-}
-
-#==============================================================================
-# Utility subroutines.
-#==============================================================================
-
-# Indent a scalar to the current indentation level.
-sub indent {
- my $self = shift;
- my ($text) = @_;
- return $text unless length $text;
- $text =~ s/\n\Z//;
- my $indent = ' ' x $self->offset->[$self->level];
- $text =~ s/^/$indent/gm;
- $text = "\n$text";
- return $text;
-}
-
-# Escapes for unprintable characters
-my @escapes = qw(\0 \x01 \x02 \x03 \x04 \x05 \x06 \a
- \x08 \t \n \v \f \r \x0e \x0f
- \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
- \x18 \x19 \x1a \e \x1c \x1d \x1e \x1f
- );
-
-# Escape the unprintable characters
-sub escape {
- my $self = shift;
- my ($text) = @_;
- $text =~ s/\\/\\\\/g;
- $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
- return $text;
-}
-
-1;
+++ /dev/null
-package YAML::Dumper::Base;
-
-use YAML::Mo;
-
-use YAML::Node;
-
-# YAML Dumping options
-has spec_version => default => sub {'1.0'};
-has indent_width => default => sub {2};
-has use_header => default => sub {1};
-has use_version => default => sub {0};
-has sort_keys => default => sub {1};
-has anchor_prefix => default => sub {''};
-has dump_code => default => sub {0};
-has use_block => default => sub {0};
-has use_fold => default => sub {0};
-has compress_series => default => sub {1};
-has inline_series => default => sub {0};
-has use_aliases => default => sub {1};
-has purity => default => sub {0};
-has stringify => default => sub {0};
-has quote_numeric_strings => default => sub {0};
-
-# Properties
-has stream => default => sub {''};
-has document => default => sub {0};
-has transferred => default => sub {{}};
-has id_refcnt => default => sub {{}};
-has id_anchor => default => sub {{}};
-has anchor => default => sub {1};
-has level => default => sub {0};
-has offset => default => sub {[]};
-has headless => default => sub {0};
-has blessed_map => default => sub {{}};
-
-# 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;
- $self->quote_numeric_strings($YAML::QuoteNumericStrings)
- if defined $YAML::QuoteNumericStrings;
-}
-
-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::Mo::Object->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::Mo::Object->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;
+++ /dev/null
-package YAML::Error;
-
-use YAML::Mo;
-
-has 'code';
-has 'type' => default => sub {'Error'};
-has 'line';
-has 'document';
-has 'arguments' => default => sub {[]};
-
-my ($error_messages, %line_adjust);
-
-sub format_message {
- my $self = shift;
- my $output = 'YAML ' . $self->type . ': ';
- my $code = $self->code;
- if ($error_messages->{$code}) {
- $code = sprintf($error_messages->{$code}, @{$self->arguments});
- }
- $output .= $code . "\n";
-
- $output .= ' Code: ' . $self->code . "\n"
- if defined $self->code;
- $output .= ' Line: ' . $self->line . "\n"
- if defined $self->line;
- $output .= ' Document: ' . $self->document . "\n"
- if defined $self->document;
- return $output;
-}
-
-sub error_messages {
- $error_messages;
-}
-
-%$error_messages = map {s/^\s+//;$_} split "\n", <<'...';
-YAML_PARSE_ERR_BAD_CHARS
- Invalid characters in stream. This parser only supports printable ASCII
-YAML_PARSE_ERR_NO_FINAL_NEWLINE
- Stream does not end with newline character
-YAML_PARSE_ERR_BAD_MAJOR_VERSION
- Can't parse a %s document with a 1.0 parser
-YAML_PARSE_WARN_BAD_MINOR_VERSION
- Parsing a %s document with a 1.0 parser
-YAML_PARSE_WARN_MULTIPLE_DIRECTIVES
- '%s directive used more than once'
-YAML_PARSE_ERR_TEXT_AFTER_INDICATOR
- No text allowed after indicator
-YAML_PARSE_ERR_NO_ANCHOR
- No anchor for alias '*%s'
-YAML_PARSE_ERR_NO_SEPARATOR
- Expected separator '---'
-YAML_PARSE_ERR_SINGLE_LINE
- Couldn't parse single line value
-YAML_PARSE_ERR_BAD_ANCHOR
- Invalid anchor
-YAML_DUMP_ERR_INVALID_INDENT
- Invalid Indent width specified: '%s'
-YAML_LOAD_USAGE
- usage: YAML::Load($yaml_stream_scalar)
-YAML_PARSE_ERR_BAD_NODE
- Can't parse node
-YAML_PARSE_ERR_BAD_EXPLICIT
- Unsupported explicit transfer: '%s'
-YAML_DUMP_USAGE_DUMPCODE
- Invalid value for DumpCode: '%s'
-YAML_LOAD_ERR_FILE_INPUT
- Couldn't open %s for input:\n%s
-YAML_DUMP_ERR_FILE_CONCATENATE
- Can't concatenate to YAML file %s
-YAML_DUMP_ERR_FILE_OUTPUT
- Couldn't open %s for output:\n%s
-YAML_DUMP_ERR_NO_HEADER
- With UseHeader=0, the node must be a plain hash or array
-YAML_DUMP_WARN_BAD_NODE_TYPE
- Can't perform serialization for node type: '%s'
-YAML_EMIT_WARN_KEYS
- Encountered a problem with 'keys':\n%s
-YAML_DUMP_WARN_DEPARSE_FAILED
- Deparse failed for CODE reference
-YAML_DUMP_WARN_CODE_DUMMY
- Emitting dummy subroutine for CODE reference
-YAML_PARSE_ERR_MANY_EXPLICIT
- More than one explicit transfer
-YAML_PARSE_ERR_MANY_IMPLICIT
- More than one implicit request
-YAML_PARSE_ERR_MANY_ANCHOR
- More than one anchor
-YAML_PARSE_ERR_ANCHOR_ALIAS
- Can't define both an anchor and an alias
-YAML_PARSE_ERR_BAD_ALIAS
- Invalid alias
-YAML_PARSE_ERR_MANY_ALIAS
- More than one alias
-YAML_LOAD_ERR_NO_CONVERT
- Can't convert implicit '%s' node to explicit '%s' node
-YAML_LOAD_ERR_NO_DEFAULT_VALUE
- No default value for '%s' explicit transfer
-YAML_LOAD_ERR_NON_EMPTY_STRING
- Only the empty string can be converted to a '%s'
-YAML_LOAD_ERR_BAD_MAP_TO_SEQ
- Can't transfer map as sequence. Non numeric key '%s' encountered.
-YAML_DUMP_ERR_BAD_GLOB
- '%s' is an invalid value for Perl glob
-YAML_DUMP_ERR_BAD_REGEXP
- '%s' is an invalid value for Perl Regexp
-YAML_LOAD_ERR_BAD_MAP_ELEMENT
- Invalid element in map
-YAML_LOAD_WARN_DUPLICATE_KEY
- Duplicate map key found. Ignoring.
-YAML_LOAD_ERR_BAD_SEQ_ELEMENT
- Invalid element in sequence
-YAML_PARSE_ERR_INLINE_MAP
- Can't parse inline map
-YAML_PARSE_ERR_INLINE_SEQUENCE
- Can't parse inline sequence
-YAML_PARSE_ERR_BAD_DOUBLE
- Can't parse double quoted string
-YAML_PARSE_ERR_BAD_SINGLE
- Can't parse single quoted string
-YAML_PARSE_ERR_BAD_INLINE_IMPLICIT
- Can't parse inline implicit value '%s'
-YAML_PARSE_ERR_BAD_IMPLICIT
- Unrecognized implicit value '%s'
-YAML_PARSE_ERR_INDENTATION
- Error. Invalid indentation level
-YAML_PARSE_ERR_INCONSISTENT_INDENTATION
- Inconsistent indentation level
-YAML_LOAD_WARN_UNRESOLVED_ALIAS
- Can't resolve alias *%s
-YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP
- No 'REGEXP' element for Perl regexp
-YAML_LOAD_WARN_BAD_REGEXP_ELEM
- Unknown element '%s' in Perl regexp
-YAML_LOAD_WARN_GLOB_NAME
- No 'NAME' element for Perl glob
-YAML_LOAD_WARN_PARSE_CODE
- Couldn't parse Perl code scalar: %s
-YAML_LOAD_WARN_CODE_DEPARSE
- Won't parse Perl code unless $YAML::LoadCode is set
-YAML_EMIT_ERR_BAD_LEVEL
- Internal Error: Bad level detected
-YAML_PARSE_WARN_AMBIGUOUS_TAB
- Amibiguous tab converted to spaces
-YAML_LOAD_WARN_BAD_GLOB_ELEM
- Unknown element '%s' in Perl glob
-YAML_PARSE_ERR_ZERO_INDENT
- Can't use zero as an indentation width
-YAML_LOAD_WARN_GLOB_IO
- Can't load an IO filehandle. Yet!!!
-...
-
-%line_adjust = map {($_, 1)}
- qw(YAML_PARSE_ERR_BAD_MAJOR_VERSION
- YAML_PARSE_WARN_BAD_MINOR_VERSION
- YAML_PARSE_ERR_TEXT_AFTER_INDICATOR
- YAML_PARSE_ERR_NO_ANCHOR
- YAML_PARSE_ERR_MANY_EXPLICIT
- YAML_PARSE_ERR_MANY_IMPLICIT
- YAML_PARSE_ERR_MANY_ANCHOR
- YAML_PARSE_ERR_ANCHOR_ALIAS
- YAML_PARSE_ERR_BAD_ALIAS
- YAML_PARSE_ERR_MANY_ALIAS
- YAML_LOAD_ERR_NO_CONVERT
- YAML_LOAD_ERR_NO_DEFAULT_VALUE
- YAML_LOAD_ERR_NON_EMPTY_STRING
- YAML_LOAD_ERR_BAD_MAP_TO_SEQ
- YAML_LOAD_ERR_BAD_STR_TO_INT
- YAML_LOAD_ERR_BAD_STR_TO_DATE
- YAML_LOAD_ERR_BAD_STR_TO_TIME
- YAML_LOAD_WARN_DUPLICATE_KEY
- YAML_PARSE_ERR_INLINE_MAP
- YAML_PARSE_ERR_INLINE_SEQUENCE
- YAML_PARSE_ERR_BAD_DOUBLE
- YAML_PARSE_ERR_BAD_SINGLE
- YAML_PARSE_ERR_BAD_INLINE_IMPLICIT
- YAML_PARSE_ERR_BAD_IMPLICIT
- YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP
- YAML_LOAD_WARN_BAD_REGEXP_ELEM
- YAML_LOAD_WARN_REGEXP_CREATE
- YAML_LOAD_WARN_GLOB_NAME
- YAML_LOAD_WARN_PARSE_CODE
- YAML_LOAD_WARN_CODE_DEPARSE
- YAML_LOAD_WARN_BAD_GLOB_ELEM
- YAML_PARSE_ERR_ZERO_INDENT
- );
-
-package YAML::Warning;
-
-our @ISA = 'YAML::Error';
-
-1;
+++ /dev/null
-package YAML::Loader;
-
-use YAML::Mo;
-extends 'YAML::Loader::Base';
-
-use 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')
- $self->{stream} .= "\n"
- if length($self->stream) and
- $self->{stream} !~ s/(.)\n\Z/$1/s;
- $self->lines([split /\x0a/, $self->stream, -1]);
- $self->line(1);
- # Throw away any comments or blanks before the header (or start of
- # content for headerless streams)
- $self->_parse_throwaway_comments();
- $self->document(0);
- $self->documents([]);
- # Add an "assumed" header if there is no header and the stream is
- # not empty (after initial throwaways).
- if (not $self->eos) {
- if ($self->lines->[0] !~ /^---(\s|$)/) {
- unshift @{$self->lines}, '---';
- $self->{line}--;
- }
- }
-
- # Main Loop. Parse out all the top level nodes and return them.
- while (not $self->eos) {
- $self->anchor2node({});
- $self->{document}++;
- $self->done(0);
- $self->level(0);
- $self->offset->[0] = -1;
-
- if ($self->lines->[0] =~ /^---\s*(.*)$/) {
- my @words = split /\s+/, $1;
- %directives = ();
- while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) {
- my ($key, $value) = ($1, $2);
- shift(@words);
- if (defined $directives{$key}) {
- $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES',
- $key, $self->document);
- next;
- }
- $directives{$key} = $value;
- }
- $self->preface(join ' ', @words);
- }
- else {
- $self->die('YAML_PARSE_ERR_NO_SEPARATOR');
- }
-
- if (not $self->done) {
- $self->_parse_next_line(COLLECTION);
- }
- if ($self->done) {
- $self->{indent} = -1;
- $self->content('');
- }
-
- $directives{YAML} ||= '1.0';
- $directives{TAB} ||= 'NONE';
- ($self->{major_version}, $self->{minor_version}) =
- split /\./, $directives{YAML}, 2;
- $self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML})
- if $self->major_version ne '1';
- $self->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML})
- if $self->minor_version ne '0';
- $self->die('Unrecognized TAB policy')
- unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/;
-
- push @{$self->documents}, $self->_parse_node();
- }
- return wantarray ? @{$self->documents} : $self->documents->[-1];
-}
-
-# This function is the dispatcher for parsing each node. Every node
-# recurses back through here. (Inlines are an exception as they have
-# their own sub-parser.)
-sub _parse_node {
- my $self = shift;
- my $preface = $self->preface;
- $self->preface('');
- my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
- my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
- ($anchor, $alias, $explicit, $implicit, $preface) =
- $self->_parse_qualifiers($preface);
- if ($anchor) {
- $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
- }
- $self->inline('');
- while (length $preface) {
- my $line = $self->line - 1;
- if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) {
- $indicator = $1;
- $chomp = $2 if defined($2);
- }
- else {
- $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator;
- $self->inline($preface);
- $preface = '';
- }
- }
- if ($alias) {
- $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
- unless defined $self->anchor2node->{$alias};
- if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
- $node = $self->anchor2node->{$alias};
- }
- else {
- $node = do {my $sv = "*$alias"};
- push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
- }
- }
- elsif (length $self->inline) {
- $node = $self->_parse_inline(1, $implicit, $explicit);
- if (length $self->inline) {
- $self->die('YAML_PARSE_ERR_SINGLE_LINE');
- }
- }
- elsif ($indicator eq $LIT_CHAR) {
- $self->{level}++;
- $node = $self->_parse_block($chomp);
- $node = $self->_parse_implicit($node) if $implicit;
- $self->{level}--;
- }
- elsif ($indicator eq $FOLD_CHAR) {
- $self->{level}++;
- $node = $self->_parse_unfold($chomp);
- $node = $self->_parse_implicit($node) if $implicit;
- $self->{level}--;
- }
- else {
- $self->{level}++;
- $self->offset->[$self->level] ||= 0;
- if ($self->indent == $self->offset->[$self->level]) {
- if ($self->content =~ /^-( |$)/) {
- $node = $self->_parse_seq($anchor);
- }
- elsif ($self->content =~ /(^\?|\:( |$))/) {
- $node = $self->_parse_mapping($anchor);
- }
- elsif ($preface =~ /^\s*$/) {
- $node = $self->_parse_implicit('');
- }
- else {
- $self->die('YAML_PARSE_ERR_BAD_NODE');
- }
- }
- else {
- $node = undef;
- }
- $self->{level}--;
- }
- $#{$self->offset} = $self->level;
-
- if ($explicit) {
- if ($class) {
- if (not ref $node) {
- my $copy = $node;
- undef $node;
- $node = \$copy;
- }
- CORE::bless $node, $class;
- }
- else {
- $node = $self->_parse_explicit($node, $explicit);
- }
- }
- if ($anchor) {
- if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
- # XXX Can't remember what this code actually does
- for my $ref (@{$self->anchor2node->{$anchor}}) {
- ${$ref->[0]} = $node;
- $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
- $anchor, $ref->[1]);
- }
- }
- $self->anchor2node->{$anchor} = $node;
- }
- return $node;
-}
-
-# Preprocess the qualifiers that may be attached to any node.
-sub _parse_qualifiers {
- my $self = shift;
- my ($preface) = @_;
- my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5;
- $self->inline('');
- while ($preface =~ /^[&*!]/) {
- my $line = $self->line - 1;
- if ($preface =~ s/^\!(\S+)\s*//) {
- $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit;
- $explicit = $1;
- }
- elsif ($preface =~ s/^\!\s*//) {
- $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit;
- $implicit = 1;
- }
- elsif ($preface =~ s/^\&([^ ,:]+)\s*//) {
- $token = $1;
- $self->die('YAML_PARSE_ERR_BAD_ANCHOR')
- unless $token =~ /^[a-zA-Z0-9]+$/;
- $self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor;
- $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias;
- $anchor = $token;
- }
- elsif ($preface =~ s/^\*([^ ,:]+)\s*//) {
- $token = $1;
- $self->die('YAML_PARSE_ERR_BAD_ALIAS')
- unless $token =~ /^[a-zA-Z0-9]+$/;
- $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias;
- $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor;
- $alias = $token;
- }
- }
- return ($anchor, $alias, $explicit, $implicit, $preface);
-}
-
-# Morph a node to it's explicit type
-sub _parse_explicit {
- my $self = shift;
- my ($node, $explicit) = @_;
- my ($type, $class);
- if ($explicit =~ /^\!?perl\/(hash|array|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) {
- ($type, $class) = (($1 || ''), ($2 || ''));
-
- # FIXME # die unless uc($type) eq ref($node) ?
-
- if ( $type eq "ref" ) {
- $self->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'XXX', $explicit)
- unless exists $node->{VALUE()} and scalar(keys %$node) == 1;
-
- my $value = $node->{VALUE()};
- $node = \$value;
- }
-
- if ( $type eq "scalar" and length($class) and !ref($node) ) {
- my $value = $node;
- $node = \$value;
- }
-
- if ( length($class) ) {
- CORE::bless($node, $class);
- }
-
- return $node;
- }
- if ($explicit =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) {
- ($type, $class) = (($1 || ''), ($2 || ''));
- my $type_class = "YAML::Type::$type";
- no strict 'refs';
- if ($type_class->can('yaml_load')) {
- return $type_class->yaml_load($node, $class, $self);
- }
- else {
- $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit);
- }
- }
- # This !perl/@Foo and !perl/$Foo are deprecated but still parsed
- elsif ($YAML::TagClass->{$explicit} ||
- $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$}
- ) {
- $class = $YAML::TagClass->{$explicit} || $2;
- if ($class->can('yaml_load')) {
- require YAML::Node;
- return $class->yaml_load(YAML::Node->new($node, $explicit));
- }
- else {
- if (ref $node) {
- return CORE::bless $node, $class;
- }
- else {
- return CORE::bless \$node, $class;
- }
- }
- }
- elsif (ref $node) {
- require YAML::Node;
- return YAML::Node->new($node, $explicit);
- }
- else {
- # XXX This is likely wrong. Failing test:
- # --- !unknown 'scalar value'
- return $node;
- }
-}
-
-# Parse a YAML mapping into a Perl hash
-sub _parse_mapping {
- my $self = shift;
- my ($anchor) = @_;
- my $mapping = {};
- $self->anchor2node->{$anchor} = $mapping;
- my $key;
- while (not $self->done and $self->indent == $self->offset->[$self->level]) {
- # If structured key:
- if ($self->{content} =~ s/^\?\s*//) {
- $self->preface($self->content);
- $self->_parse_next_line(COLLECTION);
- $key = $self->_parse_node();
- $key = "$key";
- }
- # If "default" key (equals sign)
- elsif ($self->{content} =~ s/^\=\s*//) {
- $key = VALUE;
- }
- # If "comment" key (slash slash)
- elsif ($self->{content} =~ s/^\=\s*//) {
- $key = COMMENT;
- }
- # Regular scalar key:
- else {
- $self->inline($self->content);
- $key = $self->_parse_inline();
- $key = "$key";
- $self->content($self->inline);
- $self->inline('');
- }
-
- unless ($self->{content} =~ s/^:\s*//) {
- $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT');
- }
- $self->preface($self->content);
- my $line = $self->line;
- $self->_parse_next_line(COLLECTION);
- my $value = $self->_parse_node();
- if (exists $mapping->{$key}) {
- $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
- }
- else {
- $mapping->{$key} = $value;
- }
- }
- return $mapping;
-}
-
-# Parse a YAML sequence into a Perl array
-sub _parse_seq {
- my $self = shift;
- my ($anchor) = @_;
- my $seq = [];
- $self->anchor2node->{$anchor} = $seq;
- while (not $self->done and $self->indent == $self->offset->[$self->level]) {
- if ($self->content =~ /^-(?: (.*))?$/) {
- $self->preface(defined($1) ? $1 : '');
- }
- else {
- $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT');
- }
- if ($self->preface =~ /^(\s*)(\w.*\:(?: |$).*)$/) {
- $self->indent($self->offset->[$self->level] + 2 + length($1));
- $self->content($2);
- $self->level($self->level + 1);
- $self->offset->[$self->level] = $self->indent;
- $self->preface('');
- push @$seq, $self->_parse_mapping('');
- $self->{level}--;
- $#{$self->offset} = $self->level;
- }
- else {
- $self->_parse_next_line(COLLECTION);
- push @$seq, $self->_parse_node();
- }
- }
- return $seq;
-}
-
-# Parse an inline value. Since YAML supports inline collections, this is
-# the top level of a sub parsing.
-sub _parse_inline {
- my $self = shift;
- my ($top, $top_implicit, $top_explicit) = (@_, '', '', '');
- $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump
- my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5;
- ($anchor, $alias, $explicit, $implicit, $self->{inline}) =
- $self->_parse_qualifiers($self->inline);
- if ($anchor) {
- $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
- }
- $implicit ||= $top_implicit;
- $explicit ||= $top_explicit;
- ($top_implicit, $top_explicit) = ('', '');
- if ($alias) {
- $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
- unless defined $self->anchor2node->{$alias};
- if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
- $node = $self->anchor2node->{$alias};
- }
- else {
- $node = do {my $sv = "*$alias"};
- push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
- }
- }
- elsif ($self->inline =~ /^\{/) {
- $node = $self->_parse_inline_mapping($anchor);
- }
- elsif ($self->inline =~ /^\[/) {
- $node = $self->_parse_inline_seq($anchor);
- }
- elsif ($self->inline =~ /^"/) {
- $node = $self->_parse_inline_double_quoted();
- $node = $self->_unescape($node);
- $node = $self->_parse_implicit($node) if $implicit;
- }
- elsif ($self->inline =~ /^'/) {
- $node = $self->_parse_inline_single_quoted();
- $node = $self->_parse_implicit($node) if $implicit;
- }
- else {
- if ($top) {
- $node = $self->inline;
- $self->inline('');
- }
- else {
- $node = $self->_parse_inline_simple();
- }
- $node = $self->_parse_implicit($node) unless $explicit;
- }
- if ($explicit) {
- $node = $self->_parse_explicit($node, $explicit);
- }
- if ($anchor) {
- if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
- for my $ref (@{$self->anchor2node->{$anchor}}) {
- ${$ref->[0]} = $node;
- $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
- $anchor, $ref->[1]);
- }
- }
- $self->anchor2node->{$anchor} = $node;
- }
- return $node;
-}
-
-# Parse the inline YAML mapping into a Perl hash
-sub _parse_inline_mapping {
- my $self = shift;
- my ($anchor) = @_;
- my $node = {};
- $self->anchor2node->{$anchor} = $node;
-
- $self->die('YAML_PARSE_ERR_INLINE_MAP')
- unless $self->{inline} =~ s/^\{\s*//;
- while (not $self->{inline} =~ s/^\s*\}//) {
- my $key = $self->_parse_inline();
- $self->die('YAML_PARSE_ERR_INLINE_MAP')
- unless $self->{inline} =~ s/^\: \s*//;
- my $value = $self->_parse_inline();
- if (exists $node->{$key}) {
- $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
- }
- else {
- $node->{$key} = $value;
- }
- next if $self->inline =~ /^\s*\}/;
- $self->die('YAML_PARSE_ERR_INLINE_MAP')
- unless $self->{inline} =~ s/^\,\s*//;
- }
- return $node;
-}
-
-# Parse the inline YAML sequence into a Perl array
-sub _parse_inline_seq {
- my $self = shift;
- my ($anchor) = @_;
- my $node = [];
- $self->anchor2node->{$anchor} = $node;
-
- $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
- unless $self->{inline} =~ s/^\[\s*//;
- while (not $self->{inline} =~ s/^\s*\]//) {
- my $value = $self->_parse_inline();
- push @$node, $value;
- next if $self->inline =~ /^\s*\]/;
- $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
- unless $self->{inline} =~ s/^\,\s*//;
- }
- return $node;
-}
-
-# Parse the inline double quoted string.
-sub _parse_inline_double_quoted {
- my $self = shift;
- my $node;
- # https://rt.cpan.org/Public/Bug/Display.html?id=90593
- if ($self->inline =~ /^"((?:(?:\\"|[^"]){0,32766}){0,32766})"\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 =~ /^'((?:(?:''|[^']){0,32766}){0,32766})'\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] =~ /^( *)/;
- 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
- $self->die('YAML_PARSE_ERR_NONSPACE_INDENTATION');
- if (length($1) > $offset) {
- $self->offset->[$level+1] = length($1);
- }
- else {
- $self->offset->[$level+1] = $offset + 1;
- }
- }
- $offset = $self->offset->[++$level];
- }
-
- if ($type == LEAF) {
- while (@{$self->lines} and
- $self->lines->[0] =~ m{^( *)(\#)} and
- length($1) < $offset
- ) {
- shift @{$self->lines};
- $self->{line}++;
- }
- $self->eos($self->{done} = not @{$self->lines});
- }
- else {
- $self->_parse_throwaway_comments();
- }
- return if $self->eos;
-
- if ($self->lines->[0] =~ /^---(\s|$)/) {
- $self->done(1);
- return;
- }
- if ($type == LEAF and
- $self->lines->[0] =~ /^ {$offset}(.*)$/
- ) {
- $self->indent($offset);
- $self->content($1);
- }
- elsif ($self->lines->[0] =~ /^\s*$/) {
- $self->indent($offset);
- $self->content('');
- }
- else {
- $self->lines->[0] =~ /^( *)(\S.*)$/;
- while ($self->offset->[$level] > length($1)) {
- $level--;
- }
- $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION')
- if $self->offset->[$level] != length($1);
- $self->indent(length($1));
- $self->content($2);
- }
- $self->die('YAML_PARSE_ERR_INDENTATION')
- if $self->indent - $offset > 1;
-}
-
-#==============================================================================
-# Utility subroutines.
-#==============================================================================
-
-# Printable characters for escapes
-my %unescapes = (
- 0 => "\x00",
- a => "\x07",
- t => "\x09",
- n => "\x0a",
- 'v' => "\x0b", # Potential v-string error on 5.6.2 if not quoted
- f => "\x0c",
- r => "\x0d",
- e => "\x1b",
- '\\' => '\\',
- );
-
-# Transform all the backslash style escape characters to their literal meaning
-sub _unescape {
- my $self = shift;
- my ($node) = @_;
- $node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/
- (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
- return $node;
-}
-
-1;
+++ /dev/null
-package YAML::Loader::Base;
-
-use YAML::Mo;
-
-has load_code => default => sub {0};
-has stream => default => sub {''};
-has document => default => sub {0};
-has line => default => sub {0};
-has documents => default => sub {[]};
-has lines => default => sub {[]};
-has eos => default => sub {0};
-has done => default => sub {0};
-has anchor2node => default => sub {{}};
-has level => default => sub {0};
-has offset => default => sub {[]};
-has preface => default => sub {''};
-has content => default => sub {''};
-has indent => default => sub {0};
-has major_version => default => sub {0};
-has minor_version => default => sub {0};
-has inline => default => sub {''};
-
-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;
+++ /dev/null
-use strict; use warnings;
-package YAML::Marshall;
-
-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;
+++ /dev/null
-package YAML::Mo; $VERSION = '0.88';
-# use Mo qw[builder default import];
-# The following line of code was produced from the previous line by
-# Mo::Inline version 0.31
-no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{bless{@_[1..$#_]},$_[0]};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;$a{default}or return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$a{default}->(@_):$m->(@_)}}};my$i=\&import;*{$M.import}=sub{(@_==2 and not $_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};@f=qw[builder default import];use strict;use warnings;
-
-our $DumperModule = 'Data::Dumper';
-
-my ($_new_error, $_info, $_scalar_info);
-
-no strict 'refs';
-*{$M.'Object::die'} = sub {
- my $self = shift;
- my $error = $self->$_new_error(@_);
- $error->type('Error');
- Carp::croak($error->format_message);
-};
-
-*{$M.'Object::warn'} = sub {
- 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
-*{$M.'Object::node_info'} = sub {
- 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;
-};
-
-1;
+++ /dev/null
-use strict; use warnings;
-package YAML::Node;
-
-use YAML::Tag;
-require YAML::Mo;
-
-use Exporter;
-our @ISA = qw(Exporter YAML::Mo::Object);
-our @EXPORT = qw(ynode);
-
-sub ynode {
- my $self;
- if (ref($_[0]) eq 'HASH') {
- $self = tied(%{$_[0]});
- }
- elsif (ref($_[0]) eq 'ARRAY') {
- $self = tied(@{$_[0]});
- }
- elsif (ref(\$_[0]) eq 'GLOB') {
- $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) = YAML::Mo::Object->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;
+++ /dev/null
-use strict; use warnings;
-package YAML::Tag;
-
-use overload '""' => sub { ${$_[0]} };
-
-sub new {
- my ($class, $self) = @_;
- bless \$self, $class
-}
-
-sub short {
- ${$_[0]}
-}
-
-sub canonical {
- ${$_[0]}
-}
-
-1;
+++ /dev/null
-package YAML::Types;
-
-use YAML::Mo;
-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::Mo; # XXX
-
-sub yaml_dump {
- my $self = shift;
- my ($value) = @_;
- my ($class, $type) = YAML::Mo::Object->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);
- }
- elsif ($type eq 'GLOB') {
- # blessed glob support is minimal, and will not round-trip
- # initial aim: to not cause an error
- return YAML::Type::glob->yaml_dump($value, $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;
- # $_[0] remains as the glob
- my $tag = pop @_ if 2==@_;
-
- $tag = '!perl/glob:' unless defined $tag;
- my $ynode = YAML::Node->new({}, $tag);
- 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({});
- if ($value->{fileno} = fileno(*{$_[0]})) {
- local $^W;
- map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
- $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::Mo::Object->node_info($value);
- my $tag = "!perl/code";
- $tag .= ":$class" if defined $class;
- if (not $dumpflag) {
- $code = $default;
- }
- else {
- bless $value, "CODE" if $class;
- eval { use B::Deparse };
- return if $@;
- my $deparse = B::Deparse->new();
- eval {
- local $^W = 0;
- $code = $deparse->coderef2text($value);
- };
- if ($@) {
- warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
- $code = $default;
- }
- bless $value, $class if $class;
- chomp $code;
- $code .= "\n";
- }
- $_[2] = $code;
- YAML::Node->new($_[2], $tag);
-}
-
-sub yaml_load {
- my $self = shift;
- my ($node, $class, $loader) = @_;
- if ($loader->load_code) {
- my $code = eval "package main; sub $node";
- if ($@) {
- $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
- return sub {};
- }
- else {
- CORE::bless $code, $class if $class;
- return $code;
- }
- }
- else {
- return CORE::bless sub {}, $class if $class;
- return sub {};
- }
-}
-
-#-------------------------------------------------------------------------------
-package YAML::Type::ref;
-
-sub yaml_dump {
- my $self = shift;
- YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref')
-}
-
-sub yaml_load {
- my $self = shift;
- my ($node, $class, $loader) = @_;
- $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')
- unless exists $node->{&YAML::VALUE};
- return \$node->{&YAML::VALUE};
-}
-
-#-------------------------------------------------------------------------------
-package YAML::Type::regexp;
-
-# XXX Be sure to handle blessed regexps (if possible)
-sub yaml_dump {
- die "YAML::Type::regexp::yaml_dump not currently implemented";
-}
-
-use constant _QR_TYPES => {
- '' => sub { qr{$_[0]} },
- x => sub { qr{$_[0]}x },
- i => sub { qr{$_[0]}i },
- s => sub { qr{$_[0]}s },
- m => sub { qr{$_[0]}m },
- ix => sub { qr{$_[0]}ix },
- sx => sub { qr{$_[0]}sx },
- mx => sub { qr{$_[0]}mx },
- si => sub { qr{$_[0]}si },
- mi => sub { qr{$_[0]}mi },
- ms => sub { qr{$_[0]}sm },
- six => sub { qr{$_[0]}six },
- mix => sub { qr{$_[0]}mix },
- msx => sub { qr{$_[0]}msx },
- msi => sub { qr{$_[0]}msi },
- msix => sub { qr{$_[0]}msix },
-};
-
-sub yaml_load {
- my $self = shift;
- my ($node, $class) = @_;
- return qr{$node} unless $node =~ /^\(\?([\^\-xism]*):(.*)\)\z/s;
- my ($flags, $re) = ($1, $2);
- $flags =~ s/-.*//;
- $flags =~ s/^\^//;
- my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
- my $qr = &$sub($re);
- bless $qr, $class if length $class;
- return $qr;
-}
-
-1;
use List::MoreUtils qw(apply);
use List::Util qw(first);
use Pod::Usage;
-use YAML ();
-use YAML::Loader (); # YAML tries to load Y:L at runtime, but can't find it after we chdir'ed
use SL::DBUpgrade2;
use SL::System::Process;
+use SL::YAML;
$OUTPUT_AUTOFLUSH = 1;
sub scanmenu {
my $file = shift;
- my $menu = YAML::LoadFile($file);
+ my $menu = SL::YAML::LoadFile($file);
for my $node (@$menu) {
# possible for override files
use strict;
use utf8;
-use YAML;
-
use parent qw(SL::DBUpgrade2::Base);
use SL::DBUtils;
+use SL::YAML;
sub prepare_statements {
my ($self) = @_;
$self->{h_draft}->execute('ar') || die $self->{h_draft}->errstr;
while (my $draft_record = $self->{h_draft}->fetchrow_hashref) {
- my $draft = YAML::Load($draft_record->{form});
+ my $draft = SL::YAML::Load($draft_record->{form});
my $currency_id = $self->{currency_ids_by_name}->{$draft->{currency}};
my $employee_id = $draft_record->{employee_id} || $draft->{employee_id} || (split m{--}, $draft->{employee})[1] || undef;
$self->{h_draft}->execute('ap') || die $self->{h_draft}->errstr;
while (my $draft_record = $self->{h_draft}->fetchrow_hashref) {
- my $draft = YAML::Load($draft_record->{form});
+ my $draft = SL::YAML::Load($draft_record->{form});
my $currency_id = $self->{currency_ids_by_name}->{$draft->{currency}};
my $employee_id = $draft_record->{employee_id} || $draft->{employee_id} || (split m{--}, $draft->{employee})[1] || undef;
$self->{h_draft}->execute('gl') || die $self->{h_draft}->errstr;
while (my $draft_record = $self->{h_draft}->fetchrow_hashref) {
- my $draft = YAML::Load($draft_record->{form});
+ my $draft = SL::YAML::Load($draft_record->{form});
my $employee_id = $draft_record->{employee_id} || $draft->{employee_id} || (split m{--}, $draft->{employee})[1] || undef;
my @values = (
projects / kivitendo-erp.git / commitdiff