Revision c6bc1816
Von Sven Schöling vor etwa 9 Jahren hinzugefügt
modules/override/YAML/Node.pm | ||
---|---|---|
1 |
package YAML::Node; |
|
2 | 1 |
use strict; use warnings; |
3 |
use YAML::Base; use base 'YAML::Base'; |
|
2 |
package YAML::Node; |
|
3 |
|
|
4 | 4 |
use YAML::Tag; |
5 |
require YAML::Mo; |
|
5 | 6 |
|
6 |
our @EXPORT = qw(ynode); |
|
7 |
use Exporter; |
|
8 |
our @ISA = qw(Exporter YAML::Mo::Object); |
|
9 |
our @EXPORT = qw(ynode); |
|
7 | 10 |
|
8 | 11 |
sub ynode { |
9 | 12 |
my $self; |
10 | 13 |
if (ref($_[0]) eq 'HASH') { |
11 |
$self = tied(%{$_[0]});
|
|
14 |
$self = tied(%{$_[0]});
|
|
12 | 15 |
} |
13 | 16 |
elsif (ref($_[0]) eq 'ARRAY') { |
14 |
$self = tied(@{$_[0]}); |
|
17 |
$self = tied(@{$_[0]}); |
|
18 |
} |
|
19 |
elsif (ref(\$_[0]) eq 'GLOB') { |
|
20 |
$self = tied(*{$_[0]}); |
|
15 | 21 |
} |
16 | 22 |
else { |
17 |
$self = tied($_[0]);
|
|
23 |
$self = tied($_[0]);
|
|
18 | 24 |
} |
19 | 25 |
return (ref($self) =~ /^yaml_/) ? $self : undef; |
20 | 26 |
} |
... | ... | |
23 | 29 |
my ($class, $node, $tag) = @_; |
24 | 30 |
my $self; |
25 | 31 |
$self->{NODE} = $node; |
26 |
my (undef, $type) = $class->node_info($node);
|
|
32 |
my (undef, $type) = YAML::Mo::Object->node_info($node);
|
|
27 | 33 |
$self->{KIND} = (not defined $type) ? 'scalar' : |
28 | 34 |
($type eq 'ARRAY') ? 'sequence' : |
29 |
($type eq 'HASH') ? 'mapping' :
|
|
30 |
$class->die("Can't create YAML::Node from '$type'");
|
|
35 |
($type eq 'HASH') ? 'mapping' :
|
|
36 |
$class->die("Can't create YAML::Node from '$type'");
|
|
31 | 37 |
tag($self, ($tag || '')); |
32 | 38 |
if ($self->{KIND} eq 'scalar') { |
33 |
yaml_scalar->new($self, $_[1]);
|
|
34 |
return \ $_[1];
|
|
39 |
yaml_scalar->new($self, $_[1]);
|
|
40 |
return \ $_[1];
|
|
35 | 41 |
} |
36 |
my $package = "yaml_" . $self->{KIND};
|
|
42 |
my $package = "yaml_" . $self->{KIND}; |
|
37 | 43 |
$package->new($self) |
38 | 44 |
} |
39 | 45 |
|
... | ... | |
42 | 48 |
sub tag { |
43 | 49 |
my ($self, $value) = @_; |
44 | 50 |
if (defined $value) { |
45 |
$self->{TAG} = YAML::Tag->new($value);
|
|
46 |
return $self;
|
|
51 |
$self->{TAG} = YAML::Tag->new($value);
|
|
52 |
return $self;
|
|
47 | 53 |
} |
48 | 54 |
else { |
49 | 55 |
return $self->{TAG}; |
... | ... | |
52 | 58 |
sub keys { |
53 | 59 |
my ($self, $value) = @_; |
54 | 60 |
if (defined $value) { |
55 |
$self->{KEYS} = $value;
|
|
56 |
return $self;
|
|
61 |
$self->{KEYS} = $value;
|
|
62 |
return $self;
|
|
57 | 63 |
} |
58 | 64 |
else { |
59 | 65 |
return $self->{KEYS}; |
... | ... | |
62 | 68 |
|
63 | 69 |
#============================================================================== |
64 | 70 |
package yaml_scalar; |
71 |
|
|
65 | 72 |
@yaml_scalar::ISA = qw(YAML::Node); |
66 | 73 |
|
67 | 74 |
sub new { |
... | ... | |
87 | 94 |
|
88 | 95 |
#============================================================================== |
89 | 96 |
package yaml_sequence; |
97 |
|
|
90 | 98 |
@yaml_sequence::ISA = qw(YAML::Node); |
91 | 99 |
|
92 | 100 |
sub new { |
... | ... | |
120 | 128 |
die "Not implemented yet"; # XXX |
121 | 129 |
} |
122 | 130 |
|
123 |
*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
|
|
124 |
*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
|
|
131 |
*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = |
|
132 |
*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = |
|
125 | 133 |
*undone; # XXX Must implement before release |
126 | 134 |
|
127 | 135 |
#============================================================================== |
128 | 136 |
package yaml_mapping; |
137 |
|
|
129 | 138 |
@yaml_mapping::ISA = qw(YAML::Node); |
130 | 139 |
|
131 | 140 |
sub new { |
132 | 141 |
my ($class, $self) = @_; |
133 |
@{$self->{KEYS}} = sort keys %{$self->{NODE}};
|
|
142 |
@{$self->{KEYS}} = sort keys %{$self->{NODE}}; |
|
134 | 143 |
my $new; |
135 | 144 |
tie %$new, $class, $self; |
136 | 145 |
$new |
... | ... | |
144 | 153 |
sub FETCH { |
145 | 154 |
my ($self, $key) = @_; |
146 | 155 |
if (exists $self->{NODE}{$key}) { |
147 |
return (grep {$_ eq $key} @{$self->{KEYS}})
|
|
148 |
? $self->{NODE}{$key} : undef;
|
|
156 |
return (grep {$_ eq $key} @{$self->{KEYS}})
|
|
157 |
? $self->{NODE}{$key} : undef;
|
|
149 | 158 |
} |
150 | 159 |
return $self->{HASH}{$key}; |
151 | 160 |
} |
... | ... | |
153 | 162 |
sub STORE { |
154 | 163 |
my ($self, $key, $value) = @_; |
155 | 164 |
if (exists $self->{NODE}{$key}) { |
156 |
$self->{NODE}{$key} = $value;
|
|
165 |
$self->{NODE}{$key} = $value;
|
|
157 | 166 |
} |
158 | 167 |
elsif (exists $self->{HASH}{$key}) { |
159 |
$self->{HASH}{$key} = $value;
|
|
168 |
$self->{HASH}{$key} = $value;
|
|
160 | 169 |
} |
161 | 170 |
else { |
162 |
if (not grep {$_ eq $key} @{$self->{KEYS}}) {
|
|
163 |
push(@{$self->{KEYS}}, $key);
|
|
164 |
}
|
|
165 |
$self->{HASH}{$key} = $value;
|
|
171 |
if (not grep {$_ eq $key} @{$self->{KEYS}}) {
|
|
172 |
push(@{$self->{KEYS}}, $key);
|
|
173 |
}
|
|
174 |
$self->{HASH}{$key} = $value;
|
|
166 | 175 |
} |
167 | 176 |
$value |
168 | 177 |
} |
... | ... | |
171 | 180 |
my ($self, $key) = @_; |
172 | 181 |
my $return; |
173 | 182 |
if (exists $self->{NODE}{$key}) { |
174 |
$return = $self->{NODE}{$key};
|
|
183 |
$return = $self->{NODE}{$key};
|
|
175 | 184 |
} |
176 | 185 |
elsif (exists $self->{HASH}{$key}) { |
177 |
$return = delete $self->{NODE}{$key};
|
|
186 |
$return = delete $self->{NODE}{$key};
|
|
178 | 187 |
} |
179 | 188 |
for (my $i = 0; $i < @{$self->{KEYS}}; $i++) { |
180 |
if ($self->{KEYS}[$i] eq $key) {
|
|
181 |
splice(@{$self->{KEYS}}, $i, 1);
|
|
182 |
}
|
|
189 |
if ($self->{KEYS}[$i] eq $key) {
|
|
190 |
splice(@{$self->{KEYS}}, $i, 1);
|
|
191 |
}
|
|
183 | 192 |
} |
184 | 193 |
return $return; |
185 | 194 |
} |
... | ... | |
207 | 216 |
} |
208 | 217 |
|
209 | 218 |
1; |
210 |
|
|
211 |
__END__ |
|
212 |
|
|
213 |
=head1 NAME |
|
214 |
|
|
215 |
YAML::Node - A generic data node that encapsulates YAML information |
|
216 |
|
|
217 |
=head1 SYNOPSIS |
|
218 |
|
|
219 |
use YAML; |
|
220 |
use YAML::Node; |
|
221 |
|
|
222 |
my $ynode = YAML::Node->new({}, 'ingerson.com/fruit'); |
|
223 |
%$ynode = qw(orange orange apple red grape green); |
|
224 |
print Dump $ynode; |
|
225 |
|
|
226 |
yields: |
|
227 |
|
|
228 |
--- !ingerson.com/fruit |
|
229 |
orange: orange |
|
230 |
apple: red |
|
231 |
grape: green |
|
232 |
|
|
233 |
=head1 DESCRIPTION |
|
234 |
|
|
235 |
A generic node in YAML is similar to a plain hash, array, or scalar node |
|
236 |
in Perl except that it must also keep track of its type. The type is a |
|
237 |
URI called the YAML type tag. |
|
238 |
|
|
239 |
YAML::Node is a class for generating and manipulating these containers. |
|
240 |
A YAML node (or ynode) is a tied hash, array or scalar. In most ways it |
|
241 |
behaves just like the plain thing. But you can assign and retrieve and |
|
242 |
YAML type tag URI to it. For the hash flavor, you can also assign the |
|
243 |
order that the keys will be retrieved in. By default a ynode will offer |
|
244 |
its keys in the same order that they were assigned. |
|
245 |
|
|
246 |
YAML::Node has a class method call new() that will return a ynode. You |
|
247 |
pass it a regular node and an optional type tag. After that you can |
|
248 |
use it like a normal Perl node, but when you YAML::Dump it, the magical |
|
249 |
properties will be honored. |
|
250 |
|
|
251 |
This is how you can control the sort order of hash keys during a YAML |
|
252 |
serialization. By default, YAML sorts keys alphabetically. But notice |
|
253 |
in the above example that the keys were Dumped in the same order they |
|
254 |
were assigned. |
|
255 |
|
|
256 |
YAML::Node exports a function called ynode(). This function returns the tied object so that you can call special methods on it like ->keys(). |
|
257 |
|
|
258 |
keys() works like this: |
|
259 |
|
|
260 |
use YAML; |
|
261 |
use YAML::Node; |
|
262 |
|
|
263 |
%$node = qw(orange orange apple red grape green); |
|
264 |
$ynode = YAML::Node->new($node); |
|
265 |
ynode($ynode)->keys(['grape', 'apple']); |
|
266 |
print Dump $ynode; |
|
267 |
|
|
268 |
produces: |
|
269 |
|
|
270 |
--- |
|
271 |
grape: green |
|
272 |
apple: red |
|
273 |
|
|
274 |
It tells the ynode which keys and what order to use. |
|
275 |
|
|
276 |
ynodes will play a very important role in how programs use YAML. They |
|
277 |
are the foundation of how a Perl class can marshall the Loading and |
|
278 |
Dumping of its objects. |
|
279 |
|
|
280 |
The upcoming versions of YAML.pm will have much more information on this. |
|
281 |
|
|
282 |
=head1 AUTHOR |
|
283 |
|
|
284 |
Ingy döt Net <ingy@cpan.org> |
|
285 |
|
|
286 |
=head1 COPYRIGHT |
|
287 |
|
|
288 |
Copyright (c) 2006. Ingy döt Net. All rights reserved. |
|
289 |
Copyright (c) 2002. Brian Ingerson. All rights reserved. |
|
290 |
|
|
291 |
This program is free software; you can redistribute it and/or modify it |
|
292 |
under the same terms as Perl itself. |
|
293 |
|
|
294 |
See L<http://www.perl.com/perl/misc/Artistic.html> |
|
295 |
|
|
296 |
=cut |
Auch abrufbar als: Unified diff
YAML: Versionsupdate