summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/YAML/Base.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/YAML/Base.pm')
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/YAML/Base.pm204
1 files changed, 204 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/YAML/Base.pm b/Master/tlpkg/tlperl0/lib/YAML/Base.pm
new file mode 100755
index 00000000000..2899f87238f
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/YAML/Base.pm
@@ -0,0 +1,204 @@
+package YAML::Base;
+
+use strict;
+use warnings;
+use Exporter ();
+
+our $VERSION = '0.71';
+our @ISA = 'Exporter';
+our @EXPORT = qw(field XXX);
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my $self = bless {}, $class;
+ while (@_) {
+ my $method = shift;
+ $self->$method(shift);
+ }
+ return $self;
+}
+
+# Use lexical subs to reduce pollution of private methods by base class.
+my ($_new_error, $_info, $_scalar_info, $parse_arguments, $default_as_code);
+
+sub XXX {
+ require Data::Dumper;
+ CORE::die(Data::Dumper::Dumper(@_));
+}
+
+my %code = (
+ sub_start =>
+ "sub {\n",
+ set_default =>
+ " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
+ init =>
+ " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
+ " unless \$#_ > 0 or defined \$_[0]->{%s};\n",
+ return_if_get =>
+ " return \$_[0]->{%s} unless \$#_ > 0;\n",
+ set =>
+ " \$_[0]->{%s} = \$_[1];\n",
+ sub_end =>
+ " return \$_[0]->{%s};\n}\n",
+);
+
+sub field {
+ my $package = caller;
+ my ($args, @values) = &$parse_arguments(
+ [ qw(-package -init) ],
+ @_,
+ );
+ my ($field, $default) = @values;
+ $package = $args->{-package} if defined $args->{-package};
+ return if defined &{"${package}::$field"};
+ my $default_string =
+ ( ref($default) eq 'ARRAY' and not @$default )
+ ? '[]'
+ : (ref($default) eq 'HASH' and not keys %$default )
+ ? '{}'
+ : &$default_as_code($default);
+
+ my $code = $code{sub_start};
+ if ($args->{-init}) {
+ my $fragment = $code{init};
+ $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
+ }
+ $code .= sprintf $code{set_default}, $field, $default_string, $field
+ if defined $default;
+ $code .= sprintf $code{return_if_get}, $field;
+ $code .= sprintf $code{set}, $field;
+ $code .= sprintf $code{sub_end}, $field;
+
+ my $sub = eval $code;
+ die $@ if $@;
+ no strict 'refs';
+ *{"${package}::$field"} = $sub;
+ return $code if defined wantarray;
+}
+
+sub die {
+ my $self = shift;
+ my $error = $self->$_new_error(@_);
+ $error->type('Error');
+ Carp::croak($error->format_message);
+}
+
+sub warn {
+ my $self = shift;
+ return unless $^W;
+ my $error = $self->$_new_error(@_);
+ $error->type('Warning');
+ Carp::cluck($error->format_message);
+}
+
+# This code needs to be refactored to be simpler and more precise, and no,
+# Scalar::Util doesn't DWIM.
+#
+# Can't handle:
+# * blessed regexp
+sub node_info {
+ my $self = shift;
+ my $stringify = $_[1] || 0;
+ my ($class, $type, $id) =
+ ref($_[0])
+ ? $stringify
+ ? &$_info("$_[0]")
+ : do {
+ require overload;
+ my @info = &$_info(overload::StrVal($_[0]));
+ if (ref($_[0]) eq 'Regexp') {
+ @info[0, 1] = (undef, 'REGEXP');
+ }
+ @info;
+ }
+ : &$_scalar_info($_[0]);
+ ($class, $type, $id) = &$_scalar_info("$_[0]")
+ unless $id;
+ return wantarray ? ($class, $type, $id) : $id;
+}
+
+#-------------------------------------------------------------------------------
+$_info = sub {
+ return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o);
+};
+
+$_scalar_info = sub {
+ my $id = 'undef';
+ if (defined $_[0]) {
+ \$_[0] =~ /\((\w+)\)$/o or CORE::die();
+ $id = "$1-S";
+ }
+ return (undef, undef, $id);
+};
+
+$_new_error = sub {
+ require Carp;
+ my $self = shift;
+ require YAML::Error;
+
+ my $code = shift || 'unknown error';
+ my $error = YAML::Error->new(code => $code);
+ $error->line($self->line) if $self->can('line');
+ $error->document($self->document) if $self->can('document');
+ $error->arguments([@_]);
+ return $error;
+};
+
+$parse_arguments = sub {
+ my $paired_arguments = shift || [];
+ my ($args, @values) = ({}, ());
+ my %pairs = map { ($_, 1) } @$paired_arguments;
+ while (@_) {
+ my $elem = shift;
+ if (defined $elem and defined $pairs{$elem} and @_) {
+ $args->{$elem} = shift;
+ }
+ else {
+ push @values, $elem;
+ }
+ }
+ return wantarray ? ($args, @values) : $args;
+};
+
+$default_as_code = sub {
+ no warnings 'once';
+ require Data::Dumper;
+ local $Data::Dumper::Sortkeys = 1;
+ my $code = Data::Dumper::Dumper(shift);
+ $code =~ s/^\$VAR1 = //;
+ $code =~ s/;$//;
+ return $code;
+};
+
+1;
+
+__END__
+
+=head1 NAME
+
+YAML::Base - Base class for YAML classes
+
+=head1 SYNOPSIS
+
+ package YAML::Something;
+ use YAML::Base -base;
+
+=head1 DESCRIPTION
+
+YAML::Base is the parent of all YAML classes.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut