This file is indexed.

/usr/share/perl5/Config/Model/ObjTreeScanner.pm is in libconfig-model-perl 2.082-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
#
# This file is part of Config-Model
#
# This software is Copyright (c) 2005-2016 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::ObjTreeScanner;
$Config::Model::ObjTreeScanner::VERSION = '2.082';
use strict;
use Config::Model::Exception;
use Scalar::Util qw/blessed/;
use Carp::Assert::More;
use Carp;
use warnings;

use Carp qw/croak confess cluck/;

sub new {
    my $type = shift;
    my %args = @_;

    my $self = { auto_vivify => 1, check => 'yes' };
    bless $self, $type;

    $self->{leaf_cb} = delete $args{leaf_cb}
        or croak __PACKAGE__, "->new: missing leaf_cb parameter";

    # we may use leaf_cb
    $self->create_fallback( delete $args{fallback} || 'all' );

    # get all call_backs
    my @value_cb =
        map { $_ . '_value_cb' } qw/boolean enum string uniline integer number reference/;

    foreach my $param (
        qw/check node_element_cb hash_element_cb
        list_element_cb check_list_element_cb node_content_cb
        node_content_hook list_element_hook hash_element_hook
        auto_vivify up_cb/, @value_cb
        ) {
        $self->{$param} = $args{$param} if defined $args{$param};
        delete $args{$param};    # may exists but be undefined
        croak __PACKAGE__, "->new: missing $param parameter"
            unless defined $self->{$param};
    }

    if (delete $args{experience}) {
        carp "->new: experience parameter is deprecated";
    }

    # this parameter is optional and does not need a fallback
    $self->{node_dispatch_cb} = delete $args{node_dispatch_cb} || {};

    croak __PACKAGE__, "->new: node_dispatch_cb is not a hash ref"
        unless ref( $self->{node_dispatch_cb} ) eq 'HASH';

    croak __PACKAGE__, "->new: unexpected check: $self->{check}"
        unless $self->{check} =~ /yes|no|skip/;

    croak __PACKAGE__, "->new: unexpected parameter: ", join( ' ', keys %args )
        if scalar %args;

    return $self;
}

# internal
sub create_fallback {
    my $self     = shift;
    my $fallback = shift;

    map {
        $self->{$_} =
            sub { }
    } qw/node_content_hook hash_element_hook list_element_hook/;

    return if not defined $fallback or $fallback eq 'none';

    my $done = 0;

    if ( $fallback eq 'node' or $fallback eq 'all' ) {
        $done++;
        my $node_content_cb = sub {
            my ( $scanner, $data_r, $node, @element ) = @_;
            map { $scanner->scan_element( $data_r, $node, $_ ) } @element;
        };

        my $node_element_cb = sub {
            my ( $scanner, $data_r, $node, $element_name, $key, $next_node ) = @_;
            $scanner->scan_node( $data_r, $next_node );
        };

        my $hash_element_cb = sub {
            my ( $scanner, $data_r, $node, $element_name, @keys ) = @_;
            map { $scanner->scan_hash( $data_r, $node, $element_name, $_ ) } @keys;
        };

        $self->{list_element_cb} = $hash_element_cb;
        $self->{hash_element_cb} = $hash_element_cb;
        $self->{node_element_cb} = $node_element_cb;
        $self->{node_content_cb} = $node_content_cb;
        $self->{up_cb}           = sub { };            # do nothing
    }

    if ( $fallback eq 'leaf' or $fallback eq 'all' ) {
        $done++;
        my $l = $self->{string_value_cb} ||= $self->{leaf_cb};

        $self->{check_list_element_cb} ||= $l;
        $self->{enum_value_cb}         ||= $l;
        $self->{integer_value_cb}      ||= $l;
        $self->{number_value_cb}       ||= $l;
        $self->{boolean_value_cb}      ||= $l;
        $self->{reference_value_cb}    ||= $l;
        $self->{uniline_value_cb}      ||= $l;
    }

    croak __PACKAGE__, "->new: Unexpected fallback value '$fallback'. ",
        "Expected 'node', 'leaf', 'all' or 'none'"
        if not $done;
}

