From 65b2387a54494a8cbc1d011602ae3f8d7208ea4d Mon Sep 17 00:00:00 2001 From: Moritz Bunkus Date: Fri, 29 Mar 2019 15:18:28 +0100 Subject: [PATCH] =?utf8?q?Module:=20gebundletes=20YAML=20durch=20d=C3=BCnn?= =?utf8?q?en=20Wrapper=20=C3=BCber=20YAML::XS=20&=20YAML=20ersetzt?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- SL/Auth/SessionValue.pm | 8 +- SL/BackgroundJob/CsvImport.pm | 6 +- SL/Controller/Draft.pm | 6 +- SL/Controller/Order.pm | 7 +- SL/DB/BackgroundJob.pm | 7 +- SL/DO.pm | 8 +- SL/IC.pm | 1 - SL/InstallationCheck.pm | 1 + SL/LXDebug.pm | 6 +- SL/Menu.pm | 13 +- SL/MoreCommon.pm | 6 +- SL/OE.pm | 6 +- SL/YAML.pm | 60 ++ bin/mozilla/acctranscorrections.pl | 1 - bin/mozilla/do.pl | 8 +- bin/mozilla/oe.pl | 7 +- doc/modules/README.YAML | 611 -------------- modules/override/YAML.pm | 100 --- modules/override/YAML/Any.pm | 122 --- modules/override/YAML/Dumper.pm | 575 ------------- modules/override/YAML/Dumper/Base.pm | 111 --- modules/override/YAML/Error.pm | 191 ----- modules/override/YAML/Loader.pm | 756 ------------------ modules/override/YAML/Loader/Base.pm | 33 - modules/override/YAML/Marshall.pm | 47 -- modules/override/YAML/Mo.pm | 80 -- modules/override/YAML/Node.pm | 218 ----- modules/override/YAML/Tag.pm | 19 - modules/override/YAML/Types.pm | 235 ------ scripts/locales.pl | 5 +- .../convert_drafts_to_record_templates.pl | 9 +- 31 files changed, 108 insertions(+), 3155 deletions(-) create mode 100644 SL/YAML.pm delete mode 100644 doc/modules/README.YAML delete mode 100644 modules/override/YAML.pm delete mode 100644 modules/override/YAML/Any.pm delete mode 100644 modules/override/YAML/Dumper.pm delete mode 100644 modules/override/YAML/Dumper/Base.pm delete mode 100644 modules/override/YAML/Error.pm delete mode 100644 modules/override/YAML/Loader.pm delete mode 100644 modules/override/YAML/Loader/Base.pm delete mode 100644 modules/override/YAML/Marshall.pm delete mode 100644 modules/override/YAML/Mo.pm delete mode 100644 modules/override/YAML/Node.pm delete mode 100644 modules/override/YAML/Tag.pm delete mode 100644 modules/override/YAML/Types.pm diff --git a/SL/Auth/SessionValue.pm b/SL/Auth/SessionValue.pm index cfaa6245c..3cc80bb6f 100644 --- a/SL/Auth/SessionValue.pm +++ b/SL/Auth/SessionValue.pm @@ -7,9 +7,9 @@ use strict; use SL::Locale::String (); use Scalar::Util qw(weaken); -use YAML; use SL::DBUtils; +use SL::YAML; sub new { my ($class, %params) = @_; @@ -39,7 +39,7 @@ sub get_dumped { my ($self) = @_; no warnings 'once'; local $YAML::Stringify = 1; - return YAML::Dump($self->get); + return SL::YAML::Dump($self->get); } sub _fetch { @@ -58,7 +58,7 @@ 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; @@ -71,7 +71,7 @@ sub _load_value { 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 }; diff --git a/SL/BackgroundJob/CsvImport.pm b/SL/BackgroundJob/CsvImport.pm index 1736721b9..00f76d537 100644 --- a/SL/BackgroundJob/CsvImport.pm +++ b/SL/BackgroundJob/CsvImport.pm @@ -4,8 +4,8 @@ use strict; use parent qw(SL::BackgroundJob::Base); -use YAML (); use SL::JSON; +use SL::YAML; use SL::DB::CsvImportProfile; sub create_job { @@ -23,7 +23,7 @@ sub create_job { type => 'once', active => 1, package_name => $package, - data => YAML::Dump(\%data), + data => SL::YAML::Dump(\%data), ); return $job; @@ -33,7 +33,7 @@ sub profile { 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}); } diff --git a/SL/Controller/Draft.pm b/SL/Controller/Draft.pm index ed2f602ce..02e74f586 100644 --- a/SL/Controller/Draft.pm +++ b/SL/Controller/Draft.pm @@ -9,7 +9,7 @@ use SL::Locale::String qw(t8); 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 ( @@ -53,7 +53,7 @@ sub action_save { 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, ); @@ -83,7 +83,7 @@ sub action_load { 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); diff --git a/SL/Controller/Order.pm b/SL/Controller/Order.pm index c37dc1c94..144fc87f8 100644 --- a/SL/Controller/Order.pm +++ b/SL/Controller/Order.pm @@ -11,6 +11,7 @@ use SL::PriceSource; 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; @@ -552,7 +553,7 @@ sub action_assign_periodic_invoices_config { 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); @@ -1232,7 +1233,7 @@ sub make_order { $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); } @@ -1765,7 +1766,7 @@ sub make_periodic_invoices_config_from_yaml { 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); } diff --git a/SL/DB/BackgroundJob.pm b/SL/DB/BackgroundJob.pm index 3e6c03da5..1fc8d992d 100644 --- a/SL/DB/BackgroundJob.pm +++ b/SL/DB/BackgroundJob.pm @@ -11,6 +11,7 @@ use SL::DB::MetaSetup::BackgroundJob; use SL::DB::Manager::BackgroundJob; use SL::System::Process; +use SL::YAML; __PACKAGE__->meta->initialize; @@ -76,18 +77,18 @@ sub run { 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, })); diff --git a/SL/DO.pm b/SL/DO.pm index 6a9195332..54df47ca7 100644 --- a/SL/DO.pm +++ b/SL/DO.pm @@ -37,7 +37,6 @@ package DO; use Carp; use List::Util qw(max); use Text::ParseWords; -use YAML; use SL::AM; use SL::Common; @@ -52,6 +51,7 @@ use SL::IC; use SL::TransNumber; use SL::DB; use SL::Util qw(trim); +use SL::YAML; use strict; @@ -450,7 +450,7 @@ SQL 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}), @@ -833,7 +833,7 @@ sub retrieve { push @{ $requests }, $ref; } - $doi->{"stock_${in_out}"} = YAML::Dump($requests); + $doi->{"stock_${in_out}"} = SL::YAML::Dump($requests); } $sth->finish(); @@ -1095,7 +1095,7 @@ sub unpack_stock_information { 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)); diff --git a/SL/IC.pm b/SL/IC.pm index f62c67695..a2a0a86a8 100644 --- a/SL/IC.pm +++ b/SL/IC.pm @@ -37,7 +37,6 @@ package IC; use Data::Dumper; use List::MoreUtils qw(all any uniq); -use YAML; use SL::CVar; use SL::DBUtils; diff --git a/SL/InstallationCheck.pm b/SL/InstallationCheck.pm index f5bd4a3d5..e042d27cf 100644 --- a/SL/InstallationCheck.pm +++ b/SL/InstallationCheck.pm @@ -73,6 +73,7 @@ BEGIN { # 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 = ( diff --git a/SL/LXDebug.pm b/SL/LXDebug.pm index 7dddf2a02..28a36bfff 100644 --- a/SL/LXDebug.pm +++ b/SL/LXDebug.pm @@ -22,8 +22,8 @@ use Data::Dumper; 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; @@ -213,7 +213,7 @@ sub dump { 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 { @@ -252,7 +252,7 @@ sub show_diff { 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)); } diff --git a/SL/Menu.pm b/SL/Menu.pm index 42b08de48..0c6df2247 100644 --- a/SL/Menu.pm +++ b/SL/Menu.pm @@ -3,14 +3,9 @@ package SL::Menu; 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; @@ -29,11 +24,7 @@ sub new { 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: $@"; diff --git a/SL/MoreCommon.pm b/SL/MoreCommon.pm index b1ea817e4..0aa84a729 100644 --- a/SL/MoreCommon.pm +++ b/SL/MoreCommon.pm @@ -8,7 +8,7 @@ our @EXPORT_OK = qw(ary_union ary_intersect ary_diff listify ary_to_hash uri_enc use Encode (); use List::MoreUtils qw(zip); -use YAML; +use SL::YAML; use strict; @@ -23,7 +23,7 @@ sub save_form { 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; @@ -49,7 +49,7 @@ sub restore_form { $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(); diff --git a/SL/OE.pm b/SL/OE.pm index ef6f59792..74c9ffdfb 100644 --- a/SL/OE.pm +++ b/SL/OE.pm @@ -36,7 +36,6 @@ package OE; use List::Util qw(max first); -use YAML; use SL::AM; use SL::Common; @@ -53,6 +52,7 @@ use SL::IC; use SL::TransNumber; use SL::Util qw(trim); use SL::DB; +use SL::YAML; use Text::ParseWords; use strict; @@ -816,7 +816,7 @@ sub save_periodic_invoices_config { 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}) @@ -836,7 +836,7 @@ sub load_periodic_invoice_config { 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); } } } diff --git a/SL/YAML.pm b/SL/YAML.pm new file mode 100644 index 000000000..bfccfba80 --- /dev/null +++ b/SL/YAML.pm @@ -0,0 +1,60 @@ +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, C, +C and C — 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 Em.bunkus@linet-services.deE + +=cut diff --git a/bin/mozilla/acctranscorrections.pl b/bin/mozilla/acctranscorrections.pl index c0e325e4f..18d237bf1 100644 --- a/bin/mozilla/acctranscorrections.pl +++ b/bin/mozilla/acctranscorrections.pl @@ -3,7 +3,6 @@ use SL::Form; use SL::Locale::String qw(t8); use SL::User; use Data::Dumper; -use YAML; require "bin/mozilla/common.pl"; diff --git a/bin/mozilla/do.pl b/bin/mozilla/do.pl index c35635198..ff902172d 100644 --- a/bin/mozilla/do.pl +++ b/bin/mozilla/do.pl @@ -35,7 +35,6 @@ use Carp; use List::MoreUtils qw(uniq); use List::Util qw(max sum); use POSIX qw(strftime); -use YAML; use SL::DB::DeliveryOrder; use SL::DO; @@ -44,6 +43,7 @@ use SL::IS; 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"; @@ -1390,7 +1390,7 @@ sub set_stock_in { 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); @@ -1485,7 +1485,7 @@ sub set_stock_out { 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} = []; @@ -1917,7 +1917,7 @@ sub transfer_in_out_default { 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 diff --git a/bin/mozilla/oe.pl b/bin/mozilla/oe.pl index 1d358d960..b5f3eb6b6 100644 --- a/bin/mozilla/oe.pl +++ b/bin/mozilla/oe.pl @@ -44,6 +44,7 @@ use SL::IR; 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; @@ -614,7 +615,7 @@ sub form_header { $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'); } } @@ -2171,7 +2172,7 @@ sub edit_periodic_invoices_config { 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}; @@ -2237,7 +2238,7 @@ sub save_periodic_invoices_config { 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; diff --git a/doc/modules/README.YAML b/doc/modules/README.YAML deleted file mode 100644 index 0fbb2fd09..000000000 --- a/doc/modules/README.YAML +++ /dev/null @@ -1,611 +0,0 @@ -NAME - YAML - YAML Ain't Markup Language (tm) - -SYNOPSIS - use YAML; - - # Load a YAML stream of 3 YAML documents into Perl data structures. - my ($hashref, $arrayref, $string) = Load(<<'...'); - --- - name: ingy - age: old - weight: heavy - # I should comment that I also like pink, but don't tell anybody. - favorite colors: - - red - - green - - blue - --- - - Clark Evans - - Oren Ben-Kiki - - Ingy döt Net - --- > - You probably think YAML stands for "Yet Another Markup Language". It - ain't! YAML is really a data serialization language. But if you want - to think of it as a markup, that's OK with me. A lot of people try - to use XML as a serialization format. - - "YAML" is catchy and fun to say. Try it. "YAML, YAML, YAML!!!" - ... - - # Dump the Perl data structures back into YAML. - print Dump($string, $arrayref, $hashref); - - # YAML::Dump is used the same way you'd use Data::Dumper::Dumper - use Data::Dumper; - print Dumper($string, $arrayref, $hashref); - -DESCRIPTION - The YAML.pm module implements a YAML Loader and Dumper based on the YAML - 1.0 specification. - - YAML is a generic data serialization language that is optimized for - human readability. It can be used to express the data structures of most - modern programming languages. (Including Perl!!!) - - For information on the YAML syntax, please refer to the YAML - specification. - -WHY YAML IS COOL - YAML is readable for people. - It makes clear sense out of complex data structures. You should find - that YAML is an exceptional data dumping tool. Structure is shown - through indentation, YAML supports recursive data, and hash keys are - sorted by default. In addition, YAML supports several styles of - scalar formatting for different types of data. - - YAML is editable. - YAML was designed from the ground up to be an excellent syntax for - configuration files. Almost all programs need configuration files, - so why invent a new syntax for each one? And why subject users to - the complexities of XML or native Perl code? - - YAML is multilingual. - Yes, YAML supports Unicode. But I'm actually referring to - programming languages. YAML was designed to meet the serialization - needs of Perl, Python, Ruby, Tcl, PHP, Javascript and Java. It was - also designed to be interoperable between those languages. That - means YAML serializations produced by Perl can be processed by - Python. - - YAML is taint safe. - Using modules like Data::Dumper for serialization is fine as long as - you can be sure that nobody can tamper with your data files or - transmissions. That's because you need to use Perl's "eval()" - built-in to deserialize the data. Somebody could add a snippet of - Perl to erase your files. - - YAML's parser does not need to eval anything. - - YAML is full featured. - YAML can accurately serialize all of the common Perl data structures - and deserialize them again without losing data relationships. - Although it is not 100% perfect (no serializer is or can be - perfect), it fares as well as the popular current modules: - Data::Dumper, Storable, XML::Dumper and Data::Denter. - - YAML.pm also has the ability to handle code (subroutine) references - and typeglobs. (Still experimental) These features are not found in - Perl's other serialization modules. - - YAML is extensible. - The YAML language has been designed to be flexible enough to solve - it's own problems. The markup itself has 3 basic construct which - resemble Perl's hash, array and scalar. By default, these map to - their Perl equivalents. But each YAML node also supports a tagging - mechanism (type system) which can cause that node to be interpreted - in a completely different manner. That's how YAML can support object - serialization and oddball structures like Perl's typeglob. - -YAML IMPLEMENTATIONS IN PERL - This module, YAML.pm, is really just the interface module for YAML - modules written in Perl. The basic interface for YAML consists of two - functions: "Dump" and "Load". The real work is done by the modules - YAML::Dumper and YAML::Loader. - - Different YAML module distributions can be created by subclassing - YAML.pm and YAML::Loader and YAML::Dumper. For example, YAML-Simple - consists of YAML::Simple YAML::Dumper::Simple and YAML::Loader::Simple. - - Why would there be more than one implementation of YAML? Well, despite - YAML's offering of being a simple data format, YAML is actually very - deep and complex. Implementing the entirety of the YAML specification is - a daunting task. - - For this reason I am currently working on 3 different YAML - implementations. - - YAML - The main YAML distribution will keeping evolving to support the - entire YAML specification in pure Perl. This may not be the fastest - or most stable module though. Currently, YAML.pm has lots of known - bugs. It is mostly a great tool for dumping Perl data structures to - a readable form. - - YAML::Lite - The point of YAML::Lite is to strip YAML down to the 90% that people - use most and offer that in a small, fast, stable, pure Perl form. - YAML::Lite will simply die when it is asked to do something it - can't. - - YAML::Syck - "libsyck" is the C based YAML processing library used by the Ruby - programming language (and also Python, PHP and Pugs). YAML::Syck is - the Perl binding to "libsyck". It should be very fast, but may have - problems of its own. It will also require C compilation. - - NOTE: Audrey Tang has actually completed this module and it works - great and is 10 times faster than YAML.pm. - - In the future, there will likely be even more YAML modules. Remember, - people other than Ingy are allowed to write YAML modules! - -FUNCTIONAL USAGE - YAML is completely OO under the hood. Still it exports a few useful top - level functions so that it is dead simple to use. These functions just - do the OO stuff for you. If you want direct access to the OO API see the - documentation for YAML::Dumper and YAML::Loader. - - Exported Functions - The following functions are exported by YAML.pm by default. The reason - they are exported is so that YAML works much like Data::Dumper. If you - don't want functions to be imported, just use YAML with an empty import - list: - - use YAML (); - - Dump(list-of-Perl-data-structures) - Turn Perl data into YAML. This function works very much like - Data::Dumper::Dumper(). It takes a list of Perl data strucures and - dumps them into a serialized form. It returns a string containing - the YAML stream. The structures can be references or plain scalars. - - Load(string-containing-a-YAML-stream) - Turn YAML into Perl data. This is the opposite of Dump. Just like - Storable's thaw() function or the eval() function in relation to - Data::Dumper. It parses a string containing a valid YAML stream into - a list of Perl data structures. - - Exportable Functions - These functions are not exported by default but you can request them in - an import list like this: - - use YAML qw'freeze thaw Bless'; - - freeze() and thaw() - Aliases to Dump() and Load() for Storable fans. This will also allow - YAML.pm to be plugged directly into modules like POE.pm, that use - the freeze/thaw API for internal serialization. - - DumpFile(filepath, list) - Writes the YAML stream to a file instead of just returning a string. - - LoadFile(filepath) - Reads the YAML stream from a file instead of a string. - - Bless(perl-node, [yaml-node | class-name]) - Associate a normal Perl node, with a yaml node. A yaml node is an - object tied to the YAML::Node class. The second argument is either a - yaml node that you've already created or a class (package) name that - supports a yaml_dump() function. A yaml_dump() function should take - a perl node and return a yaml node. If no second argument is - provided, Bless will create a yaml node. This node is not returned, - but can be retrieved with the Blessed() function. - - Here's an example of how to use Bless. Say you have a hash - containing three keys, but you only want to dump two of them. - Furthermore the keys must be dumped in a certain order. Here's how - you do that: - - use YAML qw(Dump Bless); - $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; - print Dump $hash; - Bless($hash)->keys(['banana', 'apple']); - print Dump $hash; - - produces: - - --- - apple: good - banana: bad - cauliflower: ugly - --- - banana: bad - apple: good - - Bless returns the tied part of a yaml-node, so that you can call the - YAML::Node methods. This is the same thing that YAML::Node::ynode() - returns. So another way to do the above example is: - - use YAML qw(Dump Bless); - use YAML::Node; - $hash = {apple => 'good', banana => 'bad', cauliflower => 'ugly'}; - print Dump $hash; - Bless($hash); - $ynode = ynode(Blessed($hash)); - $ynode->keys(['banana', 'apple']); - print Dump $hash; - - Note that Blessing a Perl data structure does not change it anyway. - The extra information is stored separately and looked up by the - Blessed node's memory address. - - Blessed(perl-node) - Returns the yaml node that a particular perl node is associated with - (see above). Returns undef if the node is not (YAML) Blessed. - -GLOBAL OPTIONS - YAML options are set using a group of global variables in the YAML - namespace. This is similar to how Data::Dumper works. - - For example, to change the indentation width, do something like: - - local $YAML::Indent = 3; - - The current options are: - - DumperClass - You can override which module/class YAML uses for Dumping data. - - LoaderClass - You can override which module/class YAML uses for Loading data. - - Indent - This is the number of space characters to use for each indentation - level when doing a Dump(). The default is 2. - - By the way, YAML can use any number of characters for indentation at - any level. So if you are editing YAML by hand feel free to do it - anyway that looks pleasing to you; just be consistent for a given - level. - - SortKeys - Default is 1. (true) - - Tells YAML.pm whether or not to sort hash keys when storing a - document. - - YAML::Node objects can have their own sort order, which is usually - what you want. To override the YAML::Node order and sort the keys - anyway, set SortKeys to 2. - - Stringify - Default is 0. (false) - - Objects with string overloading should honor the overloading and - dump the stringification of themselves, rather than the actual - object's guts. - - UseHeader - Default is 1. (true) - - This tells YAML.pm whether to use a separator string for a Dump - operation. This only applies to the first document in a stream. - Subsequent documents must have a YAML header by definition. - - UseVersion - Default is 0. (false) - - Tells YAML.pm whether to include the YAML version on the - separator/header. - - --- %YAML:1.0 - - AnchorPrefix - Default is ''. - - Anchor names are normally numeric. YAML.pm simply starts with '1' - and increases by one for each new anchor. This option allows you to - specify a string to be prepended to each anchor number. - - UseCode - Setting the UseCode option is a shortcut to set both the DumpCode - and LoadCode options at once. Setting UseCode to '1' tells YAML.pm - to dump Perl code references as Perl (using B::Deparse) and to load - them back into memory using eval(). The reason this has to be an - option is that using eval() to parse untrusted code is, well, - untrustworthy. - - DumpCode - Determines if and how YAML.pm should serialize Perl code references. - By default YAML.pm will dump code references as dummy placeholders - (much like Data::Dumper). If DumpCode is set to '1' or 'deparse', - code references will be dumped as actual Perl code. - - DumpCode can also be set to a subroutine reference so that you can - write your own serializing routine. YAML.pm passes you the code ref. - You pass back the serialization (as a string) and a format - indicator. The format indicator is a simple string like: 'deparse' - or 'bytecode'. - - LoadCode - LoadCode is the opposite of DumpCode. It tells YAML if and how to - deserialize code references. When set to '1' or 'deparse' it will - use "eval()". Since this is potentially risky, only use this option - if you know where your YAML has been. - - LoadCode can also be set to a subroutine reference so that you can - write your own deserializing routine. YAML.pm passes the - serialization (as a string) and a format indicator. You pass back - the code reference. - - UseBlock - YAML.pm uses heuristics to guess which scalar style is best for a - given node. Sometimes you'll want all multiline scalars to use the - 'block' style. If so, set this option to 1. - - NOTE: YAML's block style is akin to Perl's here-document. - - UseFold - If you want to force YAML to use the 'folded' style for all - multiline scalars, then set $UseFold to 1. - - NOTE: YAML's folded style is akin to the way HTML folds text, except - smarter. - - UseAliases - YAML has an alias mechanism such that any given structure in memory - gets serialized once. Any other references to that structure are - serialized only as alias markers. This is how YAML can serialize - duplicate and recursive structures. - - Sometimes, when you KNOW that your data is nonrecursive in nature, - you may want to serialize such that every node is expressed in full. - (ie as a copy of the original). Setting $YAML::UseAliases to 0 will - allow you to do this. This also may result in faster processing - because the lookup overhead is by bypassed. - - THIS OPTION CAN BE DANGEROUS. *If* your data is recursive, this - option *will* cause Dump() to run in an endless loop, chewing up - your computers memory. You have been warned. - - CompressSeries - Default is 1. - - Compresses the formatting of arrays of hashes: - - - - foo: bar - - - bar: foo - - becomes: - - - foo: bar - - bar: foo - - Since this output is usually more desirable, this option is turned - on by default. - -YAML TERMINOLOGY - YAML is a full featured data serialization language, and thus has its - own terminology. - - It is important to remember that although YAML is heavily influenced by - Perl and Python, it is a language in its own right, not merely just a - representation of Perl structures. - - YAML has three constructs that are conspicuously similar to Perl's hash, - array, and scalar. They are called mapping, sequence, and string - respectively. By default, they do what you would expect. But each - instance may have an explicit or implicit tag (type) that makes it - behave differently. In this manner, YAML can be extended to represent - Perl's Glob or Python's tuple, or Ruby's Bigint. - - stream - A YAML stream is the full sequence of unicode characters that a YAML - parser would read or a YAML emitter would write. A stream may - contain one or more YAML documents separated by YAML headers. - - --- - a: mapping - foo: bar - --- - - a - - sequence - - document - A YAML document is an independent data structure representation - within a stream. It is a top level node. Each document in a YAML - stream must begin with a YAML header line. Actually the header is - optional on the first document. - - --- - This: top level mapping - is: - - a - - YAML - - document - - header - A YAML header is a line that begins a YAML document. It consists of - three dashes, possibly followed by more info. Another purpose of the - header line is that it serves as a place to put top level tag and - anchor information. - - --- !recursive-sequence &001 - - * 001 - - * 001 - - node - A YAML node is the representation of a particular data stucture. - Nodes may contain other nodes. (In Perl terms, nodes are like - scalars. Strings, arrayrefs and hashrefs. But this refers to the - serialized format, not the in-memory structure.) - - tag This is similar to a type. It indicates how a particular YAML node - serialization should be transferred into or out of memory. For - instance a Foo::Bar object would use the tag 'perl/Foo::Bar': - - - !perl/Foo::Bar - foo: 42 - bar: stool - - collection - A collection is the generic term for a YAML data grouping. YAML has - two types of collections: mappings and sequences. (Similar to hashes - and arrays) - - mapping - A mapping is a YAML collection defined by unordered key/value pairs - with unique keys. By default YAML mappings are loaded into Perl - hashes. - - a mapping: - foo: bar - two: times two is 4 - - sequence - A sequence is a YAML collection defined by an ordered list of - elements. By default YAML sequences are loaded into Perl arrays. - - a sequence: - - one bourbon - - one scotch - - one beer - - scalar - A scalar is a YAML node that is a single value. By default YAML - scalars are loaded into Perl scalars. - - a scalar key: a scalar value - - YAML has many styles for representing scalars. This is important - because varying data will have varying formatting requirements to - retain the optimum human readability. - - plain scalar - A plain sclar is unquoted. All plain scalars are automatic - candidates for "implicit tagging". This means that their tag may be - determined automatically by examination. The typical uses for this - are plain alpha strings, integers, real numbers, dates, times and - currency. - - - a plain string - - -42 - - 3.1415 - - 12:34 - - 123 this is an error - - single quoted scalar - This is similar to Perl's use of single quotes. It means no escaping - except for single quotes which are escaped by using two adjacent - single quotes. - - - 'When I say ''\n'' I mean "backslash en"' - - double quoted scalar - This is similar to Perl's use of double quotes. Character escaping - can be used. - - - "This scalar\nhas two lines, and a bell -->\a" - - folded scalar - This is a multiline scalar which begins on the next line. It is - indicated by a single right angle bracket. It is unescaped like the - single quoted scalar. Line folding is also performed. - - - > - This is a multiline scalar which begins on - the next line. It is indicated by a single - carat. It is unescaped like the single - quoted scalar. Line folding is also - performed. - - block scalar - This final multiline form is akin to Perl's here-document except - that (as in all YAML data) scope is indicated by indentation. - Therefore, no ending marker is required. The data is verbatim. No - line folding. - - - | - QTY DESC PRICE TOTAL - --- ---- ----- ----- - 1 Foo Fighters $19.95 $19.95 - 2 Bar Belles $29.95 $59.90 - - parser - A YAML processor has four stages: parse, load, dump, emit. - - A parser parses a YAML stream. YAML.pm's Load() function contains a - parser. - - loader - The other half of the Load() function is a loader. This takes the - information from the parser and loads it into a Perl data structure. - - dumper - The Dump() function consists of a dumper and an emitter. The dumper - walks through each Perl data structure and gives info to the - emitter. - - emitter - The emitter takes info from the dumper and turns it into a YAML - stream. - - NOTE: In YAML.pm the parser/loader and the dumper/emitter code are - currently very closely tied together. In the future they may be - broken into separate stages. - - For more information please refer to the immensely helpful YAML - specification available at . - -ysh - The YAML Shell - The YAML distribution ships with a script called 'ysh', the YAML shell. - ysh provides a simple, interactive way to play with YAML. If you type in - Perl code, it displays the result in YAML. If you type in YAML it turns - it into Perl code. - - To run ysh, (assuming you installed it along with YAML.pm) simply type: - - ysh [options] - - Please read the "ysh" documentation for the full details. There are lots - of options. - -BUGS & DEFICIENCIES - If you find a bug in YAML, please try to recreate it in the YAML Shell - with logging turned on ('ysh -L'). When you have successfully reproduced - the bug, please mail the LOG file to the author (ingy@cpan.org). - - WARNING: This is still *ALPHA* code. Well, most of this code has been - around for years... - - BIGGER WARNING: YAML.pm has been slow in the making, but I am committed - to having top notch YAML tools in the Perl world. The YAML team is close - to finalizing the YAML 1.1 spec. This version of YAML.pm is based off of - a very old pre 1.0 spec. In actuality there isn't a ton of difference, - and this YAML.pm is still fairly useful. Things will get much better in - the future. - -RESOURCES - is the mailing - list. This is where the language is discussed and designed. - - is the official YAML website. - - is the YAML 1.0 specification. - - is the official YAML wiki. - -SEE ALSO - See YAML::Syck. Fast! - -AUTHOR - Ingy döt Net - - is resonsible for YAML.pm. - - The YAML serialization language is the result of years of collaboration - between Oren Ben-Kiki, Clark Evans and Ingy döt Net. Several others - have added help along the way. - -COPYRIGHT - Copyright (c) 2005, 2006. Ingy döt Net. All rights reserved. Copyright - (c) 2001, 2002, 2005. Brian Ingerson. All rights reserved. - - This program is free software; you can redistribute it and/or modify it - under the same terms as Perl itself. - - See - diff --git a/modules/override/YAML.pm b/modules/override/YAML.pm deleted file mode 100644 index 56c3c959f..000000000 --- a/modules/override/YAML.pm +++ /dev/null @@ -1,100 +0,0 @@ -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; diff --git a/modules/override/YAML/Any.pm b/modules/override/YAML/Any.pm deleted file mode 100644 index c2d35ee39..000000000 --- a/modules/override/YAML/Any.pm +++ /dev/null @@ -1,122 +0,0 @@ -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; diff --git a/modules/override/YAML/Dumper.pm b/modules/override/YAML/Dumper.pm deleted file mode 100644 index 5f75ab216..000000000 --- a/modules/override/YAML/Dumper.pm +++ /dev/null @@ -1,575 +0,0 @@ -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; diff --git a/modules/override/YAML/Dumper/Base.pm b/modules/override/YAML/Dumper/Base.pm deleted file mode 100644 index 23db7b1e6..000000000 --- a/modules/override/YAML/Dumper/Base.pm +++ /dev/null @@ -1,111 +0,0 @@ -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; diff --git a/modules/override/YAML/Error.pm b/modules/override/YAML/Error.pm deleted file mode 100644 index e855092f0..000000000 --- a/modules/override/YAML/Error.pm +++ /dev/null @@ -1,191 +0,0 @@ -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; diff --git a/modules/override/YAML/Loader.pm b/modules/override/YAML/Loader.pm deleted file mode 100644 index 2cef54e8e..000000000 --- a/modules/override/YAML/Loader.pm +++ /dev/null @@ -1,756 +0,0 @@ -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; diff --git a/modules/override/YAML/Loader/Base.pm b/modules/override/YAML/Loader/Base.pm deleted file mode 100644 index 6a3504c80..000000000 --- a/modules/override/YAML/Loader/Base.pm +++ /dev/null @@ -1,33 +0,0 @@ -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; diff --git a/modules/override/YAML/Marshall.pm b/modules/override/YAML/Marshall.pm deleted file mode 100644 index 14d378bed..000000000 --- a/modules/override/YAML/Marshall.pm +++ /dev/null @@ -1,47 +0,0 @@ -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; diff --git a/modules/override/YAML/Mo.pm b/modules/override/YAML/Mo.pm deleted file mode 100644 index c669ff090..000000000 --- a/modules/override/YAML/Mo.pm +++ /dev/null @@ -1,80 +0,0 @@ -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; diff --git a/modules/override/YAML/Node.pm b/modules/override/YAML/Node.pm deleted file mode 100644 index 81c272715..000000000 --- a/modules/override/YAML/Node.pm +++ /dev/null @@ -1,218 +0,0 @@ -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; diff --git a/modules/override/YAML/Tag.pm b/modules/override/YAML/Tag.pm deleted file mode 100644 index 57aef461c..000000000 --- a/modules/override/YAML/Tag.pm +++ /dev/null @@ -1,19 +0,0 @@ -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; diff --git a/modules/override/YAML/Types.pm b/modules/override/YAML/Types.pm deleted file mode 100644 index 8cbbde2c4..000000000 --- a/modules/override/YAML/Types.pm +++ /dev/null @@ -1,235 +0,0 @@ -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; diff --git a/scripts/locales.pl b/scripts/locales.pl index 105ca7cae..a4827b491 100755 --- a/scripts/locales.pl +++ b/scripts/locales.pl @@ -28,10 +28,9 @@ use IO::Dir; 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; @@ -534,7 +533,7 @@ sub scanfile { sub scanmenu { my $file = shift; - my $menu = YAML::LoadFile($file); + my $menu = SL::YAML::LoadFile($file); for my $node (@$menu) { # possible for override files diff --git a/sql/Pg-upgrade2/convert_drafts_to_record_templates.pl b/sql/Pg-upgrade2/convert_drafts_to_record_templates.pl index 0f02b1367..68c6a484f 100644 --- a/sql/Pg-upgrade2/convert_drafts_to_record_templates.pl +++ b/sql/Pg-upgrade2/convert_drafts_to_record_templates.pl @@ -6,11 +6,10 @@ package SL::DBUpgrade2::convert_drafts_to_record_templates; use strict; use utf8; -use YAML; - use parent qw(SL::DBUpgrade2::Base); use SL::DBUtils; +use SL::YAML; sub prepare_statements { my ($self) = @_; @@ -77,7 +76,7 @@ sub migrate_ar_drafts { $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; @@ -152,7 +151,7 @@ sub migrate_ap_drafts { $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; @@ -227,7 +226,7 @@ sub migrate_gl_drafts { $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 = ( -- 2.20.1