|
use strict; use warnings;
|
|
package YAML::Node;
|
|
|
|
use YAML::Tag;
|
|
require YAML::Mo;
|
|
|
|
use Exporter;
|
|
our @ISA = qw(Exporter YAML::Mo::Object);
|
|
our @EXPORT = qw(ynode);
|
|
|
|
sub ynode {
|
|
my $self;
|
|
if (ref($_[0]) eq 'HASH') {
|
|
$self = tied(%{$_[0]});
|
|
}
|
|
elsif (ref($_[0]) eq 'ARRAY') {
|
|
$self = tied(@{$_[0]});
|
|
}
|
|
elsif (ref(\$_[0]) eq 'GLOB') {
|
|
$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) = YAML::Mo::Object->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;
|