line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package TreePath; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
17061
|
use utf8; |
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
4
|
|
4
|
1
|
|
|
1
|
|
211
|
use Moose; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
with 'MooseX::Object::Pluggable'; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
use Moose::Util::TypeConstraints; |
8
|
|
|
|
|
|
|
use Config::JFDI; |
9
|
|
|
|
|
|
|
use Carp qw/croak/; |
10
|
|
|
|
|
|
|
use Data::Dumper; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = '0.12'; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
subtype MyConf => as 'HashRef'; |
15
|
|
|
|
|
|
|
coerce 'MyConf' |
16
|
|
|
|
|
|
|
=> from 'Str' => via { |
17
|
|
|
|
|
|
|
my $conf = shift; |
18
|
|
|
|
|
|
|
my ($jfdi_h, $jfdi) = Config::JFDI->open($conf) |
19
|
|
|
|
|
|
|
or croak "Error (conf: $conf) : $!\n"; |
20
|
|
|
|
|
|
|
return $jfdi->get; |
21
|
|
|
|
|
|
|
}; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
has conf => ( is => 'rw', |
24
|
|
|
|
|
|
|
isa => 'MyConf', |
25
|
|
|
|
|
|
|
coerce => 1, |
26
|
|
|
|
|
|
|
trigger => sub { |
27
|
|
|
|
|
|
|
my $self = shift; |
28
|
|
|
|
|
|
|
my $args = shift; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# if conf exist |
31
|
|
|
|
|
|
|
if ( defined $args->{$self->configword} ) { |
32
|
|
|
|
|
|
|
croak "Error: Can not find " . $self->configword . " in your conf !" |
33
|
|
|
|
|
|
|
if ( ! $args->{$self->configword}); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
$self->config($args->{$self->configword}); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
$self->debug($self->config->{'debug'}) |
38
|
|
|
|
|
|
|
if ( ! defined $self->debug && defined $self->config->{'debug'} ); |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
$self->_search_field($self->config->{backend}->{args}->{search_field}) |
41
|
|
|
|
|
|
|
if defined $self->config->{backend}->{args}->{search_field}; |
42
|
|
|
|
|
|
|
$self->_parent_field($self->config->{backend}->{args}->{parent_field}) |
43
|
|
|
|
|
|
|
if defined $self->config->{backend}->{args}->{parent_field}; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
$self->_sync($self->config->{backend}->{args}->{sync}) |
46
|
|
|
|
|
|
|
if defined $self->config->{backend}->{args}->{sync}; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
$self->_load_backend if ! $self->can('backend'); |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
# it's a hash |
51
|
|
|
|
|
|
|
else { |
52
|
|
|
|
|
|
|
$self->tree($args); |
53
|
|
|
|
|
|
|
$self->_build_tree; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
); |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
has config => ( |
61
|
|
|
|
|
|
|
isa => "HashRef", |
62
|
|
|
|
|
|
|
is => "rw", |
63
|
|
|
|
|
|
|
); |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
has 'configword' => ( |
66
|
|
|
|
|
|
|
is => 'rw', |
67
|
|
|
|
|
|
|
default => sub { __PACKAGE__ }, |
68
|
|
|
|
|
|
|
); |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
has 'debug' => ( |
71
|
|
|
|
|
|
|
is => 'rw', |
72
|
|
|
|
|
|
|
); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
has '_backend' => ( |
75
|
|
|
|
|
|
|
is => 'rw', |
76
|
|
|
|
|
|
|
isa => 'Str', |
77
|
|
|
|
|
|
|
); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
has '_sync' => ( |
80
|
|
|
|
|
|
|
is => 'rw', |
81
|
|
|
|
|
|
|
isa => 'Str', |
82
|
|
|
|
|
|
|
); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
has _plugin_ns => ( |
85
|
|
|
|
|
|
|
is => 'rw', |
86
|
|
|
|
|
|
|
required => 1, |
87
|
|
|
|
|
|
|
isa => 'Str', |
88
|
|
|
|
|
|
|
default => sub{ 'Backend' }, |
89
|
|
|
|
|
|
|
); |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
has _type_field => ( |
92
|
|
|
|
|
|
|
is => 'rw', |
93
|
|
|
|
|
|
|
isa => 'Str', |
94
|
|
|
|
|
|
|
default => sub{ 'type' }, |
95
|
|
|
|
|
|
|
); |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
has _search_field => ( |
98
|
|
|
|
|
|
|
is => 'rw', |
99
|
|
|
|
|
|
|
isa => 'Str', |
100
|
|
|
|
|
|
|
default => sub{ 'name' }, |
101
|
|
|
|
|
|
|
); |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
has _parent_field => ( |
104
|
|
|
|
|
|
|
is => 'rw', |
105
|
|
|
|
|
|
|
isa => 'Str', |
106
|
|
|
|
|
|
|
default => sub{ 'parent' }, |
107
|
|
|
|
|
|
|
); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
has _position_field => ( |
110
|
|
|
|
|
|
|
is => 'rw', |
111
|
|
|
|
|
|
|
isa => 'Str', |
112
|
|
|
|
|
|
|
default => sub{ 'position' }, |
113
|
|
|
|
|
|
|
); |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
has _rules => ( |
116
|
|
|
|
|
|
|
isa => "HashRef", |
117
|
|
|
|
|
|
|
is => "rw", |
118
|
|
|
|
|
|
|
); |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
has tree => ( |
121
|
|
|
|
|
|
|
isa => "HashRef", |
122
|
|
|
|
|
|
|
is => "rw", |
123
|
|
|
|
|
|
|
); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
has root => ( |
127
|
|
|
|
|
|
|
isa => "HashRef", |
128
|
|
|
|
|
|
|
is => "rw", |
129
|
|
|
|
|
|
|
); |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub _load_backend { |
134
|
|
|
|
|
|
|
my $self = shift; |
135
|
|
|
|
|
|
|
my $backend = $self->config->{'backend'}->{name}; |
136
|
|
|
|
|
|
|
$self->_backend($backend); |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
$self->_log("Loading $backend backend ..."); |
139
|
|
|
|
|
|
|
$self->load_plugin( $backend ); |
140
|
|
|
|
|
|
|
$self->_load_tree; |
141
|
|
|
|
|
|
|
$self->_load_rules if ( defined $self->config->{rules}); |
142
|
|
|
|
|
|
|
$self->_build_tree; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub reload { |
146
|
|
|
|
|
|
|
my $self = shift; |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
$self->_populate_backend(0) |
149
|
|
|
|
|
|
|
if $self->can('_populate_backend'); |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
$self->_load_tree; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub _log{ |
155
|
|
|
|
|
|
|
my ($self, $msg ) = @_; |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
return if ! $self->debug; |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
say STDERR "[debug] $msg"; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# Load tree from backend |
163
|
|
|
|
|
|
|
sub _load_tree { |
164
|
|
|
|
|
|
|
my $self = shift; |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
$self->tree($self->_load); |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# Load rules from config |
170
|
|
|
|
|
|
|
sub _load_rules { |
171
|
|
|
|
|
|
|
my $self = shift; |
172
|
|
|
|
|
|
|
$self->_rules($self->config->{'rules'}); |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# Build Tree (children, position, ...) |
176
|
|
|
|
|
|
|
# parents and children become HashRef |
177
|
|
|
|
|
|
|
sub _build_tree { |
178
|
|
|
|
|
|
|
my $self = shift; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
my $tree = $self->tree; |
181
|
|
|
|
|
|
|
foreach my $id ( sort keys %$tree ) { |
182
|
|
|
|
|
|
|
my $node = $tree->{$id}; |
183
|
|
|
|
|
|
|
$node->{id} = $id; |
184
|
|
|
|
|
|
|
my $parent = $tree->{$node->{parent}}; |
185
|
|
|
|
|
|
|
$node->{parent} = $parent; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
$self->add($parent, $node); |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
# return the last node sorted by id |
192
|
|
|
|
|
|
|
sub _last_node { |
193
|
|
|
|
|
|
|
my $self = shift; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
my @nodes_sorted_by_id = sort { $a <=> $b } map $_->{id}, values %{$self->tree}; |
196
|
|
|
|
|
|
|
return { id => 0 } if ! defined $nodes_sorted_by_id[0]; |
197
|
|
|
|
|
|
|
return $self->tree->{$nodes_sorted_by_id[-1]}; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
sub _bckd_create { |
201
|
|
|
|
|
|
|
my $self = shift; |
202
|
|
|
|
|
|
|
my $node = shift; |
203
|
|
|
|
|
|
|
my $msg = shift; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
return if ( ! $self->_backend || ! $self->_sync ); |
206
|
|
|
|
|
|
|
$self->_log("[" . $self->_backend . "] CREATE " . $node->{name} . " | $msg"); |
207
|
|
|
|
|
|
|
$self->_create($node); |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub _bckd_delete { |
211
|
|
|
|
|
|
|
my $self = shift; |
212
|
|
|
|
|
|
|
my $nodes = shift; |
213
|
|
|
|
|
|
|
my $msg = shift; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
return if ( ! $self->_backend || ! $self->_sync ); |
216
|
|
|
|
|
|
|
my @nodes_name = map { $_->{$self->_search_field} } @$nodes; |
217
|
|
|
|
|
|
|
$self->_log("[" . $self->_backend . "] DELETE @nodes_name | $msg"); |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
$self->_delete($nodes); |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
sub _bckd_update { |
223
|
|
|
|
|
|
|
my $self = shift; |
224
|
|
|
|
|
|
|
my $node = shift; |
225
|
|
|
|
|
|
|
my $msg = shift; |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
return if ( ! $self->_backend || ! $self->_sync ); |
228
|
|
|
|
|
|
|
$self->_log("[" . $self->_backend . "] UPDATE " . $node->{name} . " | $msg"); |
229
|
|
|
|
|
|
|
$self->_update($node); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
sub _check_rules{ |
234
|
|
|
|
|
|
|
my ($self, $node, $parent) = @_; |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
return 1 if ( ! defined $self->config || |
237
|
|
|
|
|
|
|
! defined $self->config->{rules} || |
238
|
|
|
|
|
|
|
$node->{id} == 1 |
239
|
|
|
|
|
|
|
); |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# Is node can 'link' to parent ? |
242
|
|
|
|
|
|
|
my $rules = $self->_rules; |
243
|
|
|
|
|
|
|
if ( defined $rules->{$node->{$self->_type_field}}) { |
244
|
|
|
|
|
|
|
if ( defined $rules->{$node->{$self->_type_field}}->{$parent->{$self->_type_field}}) { |
245
|
|
|
|
|
|
|
return $rules->{$node->{$self->_type_field}}->{$parent->{$self->_type_field}}; |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
else { return 0 } |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
else { return 0 } |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
sub _update_children_position { |
253
|
|
|
|
|
|
|
my $self = shift; |
254
|
|
|
|
|
|
|
my @children = @_; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
my $n=1; |
257
|
|
|
|
|
|
|
foreach my $child ( @children ) { |
258
|
|
|
|
|
|
|
if ( ! defined $child->{$self->_position_field} || |
259
|
|
|
|
|
|
|
$child->{$self->_position_field} != $n ) |
260
|
|
|
|
|
|
|
{ |
261
|
|
|
|
|
|
|
my $pos = defined $child->{$self->_position_field} ? |
262
|
|
|
|
|
|
|
$child->{$self->_position_field} : '?'; |
263
|
|
|
|
|
|
|
my $msg = 'updating position of '. $child->{$self->_search_field} . |
264
|
|
|
|
|
|
|
"( $pos -> $n)"; |
265
|
|
|
|
|
|
|
$child->{$self->_position_field} = $n; |
266
|
|
|
|
|
|
|
$self->_bckd_update($child, $msg ); |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
$n++; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
# removes the child's father |
274
|
|
|
|
|
|
|
sub _remove_child_father{ |
275
|
|
|
|
|
|
|
my $self = shift; |
276
|
|
|
|
|
|
|
my $node = shift; |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
my $father = $node->{parent}; |
279
|
|
|
|
|
|
|
my $key_children = $self->_key_children($node, $father); |
280
|
|
|
|
|
|
|
my $id = 0; |
281
|
|
|
|
|
|
|
foreach my $child ( @{$father->{$key_children}}) { |
282
|
|
|
|
|
|
|
if ( $child->{$self->_search_field} eq $node->{$self->_search_field} && |
283
|
|
|
|
|
|
|
$child->{parent} eq $node->{parent} ){ |
284
|
|
|
|
|
|
|
return splice ( @{$father->{$key_children}},$id,1); |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
$id++; |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
sub _clone_node { |
292
|
|
|
|
|
|
|
my $self = shift; |
293
|
|
|
|
|
|
|
my $node = shift; |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
my $clone = {}; |
296
|
|
|
|
|
|
|
foreach my $k (keys %$node) { |
297
|
|
|
|
|
|
|
if ( $k eq 'parent'){ |
298
|
|
|
|
|
|
|
if ( $node->{'parent'}) { |
299
|
|
|
|
|
|
|
$clone->{$self->_parent_field} = $node->{$k}->{id}; |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
# is root |
302
|
|
|
|
|
|
|
else { |
303
|
|
|
|
|
|
|
$clone->{$self->_parent_field} = 0; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
else { $clone->{$k} = $node->{$k} } |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
return $clone; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub _key_children { |
312
|
|
|
|
|
|
|
my ($self, $node, $parent) = @_; |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
my $key_children; |
315
|
|
|
|
|
|
|
#if parent have a type |
316
|
|
|
|
|
|
|
if ( defined $parent->{$self->_type_field}) { |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# if node have a type |
319
|
|
|
|
|
|
|
if ( defined $node->{$self->_type_field}) { |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
# if node and parent have the same type |
322
|
|
|
|
|
|
|
if ( $node->{$self->_type_field} eq $parent->{$self->_type_field} ) { |
323
|
|
|
|
|
|
|
$key_children = 'children'; |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
else { |
326
|
|
|
|
|
|
|
$key_children = 'children_' . $node->{$self->_type_field}; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
# else node have the same type as parent |
330
|
|
|
|
|
|
|
else { |
331
|
|
|
|
|
|
|
$node->{$self->_type_field} = $parent->{$self->_type_field}; |
332
|
|
|
|
|
|
|
$key_children = 'children'; |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
# parent haven't type |
336
|
|
|
|
|
|
|
else { |
337
|
|
|
|
|
|
|
if ( defined $node->{$self->_type_field}) { |
338
|
|
|
|
|
|
|
die 'node have a type but not the parent !'; |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
else { |
341
|
|
|
|
|
|
|
$key_children = 'children'; |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
return $key_children; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
sub search { |
347
|
|
|
|
|
|
|
my ( $self, $args, $opts ) = @_; |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
my $results = []; |
350
|
|
|
|
|
|
|
my $tree = $self->tree; |
351
|
|
|
|
|
|
|
foreach my $id ( sort {$a <=> $b} keys %$tree ) { |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
my $found = 1; |
354
|
|
|
|
|
|
|
foreach my $key ( keys %$args ) { |
355
|
|
|
|
|
|
|
my $current; |
356
|
|
|
|
|
|
|
if ( $key =~ m/(.*)\.(.*)/) { |
357
|
|
|
|
|
|
|
# ex: parent.name |
358
|
|
|
|
|
|
|
if ( defined $tree->{$id}->{$1} && ref($tree->{$id}->{$1})) { |
359
|
|
|
|
|
|
|
$current = $tree->{$id}->{$1}->{$2}; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
else { next } |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
else { |
364
|
|
|
|
|
|
|
if ( defined $tree->{$id}->{$key} ){ |
365
|
|
|
|
|
|
|
$current = $tree->{$id}->{$key}; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
else { |
368
|
|
|
|
|
|
|
die "'$key' is not a key hash [node id:$id]"; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
my $value = $args->{$key}; |
372
|
|
|
|
|
|
|
if ( $current ne $value ) { |
373
|
|
|
|
|
|
|
$found = 0; |
374
|
|
|
|
|
|
|
last; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
if ( $found ){ |
379
|
|
|
|
|
|
|
if ( wantarray) { |
380
|
|
|
|
|
|
|
push(@$results, $tree->{$id}); |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
# if found and scalar context |
383
|
|
|
|
|
|
|
else { |
384
|
|
|
|
|
|
|
return $tree->{$id}; |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
return 0 if ( ! wantarray && ! $$results[0] ); |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
# wantarray |
392
|
|
|
|
|
|
|
return @$results; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
# ex : search_path(/A/B/C') |
397
|
|
|
|
|
|
|
sub search_path { |
398
|
|
|
|
|
|
|
my ( $self, $path, $opts ) = @_; |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
# search by 'name' if not defined |
401
|
|
|
|
|
|
|
$opts->{by} = $self->_search_field if ! defined $opts->{by}; |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
croak "path must be start by '/' !: $!\n" if ( $path !~ m|^/| ); |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
my $nodes = [ split m%/%, $path ]; |
406
|
|
|
|
|
|
|
$$nodes[0] = '/'; |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
my (@found, @not_found); |
409
|
|
|
|
|
|
|
my $parent = '/'; |
410
|
|
|
|
|
|
|
foreach my $node ( @$nodes ) { |
411
|
|
|
|
|
|
|
my $args = { $opts->{by} => $node, "parent\.$opts->{by}" => $parent}; |
412
|
|
|
|
|
|
|
my $result = $self->search($args, $opts); |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
$parent = $result->{$opts->{by}} if $result; |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
if ( $result ) { |
417
|
|
|
|
|
|
|
push(@found, $result); |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
else { |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
push(@not_found, $node); |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
if ( wantarray ) { |
426
|
|
|
|
|
|
|
return ( \@found, \@not_found ); |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
else { |
429
|
|
|
|
|
|
|
if ( $not_found[-1] ) { |
430
|
|
|
|
|
|
|
return ''; |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
else { |
433
|
|
|
|
|
|
|
return $found[-1]; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
sub count { |
440
|
|
|
|
|
|
|
my $self = shift; |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
return scalar keys %{$self->tree}; |
443
|
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
sub dump { |
446
|
|
|
|
|
|
|
my $self = shift; |
447
|
|
|
|
|
|
|
my $var = shift; |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
$var = $self->tree if ! defined $var; |
450
|
|
|
|
|
|
|
$Data::Dumper::Maxdepth = 3; |
451
|
|
|
|
|
|
|
$Data::Dumper::Sortkeys = 1; |
452
|
|
|
|
|
|
|
$Data::Dumper::Terse = 1; |
453
|
|
|
|
|
|
|
return Dumper($var); |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
sub traverse { |
457
|
|
|
|
|
|
|
my ($self, $node, $funcref, $args) = @_; |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
return 0 if ( ! $node ); |
460
|
|
|
|
|
|
|
$args ||= {}; |
461
|
|
|
|
|
|
|
$args->{_count} = 1 if ! defined ($args->{_count}); |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
my $nofunc = 0; |
464
|
|
|
|
|
|
|
if ( ! $funcref ) { |
465
|
|
|
|
|
|
|
$nofunc = 1; |
466
|
|
|
|
|
|
|
$funcref = sub { my ($node, $args) = @_; |
467
|
|
|
|
|
|
|
$args->{_each_nodes} = [] |
468
|
|
|
|
|
|
|
if ( ! defined $args->{_each_nodes}); |
469
|
|
|
|
|
|
|
if(defined($node)) { |
470
|
|
|
|
|
|
|
push(@{$args->{_each_nodes}}, $node); |
471
|
|
|
|
|
|
|
return 1; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
# if first node |
476
|
|
|
|
|
|
|
if ( $args->{_count} == 1 ) { |
477
|
|
|
|
|
|
|
return 0 if ( ! &$funcref( $node, $args ) ) |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
my $key_children = $self->_key_children($node, $node->{parent}); |
481
|
|
|
|
|
|
|
if(defined($node->{$key_children})) { |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
foreach my $child ( @{$node->{$key_children}} ) { |
484
|
|
|
|
|
|
|
return 0 if ( ! &$funcref( $child, $args ) ); |
485
|
|
|
|
|
|
|
$args->{_count}++; |
486
|
|
|
|
|
|
|
$self->traverse( $child, $funcref, $args ); |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
return $args->{_each_nodes} if $nofunc; |
491
|
|
|
|
|
|
|
return 1; |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
sub del { |
496
|
|
|
|
|
|
|
my ($self, @nodes) = @_; |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
my @deleted; |
499
|
|
|
|
|
|
|
foreach my $node ( @nodes ) { |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
my $father = $node->{parent}; |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
$self->_remove_child_father($node); |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
my $key_children = $self->_key_children($node, $node->{parent}); |
506
|
|
|
|
|
|
|
# if position field exist, recalc all children position |
507
|
|
|
|
|
|
|
$self->_update_children_position( @{$father->{$key_children}} ) |
508
|
|
|
|
|
|
|
if ( defined $node->{$self->_position_field}); |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
# traverse child branches and delete it |
511
|
|
|
|
|
|
|
my $nodes = $self->traverse($node); |
512
|
|
|
|
|
|
|
push(@deleted,map { delete $self->tree->{$_->{id}} } @$nodes); |
513
|
|
|
|
|
|
|
$self->_bckd_delete($nodes, "delete " . @$nodes . " node(s)"); |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
return @deleted; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
# Inserts a node beneath the parent at the given position. |
519
|
|
|
|
|
|
|
sub add { |
520
|
|
|
|
|
|
|
my ($self, $parent, $node, $position) = @_; |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
$node->{id} = $self->_last_node->{id} +1 |
523
|
|
|
|
|
|
|
if ! defined $node->{id}; |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
if ( ! $position && defined $node->{$self->_position_field}) { |
526
|
|
|
|
|
|
|
$position = $node->{$self->_position_field}; |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
if ( ! $parent ){ |
530
|
|
|
|
|
|
|
if ( $self->root) { |
531
|
|
|
|
|
|
|
die "root already exist !"; |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
$self->root($node); |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
$node->{parent} = $parent; |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
# check rules |
539
|
|
|
|
|
|
|
return 0 if ! $self->_check_rules($node, $parent); |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
my $is_exist_in_backend; |
543
|
|
|
|
|
|
|
$is_exist_in_backend = 1 |
544
|
|
|
|
|
|
|
if $self->tree->{$node->{id}}; |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
# save node in tree |
547
|
|
|
|
|
|
|
$self->tree->{$node->{id}} = $node; |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
my $key_children; |
550
|
|
|
|
|
|
|
my $update_children = 0; |
551
|
|
|
|
|
|
|
# node == root |
552
|
|
|
|
|
|
|
if ( defined $parent && $parent ) { |
553
|
|
|
|
|
|
|
$key_children = $self->_key_children($node, $parent); |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
if ( $parent ) { |
556
|
|
|
|
|
|
|
if ( $position ) { |
557
|
|
|
|
|
|
|
splice @{$parent->{$key_children}}, $position -1, 0, $self->tree->{$node->{id}}; |
558
|
|
|
|
|
|
|
$update_children = 1; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
else { |
561
|
|
|
|
|
|
|
push(@{$parent->{$key_children}}, $self->tree->{$node->{id}}); |
562
|
|
|
|
|
|
|
if ( defined ${$parent->{$key_children}}[0] && ${$parent->{$key_children}}[0]->{$self->_position_field}) { |
563
|
|
|
|
|
|
|
$update_children = 1; |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
# add node in tree |
569
|
|
|
|
|
|
|
$self->_bckd_create($node, 'add node ' . $node->{$self->_search_field}) |
570
|
|
|
|
|
|
|
if ! $is_exist_in_backend; |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
return $self->root if ! $parent; |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
# recalc position of children |
575
|
|
|
|
|
|
|
$self->_update_children_position(@{$parent->{$key_children}}) if $update_children; |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
return $node; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
sub insert_before { |
581
|
|
|
|
|
|
|
my ($self, $sibling, $node) = @_; |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
if ( ! defined $sibling->{$self->_position_field}) { |
584
|
|
|
|
|
|
|
return $self->add($sibling->{parent}, $node, 1 ); |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
return $self->add($sibling->{parent}, $node, $sibling->{$self->_position_field} ); |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
sub update { |
592
|
|
|
|
|
|
|
my ($self, $node, $datas) = @_; |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
foreach my $k ( sort keys %$datas ) { |
595
|
|
|
|
|
|
|
next if ( ! defined $node->{$k}); |
596
|
|
|
|
|
|
|
next if ( $node->{$k} eq $datas->{$k}); |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
my $previous = $node->{$k}; |
599
|
|
|
|
|
|
|
my $parent = $node->{parent}; |
600
|
|
|
|
|
|
|
my $key_children = $self->_key_children($node, $parent); |
601
|
|
|
|
|
|
|
my $children = $parent->{$key_children}; |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
# if update 'position' |
605
|
|
|
|
|
|
|
if ( $k eq $self->_position_field ) { |
606
|
|
|
|
|
|
|
# delete child in parent in previous position |
607
|
|
|
|
|
|
|
my $old = splice(@$children, $previous -1, 1); |
608
|
|
|
|
|
|
|
# add child in parent in new positioh |
609
|
|
|
|
|
|
|
splice(@$children,$datas->{$k} -1,0, $old); |
610
|
|
|
|
|
|
|
$self->_update_children_position(@{$node->{parent}->{$key_children}}) |
611
|
|
|
|
|
|
|
if ( defined $node->{$self->_position_field}); |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
elsif ( $k eq 'parent') { |
614
|
|
|
|
|
|
|
my $old = $self->_remove_child_father($node); |
615
|
|
|
|
|
|
|
my $new_parent = $datas->{$k}; |
616
|
|
|
|
|
|
|
push(@{$new_parent->{$key_children}}, $old); |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
$node->{parent} = $new_parent; |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
my $msg = 'updating parent of '. $node->{$self->_search_field} . |
621
|
|
|
|
|
|
|
" ( " . $old->{name} . " -> ". $node->{parent}->{name} .")"; |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
$self->_bckd_update($node, $msg); |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
if ( defined $node->{$self->_position_field}) { |
626
|
|
|
|
|
|
|
$self->_update_children_position(@{$parent->{$key_children}}); |
627
|
|
|
|
|
|
|
$self->_update_children_position(@{$new_parent->{$key_children}}); |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
else { |
631
|
|
|
|
|
|
|
$node->{$k} = $datas->{$k}; |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
return $node; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
sub move { |
639
|
|
|
|
|
|
|
my ($self, $node, $parent) = @_; |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
return $self->update($node, { parent => $parent }); |
642
|
|
|
|
|
|
|
} |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
=head1 NAME |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
TreePath - Simple Tree Path! |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
=head1 VERSION |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
=head1 SYNOPSIS |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
use TreePath; |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
my $tp = TreePath->new( conf => $conf ); |
656
|
|
|
|
|
|
|
my $tree = $tp->tree; |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
# All nodes are hash |
659
|
|
|
|
|
|
|
# The first is called 'root' |
660
|
|
|
|
|
|
|
my $root = $tp->root; |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
# a node can have children |
663
|
|
|
|
|
|
|
my $children = $root->{children}; |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
=head1 SUBROUTINES/METHODS |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
=head2 new($method => $value) |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
# for now there are two backends : DBIX and File |
670
|
|
|
|
|
|
|
$tp = TreePath->new( conf => 't/conf/treefromdbix.yml') |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
# see t/conf/treepath.yml for hash structure |
673
|
|
|
|
|
|
|
$tp = TreePath->new( datas => $datas); |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
also see t/01-tpath.t |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
=cut |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
=head2 tree |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
$tree = $tp->tree; |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
=cut |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
=head2 reload |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
# reload tree from backend |
688
|
|
|
|
|
|
|
$tree = $tp->reload; |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
=cut |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
=head2 nodes |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
$root = $tp->root; |
695
|
|
|
|
|
|
|
# $root and $tree->{1} are the same node |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
This is the root node ( a simple hashref ) |
698
|
|
|
|
|
|
|
it has no parent. |
699
|
|
|
|
|
|
|
{ |
700
|
|
|
|
|
|
|
'1' => { |
701
|
|
|
|
|
|
|
'id' => '1', |
702
|
|
|
|
|
|
|
'name' => '/', |
703
|
|
|
|
|
|
|
'parent' => '0' |
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
$A = $tp->search( { name => 'A' } ); |
708
|
|
|
|
|
|
|
See the dump : |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
{ |
711
|
|
|
|
|
|
|
'children' => [ |
712
|
|
|
|
|
|
|
{ |
713
|
|
|
|
|
|
|
'children' => 'ARRAY(0x293ce00)', |
714
|
|
|
|
|
|
|
'id' => '3', |
715
|
|
|
|
|
|
|
'name' => 'B', |
716
|
|
|
|
|
|
|
'parent' => $VAR1 |
717
|
|
|
|
|
|
|
}, |
718
|
|
|
|
|
|
|
{ |
719
|
|
|
|
|
|
|
'children' => 'ARRAY(0x2fd69b0)', |
720
|
|
|
|
|
|
|
'id' => '7', |
721
|
|
|
|
|
|
|
'name' => 'F', |
722
|
|
|
|
|
|
|
'parent' => $VAR1 |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
], |
725
|
|
|
|
|
|
|
'id' => '2', |
726
|
|
|
|
|
|
|
'name' => 'A', |
727
|
|
|
|
|
|
|
'parent' => { |
728
|
|
|
|
|
|
|
'children' => [ |
729
|
|
|
|
|
|
|
$VAR1 |
730
|
|
|
|
|
|
|
], |
731
|
|
|
|
|
|
|
'id' => '1', |
732
|
|
|
|
|
|
|
'name' => '/', |
733
|
|
|
|
|
|
|
'parent' => '0' |
734
|
|
|
|
|
|
|
} |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
=> 'parent' is a reference on root node and 'children' is an array containing 2 nodes |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
=> if nodes have 'type', it's possible to 'link' some 'type' of node on some others types |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
For example, A:(type1), B:(type1, parent:A), C:(type2, parent:A) becomes : |
742
|
|
|
|
|
|
|
A:(type1, children:[B], children_type2[C]) |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
Each children can be ordered : { name => A, position => 2}; |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
It's also possible to block link with 'rules'. 'link' must be follow these rules to be applied. |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
=cut |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
=head2 search (hashref) |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
# in scalar context return the first result |
753
|
|
|
|
|
|
|
my $E = $tp->search( { name => 'E' } ); |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
# return all result in array context |
756
|
|
|
|
|
|
|
my @allE = $tp->search( { name => 'E' } ); |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
# It is also possible to specify a particular field of a hash |
759
|
|
|
|
|
|
|
my $B = $tp->search( { name => 'B', 'parent.name' => 'A'} ); |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
=cut |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
=head2 search_path (PATH) |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
# Search a path in a tree |
766
|
|
|
|
|
|
|
# in scalar context return last node |
767
|
|
|
|
|
|
|
my $c = $tp->search_path('/A/B/C'); |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
# in array context return found and not_found nodes |
770
|
|
|
|
|
|
|
my ($found, $not_found) = $tp->search_path('/A/B/X/D/E'); |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
=cut |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
=head2 dump |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
# dump whole tree |
777
|
|
|
|
|
|
|
print $tp->dump; |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# dump a node |
780
|
|
|
|
|
|
|
print $tp->dump($c);; |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
=cut |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
=head2 count |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# return the number of nodes |
787
|
|
|
|
|
|
|
print $tp->count; |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
=cut |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
=head2 traverse ($node, [\&function], [$args]) |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
# return an arrayref of nodes |
794
|
|
|
|
|
|
|
my $nodes = $tp->traverse($node); |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
# or use a function on each nodes |
797
|
|
|
|
|
|
|
$tp->traverse($node, \&function, $args); |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
=cut |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
=head2 del ($node) |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
# delete recursively all children and node |
804
|
|
|
|
|
|
|
$deleted = $tp->del($node); |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
# delete several nodes at once |
807
|
|
|
|
|
|
|
@del = $tp->del($n1, $n2, ...); |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
=cut |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
=head2 add ($parent, $node) |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
# add the root |
814
|
|
|
|
|
|
|
$root = $tp->add(0, { name => '/'}); |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
# add a node beneath the parent at the last position. |
817
|
|
|
|
|
|
|
$Z = $tp->add($parent, { name => 'Z' }); |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
# or at given position |
820
|
|
|
|
|
|
|
$Z = $tp->add($parent, { name => 'Z', position => 2 }); |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=cut |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
=head2 update ($node, $datas) |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
# update node with somes datas |
827
|
|
|
|
|
|
|
$Z = $tp->update($node, { name => 'new_name' }); |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
# it's possible to update position |
830
|
|
|
|
|
|
|
$X = $tp->update($node, { position => 2 }); |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
=cut |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
=head2 move ($node, $parent) |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
# move a node as child of given parent |
838
|
|
|
|
|
|
|
$Z = $tp->move($Z, $X); |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
=cut |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
=head2 insert_before ($sibling, $node) |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
# Inserts a node beneath the parent before the given sibling. |
845
|
|
|
|
|
|
|
$Y = $tp->insert_before($Z, { name => 'Y' }); |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
=cut |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
=head1 AUTHOR |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
Daniel Brosseau, C<< <dab at catapulse.org> >> |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
=head1 BUGS |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
Please report any bugs or feature requests to C<bug-tpath at rt.cpan.org>, or through |
858
|
|
|
|
|
|
|
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TreePath>. I will be notified, and then you'll |
859
|
|
|
|
|
|
|
automatically be notified of progress on your bug as I make changes. |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
=head1 SUPPORT |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
perldoc TreePath |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
You can also look for information at: |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
=over 4 |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker (report bugs here) |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=TreePath> |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
L<http://annocpan.org/dist/TreePath> |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
=item * CPAN Ratings |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
L<http://cpanratings.perl.org/d/TreePath> |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
=item * Search CPAN |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
L<http://search.cpan.org/dist/TreePath/> |
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
=back |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
=head1 LICENSE AND COPYRIGHT |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
Copyright 2014 Daniel Brosseau. |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
902
|
|
|
|
|
|
|
under the terms of the the Artistic License (2.0). You may obtain a |
903
|
|
|
|
|
|
|
copy of the full license at: |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
L<http://www.perlfoundation.org/artistic_license_2_0> |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
Any use, modification, and distribution of the Standard or Modified |
908
|
|
|
|
|
|
|
Versions is governed by this Artistic License. By using, modifying or |
909
|
|
|
|
|
|
|
distributing the Package, you accept this license. Do not use, modify, |
910
|
|
|
|
|
|
|
or distribute the Package, if you do not accept this license. |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
If your Modified Version has been derived from a Modified Version made |
913
|
|
|
|
|
|
|
by someone other than you, you are nevertheless required to ensure that |
914
|
|
|
|
|
|
|
your Modified Version complies with the requirements of this license. |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
This license does not grant you the right to use any trademark, service |
917
|
|
|
|
|
|
|
mark, tradename, or logo of the Copyright Holder. |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
This license includes the non-exclusive, worldwide, free-of-charge |
920
|
|
|
|
|
|
|
patent license to make, have made, use, offer to sell, sell, import and |
921
|
|
|
|
|
|
|
otherwise transfer the Package with respect to any patent claims |
922
|
|
|
|
|
|
|
licensable by the Copyright Holder that are necessarily infringed by the |
923
|
|
|
|
|
|
|
Package. If you institute patent litigation (including a cross-claim or |
924
|
|
|
|
|
|
|
counterclaim) against any party alleging that the Package constitutes |
925
|
|
|
|
|
|
|
direct or contributory patent infringement, then this Artistic License |
926
|
|
|
|
|
|
|
to you shall terminate on the date that such litigation is filed. |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER |
929
|
|
|
|
|
|
|
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. |
930
|
|
|
|
|
|
|
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR |
931
|
|
|
|
|
|
|
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY |
932
|
|
|
|
|
|
|
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR |
933
|
|
|
|
|
|
|
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR |
934
|
|
|
|
|
|
|
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, |
935
|
|
|
|
|
|
|
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
=cut |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
1; # End of TreePath |