X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/kivitendo-erp.git/blobdiff_plain/deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44..53593baa211863fbf66540cf1bcc36c8fb37257f:/modules/override/YAML/Node.pm diff --git a/modules/override/YAML/Node.pm b/modules/override/YAML/Node.pm deleted file mode 100644 index 81c272715..000000000 --- a/modules/override/YAML/Node.pm +++ /dev/null @@ -1,218 +0,0 @@ -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;