modules/override/YAML/Base.pm

   1 package YAML::Base;
   2 use strict; use warnings;
   3 use base 'Exporter';
   4
   5 our @EXPORT = qw(field XXX);
   6
   7 sub new {
   8     my $class = shift;
   9     $class = ref($class) || $class;
  10     my $self = bless {}, $class;
  11     while (@_) {
  12         my $method = shift;
  13         $self->$method(shift);
  14     }
  15     return $self;
  16 }
  17
  18 # Use lexical subs to reduce pollution of private methods by base class.
  19 my ($_new_error, $_info, $_scalar_info, $parse_arguments, $default_as_code);
  20
  21 sub XXX {
  22     require Data::Dumper;
  23     CORE::die(Data::Dumper::Dumper(@_));
  24 }
  25
  26 my %code = (
  27     sub_start =>
  28       "sub {\n",
  29     set_default =>
  30       "  \$_[0]->{%s} = %s\n    unless exists \$_[0]->{%s};\n",
  31     init =>
  32       "  return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
  33       "    unless \$#_ > 0 or defined \$_[0]->{%s};\n",
  34     return_if_get =>
  35       "  return \$_[0]->{%s} unless \$#_ > 0;\n",
  36     set =>
  37       "  \$_[0]->{%s} = \$_[1];\n",
  38     sub_end =>
  39       "  return \$_[0]->{%s};\n}\n",
  40 );
  41
  42 sub field {
  43     my $package = caller;
  44     my ($args, @values) = &$parse_arguments(
  45         [ qw(-package -init) ],
  46         @_,
  47     );
  48     my ($field, $default) = @values;
  49     $package = $args->{-package} if defined $args->{-package};
  50     return if defined &{"${package}::$field"};
  51     my $default_string =
  52         ( ref($default) eq 'ARRAY' and not @$default )
  53         ? '[]'
  54         : (ref($default) eq 'HASH' and not keys %$default )
  55           ? '{}'
  56           : &$default_as_code($default);
  57
  58     my $code = $code{sub_start};
  59     if ($args->{-init}) {
  60         my $fragment = $code{init};
  61         $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
  62     }
  63     $code .= sprintf $code{set_default}, $field, $default_string, $field
  64       if defined $default;
  65     $code .= sprintf $code{return_if_get}, $field;
  66     $code .= sprintf $code{set}, $field;
  67     $code .= sprintf $code{sub_end}, $field;
  68
  69     my $sub = eval $code;
  70     die $@ if $@;
  71     no strict 'refs';
  72     *{"${package}::$field"} = $sub;
  73     return $code if defined wantarray;
  74 }
  75
  76 sub die {
  77     my $self = shift;
  78     my $error = $self->$_new_error(@_);
  79     $error->type('Error');
  80     Carp::croak($error->format_message);
  81 }
  82
  83 sub warn {
  84     my $self = shift;
  85     return unless $^W;
  86     my $error = $self->$_new_error(@_);
  87     $error->type('Warning');
  88     Carp::cluck($error->format_message);
  89 }
  90
  91 # This code needs to be refactored to be simpler and more precise, and no,
  92 # Scalar::Util doesn't DWIM.
  93 #
  94 # Can't handle:
  95 # * blessed regexp
  96 sub node_info {
  97     my $self = shift;
  98     my $stringify = $_[1] || 0;
  99     my ($class, $type, $id) =
 100         ref($_[0])
 101         ? $stringify
 102           ? &$_info("$_[0]")
 103           : do {
 104               require overload;
 105               my @info = &$_info(overload::StrVal($_[0]));
 106               if (ref($_[0]) eq 'Regexp') {
 107                   @info[0, 1] = (undef, 'REGEXP');
 108               }
 109               @info;
 110           }
 111         : &$_scalar_info($_[0]);
 112     ($class, $type, $id) = &$_scalar_info("$_[0]")
 113         unless $id;
 114     return wantarray ? ($class, $type, $id) : $id;
 115 }
 116
 117 #-------------------------------------------------------------------------------
 118 $_info = sub {
 119     return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o);
 120 };
 121
 122 $_scalar_info = sub {
 123     my $id = 'undef';
 124     if (defined $_[0]) {
 125         \$_[0] =~ /\((\w+)\)$/o or CORE::die();
 126         $id = "$1-S";
 127     }
 128     return (undef, undef, $id);
 129 };
 130
 131 $_new_error = sub {
 132     require Carp;
 133     my $self = shift;
 134     require YAML::Error;
 135
 136     my $code = shift || 'unknown error';
 137     my $error = YAML::Error->new(code => $code);
 138     $error->line($self->line) if $self->can('line');
 139     $error->document($self->document) if $self->can('document');
 140     $error->arguments([@_]);
 141     return $error;
 142 };
 143
 144 $parse_arguments = sub {
 145     my $paired_arguments = shift || [];
 146     my ($args, @values) = ({}, ());
 147     my %pairs = map { ($_, 1) } @$paired_arguments;
 148     while (@_) {
 149         my $elem = shift;
 150         if (defined $elem and defined $pairs{$elem} and @_) {
 151             $args->{$elem} = shift;
 152         }
 153         else {
 154             push @values, $elem;
 155         }
 156     }
 157     return wantarray ? ($args, @values) : $args;
 158 };
 159
 160 $default_as_code = sub {
 161     no warnings 'once';
 162     require Data::Dumper;
 163     local $Data::Dumper::Sortkeys = 1;
 164     my $code = Data::Dumper::Dumper(shift);
 165     $code =~ s/^\$VAR1 = //;
 166     $code =~ s/;$//;
 167     return $code;
 168 };
 169
 170 1;
 171
 172 __END__
 173
 174 =head1 NAME
 175
 176 YAML::Base - Base class for YAML classes
 177
 178 =head1 SYNOPSIS
 179
 180     package YAML::Something;
 181     use YAML::Base -base;
 182
 183 =head1 DESCRIPTION
 184
 185 YAML::Base is the parent of all YAML classes.
 186
 187 =head1 AUTHOR
 188
 189 Ingy döt Net <ingy@cpan.org>
 190
 191 =head1 COPYRIGHT
 192
 193 Copyright (c) 2006. Ingy döt Net. All rights reserved.
 194
 195 This program is free software; you can redistribute it and/or modify it
 196 under the same terms as Perl itself.
 197
 198 See L<http://www.perl.com/perl/misc/Artistic.html>
 199
 200 =cut