sub scan_node {
    my ( $self, $data_r, $node ) = @_;

    #print "scan_node ",$node->name,"\n";
    # get all elements according to catalog

    Config::Model::Exception::Internal->throw( error => "'$node' is not a Config::Model object" )
        unless blessed($node)
        and $node->isa("Config::Model::AnyThing");

    # skip exploration of warped out node
    if ( $node->isa('Config::Model::WarpedNode') ) {
        $node = $node->get_actual_node;
        return unless defined $node;
    }

    my $config_class     = $node->config_class_name;
    my $node_dispatch_cb = $self->{node_dispatch_cb}{$config_class};

    my $actual_cb = $node_dispatch_cb || $self->{node_content_cb};

    my @element_list = $node->get_element_name( check => $self->{check} );

    $self->{node_content_hook}->( $self, $data_r, $node, @element_list );

    # we could add here a "last element" call-back, but it's not
    # very useful if the last element is a hash.
    $actual_cb->( $self, $data_r, $node, @element_list );

    $self->{up_cb}->( $self, $data_r, $node );
}

sub scan_element {
    my ( $self, $data_r, $node, $element_name ) = @_;

    my $element_type = $node->element_type($element_name);

    my $autov = $self->{auto_vivify};

    #print "scan_element $element_name ";
    if ( $element_type eq 'hash' ) {

        #print "type hash\n";
        my @keys = $self->get_keys( $node, $element_name );

        # if hash element grab keys and perform callback
        $self->{hash_element_hook}->( $self, $data_r, $node, $element_name, @keys );
        $self->{hash_element_cb}->( $self, $data_r, $node, $element_name, @keys );
    }
    elsif ( $element_type eq 'list' ) {

        #print "type list\n";
        my @keys = $self->get_keys( $node, $element_name );
        $self->{list_element_hook}->( $self, $data_r, $node, $element_name, @keys );
        $self->{list_element_cb}->( $self, $data_r, $node, $element_name, @keys );
    }
    elsif ( $element_type eq 'check_list' ) {

        #print "type list\n";
        my $cl_elt = $node->fetch_element( name => $element_name, check => $self->{check} );
        $self->{check_list_element_cb}->( $self, $data_r, $node, $element_name, undef, $cl_elt );
    }
    elsif ( $element_type eq 'node' ) {

        #print "type object\n";
        # avoid auto-vivification
        my $next_obj =
            ( $autov or $node->is_element_defined($element_name) )
            ? $node->fetch_element( name => $element_name, check => $self->{check} )
            : undef;

        # if obj element, cb
        $self->{node_element_cb}->( $self, $data_r, $node, $element_name, undef, $next_obj );
    }
    elsif ( $element_type eq 'warped_node' ) {

        #print "type warped\n";
        my $next_obj =
            ( $autov or $node->is_element_defined($element_name) )
            ? $node->fetch_element( name => $element_name, check => $self->{check} )
            : undef;
        $self->{node_element_cb}->( $self, $data_r, $node, $element_name, undef, $next_obj );
    }
    elsif ( $element_type eq 'leaf' ) {
        my $next_obj = $node->fetch_element( name => $element_name, check => $self->{check} );
        my $type = $next_obj->value_type;
        return unless $type;
        my $cb_name = $type . '_value_cb';
        my $cb      = $self->{$cb_name};
        croak "scan_element: No call_back specified for '$cb_name'"
            unless defined $cb;
        $cb->( $self, $data_r, $node, $element_name, undef, $next_obj );
    }
    else {
        croak "Unexpected element_type: $element_type";
    }
}

