File Coverage

blib/lib/Config/Model/Iterator.pm
Criterion Covered Total %
statement 129 135 95.5
branch 38 50 76.0
condition 26 39 66.6
subroutine 22 22 100.0
pod 6 9 66.6
total 221 255 86.6


line stmt bran cond sub pod time code
1             #
2             # This file is part of Config-Model
3             #
4             # This software is Copyright (c) 2005-2022 by Dominique Dumont.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10              
11             use v5.20;
12 59     59   662 use Carp;
  59         191  
13 59     59   273 use strict;
  59         130  
  59         2973  
14 59     59   325 use warnings;
  59         124  
  59         1324  
15 59     59   282 use Config::Model::ObjTreeScanner;
  59         98  
  59         1665  
16 59     59   363 use Log::Log4perl qw(get_logger :levels);
  59         116  
  59         1715  
17 59     59   333  
  59         138  
  59         404  
18             use Config::Model::Exception;
19 59     59   6990  
  59         114  
  59         1692  
20             use feature qw/postderef signatures/;
21 59     59   338 no warnings qw/experimental::postderef experimental::signatures/;
  59         132  
  59         5412  
22 59     59   411  
  59         139  
  59         94011  
23             my $logger = get_logger("Iterator");
24              
25              
26 1     1 0 2 my $self = {
  1         2  
  1         5  
  1         1  
27             call_back_on_important => 0,
28 1         3 forward => 1,
29             status => 'standard',
30             };
31              
32             if (delete $args{experience}) {
33             carp "experience parameter is deprecated";
34 1 50       4 }
35 0         0  
36             foreach my $p (qw/root/) {
37             $self->{$p} = delete $args{$p}
38 1         3 or croak "Iterator->new: Missing $p parameter";
39 1 50       4 }
40              
41             foreach my $p (qw/call_back_on_important call_back_on_warning status/) {
42             $self->{$p} = delete $args{$p} if defined $args{$p};
43 1         2 }
44 3 100       8  
45             bless $self, $type;
46              
47 1         3 my %cb_hash;
48              
49 1         1 # mandatory call-back parameters
50             foreach my $item (qw/leaf_cb hash_element_cb/) {
51             $cb_hash{$item} = delete $args{$item}
52 1         3 or croak "Iterator->new: Missing $item parameter";
53 2 50       6 }
54              
55             # handle optional list_element_cb parameter
56             $cb_hash{list_element_cb} = delete $args{list_element_cb}
57             || $cb_hash{hash_element_cb};
58              
59 1   33     3 # optional call-back parameter
60             $cb_hash{check_list_element_cb} =
61             delete $args{check_list_element_cb} || $cb_hash{leaf_cb};
62              
63 1   33     6 # optional call-back parameters
64             foreach my $p (
65             qw/enum_value reference_value
66 1         3 integer_value number_value
67             boolean_value string_value uniline_value/
68             ) {
69             my $item = $p . '_cb';
70             $cb_hash{$item} = delete $args{$item} || $cb_hash{leaf_cb};
71 7         10 }
72 7   66     20  
73             $self->{dispatch_cb} = \%cb_hash;
74              
75 1         6 if (%args) {
76             die "Iterator->new: unexpected parameters: ", join( ' ', keys %args ), "\n";
77 1 50       2 }
78 0         0  
79             # user call-back are *not* passed to ObjTreeScanner. They will be
80             # called indirectly through wizard-helper own call-backs
81              
82             $self->{scanner} = Config::Model::ObjTreeScanner->new(
83             fallback => 'all',
84             hash_element_cb => sub { $self->hash_element_cb(@_) },
85             list_element_cb => sub { $self->hash_element_cb(@_) },
86 15     15   34 node_content_cb => sub { $self->node_content_cb(@_) },
87 5     5   11 leaf_cb => sub { $self->leaf_cb(@_) },
88 36     36   84 );
89 175     175   363  
90 1         15 return $self;
91             }
92 1         5  
93             my $self = shift;
94             $self->{bail_out} = 0;
95             $self->{scanner}->scan_node( undef, $self->{root} );
96 1     1 1 384 return;
97 1         3 }
98 1         5  
99 1         3 my $self = shift;
100             $self->{bail_out} = 1;
101             return;
102             }
103 1     1 1 11  
104 1         3 # internal. This call-back is passed to ObjTreeScanner. It will call
105 1         3 # scan_element in an order which depends on $self->{forward}.
106             my ( $self, $scanner, $data_r, $node, @element ) = @_;
107              
108             $logger->info( "node_content_cb called on '", $node->name, "' element: @element" );
109              
110             my $element;
111 36     36 0 89  
112             while (1) {
113 36         75  
114             # @element from ObjTreeScanner is not used as user actions may
115 36         214 # change the element list due to warping
116             $element = $node->next_element(
117 36         46 name => $element,
118             status => $self->{status},
119             reverse => 1 - $self->{forward} );
120              
121             last unless defined $element;
122              
123             $logger->info( "node_content_cb calls scan_element ", "on element $element" );
124 232         727  
125             $self->{scanner}->scan_element( $data_r, $node, $element );
126 232 100       402 return if $self->{bail_out};
127             }
128 197         662 return;
129             }
130 197         1660  
131 197 100       424 # internal. Used to find which user call-back to use for a given
132             # element type.
133 35         83 my $self = shift;
134             my $elt_type = shift;
135             return $self->{dispatch_cb}{ $elt_type . '_cb' }
136             || croak "wizard get_cb: unexpected type $elt_type";
137             }
138              
139 195     195 0 238 # internal. This call-back is passed to ObjTreeScanner. It will call
140 195         256 # scan_hash in an order which depends on $self->{forward}. it will
141 195   33     480 # also check if the hash (or list) element is flagged as 'important'
142             # and call user's hash or list call-back if needed
143             my @keys = sort @raw_keys;
144              
145             my $level = $node->get_element_property( element => $element, property => 'level' );
146              
147             $logger->info( "hash_element_cb (element $element) called on '",
148             $node->location, "' level $level, keys: '@keys'" );
149 20     20 1 22  
  20         23  
  20         23  
  20         20  
  20         24  
  20         27  
  20         30  
  20         23  
