File Coverage

blib/lib/Config/Model/ListId.pm
Criterion Covered Total %
statement 242 255 94.9
branch 77 100 77.0
condition 7 13 53.8
subroutine 41 42 97.6
pod 19 22 86.3
total 386 432 89.3


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 5.10.1;
12 29     29   386 use Mouse;
  29         97  
13 29     29   145  
  29         51  
  29         260  
14             use Config::Model::Exception;
15 29     29   12737 use Log::Log4perl qw(get_logger :levels);
  29         60  
  29         858  
16 29     29   158  
  29         54  
  29         331  
17             use Carp;
18 29     29   3720 extends qw/Config::Model::AnyId/;
  29         67  
  29         35589  
19              
20             with "Config::Model::Role::Grab";
21             with "Config::Model::Role::ComputeFunction";
22              
23             my $logger = get_logger("Tree::Element::Id::List");
24             my $user_logger = get_logger("User");
25              
26             has data => (
27             is => 'rw',
28             isa => 'ArrayRef',
29             default => sub { []; },
30             traits => ['Array'],
31             handles => {
32             _sort_data => 'sort_in_place',
33             _all_data => 'elements',
34             _splice_data => 'splice',
35             } );
36              
37             # compatibility with HashId
38             has index_type => ( is => 'ro', isa => 'Str', default => 'integer' );
39             has auto_create_ids => ( is => 'rw' );
40              
41             my $self = shift;
42              
43 284     284 1 441 foreach my $wrong (qw/max_nb min_index default_keys/) {
44             Config::Model::Exception::Model->throw(
45 284         577 object => $self,
46             error => "Cannot use $wrong with " . $self->get_type . " element"
47             ) if defined $self->{$wrong};
48             }
49 852 50       3436  
50             if ( defined $self->{migrate_keys_from} ) {
51             $user_logger->warn(
52 284 50       627 $self->name, "Using migrate_keys_from with ",
53 0         0 "list element is deprecated. Use migrate_values_from"
54             );
55             }
56              
57             # Supply the mandatory parameter
58             return $self;
59             }
60 284         2145  
61             my $self = shift;
62              
63             $self->SUPER::set_properties(@_);
64 287     287 0 488  
65             # remove unwanted items
66 287         1256 my $data = $self->{data};
67              
68             return unless defined $self->{max_index};
69 284         490  
70             # delete entries that no longer fit the constraints imposed by the
71 284 100       780 # warp mechanism
72             foreach my $k ( 0 .. $#{$data} ) {
73             next unless $k > $self->{max_index};
74             $logger->trace( "set_properties: ", $self->name, " deleting index $k" );
75 1         3 delete $data->[$k];
  1         6  
76 0 0       0 }
77 0         0 }
78 0         0  
79             my $self = shift;
80              
81             return if $self->{migration_done};
82              
83 1675     1675   2273 # migration must be done *after* initial load to make sure that all data
84             # were retrieved from the file before migration.
85 1675 100       3566 return if $self->instance->initial_load;
86              
87             $self->{migration_done} = 1;
88              
89 554 100       2268 if ( $self->{migrate_values_from} ) {
90             my $followed = $self->safe_typed_grab( param => 'migrate_values_from', check => 'no' );
91 277         526 $logger->debug( $self->name, " migrate values from ", $followed->name )
92             if $logger->is_debug;
93 277 100       942 my $idx = $self->fetch_size;
    50          
94 2         7 foreach my $item ( $followed->fetch_all_indexes ) {
95 2 50       5 my $data = $followed->fetch_with_id($item)->dump_as_data( check => 'no' );
96             $self->fetch_with_id( $idx++ )->load_data($data);
97 2         11 }
98 2         8 }
99 5         12 elsif ( $self->{migrate_keys_from} ) {
100 5         15  
101             # FIXME: remove this deprecated stuff
102             my $followed = $self->safe_typed_grab( param => 'migrate_keys_from', check => 'no' );
103             for ( $followed->fetch_all_indexes ) {
104             $self->_store( $_, undef ) unless $self->_defined($_);
105             }
106 0         0 }
107 0         0  
108 0 0       0 }
109              
110             my $self = shift;
111             return 'list';
112             }
113              
114             my $self = shift;
115 786     786 1 1152  
116 786         1566 my @items = (
117             'type: ' . $self->get_type,
118             'index: ' . $self->index_type,
119             'cargo: ' . $self->cargo_type,
120 2     2 1 4 );
121              
122 2         6 if ( $self->cargo_type eq 'node' ) {
123             push @items, "cargo class: " . $self->config_class_name;
124             }
125              
126             if ( $self->cargo_type eq 'leaf' ) {
127             push @items, "leaf value type: " . ( $self->get_cargo_info('value_type') || '' );
128 2 100       5 }
129 1         5  
130             foreach my $what (qw/min_index max_index/) {
131             my $v = $self->$what();
132 2 100       6 my $str = $what;
133 1   50     8 $str =~ s/_/ /g;
134             push @items, "$str: $v" if defined $v;
135             }
136 2         6  
137 4         11 return @items;
138 4         7 }
139 4         9  
140 4 50       11 # important: return the actual size (not taking into account auto-created stuff)
141             my $self = shift;
142             return scalar @{ $self->{data} };
143 2         7 }
144              
145             my $self = shift;
146             my $data = $self->{data};
147             return scalar @$data ? ( 0 .. $#$data ) : ();
148 900     900 1 1384 }
149 900         1150  
  900         2021  
