File Coverage

inc/YAML/Node.pm
Criterion Covered Total %
statement 12 115 10.4
branch 0 34 0.0
condition 0 2 0.0
subroutine 4 29 13.7
pod 0 6 0.0
total 16 186 8.6


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