150 20         44 # get the call-back to use
151             my $cb = $self->get_cb( $node->element_type($element) . '_element' );
152 20         44  
153             # use the same algorithm for check_important and
154 20         125 # scan_element pseudo elements
155             my $i = $self->{forward} == 1 ? 0 : 1;
156              
157             while ( $i >= 0 and $i < 2 ) {
158 20         146 if ( $self->{call_back_on_important} and $i == 0 and $level eq 'important' ) {
159             $cb->( $self, $data_r, $node, $element, @keys );
160             return if $self->{bail_out}; # may be modified in callback
161             # recompute keys as they may have been modified during call-back
162 20 100       47 @keys = $self->{scanner}->get_keys( $node, $element );
163             }
164 20   100     59  
165 41 100 66     126 if ( $self->{call_back_on_warning} and $i == 0 and $node->fetch_element($element)->has_warning ) {
      100        
166 3         11 $logger->info("hash_element_cb found elt with warning: '", $node->name, "' element $element");
167 3 50       2173 $cb->( $self, $data_r, $node, $element, @keys );
168             }
169 3         10  
170             if ( $i == 1 ) {
171             my $j = $self->{forward} == 1 ? 0 : $#keys;
172 41 50 66     125 while ( $j >= 0 and $j < @keys ) {
      66        
173 0         0 my $k = $keys[$j];
174 0         0 $logger->info( "hash_element_cb (element $element) calls ", "scan_hash on key $k" );
175             $self->{scanner}->scan_hash( $data_r, $node, $element, $k );
176             $j += $self->{forward};
177 41 100       72 }
178 21 100       39 }
179 21   100     55 $i += $self->{forward};
180 33         52 }
181 33         121 return;
182 33         256 }
183 33         111  
184             # internal. This call-back is passed to ObjTreeScanner. It will also
185             # check if the leaf element is flagged as 'important' or if the leaf
186 41         112 # element contains an error (mostly undefined mandatory values) and
187             # call user's call-back if needed
188 20         50  
189             my ( $self, $scanner, $data_r, $node, $element, $index, $value_obj ) = @_;
190              
191             $logger->info(
192             "leaf_cb called on '",
193             $node->name,
194             "' element '$element'",
195             defined $index ? ", index $index" : ''
196             );
197 175     175 1 308  
198             my $elt_type = $node->element_type($element);
199 175 100       333 my $key =
200             $elt_type eq 'check_list'
201             ? 'check_list_element'
202             : $value_obj->value_type . '_value';
203              
204             my $user_leaf_cb = $self->get_cb($key);
205              
206 175         1195 my $level = $node->get_element_property( element => $element, property => 'level' );
207 175 100       450  
208             if ( $self->{call_back_on_important} and $level eq 'important' ) {
209             $logger->info(
210             "leaf_cb found important elt: '",
211             $node->name,
212 175         320 "' element $element",
213             defined $index ? ", index $index" : ''
214 175         345 );
215             $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj );
216 175 100 66     552 }
217 19 100       36  
218             if ( $self->{call_back_on_warning} and $value_obj->warning_msg ) {
219             $logger->info(
220             "leaf_cb found elt with warning: '",
221             $node->name,
222             "' element $element",
223 19         135 defined $index ? ", index $index" : ''
224             );
225             $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj );
226 175 100 66     13679 }
227 1 50       17  
228             # now need to check for errors...
229             my $result;
230             eval { $result = $value_obj->fetch(); };
231              
232             my $e = $@;
233 1         7 if ( ref $e and $e->isa('Config::Model::Exception::User') ) {
234              
235             # ignore errors that has just been catched and call user call-back
236             $logger->info(
237 175         3119 "leaf_cb oopsed on '",
238 175         253 $node->name,
  175         411  
239             "' element $element",
240 175         270 defined $index ? ", index $index" : ''
241 175 100 66     502 );
    50          
    50          
242             $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj, $e->error );
243             }
244 3 50       11 elsif ( ref $e ) {
245             $e->rethrow;
246             # does not return ...
247             }
248             elsif ($e) {
249             die "Iterator failed on value object: $e";
250 3         28 }
251             return;
252             }
253 0         0  
254             my $self = shift;
255             $logger->info("Going forward") if $self->{forward} == -1;
256             $self->{forward} = 1;
257 0         0 return;
258             }
259 175         2590  
260             my $self = shift;
261             $logger->info("Going backward") if $self->{forward} == 1;
262             $self->{forward} = -1;
263 2     2 1 18 return;
264 2 50       10 }
265 2         13  
266 2         4 1;
267              
268             # ABSTRACT: Iterates forward or backward a configuration tree
269              
270 3     3 1 34  
271 3 50       13 =pod
272 3         17  
273 3         7 =encoding UTF-8
274              
275             =head1 NAME
276              
277             Config::Model::Iterator - Iterates forward or backward a configuration tree
278              
279             =head1 VERSION
280              
281             version 2.151
282              
283             =head1 SYNOPSIS
284              
285             use Config::Model;
286              
287             # define configuration tree object
288             my $model = Config::Model->new;
289             $model->create_config_class(
290             name => "Foo",
291             element => [
292             [qw/bar baz/] => {
293             type => 'leaf',
294             value_type => 'string',
295             level => 'important' ,
296             },
297             ]
298             );
299             $model->create_config_class(
300             name => "MyClass",
301             element => [
302             foo_nodes => {
303             type => 'hash', # hash id
304             index_type => 'string',
305             level => 'important' ,
306             cargo => {
307             type => 'node',
308             config_class_name => 'Foo'
309             },
310             },
311             ],
312             );
313              
314             my $inst = $model->instance( root_class_name => 'MyClass' );
315             # create some Foo objects
316             $inst->config_root->load("foo_nodes:foo1 - foo_nodes:foo2 ") ;
317              
318             my $my_leaf_cb = sub {
319             my ($iter, $data_r,$node,$element,$index, $leaf_object) = @_ ;
320             print "leaf_cb called for ",$leaf_object->location,"\n" ;
321             } ;
322             my $my_hash_cb = sub {
323             my ($iter, $data_r,$node,$element,@keys) = @_ ;
324             print "hash_element_cb called for element $element with keys @keys\n" ;
325             } ;
326              
327             my $iterator = $inst -> iterator (
328             leaf_cb => $my_leaf_cb,
329             hash_element_cb => $my_hash_cb ,
330             );
331              
332             $iterator->start ;
333             ### prints
334             # hash_element_cb called for element foo_nodes with keys foo1 foo2
335             # leaf_cb called for foo_nodes:foo1 bar
336             # leaf_cb called for foo_nodes:foo1 baz
337             # leaf_cb called for foo_nodes:foo2 bar
338             # leaf_cb called for foo_nodes:foo2 baz
339              
340             =head1 DESCRIPTION
341              
342             This module provides a class that is able to iterate forward or backward a configuration tree.
343             The iterator stops and calls back user defined subroutines on one of the following condition:
344              
345             =over
346              
347             =item *
348              
349             A configuration item contains an error (mostly undefined mandatory
350             values)
351              
352             =item *
353              
354             A configuration item contains warnings and the constructor's argument
355             C<call_back_on_warning> was set.
356              
357             =item *
358              
359             A configuration item has a C<important> level and the constructor's argument
360             C<call_back_on_important> was set.. See
361             L<level parameter|Config::Model::Node/"Configuration class declaration">
362             for details.
363              
364             =back
365              
366             The iterator supports going forward and backward
367             (to support C<back> and C<next> buttons on a wizard widget).
368              
369             =head1 CONSTRUCTOR
370              
371             The constructor should be used only by L<Config::Model::Instance> with
372             the L<iterator|Config::Model::Instance/"iterator ( ... )">
373             method.
374              
375             =head1 Creating an iterator
376              
377             A iterator requires at least two kind of call-back:
378             a call-back for leaf elements and a call-back
379             for hash elements (which is also used for list elements).
380              
381             These call-back must be passed when creating the iterator (the
382             parameters are named C<leaf_cb> and C<hash_element_cb>)
383              
384             Here are the the parameters accepted by C<iterator>:
385              
386             =head2 call_back_on_important
387              
388             Whether to call back when an important element is found (default 0).
389              
390             =head2 call_back_on_warning
391              
392             Whether to call back when an item with warnings is found (default 0).
393              
394             =head2 status
395              
396             Specifies the status of the element scanned by the wizard (default
397             'standard').
398              
399             =head2 leaf_cb
400              
401             Subroutine called backed for leaf elements. See
402             L<Config::Model::ObjTreeScanner/"Callback prototypes"> for signature
403             and details. (mandatory)
404              
405             =head2 hash_element_cb
406              
407             Subroutine called backed for hash elements. See
408             L<Config::Model::ObjTreeScanner/"Callback prototypes"> for signature
409             and details. (mandatory)
410              
411             =head1 Custom callbacks
412              
413             By default, C<leaf_cb> is called for all types of leaf elements
414             (i.e enum. integer, strings, ...). But you can provide dedicated
415             call-back for each type of leaf:
416              
417             enum_value_cb, integer_value_cb, number_value_cb, boolean_value_cb,
418             uniline_value_cb, string_value_cb
419              
420             Likewise, you can also provide a call-back dedicated to list elements with
421             C<list_element_cb>
422              
423             =head1 Methods
424              
425             =head2 start
426              
427             Start the scan and perform call-back when needed. This function returns
428             when the scan is completely done.
429              
430             =head2 bail_out
431              
432             When called, a variable is set so that all call_backs returns as soon as possible. Used to
433             abort wizard.
434              
435             =head2 go_forward
436              
437             Set wizard in forward (default) mode.
438              
439             =head2 go_backward
440              
441             Set wizard in backward mode.
442              
443             =head1 AUTHOR
444              
445             Dominique Dumont, (ddumont at cpan dot org)
446              
447             =head1 SEE ALSO
448              
449             L<Config::Model>,
450             L<Config::Model::Instance>,
451             L<Config::Model::Node>,
452             L<Config::Model::HashId>,
453             L<Config::Model::ListId>,
454             L<Config::Model::Value>,
455             L<Config::Model::CheckList>,
456             L<Config::Model::ObjTreeScanner>,
457              
458             =head1 AUTHOR
459              
460             Dominique Dumont
461              
462             =head1 COPYRIGHT AND LICENSE
463              
464             This software is Copyright (c) 2005-2022 by Dominique Dumont.
465              
466             This is free software, licensed under:
467              
468             The GNU Lesser General Public License, Version 2.1, February 1999
469              
470             =cut