150             # fetch without any check
151             my ( $self, $idx ) = @_;
152             return $self->{data}[$idx];
153 1601     1601   2226 }
154 1601         2219  
155 1601 100       5230 my ( $self, $string, %args ) = @_;
156             my $check = $self->_check_check( $args{check} ); # I write too many checks.
157              
158             my @set;
159             my $cmd = $string;
160 2433     2433   3869 $logger->debug( "load: ", $self->name, " called with ->$string<-" );
161 2433         8593  
162             my $regex = qr/^(
163             (?:
164             "
165 68     68 1 8997 (?: \\" | [^"] )*?
166 68         270 "
167             )
168 68         138 |
169 68         128 [^,]+
170 68         244 )
171             /x;
172 68         695  
173             while ( length($string) ) {
174             $string =~ s/$regex// or last;
175             my $tmp = $1;
176              
177             $tmp =~ s/^"|"$//g if defined $tmp;
178             $tmp =~ s/\\"/"/g if defined $tmp;
179             push @set, $tmp;
180              
181             last unless length($string);
182             }
183 68         223 continue {
184 207 100       1202 $string =~ s/^,// or last;
185 205         510 }
186              
187 205 50       615 if ( length($string) ) {
188 205 50       422 Config::Model::Exception::Load->throw(
189 205         335 object => $self,
190             command => $cmd,
191 205 100       463 message => "unexpected load command '$cmd', left '$cmd'"
192             );
193             }
194 139 50       505  
195             $self->store_set(\@set, check => $check);
196             }
197 68 100       188  
198 2         35 my $self = shift;
199             my (@v, %args);
200              
201             if (ref $_[0] eq 'ARRAY') {
202             @v = @{ shift @_ };
203             %args = @_;
204             }
205 66         261 else {
206             %args = ( check => 'yes' );
207             @v = @_;
208             }
209 93     93 1 280  
210 93         210 if ($logger->is_debug) {
211             no warnings "uninitialized";
212 93 100       381 $logger->debug($self->name, " store_set called with ".map {"«$_» "} @v);
213 67         124 }
  67         219  
214 67         192  
215             my @comments = @{ $args{comment} || [] };
216             my $idx = 0;
217 26         78 foreach my $value (@v) {
218 26         72 my $v_obj = $self->fetch_with_id( $idx++ );
219             $v_obj->store( %args, value => $value );
220             $v_obj->annotation( shift @comments ) if @comments;
221 93 100       318 }
222 29     29   245  
  29         63  
  29         56918  
223 3         18 # and delete unused items
  7         24  
224             $self->_prune_above_idx($idx);
225             }
226 93 50       681  
  93         493  
