Projekt

Allgemein

Profil

Herunterladen (4,32 KB) Statistiken
| Zweig: | Markierung: | Revision:

kivitendo/modules/override/YAML/Node.pm @ 5daf1cf9

99ed8abf Moritz Bunkus
use strict; use warnings;
c6bc1816 Sven Schöling
package YAML::Node;

99ed8abf Moritz Bunkus
use YAML::Tag;
c6bc1816 Sven Schöling
require YAML::Mo;
99ed8abf Moritz Bunkus
c6bc1816 Sven Schöling
use Exporter;
our @ISA = qw(Exporter YAML::Mo::Object);
our @EXPORT = qw(ynode);
99ed8abf Moritz Bunkus
sub ynode {
my $self;
if (ref($_[0]) eq 'HASH') {
c6bc1816 Sven Schöling
$self = tied(%{$_[0]});
99ed8abf Moritz Bunkus
}
elsif (ref($_[0]) eq 'ARRAY') {
c6bc1816 Sven Schöling
$self = tied(@{$_[0]});
}
elsif (ref(\$_[0]) eq 'GLOB') {
$self = tied(*{$_[0]});
99ed8abf Moritz Bunkus
}
else {
c6bc1816 Sven Schöling
$self = tied($_[0]);
99ed8abf Moritz Bunkus
}
return (ref($self) =~ /^yaml_/) ? $self : undef;
}

sub new {
my ($class, $node, $tag) = @_;
my $self;
$self->{NODE} = $node;
c6bc1816 Sven Schöling
my (undef, $type) = YAML::Mo::Object->node_info($node);
99ed8abf Moritz Bunkus
$self->{KIND} = (not defined $type) ? 'scalar' :
($type eq 'ARRAY') ? 'sequence' :
c6bc1816 Sven Schöling
($type eq 'HASH') ? 'mapping' :
$class->die("Can't create YAML::Node from '$type'");
99ed8abf Moritz Bunkus
tag($self, ($tag || ''));
if ($self->{KIND} eq 'scalar') {
c6bc1816 Sven Schöling
yaml_scalar->new($self, $_[1]);
return \ $_[1];
99ed8abf Moritz Bunkus
}
c6bc1816 Sven Schöling
my $package = "yaml_" . $self->{KIND};
99ed8abf Moritz Bunkus
$package->new($self)
}

sub node { $_->{NODE} }
sub kind { $_->{KIND} }
sub tag {
my ($self, $value) = @_;
if (defined $value) {
c6bc1816 Sven Schöling
$self->{TAG} = YAML::Tag->new($value);
return $self;
99ed8abf Moritz Bunkus
}
else {
return $self->{TAG};
}
}
sub keys {
my ($self, $value) = @_;
if (defined $value) {
c6bc1816 Sven Schöling
$self->{KEYS} = $value;
return $self;
99ed8abf Moritz Bunkus
}
else {
return $self->{KEYS};
}
}

#==============================================================================
package yaml_scalar;
c6bc1816 Sven Schöling
99ed8abf Moritz Bunkus
@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;
c6bc1816 Sven Schöling
99ed8abf Moritz Bunkus
@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
}

c6bc1816 Sven Schöling
*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
99ed8abf Moritz Bunkus
*undone; # XXX Must implement before release

#==============================================================================
package yaml_mapping;
c6bc1816 Sven Schöling
99ed8abf Moritz Bunkus
@yaml_mapping::ISA = qw(YAML::Node);

sub new {
my ($class, $self) = @_;
c6bc1816 Sven Schöling
@{$self->{KEYS}} = sort keys %{$self->{NODE}};
99ed8abf Moritz Bunkus
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}) {
c6bc1816 Sven Schöling
return (grep {$_ eq $key} @{$self->{KEYS}})
? $self->{NODE}{$key} : undef;
99ed8abf Moritz Bunkus
}
return $self->{HASH}{$key};
}

sub STORE {
my ($self, $key, $value) = @_;
if (exists $self->{NODE}{$key}) {
c6bc1816 Sven Schöling
$self->{NODE}{$key} = $value;
99ed8abf Moritz Bunkus
}
elsif (exists $self->{HASH}{$key}) {
c6bc1816 Sven Schöling
$self->{HASH}{$key} = $value;
99ed8abf Moritz Bunkus
}
else {
c6bc1816 Sven Schöling
if (not grep {$_ eq $key} @{$self->{KEYS}}) {
push(@{$self->{KEYS}}, $key);
}
$self->{HASH}{$key} = $value;
99ed8abf Moritz Bunkus
}
$value
}

sub DELETE {
my ($self, $key) = @_;
my $return;
if (exists $self->{NODE}{$key}) {
c6bc1816 Sven Schöling
$return = $self->{NODE}{$key};
99ed8abf Moritz Bunkus
}
elsif (exists $self->{HASH}{$key}) {
c6bc1816 Sven Schöling
$return = delete $self->{NODE}{$key};
99ed8abf Moritz Bunkus
}
for (my $i = 0; $i < @{$self->{KEYS}}; $i++) {
c6bc1816 Sven Schöling
if ($self->{KEYS}[$i] eq $key) {
splice(@{$self->{KEYS}}, $i, 1);
}
99ed8abf Moritz Bunkus
}
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;