init III

Perl OTRS/Kernel/cpan-lib/YAML/Node.pm

@@ -0,0 +1,218 @@
+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;