227 93         213 my ($self, $idx) = @_;
228 93         218 # and delete unused items
229 284         977 my $ref = $self->{data};
230 284         1173 while (scalar @$ref > $idx) {
231 283 50       833 $logger->debug($self->name, " pruning idx ", $#$ref);
232             $self->delete($#$ref);
233             }
234             }
235 92         339  
236             # store without any check
237             my ( $self, $idx, $value ) = @_;
238             return $self->{data}[$idx] = $value;
239 193     193   481 }
240              
241 193         393 my ( $self, $key ) = @_;
242 193         3087 croak "argument '$key' is not numeric" unless $key =~ /^\d+$/;
243 38         125 return defined $self->{data}[$key];
244 38         345 }
245              
246             my ( $self, $idx ) = @_;
247             return exists $self->{data}[$idx];
248             }
249              
250 550     550   1085 my ( $self, $idx ) = @_;
251 550         1386 return delete $self->{data}[$idx];
252             }
253              
254             my ($self) = @_;
255 4884     4884   7419 $self->{data} = [];
256 4884 50       15839 }
257 4884         16284  
258             my ( $self, $from, $to, %args ) = @_;
259             my $check = $self->_check_check( $args{check} );
260              
261 606     606   1165 my $moved = $self->fetch_with_id($from);
262 606         1725 $self->_delete($from);
263             delete $self->{warning_hash}{$from};
264              
265             my $ok = $self->check_idx($to);
266 44     44   91 if ( $ok or $check eq 'no' ) {
267 44         126 $self->_store( $to, $moved );
268             $moved->index_value($to);
269             $self->notify_change( note => "moved from index $from to $to" );
270             my $imode = $self->instance->get_data_mode;
271 13     13   30 $self->set_data_mode( $to, $imode );
272 13         464 }
273             else {
274             # restore moved item where it came from
275             $self->_store( $from, $moved );
276 2     2 1 741 if ( $check ne 'skip' ) {
277 2         8 Config::Model::Exception::WrongValue->throw(
278             error => join( "\n\t", @{ $self->{error} } ),
279 2         9 object => $self
280 2         10 );
281 2         7 }
282             }
283 2         7 }
284 2 50 33     9  
285 2         9 # list only methods
286 2         21 my $self = shift;
287 2         13 $self->_assert_leaf_cargo;
288 2         11 my $idx = $self->fetch_size;
289 2         9 map { $self->fetch_with_id( $idx++ )->store($_); } @_;
290             }
291              
292             # list only methods
293 0         0 my $self = shift;
294 0 0       0 my %args = @_;
295             $self->_assert_leaf_cargo;
296 0         0 my $check = delete $args{check} || 'yes';
  0         0  
297             my $v_arg = delete $args{values} || delete $args{value};
298             my @v = ref($v_arg) ? @$v_arg : ($v_arg);
299             my $anno = delete $args{annotation};
300             my @a = ref($anno) ? @$anno : $anno ? ($anno) : ();
301              
302             croak( "push_x: unexpected parameter ", join( ' ', keys %args ) ) if %args;
303              
304             my $idx = $self->fetch_size;
305 19     19 1 67 while (@v) {
306 19         69 my $val = shift @v;
307 19         56 my $obj = $self->fetch_with_id( $idx++ );
308 19         43 $obj->store($val);
  26         96  
309             $obj->annotation( shift @a ) if @a;
310             }
311             }
312              
313 2     2 1 6 my $self = shift;
314 2         11 $self->insert_at( 0, @_ );
315 2         9 }
316 2   50     8  
317 2   33     7 my $self = shift;
318 2 100       9 my $idx = shift;
319 2         3  
320 2 50       8 $self->_assert_leaf_cargo;
    100          
