diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/YAML/Base.pm')
| -rwxr-xr-x | Master/tlpkg/tlperl0/lib/YAML/Base.pm | 204 |
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 |