2 use strict; use warnings;
5 our @EXPORT = qw(field XXX);
9 $class = ref($class) || $class;
10 my $self = bless {}, $class;
13 $self->$method(shift);
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);
23 CORE::die(Data::Dumper::Dumper(@_));
30 " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
32 " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
33 " unless \$#_ > 0 or defined \$_[0]->{%s};\n",
35 " return \$_[0]->{%s} unless \$#_ > 0;\n",
37 " \$_[0]->{%s} = \$_[1];\n",
39 " return \$_[0]->{%s};\n}\n",
44 my ($args, @values) = &$parse_arguments(
45 [ qw(-package -init) ],
48 my ($field, $default) = @values;
49 $package = $args->{-package} if defined $args->{-package};
50 return if defined &{"${package}::$field"};
52 ( ref($default) eq 'ARRAY' and not @$default )
54 : (ref($default) eq 'HASH' and not keys %$default )
56 : &$default_as_code($default);
58 my $code = $code{sub_start};
60 my $fragment = $code{init};
61 $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
63 $code .= sprintf $code{set_default}, $field, $default_string, $field
65 $code .= sprintf $code{return_if_get}, $field;
66 $code .= sprintf $code{set}, $field;
67 $code .= sprintf $code{sub_end}, $field;
72 *{"${package}::$field"} = $sub;
73 return $code if defined wantarray;
78 my $error = $self->$_new_error(@_);
79 $error->type('Error');
80 Carp::croak($error->format_message);
86 my $error = $self->$_new_error(@_);
87 $error->type('Warning');
88 Carp::cluck($error->format_message);
91 # This code needs to be refactored to be simpler and more precise, and no,
92 # Scalar::Util doesn't DWIM.
98 my $stringify = $_[1] || 0;
99 my ($class, $type, $id) =
105 my @info = &$_info(overload::StrVal($_[0]));
106 if (ref($_[0]) eq 'Regexp') {
107 @info[0, 1] = (undef, 'REGEXP');
111 : &$_scalar_info($_[0]);
112 ($class, $type, $id) = &$_scalar_info("$_[0]")
114 return wantarray ? ($class, $type, $id) : $id;
117 #-------------------------------------------------------------------------------
119 return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o);
122 $_scalar_info = sub {
125 \$_[0] =~ /\((\w+)\)$/o or CORE::die();
128 return (undef, undef, $id);
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([@_]);
144 $parse_arguments = sub {
145 my $paired_arguments = shift || [];
146 my ($args, @values) = ({}, ());
147 my %pairs = map { ($_, 1) } @$paired_arguments;
150 if (defined $elem and defined $pairs{$elem} and @_) {
151 $args->{$elem} = shift;
157 return wantarray ? ($args, @values) : $args;
160 $default_as_code = sub {
162 require Data::Dumper;
163 local $Data::Dumper::Sortkeys = 1;
164 my $code = Data::Dumper::Dumper(shift);
165 $code =~ s/^\$VAR1 = //;
176 YAML::Base - Base class for YAML classes
180 package YAML::Something;
181 use YAML::Base -base;
185 YAML::Base is the parent of all YAML classes.
189 Ingy döt Net <ingy@cpan.org>
193 Copyright (c) 2006. Ingy döt Net. All rights reserved.
195 This program is free software; you can redistribute it and/or modify it
196 under the same terms as Perl itself.
198 See L<http://www.perl.com/perl/misc/Artistic.html>