321              
322 2 50       6 # check if max_idx is respected
323             $self->check_idx( $self->fetch_size + scalar @_ );
324 2         7  
325 2         7 # make room at the beginning of the array
326 3         5 $self->_splice_data( $idx, 0, (undef) x scalar @_ );
327 3         9 my $i = $idx;
328 3         13 map { $self->fetch_with_id( $i++ )->store($_); } @_;
329 3 100       23  
330             $self->_reindex;
331             }
332              
333             my $self = shift;
334 3     3 1 12 my $val = shift;
335 3         13 my $test =
336             ref($val) eq 'Regexp'
337             ? sub { $_[0] =~ /$val/ }
338             : sub { $_[0] eq $val };
339 22     22 1 49  
340 22         37 $self->_assert_leaf_cargo;
341              
342 22         62 my $point = 0;
343             foreach my $v ( $self->fetch_all_values ) {
344             last if $test->($v);
345 22         83 $point++;
346             }
347              
348 22         114 $self->insert_at( $point, @_ );
349 22         567 }
350 22         54  
  30         107  
351             my $self = shift;
352 22         76 $self->_assert_leaf_cargo;
353             my @insert = sort @_;
354              
355             my $point = 0;
356 5     5 1 17 foreach my $v ( $self->fetch_all_values ) {
357 5         8 while ( @insert and $insert[0] lt $v ) {
358             $self->insert_at( $point++, shift @insert );
359             }
360 10     10   53 $point++;
361 5 100   4   36 }
  4         15  
362             $self->push(@insert) if @insert;
363 5         24 }
364              
365 5         10 my $self = shift;
366 5         25 $self->push_x(@_);
367 14 100       29 }
368 9         16  
369             my $self = shift;
370              
371 5         25 my $ct = $self->cargo_type;
372              
373             Config::Model::Exception::User->throw(
374             object => $self,
375 6     6 1 18 error => "Cannot call sort on list of $ct"
376 6         28 ) unless $ct eq 'leaf';
377 6         26 }
378              
379 6         12 return sub { $_[0]->fetch cmp $_[1]->fetch; };
380 6         29 }
381 36   100     110  
382 13         47 my $self = shift;
383              
384 36         55 $self->_assert_leaf_cargo;
385             $self->_sort_data( $self->sort_algorithm );
386 6 100       35  
387             my $has_changed = $self->_reindex;
388             $self->notify_change( note => "sorted" ) if $has_changed;
389             }
390 0     0 1 0  
391 0         0 my $self = shift;
392              
393             my $i = 0;
394             my $has_changed = 0;
395 60     60   104 foreach my $o ( $self->_all_data ) {
396             next unless defined $o;
397 60         222 $has_changed = 1 if $o->index_value != $i;
398             $o->index_value( $i++ );
399 60 50       192 }
400             return $has_changed;
401             }
402              
403             my $self = shift;
404             my $ida = shift;
405             my $idb = shift;
406 32     32 1 273  
  6     6   47  
407             my $obja = $self->{data}[$ida];
408             my $objb = $self->{data}[$idb];
409              
410 6     6 1 875 # swap the index values contained in the objects
411             my $obja_index = $obja->index_value;
412 6         26 $obja->index_value( $objb->index_value );
413 6         23 $objb->index_value($obja_index);
414              
415 6         109 # then swap the objects
416 6 100       38 $self->{data}[$ida] = $objb;
417             $self->{data}[$idb] = $obja;
418              
419             $self->notify_change( note => "swapped index $ida and $idb" );
420 28     28   56 }
421              
422 28         48 #die "check index number after wap";
423 28         48  
424 28         118 my $self = shift;
425 173 50       590 my $idx = shift;
426 173 100       499  
427 173         612 Config::Model::Exception::User->throw(
428             object => $self,
429 28         140 error => "Non numeric index for list: $idx"
430             ) unless $idx =~ /^\d+$/;
431              
432             $self->delete_data_mode( index => $idx );
433 2     2 1 711 my $note = "removed idx $idx";
434 2         7 if ( $self->{cargo}{type} eq 'leaf' ) {
435 2         6 $note .= ' ("' . $self->fetch_summary($idx) . '")';
436             }
437 2         4 $self->notify_change(note => $note);
438 2         5 splice @{ $self->{data} }, $idx, 1;
439             }
440              
441 2         8 #internal
442 2         24 my $self = shift;
443 2         11  
444             my $auto_nb = $self->auto_create_ids;
445             return unless defined $auto_nb;
446 2         19  
447 2         5 $logger->debug( $self->name, " auto-creating $auto_nb elements" );
448              
449 2         13 Config::Model::Exception::Model->throw(
450             object => $self,
451             error => "Wrong auto_create argument for list: $auto_nb"
452             ) unless $auto_nb =~ /^\d+$/;
453              
454             my $auto_p = $auto_nb - 1;
455 18     18 1 31  
456 18         29 # create empty slots
457             map { $self->{data}[$_] = undef unless defined $self->{data}[$_]; } ( 0 .. $auto_p );
458 18 100       106 }
459              
460             # internal
461             my $self = shift;
462              
463 17         83 return if @{ $self->{data} };
464 17         236  
465 17 100       46 # list is empty so create empty element for default keys
466 14         55 my $def = $self->get_default_keys;
467              
468 17         72 map { $self->{data}[$_] = undef } @$def;
469 17         23  
  17         81  