sub scan_hash {
    my ( $self, $data_r, $node, $element_name, $key ) = @_;

    assert_like( $node->element_type($element_name), qr/(hash|list)/ );

    #print "scan_hash ",$node->name," element $element_name key $key ";
    my $item = $node->fetch_element( name => $element_name, check => $self->{check} );

    my $cargo_type = $item->cargo_type($element_name);
    my $next_obj = $item->fetch_with_id( index => $key, check => $self->{check} );

    if ( $cargo_type =~ /node$/ ) {

        #print "type object or warped\n";
        $self->{node_element_cb}->( $self, $data_r, $node, $element_name, $key, $next_obj );
    }
    elsif ( $cargo_type eq 'leaf' ) {
        my $cb_name = $next_obj->value_type . '_value_cb';
        my $cb      = $self->{$cb_name};
        croak "scan_hash: No call_back specified for '$cb_name'"
            unless defined $cb;
        $cb->( $self, $data_r, $node, $element_name, $key, $next_obj );
    }
    else {
        croak "Unexpected cargo_type: $cargo_type";
    }
}

sub scan_list {
    goto &scan_hash;
}

sub get_keys {
    my ( $self, $node, $element_name ) = @_;

    my $element_type = $node->element_type($element_name);
    my $item = $node->fetch_element( name => $element_name, check => $self->{check} );

    return $item->fetch_all_indexes
        if $element_type eq 'hash'
        || $element_type eq 'list';

    Config::Model::Exception::Internal->throw(
        error  => "called get_keys on non hash or non list" . " element $element_name",
        object => $node
    );

}

1;

# ABSTRACT: Scan config tree and perform call-backs for each element or node

__END__

=pod

=encoding UTF-8

=head1 NAME

Config::Model::ObjTreeScanner - Scan config tree and perform call-backs for each element or node

=head1 VERSION

version 2.082

=head1 SYNOPSIS

 use Config::Model ;

 # define configuration tree object
 my $model = Config::Model->new ;
 $model ->create_config_class (
    name => "MyClass",
    element => [
        [qw/foo bar/] => {
            type => 'leaf',
            value_type => 'string'
        },
        baz => {
            type => 'hash',
            index_type => 'string' ,
            cargo => {
                type => 'leaf',
                value_type => 'string',
            },
        },

    ],
 ) ;

 my $inst = $model->instance(root_class_name => 'MyClass' );

 my $root = $inst->config_root ;

 # put some data in config tree the hard way
 $root->fetch_element('foo')->store('yada') ;
 $root->fetch_element('bar')->store('bla bla') ;
 $root->fetch_element('baz')->fetch_with_id('en')->store('hello') ;

 # put more data the easy way
 my $step = 'baz:fr=bonjour baz:hr="dobar dan"';
 $root->load( step => $step ) ;

 # define leaf call back
 my $disp_leaf = sub {
      my ($scanner, $data_ref, $node,$element_name,$index, $leaf_object) = @_ ;
      $$data_ref .= "disp_leaf called for '". $leaf_object->name.
	"' value '".$leaf_object->fetch."'\n";
    } ;

 # simple scanner, (print all values)
 my $scan = Config::Model::ObjTreeScanner-> new (
   leaf_cb => $disp_leaf, # only mandatory parameter
 ) ;

 my $result = '';
 $scan->scan_node(\$result, $root) ;
 print $result ;

=head1 DESCRIPTION

This module creates an object that will explore (depth first) a
configuration tree.

For each part of the configuration tree, ObjTreeScanner object will call
one of the subroutine reference passed during construction. (a call-back
or a hook)

Call-back and hook routines will be called:

=over

=item *

For each node containing elements (including root node)

=item *

For each element of a node. This element can be a list, hash, node or
simple leaf element.

=item *

For each item contained in a node, hash or list. This item can be a
simple leaf or another node.

=back

To continue the exploration, these call-backs must also call the
scanner. (i.e. perform another call-back). In other words the user's
subroutine and the scanner play a game of ping-pong until the tree is
completely explored.

Hooks routines are not required to resume the exploration, i.e. to call
the scanner. This will be done after the hook routine has returned.

The scanner provides a set of default callback for the nodes. This
way, the user only have to provide call-backs for the leaves.

The scan is started with a call to C<scan_node>. The first parameter
of scan_node is a ref that is passed untouched to all call-back. This
ref may be used to store whatever result you want.

