Projekt

Allgemein

Profil

« Zurück | Weiter » 

Revision c6bc1816

Von Sven Schöling vor etwa 9 Jahren hinzugefügt

  • ID c6bc181610ac4dd26cfd615075bcc8686dc219cf
  • Vorgänger 778622af
  • Nachfolger e8521020

YAML: Versionsupdate

Unterschiede anzeigen:

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