470             $self->create_default_with_init;
471             }
472              
473             my $self = shift;
474 287     287 0 419 my %args = @_ > 1 ? @_ : ( data => shift );
475             my $raw_data = delete $args{data};
476 287         805 my $check = $self->_check_check( $args{check} );
477 287 100       718  
478             my $data =
479 2         8 ref($raw_data) eq 'ARRAY' ? $raw_data
480             : $args{split_reg} ? [ split $args{split_reg}, $raw_data ]
481 2 100       45 : defined $raw_data ? [$raw_data]
482             : undef;
483              
484             Config::Model::Exception::LoadData->throw(
485             object => $self,
486 1         3 message => "load_data called with non expected data. Expected array ref or scalar",
487             wrong_data => $raw_data,
488             ) unless defined $data;
489 1 50       4  
  4         14  
490             my $idx = 0;
491             $logger->info( "ListId load_data (", $self->location, ") will load idx ", "0..$#$data" );
492             foreach my $item (@$data) {
493             my $obj = $self->fetch_with_id( $idx );
494 1313     1313 0 1725 # increment idx only if the value was accepted. This allow to
495             # prune the array to the right size.
496 1313 100       1652 $idx += $obj->load_data( %args, data => $item );
  1313         3309  
497             }
498              
499 548         1257 # and delete unused items
500             $self->_prune_above_idx($idx);
501 548         827 }
  4         11  
502              
503 548         1157 __PACKAGE__->meta->make_immutable;
504              
505             1;
506              
507 102     102 1 12118 # ABSTRACT: Handle list element for configuration model
508 102 100       378  
509 102         214  
510 102         325 =pod
511              
512             =encoding UTF-8
513              
514 102 100       665 =head1 NAME
    100          
    100          