=head1 CONSTRUCTOR

=head2 new ( ... )

One way or another, the ObjTreeScanner object must be able to find all
callback for all the items of the tree. All the possible call-back and
hooks are listed below:

=over

=item leaf callback:

C<leaf_cb> is a catch-all generic callback. All other are specialized
call-back : C<enum_value_cb>, C<integer_value_cb>, C<number_value_cb>,
C<boolean_value_cb>, C<string_value_cb>, C<uniline_value_cb>,
C<reference_value_cb>

=item node callback:

C<node_content_cb> , C<node_dispatch_cb>

=item node hooks:

C<node_content_hook>

=item element callback:

All these call-backs are called on the elements of a node:
C<list_element_cb>, C<check_list_element_cb>, C<hash_element_cb>,
C<node_element_cb>, C<node_content_cb>.

=item element hooks:

C<list_element_hook>, C<hash_element_hook>.

=back

The user may specify all of them by passing a sub ref to the
constructor:

   $scan = Config::Model::ObjTreeScanner-> new
  (
   list_element_cb => sub { ... },
   ...
  )

Or use some default callback using the fallback parameter. Note that
at least one callback must be provided: C<leaf_cb>.

Optional parameter:

=over

=item fallback

If set to C<node>, the scanner will provide default call-back for node
items. If set to C<leaf>, the scanner will set all leaf callback (like
enum_value_cb ...) to string_value_cb or to the mandatory leaf_cb
value. "fallback" callback will not override callbacks provided by the
user.

If set to C<all> , the scanner provides fallbacks for leaf and node. 
By default, all fallback are provided.

=item auto_vivify

Whether to create configuration objects while scanning (default is 1).

=item check

C<yes>, C<no> or C<skip>.

=back

=head1 Callback prototypes

=head2 Leaf callback

C<leaf_cb> is called for each leaf of the tree. The leaf callback will
be called with the following parameters:

 ($scanner, $data_ref,$node,$element_name,$index, $leaf_object)

where:

=over

=item *

C<$scanner> is the scanner object.

=item *

C<$data_ref> is a reference that is first passed to the first call of
the scanner. Then C<$data_ref> is relayed through the various
call-backs

=item *

C<$node> is the node that contain the leaf.

=item *

C<$element_name> is the element (or attribute) that contain the leaf.

=item *

C<$index> is the index (or hash key) used to get the leaf. This may
be undefined if the element type is scalar.

=item *

C<$leaf_object> is a L<Config::Model::Value> object.

=back

=head2 List element callback

C<list_element_cb> is called on all list element of a node, i.e. call
on the list object itself and not in the elements contained in the
list.

 ($scanner, $data_ref,$node,$element_name,@indexes)

C<@indexes> is a list containing all the indexes of the list.

Example:

  sub my_list_element_cb {
     my ($scanner, $data_ref,$node,$element_name,@idx) = @_ ;

     # custom code using $data_ref

     # resume exploration (if needed)
     map {$scanner->scan_list($data_ref,$node,$element_name,$_)} @idx ;

     # note: scan_list and scan_hash are equivalent
  }

=head2 List element hook

C<list_element_hook>: Works like the list element callback. Except that the calls to
C<scan_list> are not required. This will be done once the hook returns.

=head2 Check list element callback

C<check_list_element_cb>: Like C<list_element_cb>, but called on a
check_list element.

 ($scanner, $data_ref,$node,$element_name,@check_items)

C<@check_items> is a list containing all the items of the check_list.

=head2 Hash element callback

C<hash_element_cb>: Like C<list_element_cb>, but called on a
hash element.

 ($scanner, $data_ref,$node,$element_name,@keys)

C<@keys> is an list containing all the keys of the hash.

Example:

  sub my_hash_element_cb {
     my ($scanner, $data_ref,$node,$element_name,@keys) = @_ ;

     # custom code using $data_ref

     # resume exploration
     map {$scanner->scan_hash($data_ref,$node,$element_name,$_)} @keys ;
  }

=head2 Hash element hook

