ActionBar: oe Prototyp
[kivitendo-erp.git] / 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;