modules/override/YAML/Node.pm

   1 use strict; use warnings;
   2 package YAML::Node;
   3
   4 use YAML::Tag;
   5 require YAML::Mo;
   6
   7 use Exporter;
   8 our @ISA     = qw(Exporter YAML::Mo::Object);
   9 our @EXPORT  = qw(ynode);
  10
  11 sub ynode {
  12     my $self;
  13     if (ref($_[0]) eq 'HASH') {
  14         $self = tied(%{$_[0]});
  15     }
  16     elsif (ref($_[0]) eq 'ARRAY') {
  17         $self = tied(@{$_[0]});
  18     }
  19     elsif (ref(\$_[0]) eq 'GLOB') {
  20         $self = tied(*{$_[0]});
  21     }
  22     else {
  23         $self = tied($_[0]);
  24     }
  25     return (ref($self) =~ /^yaml_/) ? $self : undef;
  26 }
  27
  28 sub new {
  29     my ($class, $node, $tag) = @_;
  30     my $self;
  31     $self->{NODE} = $node;
  32     my (undef, $type) = YAML::Mo::Object->node_info($node);
  33     $self->{KIND} = (not defined $type) ? 'scalar' :
  34                     ($type eq 'ARRAY') ? 'sequence' :
  35                     ($type eq 'HASH') ? 'mapping' :
  36                     $class->die("Can't create YAML::Node from '$type'");
  37     tag($self, ($tag || ''));
  38     if ($self->{KIND} eq 'scalar') {
  39         yaml_scalar->new($self, $_[1]);
  40         return \ $_[1];
  41     }
  42     my $package = "yaml_" . $self->{KIND};
  43     $package->new($self)
  44 }
  45
  46 sub node { $_->{NODE} }
  47 sub kind { $_->{KIND} }
  48 sub tag {
  49     my ($self, $value) = @_;
  50     if (defined $value) {
  51                $self->{TAG} = YAML::Tag->new($value);
  52         return $self;
  53     }
  54     else {
  55        return $self->{TAG};
  56     }
  57 }
  58 sub keys {
  59     my ($self, $value) = @_;
  60     if (defined $value) {
  61                $self->{KEYS} = $value;
  62         return $self;
  63     }
  64     else {
  65        return $self->{KEYS};
  66     }
  67 }
  68
  69 #==============================================================================
  70 package yaml_scalar;
  71
  72 @yaml_scalar::ISA = qw(YAML::Node);
  73
  74 sub new {
  75     my ($class, $self) = @_;
  76     tie $_[2], $class, $self;
  77 }
  78
  79 sub TIESCALAR {
  80     my ($class, $self) = @_;
  81     bless $self, $class;
  82     $self
  83 }
  84
  85 sub FETCH {
  86     my ($self) = @_;
  87     $self->{NODE}
  88 }
  89
  90 sub STORE {
  91     my ($self, $value) = @_;
  92     $self->{NODE} = $value
  93 }
  94
  95 #==============================================================================
  96 package yaml_sequence;
  97
  98 @yaml_sequence::ISA = qw(YAML::Node);
  99
 100 sub new {
 101     my ($class, $self) = @_;
 102     my $new;
 103     tie @$new, $class, $self;
 104     $new
 105 }
 106
 107 sub TIEARRAY {
 108     my ($class, $self) = @_;
 109     bless $self, $class
 110 }
 111
 112 sub FETCHSIZE {
 113     my ($self) = @_;
 114     scalar @{$self->{NODE}};
 115 }
 116
 117 sub FETCH {
 118     my ($self, $index) = @_;
 119     $self->{NODE}[$index]
 120 }
 121
 122 sub STORE {
 123     my ($self, $index, $value) = @_;
 124     $self->{NODE}[$index] = $value
 125 }
 126
 127 sub undone {
 128     die "Not implemented yet"; # XXX
 129 }
 130
 131 *STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
 132 *STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
 133 *undone; # XXX Must implement before release
 134
 135 #==============================================================================
 136 package yaml_mapping;
 137
 138 @yaml_mapping::ISA = qw(YAML::Node);
 139
 140 sub new {
 141     my ($class, $self) = @_;
 142     @{$self->{KEYS}} = sort keys %{$self->{NODE}};
 143     my $new;
 144     tie %$new, $class, $self;
 145     $new
 146 }
 147
 148 sub TIEHASH {
 149     my ($class, $self) = @_;
 150     bless $self, $class
 151 }
 152
 153 sub FETCH {
 154     my ($self, $key) = @_;
 155     if (exists $self->{NODE}{$key}) {
 156         return (grep {$_ eq $key} @{$self->{KEYS}})
 157                ? $self->{NODE}{$key} : undef;
 158     }
 159     return $self->{HASH}{$key};
 160 }
 161
 162 sub STORE {
 163     my ($self, $key, $value) = @_;
 164     if (exists $self->{NODE}{$key}) {
 165         $self->{NODE}{$key} = $value;
 166     }
 167     elsif (exists $self->{HASH}{$key}) {
 168         $self->{HASH}{$key} = $value;
 169     }
 170     else {
 171         if (not grep {$_ eq $key} @{$self->{KEYS}}) {
 172             push(@{$self->{KEYS}}, $key);
 173         }
 174         $self->{HASH}{$key} = $value;
 175     }
 176     $value
 177 }
 178
 179 sub DELETE {
 180     my ($self, $key) = @_;
 181     my $return;
 182     if (exists $self->{NODE}{$key}) {
 183         $return = $self->{NODE}{$key};
 184     }
 185     elsif (exists $self->{HASH}{$key}) {
 186         $return = delete $self->{NODE}{$key};
 187     }
 188     for (my $i = 0; $i < @{$self->{KEYS}}; $i++) {
 189         if ($self->{KEYS}[$i] eq $key) {
 190             splice(@{$self->{KEYS}}, $i, 1);
 191         }
 192     }
 193     return $return;
 194 }
 195
 196 sub CLEAR {
 197     my ($self) = @_;
 198     @{$self->{KEYS}} = ();
 199     %{$self->{HASH}} = ();
 200 }
 201
 202 sub FIRSTKEY {
 203     my ($self) = @_;
 204     $self->{ITER} = 0;
 205     $self->{KEYS}[0]
 206 }
 207
 208 sub NEXTKEY {
 209     my ($self) = @_;
 210     $self->{KEYS}[++$self->{ITER}]
 211 }
 212
 213 sub EXISTS {
 214     my ($self, $key) = @_;
 215     exists $self->{NODE}{$key}
 216 }
 217
 218 1;