C<hash_element_hook>: Works like the hash element callback. Except that the calls to
C<scan_hash> are not required. This will be done once the hook returns.

=head2 Node content callback

C<node_content_cb>: This call-back is called foreach node (including
root node).

 ($scanner, $data_ref,$node,@element_list)

C<@element_list> contains all the element names of the node.

Example:

  sub my_content_cb {
     my ($scanner, $data_ref,$node,@element) = @_ ;

     # custom code using $data_ref

     # resume exploration
     map {$scanner->scan_element($data_ref, $node,$_)} @element ;
  }

=head2 Node content hook

C<node_content_hook>: This hook is called foreach node (including
root node). Works like the node content call-back. Except that the calls to
C<scan_element> are not required. This will be done once the hook returns.

=head2 Dispatch node callback

C<node_dispatch_cb>: Any callback specified in the hash will be called for
each instance of the specified configuration class.
(this may include the  root node).

For instance, if you have:

  node_dispach_cb => {
    ClassA => \&my_class_a_dispatch_cb,
    ClassB => \&my_class_b_dispatch_cb,
  }

C<&my_class_a_dispatch_cb> will be called for each instance of C<ClassA> and
C<&my_class_b_dispatch_cb> will be called for each instance of C<ClassB>.

They will be called with the following parameters:

 ($scanner, $data_ref,$node,@element_list)

C<@element_list> contains all the element names of the node.

Example:

  sub my_class_a_dispatch_cb = {
     my ($scanner, $data_ref,$node,@element) = @_ ;

     # custom code using $data_ref

     # resume exploration
     map {$scanner->scan_element($data_ref, $node,$_)} @element ;
  }

=head2 Node element callback

C<node_element_cb> is called for each node contained within a node
(i.e not with root node). This node can be held by a plain element or
a hash element or a list element:

 ($scanner, $data_ref,$node,$element_name,$key, $contained_node)

C<$key> may be undef if C<$contained_node> is not a part of a hash or
a list. C<$element_name> and C<$key> specifies the element name and
key of the the contained node you want to scan. (passed with
C<$contained_node>) Note that C<$contained_node> may be undef if
C<auto_vivify> is 0.

Example:

  sub my_node_element_cb {
    my ($scanner, $data_ref,$node,$element_name,$key, $contained_node) = @_;

    # your custom code using $data_ref

    # explore next node
    $scanner->scan_node($data_ref,$contained_node);
  }

=head1 METHODS

=head2 scan_node ($data_r,$node)

Explore the node and call either C<node_dispatch_cb> (if the node class
name matches the dispatch_node hash) B<or> (e.g. xor) C<node_element_cb> passing
all element names.

After the first callback has returned, C<up_cb> will be called.

=head2 scan_element($data_r,$node,$element_name)

Explore the element and call either C<hash_element_cb>,
C<list_element_cb>, C<node_content_cb> or a leaf call-back (the leaf
call-back called depends on the Value object properties: enum, string,
integer and so on)

=head2 scan_hash ($data_r,$node,$element_name,$key)

Explore the hash member (or hash value) and call either C<node_content_cb> or
a leaf call-back.

=head2 scan_list ($data_r,$node,$element_name,$index)

Just like C<scan_hash>: Explore the list member and call either
C<node_content_cb> or a leaf call-back.

=head2 get_keys ($node, $element_name)

Returns an list containing the sorted keys of a hash element or returns
an list containing (0.. last_index) of an list element.

Throws an exception if element is not an list or a hash element.

=head1 AUTHOR

Dominique Dumont, (ddumont at cpan dot org)

=head1 SEE ALSO

L<Config::Model>,L<Config::Model::Node>,L<Config::Model::Instance>,
L<Config::Model::HashId>,
L<Config::Model::ListId>,
L<Config::Model::CheckList>,
L<Config::Model::Value>

=head1 AUTHOR

Dominique Dumont

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2005-2016 by Dominique Dumont.

This is free software, licensed under:

  The GNU Lesser General Public License, Version 2.1, February 1999

=cut