local-lib5/lib/perl5/YAML/Node.pm

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