line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyright Infomation |
2
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
3
|
|
|
|
|
|
|
# Author : Dr. Ahmed Amin Elsheshtawy, Ph.D. |
4
|
|
|
|
|
|
|
# Website: https://github.com/mewsoft/Nile, http://www.mewsoft.com |
5
|
|
|
|
|
|
|
# Email : mewsoft@cpan.org, support@mewsoft.com |
6
|
|
|
|
|
|
|
# Copyrights (c) 2014-2015 Mewsoft Corp. All rights reserved. |
7
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
8
|
|
|
|
|
|
|
package Nile::XML; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
our $VERSION = '0.54'; |
11
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:MEWSOFT'; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
=pod |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=encoding utf8 |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 NAME |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
Nile::XML - XML file manager. |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=head1 SYNOPSIS |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# get a reference to the framework xml object. |
24
|
|
|
|
|
|
|
$xml = $self->app->xml; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# get a reference to a new xml object. |
27
|
|
|
|
|
|
|
$xml = $self->app->xml->new; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# keep sort order when reading and writing the xml file data. default is off. |
30
|
|
|
|
|
|
|
#$xml->keep_order(1); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# load xml file |
33
|
|
|
|
|
|
|
$xml->load("path/to/xml/file.xml"); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# load and append another xml file to the same object |
36
|
|
|
|
|
|
|
$xml->load("path/to/xml/another.xml"); |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# get value of email tag <email>ahmed@mewsoft.com</email> |
39
|
|
|
|
|
|
|
say $xml->get('email'); |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# get tag value, if not found return the provided default value. |
42
|
|
|
|
|
|
|
$var = $xml->get($name, $default); |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
# get tag attribute of email tag <email status='expired'>ahmed@mewsoft.com</email> |
45
|
|
|
|
|
|
|
# The prefix '-' is added on every attribute's name. |
46
|
|
|
|
|
|
|
say $xml->get('email')->{'-status'}; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# if an element has both of a text node and attributes or both of a text node and other child nodes, |
49
|
|
|
|
|
|
|
# value of a text node is moved to #text like child nodes. |
50
|
|
|
|
|
|
|
say $xml->get('email')->{'#text'}; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# get value of email tag inside other tags |
53
|
|
|
|
|
|
|
# <users><user><contact><email>ahmed@mewsoft.com</email></contact></user></users> |
54
|
|
|
|
|
|
|
say $xml->get('users/user/contact/email'); |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# automatic getter support |
57
|
|
|
|
|
|
|
$email = $xml->email; # same as $xml->get('email'); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# automatic setter support |
60
|
|
|
|
|
|
|
$xml->email('ahmed@mewsoft.com'); # $xml->set('email', 'ahmed@mewsoft.com'); |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# set value of email tag <email></email> |
63
|
|
|
|
|
|
|
$xml->set('email', 'ahmed@mewsoft.com'); |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# set value of email tag inside other tags |
66
|
|
|
|
|
|
|
# <users><user><contact><email></email></contact></user></users> |
67
|
|
|
|
|
|
|
$xml->set('users/user/contact/email', 'ahmed@mewsoft.com'); |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# access variables as a hash tree |
70
|
|
|
|
|
|
|
$xml->var->{accounts}->{users}->{admin}->{username} = 'admin'; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# get a list of tags values. |
73
|
|
|
|
|
|
|
($users, $views, $items) = $xml->list( qw( users views items ) ); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# delete xml tags by names |
76
|
|
|
|
|
|
|
$xml->delete(@names); |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# delete entire xml object contents in memory |
79
|
|
|
|
|
|
|
$xml->clear(); |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# load and append another xml file to the object |
82
|
|
|
|
|
|
|
$xml->add_file($another_file); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# updated the provided tags and save changes to the file |
85
|
|
|
|
|
|
|
$xml->update(%tags); |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# Save changes to the output file. If no file name just update the loaded file name. |
88
|
|
|
|
|
|
|
$xml->save($file); |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# load xml file content and return it as a hash, not added to the object |
91
|
|
|
|
|
|
|
%xml_hash = $xml->get_file($file); |
92
|
|
|
|
|
|
|
say $xml_hash{root}{config}{database}{user}; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# load xml file content and return it as a hash ref, not added to the object |
95
|
|
|
|
|
|
|
$xml_hash_ref = $xml->get_file($file); |
96
|
|
|
|
|
|
|
say $xml_hash_ref->{root}->{config}->{database}->{user}; |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
# get a new xml object |
99
|
|
|
|
|
|
|
#my $xml_other = $xml->object; |
100
|
|
|
|
|
|
|
#my $xml_other = $xml->new; |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# load and manage another xml files separately |
103
|
|
|
|
|
|
|
#$xml_other->load("xmlfile"); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
=head1 DESCRIPTION |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
Nile::XML - XML file manager. |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
Parsing and writing XML files into a hash tree object supports sorted order and build on the module L<XML::TreePP>. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=cut |
112
|
|
|
|
|
|
|
|
113
|
1
|
|
|
1
|
|
7
|
use Nile::Base; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
10
|
|
114
|
1
|
|
|
1
|
|
6265
|
use XML::TreePP; |
|
1
|
|
|
|
|
5323
|
|
|
1
|
|
|
|
|
1163
|
|
115
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
116
|
|
|
|
|
|
|
=head2 xml() |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# get a new XML::TreePP object. |
119
|
|
|
|
|
|
|
$xml_obj = $xml->xml(@names); |
120
|
|
|
|
|
|
|
# then you can use $xml_obj as XML::TreePP object. |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Returns a new L<XML::TreePP> object. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=cut |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
has 'xml' => ( |
127
|
|
|
|
|
|
|
is => 'rw', |
128
|
|
|
|
|
|
|
default => sub {XML::TreePP->new()}, |
129
|
|
|
|
|
|
|
); |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=head2 file() |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
# set output file name for saving |
135
|
|
|
|
|
|
|
$xml->file($file); |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# get output file name |
138
|
|
|
|
|
|
|
$file = $xml->file(); |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
Get and set the output xml file name used when saving or updating. |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
=cut |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
has 'file' => ( |
145
|
|
|
|
|
|
|
is => 'rw', |
146
|
|
|
|
|
|
|
); |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
=head2 encoding() |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# get encoding used to read/write the file, default is 'UTF-8'. |
151
|
|
|
|
|
|
|
$encoding = $xml->encoding(); |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
# set encoding used to read/write the file, default is 'UTF-8'. |
154
|
|
|
|
|
|
|
$xml->encoding('UTF-8'); |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
Get and set encoding used to read/write the xml file The default encoding is 'UTF-8'. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=cut |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
has 'encoding' => ( |
161
|
|
|
|
|
|
|
is => 'rw', |
162
|
|
|
|
|
|
|
default => 'UTF-8', |
163
|
|
|
|
|
|
|
); |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=head2 indent() |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# get indent, default 4. |
168
|
|
|
|
|
|
|
$indent = $xml->indent(); |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# set indent. |
171
|
|
|
|
|
|
|
$xml->indent(6); |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
This makes the output more human readable by indenting appropriately. |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=cut |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
has 'indent' => ( |
178
|
|
|
|
|
|
|
is => 'rw', |
179
|
|
|
|
|
|
|
default => 4, |
180
|
|
|
|
|
|
|
); |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
183
|
|
|
|
|
|
|
sub AUTOLOAD { |
184
|
0
|
|
|
0
|
|
|
my ($self) = shift; |
185
|
|
|
|
|
|
|
|
186
|
0
|
|
|
|
|
|
my ($class, $method) = our $AUTOLOAD =~ /^(.*)::(\w+)$/; |
187
|
|
|
|
|
|
|
|
188
|
0
|
0
|
|
|
|
|
if ($self->can($method)) { |
189
|
0
|
|
|
|
|
|
return $self->$method(@_); |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
0
|
0
|
|
|
|
|
if (@_) { |
193
|
0
|
|
|
|
|
|
$self->set($method, $_[0]); |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
else { |
196
|
0
|
|
|
|
|
|
return $self->get($method); |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
200
|
|
|
|
|
|
|
=head2 load() |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# get xml object |
203
|
|
|
|
|
|
|
$xml = $self->app->xml->new; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# load xml file |
206
|
|
|
|
|
|
|
$xml->load($file); |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# load and append another xml file |
209
|
|
|
|
|
|
|
$xml->load($another); |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
Loads xml files to the object in memory. This will not clear any previously loaded files. To will add files. |
212
|
|
|
|
|
|
|
This method can be chained C<$xml->load($file)->add_file($another_file)>; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=cut |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
sub load { |
217
|
|
|
|
|
|
|
|
218
|
0
|
|
|
0
|
0
|
|
my ($self, $file) = @_; |
219
|
|
|
|
|
|
|
|
220
|
0
|
0
|
|
|
|
|
$file .= ".xml" unless ($file =~ /\.[^.]*$/i); |
221
|
0
|
0
|
0
|
|
|
|
($file && -f $file) || $self->app->abort("Error reading file '$file'. $!"); |
222
|
|
|
|
|
|
|
|
223
|
0
|
|
|
|
|
|
my $xml = $self->xml->parsefile($file); |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
#$self->{vars} ||= +{}; |
226
|
|
|
|
|
|
|
#$self->{vars} = {%{$self->{vars}}, %$xml}; |
227
|
|
|
|
|
|
|
|
228
|
0
|
0
|
|
|
|
|
if ($self->{vars}) { |
229
|
0
|
|
|
|
|
|
while (my ($k, $v) = each %{$xml}) { |
|
0
|
|
|
|
|
|
|
230
|
0
|
|
|
|
|
|
$self->{vars}->{$k} = $v; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
else { |
234
|
0
|
|
|
|
|
|
$self->{vars} = $xml; |
235
|
0
|
|
|
|
|
|
$self->file($file); |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
0
|
|
|
|
|
|
$self; |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
241
|
|
|
|
|
|
|
=head2 keep_order() |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
# keep sort order when loading and saving the file. default is off. |
244
|
|
|
|
|
|
|
$xml->keep_order(1); |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
# turn it off |
247
|
|
|
|
|
|
|
$xml->keep_order(0); |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
This option keeps the order for each element appeared in XML. L<Tie::IxHash> module is required. |
250
|
|
|
|
|
|
|
This makes parsing performance slow (about 100% slower than default). But sometimes it is required |
251
|
|
|
|
|
|
|
for example when loading url routes files, it is important to keep routes in the same sorted order in the files. |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
=cut |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
sub keep_order { |
256
|
0
|
|
|
0
|
0
|
|
my ($self, $status) = @_; |
257
|
|
|
|
|
|
|
# This option keeps the order for each element appeared in XML. Tie::IxHash module is required. |
258
|
|
|
|
|
|
|
# This makes parsing performance slow. (about 100% slower than default) |
259
|
0
|
|
|
|
|
|
$self->xml->set(use_ixhash => $status); |
260
|
0
|
|
|
|
|
|
return $self; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
263
|
|
|
|
|
|
|
=head2 get() |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# get value of email tag <email>ahmed@mewsoft.com</email> |
266
|
|
|
|
|
|
|
say $xml->get('email'); # returns ahmed@mewsoft.com |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# get tag value, if not found return the optional provided default value. |
269
|
|
|
|
|
|
|
$var = $xml->get($name, $default); |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# get value of email tag inside other tags |
272
|
|
|
|
|
|
|
# <users><user><contact><email>ahmed@mewsoft.com</email></contact></user></users> |
273
|
|
|
|
|
|
|
say $xml->get('users/user/contact/email'); # returns ahmed@mewsoft.com |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
# automatic getter support |
276
|
|
|
|
|
|
|
$email = $xml->email; # same as $xml->get('email'); |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# get list |
279
|
|
|
|
|
|
|
# <lang><file>general</file><file>contact</file><file>register</file></lang> |
280
|
|
|
|
|
|
|
@files = $xml->get("lang/file"); |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
Returns xml tag value, if not found returns the optional provided default value. |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
=cut |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
sub get { |
287
|
|
|
|
|
|
|
|
288
|
0
|
|
|
0
|
0
|
|
my ($self, $path, $default) = @_; |
289
|
|
|
|
|
|
|
|
290
|
0
|
|
|
|
|
|
my $value; |
291
|
|
|
|
|
|
|
|
292
|
0
|
0
|
|
|
|
|
if ($path !~ /\//) { |
293
|
0
|
0
|
|
|
|
|
$value = exists $self->{vars}->{$path}? $self->{vars}->{$path} : $default; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
else { |
296
|
0
|
|
|
|
|
|
$path =~ s/^\/+|\/+$//g; |
297
|
0
|
|
|
|
|
|
my @path = split /\//, $path; |
298
|
0
|
|
|
|
|
|
my $v = $self->{vars}; |
299
|
|
|
|
|
|
|
|
300
|
0
|
|
|
|
|
|
while (my $k = shift @path) { |
301
|
0
|
0
|
|
|
|
|
if (!exists $v->{$k}) { |
302
|
0
|
|
|
|
|
|
$v = $default; |
303
|
0
|
|
|
|
|
|
last; |
304
|
|
|
|
|
|
|
} |
305
|
0
|
|
|
|
|
|
$v = $v->{$k}; |
306
|
|
|
|
|
|
|
} |
307
|
0
|
|
|
|
|
|
$value = $v; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
0
|
0
|
|
|
|
|
if (ref($value) eq "ARRAY" ) { |
|
|
0
|
|
|
|
|
|
311
|
0
|
|
|
|
|
|
return @{$value}; |
|
0
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
elsif (ref($value) eq "HASH" ) { |
314
|
|
|
|
|
|
|
#return %{$value}; |
315
|
0
|
|
|
|
|
|
return $value; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
else { |
318
|
0
|
|
|
|
|
|
return $value; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
322
|
|
|
|
|
|
|
=head2 set() |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# set tag value |
325
|
|
|
|
|
|
|
$xml->set('email', 'ahmed@mewsoft.com'); |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
# set a group of tags |
328
|
|
|
|
|
|
|
$xml->set(%tags); |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
# set value of nested tags |
331
|
|
|
|
|
|
|
# <users><user><contact><email>ahmed@mewsoft.com</email></contact></user></users> |
332
|
|
|
|
|
|
|
$xml->set('users/user/contact/email', 'ahmed@mewsoft.com'); |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
Sets tags values. |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
=cut |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
sub set { |
339
|
|
|
|
|
|
|
|
340
|
0
|
|
|
0
|
0
|
|
my ($self, %vars) = @_; |
341
|
|
|
|
|
|
|
#map { $self->{vars}->{$_} = $vars{$_}; } keys %vars; |
342
|
|
|
|
|
|
|
|
343
|
0
|
|
|
|
|
|
my ($path, $value, @path, $k, $v, $key); |
344
|
|
|
|
|
|
|
|
345
|
0
|
|
|
|
|
|
while ( ($path, $value) = each %vars) { |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
#if ($path !~ /\//) { |
348
|
|
|
|
|
|
|
# $self->{vars}->{$path} = $value; |
349
|
|
|
|
|
|
|
# next; |
350
|
|
|
|
|
|
|
#} |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
# path /accounts/users/admin |
353
|
0
|
|
|
|
|
|
$path =~ s/^\/+|\/+$//g; |
354
|
0
|
|
|
|
|
|
@path = split /\//, $path; |
355
|
0
|
|
|
|
|
|
$v = $self->{vars}; |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# $key = admin, @path= (accounts, users) |
358
|
0
|
|
|
|
|
|
$key = pop @path; |
359
|
|
|
|
|
|
|
|
360
|
0
|
|
|
|
|
|
while ($k = shift @path) { |
361
|
0
|
0
|
|
|
|
|
if (!exists $v->{$k}) { |
362
|
0
|
|
|
|
|
|
$v->{$k} = +{}; |
363
|
|
|
|
|
|
|
} |
364
|
0
|
|
|
|
|
|
$v = $v->{$k}; |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
# $v = $self->{vars}->{accounts}->{users}, $key = admin |
368
|
0
|
|
|
|
|
|
$v->{$key} = $value; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
|
371
|
0
|
|
|
|
|
|
$self; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
374
|
|
|
|
|
|
|
=head2 list() |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# get a list of tags values. |
377
|
|
|
|
|
|
|
@values = $xml->list(@names); |
378
|
|
|
|
|
|
|
($users, $views, $items) = $xml->list( qw( users views items ) ); |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
Returns a list of tags values. |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
=cut |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
sub list { |
385
|
0
|
|
|
0
|
0
|
|
my ($self, @n) = @_; |
386
|
0
|
|
|
|
|
|
my @v; |
387
|
0
|
|
|
|
|
|
push @v, $self->get($_) for @n; |
388
|
|
|
|
|
|
|
return @v |
389
|
0
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
391
|
|
|
|
|
|
|
=head2 var() |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# get a hash ref to the xml data for direct access. |
394
|
|
|
|
|
|
|
$xml_ref = $xml->var(); |
395
|
|
|
|
|
|
|
$xml_ref->{root}->{users}->{user}->{admin} = 'username'; |
396
|
|
|
|
|
|
|
say $xml_ref->{root}->{users}->{user}->{admin}; |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
Returns a hash reference to the in memory xml data. |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=cut |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
sub var { |
403
|
0
|
|
|
0
|
0
|
|
my ($self) = @_; |
404
|
0
|
|
|
|
|
|
return $self->{vars}; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
407
|
|
|
|
|
|
|
=head2 delete() |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# delete tags from memory, changes will apply when saving file. |
410
|
|
|
|
|
|
|
$xml->delete(@names); |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
Delete a list of tags. Tags will be deleted from the object and memory only and will apply |
413
|
|
|
|
|
|
|
when updating or saving the file. |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
=cut |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub delete { |
418
|
0
|
|
|
0
|
0
|
|
my ($self, @vars) = @_; |
419
|
0
|
|
|
|
|
|
delete $self->{vars}->{$_} for @vars; |
420
|
0
|
|
|
|
|
|
$self; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
423
|
|
|
|
|
|
|
=head2 clear() |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
# delete entire xml object data. |
426
|
|
|
|
|
|
|
$xml->clear(); |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
Completely clears all loaded xml data from memory. This does not apply to the file until file is |
429
|
|
|
|
|
|
|
updated or saved. |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
=cut |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
sub clear { |
434
|
0
|
|
|
0
|
0
|
|
my ($self) = @_; |
435
|
0
|
|
|
|
|
|
$self->{vars} = +{}; |
436
|
0
|
|
|
|
|
|
$self; |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
439
|
|
|
|
|
|
|
=head2 update() |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
# save a list of variables and update the file. |
442
|
|
|
|
|
|
|
$xml->update(%vars); |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
Set list of variables and save to the output file immediately. |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=cut |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
sub update { |
449
|
0
|
|
|
0
|
0
|
|
my ($self, %vars) = @_; |
450
|
0
|
|
|
|
|
|
$self->set(%vars); |
451
|
0
|
|
|
|
|
|
$self->save(); |
452
|
0
|
|
|
|
|
|
$self; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
455
|
|
|
|
|
|
|
=head2 save() |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
# write the output file. |
458
|
|
|
|
|
|
|
$xml->save($file); |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
Save changes to the output file. If no file name just update the loaded file name. |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
=cut |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
sub save { |
465
|
0
|
|
|
0
|
0
|
|
my ($self, $file) = @_; |
466
|
0
|
|
|
|
|
|
$self->xml->set(indent => $self->indent); |
467
|
0
|
|
0
|
|
|
|
$self->xml->writefile($file || $self->file, $self->{vars}, $self->encoding); |
468
|
0
|
|
|
|
|
|
$self; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
471
|
|
|
|
|
|
|
=head2 get_file() |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# load xml file content and return it as a hash, not added to the object |
474
|
|
|
|
|
|
|
%xml_hash = $xml->get_file($file); |
475
|
|
|
|
|
|
|
say $xml_hash{root}{config}{database}{user}; |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
# load xml file content and return it as a hash ref, not added to the object |
478
|
|
|
|
|
|
|
$xml_hash_ref = $xml->get_file($file); |
479
|
|
|
|
|
|
|
say $xml_hash_ref->{root}->{config}->{database}->{user}; |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
Load xml file content and return it as a hash or hash ref, not added to the object. |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
=cut |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
sub get_file { |
486
|
0
|
|
|
0
|
0
|
|
my ($self, $file) = @_; |
487
|
0
|
0
|
0
|
|
|
|
($file && -f $file) || $self->app->abort("Error reading file '$file'. $!"); |
488
|
0
|
|
|
|
|
|
my $xml = $self->xml->parsefile($file); |
489
|
0
|
0
|
|
|
|
|
return wantarray? %{$xml} : $xml; |
|
0
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
492
|
|
|
|
|
|
|
=head2 add_file() |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# load and append another xml file to the object |
495
|
|
|
|
|
|
|
$xml->add_file($another_file); |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
Load and append another xml file to the object. |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
=cut |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
sub add_file { |
502
|
0
|
|
|
0
|
0
|
|
my ($self, $file) = @_; |
503
|
0
|
|
|
|
|
|
my $xml = $self->get_file($file); |
504
|
0
|
|
|
|
|
|
while (my ($k, $v) = each %{$xml}) { |
|
0
|
|
|
|
|
|
|
505
|
0
|
|
|
|
|
|
$self->{vars}->{$k} = $v; |
506
|
|
|
|
|
|
|
} |
507
|
0
|
|
|
|
|
|
$self; |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
510
|
0
|
|
|
0
|
|
|
sub DESTROY { |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
=pod |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
=head1 Bugs |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
This project is available on github at L<https://github.com/mewsoft/Nile>. |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
=head1 HOMEPAGE |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
Please visit the project's homepage at L<https://metacpan.org/release/Nile>. |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
=head1 SOURCE |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
Source repository is at L<https://github.com/mewsoft/Nile>. |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
=head1 SEE ALSO |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
See L<Nile> for details about the complete framework. |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
=head1 AUTHOR |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
Ahmed Amin Elsheshtawy, اØÙ
د اÙ
Ù٠اÙششتاÙÙ <mewsoft@cpan.org> |
535
|
|
|
|
|
|
|
Website: http://www.mewsoft.com |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
Copyright (C) 2014-2015 by Dr. Ahmed Amin Elsheshtawy اØÙ
د اÙ
Ù٠اÙششتاÙÙ mewsoft@cpan.org, support@mewsoft.com, |
540
|
|
|
|
|
|
|
L<https://github.com/mewsoft/Nile>, L<http://www.mewsoft.com> |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
=cut |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
1; |