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