X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FGitalist.git;a=blobdiff_plain;f=local-lib5%2Flib%2Fperl5%2FYAML%2FNode.pm;fp=local-lib5%2Flib%2Fperl5%2FYAML%2FNode.pm;h=223e1627a93ea9c96029015f1ebdd0a7d1bc2154;hp=0000000000000000000000000000000000000000;hb=3fea05b9fbf95091f4522528b9980a33e0235603;hpb=af746827daa7a8feccee889e1d12ebc74cc9201e diff --git a/local-lib5/lib/perl5/YAML/Node.pm b/local-lib5/lib/perl5/YAML/Node.pm new file mode 100644 index 0000000..223e162 --- /dev/null +++ b/local-lib5/lib/perl5/YAML/Node.pm @@ -0,0 +1,305 @@ +package YAML::Node; + +use strict; +use warnings; + +use YAML::Base; +use YAML::Tag; + +our $VERSION = '0.70'; +our @ISA = 'YAML::Base'; +our @EXPORT = qw(ynode); + +sub ynode { + my $self; + if (ref($_[0]) eq 'HASH') { + $self = tied(%{$_[0]}); + } + elsif (ref($_[0]) eq 'ARRAY') { + $self = tied(@{$_[0]}); + } + else { + $self = tied($_[0]); + } + return (ref($self) =~ /^yaml_/) ? $self : undef; +} + +sub new { + my ($class, $node, $tag) = @_; + my $self; + $self->{NODE} = $node; + my (undef, $type) = $class->node_info($node); + $self->{KIND} = (not defined $type) ? 'scalar' : + ($type eq 'ARRAY') ? 'sequence' : + ($type eq 'HASH') ? 'mapping' : + $class->die("Can't create YAML::Node from '$type'"); + tag($self, ($tag || '')); + if ($self->{KIND} eq 'scalar') { + yaml_scalar->new($self, $_[1]); + return \ $_[1]; + } + my $package = "yaml_" . $self->{KIND}; + $package->new($self) +} + +sub node { $_->{NODE} } +sub kind { $_->{KIND} } +sub tag { + my ($self, $value) = @_; + if (defined $value) { + $self->{TAG} = YAML::Tag->new($value); + return $self; + } + else { + return $self->{TAG}; + } +} +sub keys { + my ($self, $value) = @_; + if (defined $value) { + $self->{KEYS} = $value; + return $self; + } + else { + return $self->{KEYS}; + } +} + +#============================================================================== +package yaml_scalar; + +@yaml_scalar::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + tie $_[2], $class, $self; +} + +sub TIESCALAR { + my ($class, $self) = @_; + bless $self, $class; + $self +} + +sub FETCH { + my ($self) = @_; + $self->{NODE} +} + +sub STORE { + my ($self, $value) = @_; + $self->{NODE} = $value +} + +#============================================================================== +package yaml_sequence; + +@yaml_sequence::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + my $new; + tie @$new, $class, $self; + $new +} + +sub TIEARRAY { + my ($class, $self) = @_; + bless $self, $class +} + +sub FETCHSIZE { + my ($self) = @_; + scalar @{$self->{NODE}}; +} + +sub FETCH { + my ($self, $index) = @_; + $self->{NODE}[$index] +} + +sub STORE { + my ($self, $index, $value) = @_; + $self->{NODE}[$index] = $value +} + +sub undone { + die "Not implemented yet"; # XXX +} + +*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = +*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = +*undone; # XXX Must implement before release + +#============================================================================== +package yaml_mapping; + +@yaml_mapping::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + @{$self->{KEYS}} = sort keys %{$self->{NODE}}; + my $new; + tie %$new, $class, $self; + $new +} + +sub TIEHASH { + my ($class, $self) = @_; + bless $self, $class +} + +sub FETCH { + my ($self, $key) = @_; + if (exists $self->{NODE}{$key}) { + return (grep {$_ eq $key} @{$self->{KEYS}}) + ? $self->{NODE}{$key} : undef; + } + return $self->{HASH}{$key}; +} + +sub STORE { + my ($self, $key, $value) = @_; + if (exists $self->{NODE}{$key}) { + $self->{NODE}{$key} = $value; + } + elsif (exists $self->{HASH}{$key}) { + $self->{HASH}{$key} = $value; + } + else { + if (not grep {$_ eq $key} @{$self->{KEYS}}) { + push(@{$self->{KEYS}}, $key); + } + $self->{HASH}{$key} = $value; + } + $value +} + +sub DELETE { + my ($self, $key) = @_; + my $return; + if (exists $self->{NODE}{$key}) { + $return = $self->{NODE}{$key}; + } + elsif (exists $self->{HASH}{$key}) { + $return = delete $self->{NODE}{$key}; + } + for (my $i = 0; $i < @{$self->{KEYS}}; $i++) { + if ($self->{KEYS}[$i] eq $key) { + splice(@{$self->{KEYS}}, $i, 1); + } + } + return $return; +} + +sub CLEAR { + my ($self) = @_; + @{$self->{KEYS}} = (); + %{$self->{HASH}} = (); +} + +sub FIRSTKEY { + my ($self) = @_; + $self->{ITER} = 0; + $self->{KEYS}[0] +} + +sub NEXTKEY { + my ($self) = @_; + $self->{KEYS}[++$self->{ITER}] +} + +sub EXISTS { + my ($self, $key) = @_; + exists $self->{NODE}{$key} +} + +1; + +__END__ + +=head1 NAME + +YAML::Node - A generic data node that encapsulates YAML information + +=head1 SYNOPSIS + + use YAML; + use YAML::Node; + + my $ynode = YAML::Node->new({}, 'ingerson.com/fruit'); + %$ynode = qw(orange orange apple red grape green); + print Dump $ynode; + +yields: + + --- !ingerson.com/fruit + orange: orange + apple: red + grape: green + +=head1 DESCRIPTION + +A generic node in YAML is similar to a plain hash, array, or scalar node +in Perl except that it must also keep track of its type. The type is a +URI called the YAML type tag. + +YAML::Node is a class for generating and manipulating these containers. +A YAML node (or ynode) is a tied hash, array or scalar. In most ways it +behaves just like the plain thing. But you can assign and retrieve and +YAML type tag URI to it. For the hash flavor, you can also assign the +order that the keys will be retrieved in. By default a ynode will offer +its keys in the same order that they were assigned. + +YAML::Node has a class method call new() that will return a ynode. You +pass it a regular node and an optional type tag. After that you can +use it like a normal Perl node, but when you YAML::Dump it, the magical +properties will be honored. + +This is how you can control the sort order of hash keys during a YAML +serialization. By default, YAML sorts keys alphabetically. But notice +in the above example that the keys were Dumped in the same order they +were assigned. + +YAML::Node exports a function called ynode(). This function returns the tied object so that you can call special methods on it like ->keys(). + +keys() works like this: + + use YAML; + use YAML::Node; + + %$node = qw(orange orange apple red grape green); + $ynode = YAML::Node->new($node); + ynode($ynode)->keys(['grape', 'apple']); + print Dump $ynode; + +produces: + + --- + grape: green + apple: red + +It tells the ynode which keys and what order to use. + +ynodes will play a very important role in how programs use YAML. They +are the foundation of how a Perl class can marshall the Loading and +Dumping of its objects. + +The upcoming versions of YAML.pm will have much more information on this. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +Copyright (c) 2002. Brian Ingerson. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut