modules/override/YAML/Node.pm

   1 package YAML::Node;
   2 use strict; use warnings;
   3 use YAML::Base; use base 'YAML::Base';
   4 use YAML::Tag;
   5
   6 our @EXPORT = qw(ynode);
   7
   8 sub ynode {
   9     my $self;
  10     if (ref($_[0]) eq 'HASH') {
  11         $self = tied(%{$_[0]});
  12     }
  13     elsif (ref($_[0]) eq 'ARRAY') {
  14         $self = tied(@{$_[0]});
  15     }
  16     else {
  17         $self = tied($_[0]);
  18     }
  19     return (ref($self) =~ /^yaml_/) ? $self : undef;
  20 }
  21
  22 sub new {
  23     my ($class, $node, $tag) = @_;
  24     my $self;
  25     $self->{NODE} = $node;
  26     my (undef, $type) = $class->node_info($node);
  27     $self->{KIND} = (not defined $type) ? 'scalar' :
  28                     ($type eq 'ARRAY') ? 'sequence' :
  29                     ($type eq 'HASH') ? 'mapping' :
  30                     $class->die("Can't create YAML::Node from '$type'");
  31     tag($self, ($tag || ''));
  32     if ($self->{KIND} eq 'scalar') {
  33         yaml_scalar->new($self, $_[1]);
  34         return \ $_[1];
  35     }
  36     my $package = "yaml_" . $self->{KIND};
  37     $package->new($self)
  38 }
  39
  40 sub node { $_->{NODE} }
  41 sub kind { $_->{KIND} }
  42 sub tag {
  43     my ($self, $value) = @_;
  44     if (defined $value) {
  45         $self->{TAG} = YAML::Tag->new($value);
  46         return $self;
  47     }
  48     else {
  49        return $self->{TAG};
  50     }
  51 }
  52 sub keys {
  53     my ($self, $value) = @_;
  54     if (defined $value) {
  55         $self->{KEYS} = $value;
  56         return $self;
  57     }
  58     else {
  59        return $self->{KEYS};
  60     }
  61 }
  62
  63 #==============================================================================
  64 package yaml_scalar;
  65 @yaml_scalar::ISA = qw(YAML::Node);
  66
  67 sub new {
  68     my ($class, $self) = @_;
  69     tie $_[2], $class, $self;
  70 }
  71
  72 sub TIESCALAR {
  73     my ($class, $self) = @_;
  74     bless $self, $class;
  75     $self
  76 }
  77
  78 sub FETCH {
  79     my ($self) = @_;
  80     $self->{NODE}
  81 }
  82
  83 sub STORE {
  84     my ($self, $value) = @_;
  85     $self->{NODE} = $value
  86 }
  87
  88 #==============================================================================
  89 package yaml_sequence;
  90 @yaml_sequence::ISA = qw(YAML::Node);
  91
  92 sub new {
  93     my ($class, $self) = @_;
  94     my $new;
  95     tie @$new, $class, $self;
  96     $new
  97 }
  98
  99 sub TIEARRAY {
 100     my ($class, $self) = @_;
 101     bless $self, $class
 102 }
 103
 104 sub FETCHSIZE {
 105     my ($self) = @_;
 106     scalar @{$self->{NODE}};
 107 }
 108
 109 sub FETCH {
 110     my ($self, $index) = @_;
 111     $self->{NODE}[$index]
 112 }
 113
 114 sub STORE {
 115     my ($self, $index, $value) = @_;
 116     $self->{NODE}[$index] = $value
 117 }
 118
 119 sub undone {
 120     die "Not implemented yet"; # XXX
 121 }
 122
 123 *STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
 124 *STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
 125 *undone; # XXX Must implement before release
 126
 127 #==============================================================================
 128 package yaml_mapping;
 129 @yaml_mapping::ISA = qw(YAML::Node);
 130
 131 sub new {
 132     my ($class, $self) = @_;
 133     @{$self->{KEYS}} = sort keys %{$self->{NODE}};
 134     my $new;
 135     tie %$new, $class, $self;
 136     $new
 137 }
 138
 139 sub TIEHASH {
 140     my ($class, $self) = @_;
 141     bless $self, $class
 142 }
 143
 144 sub FETCH {
 145     my ($self, $key) = @_;
 146     if (exists $self->{NODE}{$key}) {
 147         return (grep {$_ eq $key} @{$self->{KEYS}})
 148                ? $self->{NODE}{$key} : undef;
 149     }
 150     return $self->{HASH}{$key};
 151 }
 152
 153 sub STORE {
 154     my ($self, $key, $value) = @_;
 155     if (exists $self->{NODE}{$key}) {
 156         $self->{NODE}{$key} = $value;
 157     }
 158     elsif (exists $self->{HASH}{$key}) {
 159         $self->{HASH}{$key} = $value;
 160     }
 161     else {
 162         if (not grep {$_ eq $key} @{$self->{KEYS}}) {
 163             push(@{$self->{KEYS}}, $key);
 164         }
 165         $self->{HASH}{$key} = $value;
 166     }
 167     $value
 168 }
 169
 170 sub DELETE {
 171     my ($self, $key) = @_;
 172     my $return;
 173     if (exists $self->{NODE}{$key}) {
 174         $return = $self->{NODE}{$key};
 175     }
 176     elsif (exists $self->{HASH}{$key}) {
 177         $return = delete $self->{NODE}{$key};
 178     }
 179     for (my $i = 0; $i < @{$self->{KEYS}}; $i++) {
 180         if ($self->{KEYS}[$i] eq $key) {
 181             splice(@{$self->{KEYS}}, $i, 1);
 182         }
 183     }
 184     return $return;
 185 }
 186
 187 sub CLEAR {
 188     my ($self) = @_;
 189     @{$self->{KEYS}} = ();
 190     %{$self->{HASH}} = ();
 191 }
 192
 193 sub FIRSTKEY {
 194     my ($self) = @_;
 195     $self->{ITER} = 0;
 196     $self->{KEYS}[0]
 197 }
 198
 199 sub NEXTKEY {
 200     my ($self) = @_;
 201     $self->{KEYS}[++$self->{ITER}]
 202 }
 203
 204 sub EXISTS {
 205     my ($self, $key) = @_;
 206     exists $self->{NODE}{$key}
 207 }
 208
 209 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