515              
516             Config::Model::ListId - Handle list element for configuration model
517              
518 102 100       263 =head1 VERSION
519              
520             version 2.152
521              
522             =head1 SYNOPSIS
523              
524 101         145 See L<Config::Model::AnyId/SYNOPSIS>
525 101         552  
526 101         880 =head1 DESCRIPTION
527 215         610  
528             This class provides list elements for a L<Config::Model::Node>.
529              
530 215         784 =head1 CONSTRUCTOR
531              
532             ListId object should not be created directly.
533              
534 101         340 =head1 List model declaration
535              
536             See
537             L<model declaration section|Config::Model::AnyId/"Hash or list model declaration">
538             from L<Config::Model::AnyId>.
539              
540             =head1 Methods
541              
542             =head2 get_type
543              
544             Returns C<list>.
545              
546             =head2 fetch_size
547              
548             Returns the number of elements of the list.
549              
550             =head2 load
551              
552             Parameters: C<< (string, [ check => 'no' ] ) >>
553              
554             Store a set of values passed as a comma separated list of values.
555             Values can be quoted strings. (i.e C<"a,a",b> yields
556             C<('a,a', 'b')> list).
557              
558             C<check> can be yes, no or skip
559              
560             =head2 store_set
561              
562             Store a set of values (passed as list)
563              
564             If tinkering with check is required, use the following way :
565              
566             store_set ( \@v , check => 'skip' );
567              
568             =head2 move
569              
570             Parameters: C<< ( from_index, to_index, [ check => 'no' ) >>
571              
572             Move an element within the list. C<check> can be 'yes' 'no' 'skip'
573              
574             =head2 push
575              
576             Parameters: C<< ( value1, [ value2 ... ] ) >>
577              
578             push some values at the end of the list.
579              
580             =head2 push_x
581              
582             Parameters: C<< ( values => [ v1','v2', ...] , ... ) >>
583              
584             Like push with extended options. Options are:
585              
586             =over
587              
588             =item check
589              
590             Check value validaty. Either C<yes> (default), C<no>, C<skip>
591              
592             =item values
593              
594             Values to push (array_ref)
595              
596             =item value
597              
598             Single value to push
599              
600             =item annotation
601              
602             =back
603              
604             =head2 unshift
605              
606             Parameters: C<< ( value1, [ value2 ... ] ) >>
607              
608             unshift some values at the end of the list.
609              
610             =head2 insert_at
611              
612             Parameters: C<< ( idx, value1, [ value2 ... ] ) >>
613              
614             unshift some values at index idx in the list.
615              
616             =head2 insert_before
617              
618             Parameters: C<< ( ( val | qr/stuff/ ) , value1, [ value2 ... ] ) >>
619              
620             unshift some values before value equal to C<val> or before value matching C<stuff>.
621              
622             =head2 insort
623              
624             Parameters: C<< ( value1, [ value2 ... ] ) >>
625              
626             Insert C<zz> value on C<xxx> list so that existing alphanumeric order is preserved.
627             C<insort> yields unpexpected results when called on an unsorted list.
628              
629             =head2 store
630              
631             Equivalent to push_x. This method is provided to help write
632             configuration parser, so the call is the same when dealing with leaf or
633             list values. Prefer C<push_x> when practical.
634              
635             =over 4
636              
637             =item check
638              
639             C<yes>, C<no> or C<skip>
640              
641             =item annotation
642              
643             list ref of annotation to store with the list values
644              
645             =back
646              
647             Example:
648              
649             $elt->push_x (
650             values => [ 'v1','v2' ] ,
651             annotation => [ 'v1 comment', 'v2 comment' ],
652             check => 'skip'
653             );
654              
655             =head2 sort
656              
657             Sort the content of the list. Can only be called on list of leaf.
658              
659             =head2 swap
660              
661             Parameters: C<< ( ida , idb ) >>
662              
663             Swap 2 elements within the array
664              
665             =head2 remove
666              
667             Parameters: C<< ( idx ) >>
668              
669             Remove an element from the list. Equivalent to C<splice @list,$idx,1>
670              
671             =head2 load_data
672              
673             Parameters: C<< ( data => ( ref | scalar ) [, check => ... ] [ , split_reg => $re ] ) >>
674              
675             Clear and load list from data contained in the C<data> array ref. If a scalar or a hash ref
676             is passed, the list is cleared and the data is stored in
677             the first element of the list. If split_reg is specified, the scalar is split
678             to load the array.
679              
680             For instance
681              
682             $elt->load_data( data => 'foo,bar', split_reg => qr(,) ) ;
683              
684             loads C< [ 'foo','bar']> in C<$elt>
685              
686             =head2 sort_algorithm
687              
688             Returns a sub used to sort the list elements. See
689             L<perlfunc/sort>. Used only for list of leaves. This method can be
690             overridden to alter sort order.
691              
692             =head2 get_info
693              
694             Returns a list of information related to the list. See
695             L<Config::Model::Value/get_info> for more details.
696              
697             =head1 AUTHOR
698              
699             Dominique Dumont, (ddumont at cpan dot org)
700              
701             =head1 SEE ALSO
702              
703             L<Config::Model::Model>,
704             L<Config::Model::Instance>,
705             L<Config::Model::AnyId>,
706             L<Config::Model::HashId>,
707             L<Config::Model::Value>
708              
709             =head1 AUTHOR
710              
711             Dominique Dumont
712              
713             =head1 COPYRIGHT AND LICENSE
714              
715             This software is Copyright (c) 2005-2022 by Dominique Dumont.
716              
717             This is free software, licensed under:
718              
719             The GNU Lesser General Public License, Version 2.1, February 1999
720              
721             =cut