File Coverage

blib/lib/Cisco/Reconfig.pm
Criterion Covered Total %
statement 390 424 91.9
branch 207 304 68.0
condition 59 99 59.6
subroutine 42 45 93.3
pod 15 36 41.6
total 713 908 78.5


line stmt bran cond sub pod time code
1              
2             package Cisco::Reconfig;
3              
4             @ISA = qw(Exporter);
5             @EXPORT = qw(readconfig);
6             @EXPORT_OK = qw(readconfig stringconfig $minus_one_indent_rx);
7              
8             $VERSION = '0.911';
9              
10             require Exporter;
11 9     9   7015 use strict;
  9         18  
  9         328  
12 9     9   9411 use Text::Tabs;
  9         8177  
  9         1260  
13 9     9   85 use Carp;
  9         18  
  9         6916  
14 9     9   47 use Carp qw(verbose confess);
  9         14  
  9         1427  
15 9     9   8599 use IO::File;
  9         119942  
  9         1632  
16 9     9   85 use Scalar::Util qw(weaken);
  9         18  
  9         2023  
17             my $iostrings;
18             our $allow_minus_one_indent = qr/class /;
19             our $allow_plus_one_indent = qr/service-policy /;
20             our $bad_indent_policy = 'DIE';
21              
22              
23             BEGIN {
24 9     9   617 eval " use IO::String ";
  9     9   9921  
  9         28824  
  9         191  
25 9 50       2165 $iostrings = $@ ? 0 : 1;
26             }
27              
28              
29             my $debug_get = 0;
30             my $debug_mget = 0;
31             my $debug_set = 0;
32             my $debug_context = 0;
33             my $debug_text = 0;
34             my $ddata = $debug_get
35             || $debug_mget
36             || $debug_set
37             || $debug_context
38             || $debug_text
39             || 0; # add debugging data to data structures
40              
41             my $spec = qr{^ };
42             my $text = " text";
43             my $subs = " subs";
44             my $next = " next";
45             my $cntx = " cntx";
46             my $word = " word";
47             my $seqn = " seqn";
48             my $dupl = " dupl";
49             my $debg = " debg";
50             my $bloc = " bloc";
51             my $UNDEFDESC = "! undefined\n";
52             my $undef = bless { $debg => $UNDEFDESC, $text => '' }, __PACKAGE__;
53             my $dseq = "O0000000";
54             our $nonext;
55              
56             my $line;
57             my $fh;
58              
59             use overload
60 9         106 'bool' => \&defined,
61             '""' => \&text,
62 9     9   21918 'fallback' => 1;
  9         11265  
63              
64             sub stringconfig
65             {
66 1 50   1 0 13 Carp::croak 'IO::Strings need to be installed to use "stringconfig"'
67             . ' install it or use "readconfig" instead.' unless $iostrings;
68 1         39 readconfig(IO::String->new(join("\n",@_)));
69             }
70              
71             sub readconfig
72             {
73 9     9 0 155 my ($file) = @_;
74              
75 9 50       221 $fh = ref($file) ? $file : IO::File->new($file, "r");
76              
77 9         56 $line = <$fh>;
78 9         73 return rc1(0, 'aaaa', $undef, "! whole enchalada\n");
79             }
80              
81             sub rc1
82             {
83 93     93 0 173 my ($indent, $seq, $parent, $dcon) = @_;
84 93         90 my $last;
85 93         273 my $config = bless { $bloc => 1 }, __PACKAGE__;
86              
87 93 50       221 $config->{$debg} = "BLOCK:$dseq:$dcon" if $ddata;
88              
89 93         717 $config->{$cntx} = $parent;
90 93         243 weaken $config->{$cntx};
91              
92 93         104 $dseq++;
93 93         98 my $prev;
94             my $ciscobug;
95 93         176 for(;$line;$prev = $line, $line = <$fh>) {
96 890         1156 $_ = $line;
97 890         2747 s/^( *)//;
98 890         1416 my $in = length($1);
99 890         1101 s/^(no +)//;
100 890         1233 my $no = $1;
101 890 100       2013 if ($in > $indent) {
    100          
102 81 100       170 if ($last) {
103 79         382 $last->{$subs} = rc1($in, "$last->{$seqn}aaa", $last, $line);
104 79         110 undef $last;
105 79 100       183 redo if $line;
106             } else {
107             # This really shouldn't happen. But it does. It's a violation of
108             # the usual indentation rules.
109             #
110             # An exclamation marks a reset of the indentation to zero.
111             #
112 2 50 33     31 if ($indent + 1 == $in && $allow_plus_one_indent && $line =~ /^\s*$allow_plus_one_indent/) {
      33        
113 0         0 $indent = $indent + 1;
114 0         0 redo;
115             }
116 2 50 33     17 if ($indent != 0 || ($prev ne "!\n" && $prev !~ /^!.*$/)) {
      33        
117 0 0       0 if ($bad_indent_policy eq 'IGNORE') {
    0          
118             # okay then
119             } elsif ($bad_indent_policy eq 'WARN') {
120 0         0 warn "Unexpected indentation change <$.:$_>";
121             } else {
122 0         0 confess "Unexpected indentation change <$.:$_>";
123             }
124             }
125 2         3 $ciscobug = 1;
126 2         2 $indent = $in;
127             }
128             } elsif ($in < $indent) {
129 90 100 66     277 if ($ciscobug && $in == 0) {
    100 100        
      66        
      66        
130 2         3 $indent = 0;
131             } elsif ($last && $indent - 1 == $in && $allow_minus_one_indent && $line =~ /^\s*$allow_minus_one_indent/) {
132 5 50       13 confess unless $last->{$seqn};
133 5         35 $last->{$subs} = rc1($in, "$last->{$seqn}aaa", $last, $line);
134 5         8 undef $last;
135 5 50       14 redo if $line;
136             } else {
137 83         274 return $config;
138             }
139             }
140 724 100       1580 next if /^$/;
141 718 100       1889 next if /^\s*!/;
142 553         581 my $context = $config;
143 553         1761 my (@x) = split;
144 553         710 my $owords = @x;
145 553   100     2567 while (@x && ref $context->{$x[0]}) {
146 435         595 $context = $context->{$x[0]};
147 435         1992 shift @x;
148             }
149 553 100       1500 if (! @x) {
    50          
150             # A duplicate line. Not fun.
151             # As far as we know this can only occur as a remark inside
152             # filter list.
153             # Q: what's the point of keeping track of these? Need to be
154             # able to accurately dump filter list definitions
155             #
156 15 100       57 $context->{$dupl} = []
157             unless $context->{$dupl};
158 15 50       50 my $n = bless {
159             $ddata
160             ? ( $debg => "$dseq:DUP:$line",
161             $word => $context->{$word}, )
162             : (),
163             }, __PACKAGE__;
164 15         19 $dseq++;
165              
166 15         14 push(@{$context->{$dupl}}, $n);
  15         35  
167 15         20 $context = $n;
168             } elsif (defined $context->{$x[0]}) {
169 0         0 confess "already $.: '$x[0]' $line";
170             }
171 553         985 while (@x) {
172 1473         1749 my $x = shift @x;
173 1473 50       3030 confess unless defined $x;
174 1473 50       2197 confess unless defined $dseq;
175 1473 100       7430 $line = "" unless defined $line;
176 1473 50       4877 $context = $context->{$x} = bless {
177             $ddata
178             ? ( $debg => "$dseq:$x:$line",
179             $word => $x, )
180             : (),
181             }, __PACKAGE__;
182 1473         3210 $dseq++;
183             }
184 553         1336 $context->{$seqn} = $seq++;
185 553         1011 $context->{$text} = $line;
186 553 50       1133 confess if $context->{$cntx};
187              
188 553         738 $context->{$cntx} = $config;
189 553         1272 weaken $context->{$cntx};
190              
191 553 50       1025 unless ($nonext) {
192 553 100       1093 if ($last) {
193 393         615 $last->{$next} = $context;
194 393         984 weaken $last->{$next};
195             } else {
196 160         247 $config->{$next} = $context;
197 160         350 weaken $config->{$next};
198             }
199             }
200              
201 553         653 $last = $context;
202              
203 553 100 100     4842 if ($line &&
      66        
      66        
204             ($line =~ /(\^C)/ && $line !~ /\^C.*\^C/)
205             ||
206             ($line =~ /banner [a-z\-]+ ((?!\^C).+)/))
207             {
208             #
209             # big special case for banners 'cause they don't follow
210             # normal indenting rules
211             #
212 8 50       47 die unless defined $1;
213 8         70 my $sep = qr/\Q$1\E/;
214 8         32 my $sub = $last->{$subs} = bless { $bloc => 1 }, __PACKAGE__;
215 8         13 $sub->{$cntx} = $last;
216 8         27 weaken $sub->{$cntx};
217 8         31 my $subnull = $sub->{''} = bless { $bloc => 1, $dupl => [] }, __PACKAGE__;
218 8         14 $subnull->{$cntx} = $sub;
219 8         20 weaken $subnull->{$cntx};
220 8         7 for(;;) {
221 48         90 $line = <$fh>;
222 48 50       85 last unless $line;
223 48 50       127 my $l = bless {
224             $ddata ? ( $debg => "$dseq:DUP:$line" ) : (),
225             }, __PACKAGE__;
226 48         65 $dseq++;
227 48         113 $l->{$seqn} = $seq++;
228 48         100 $l->{$text} = $line;
229 48         94 $l->{$cntx} = $subnull;
230 48         125 weaken($l->{$cntx});
231 48         44 push(@{$subnull->{$dupl}}, $l);
  48         88  
232 48 100       263 last if $line =~ /$sep[\r]?$/;
233             }
234 8 50 33     153 warn "parse probably failed"
235             unless $line && $line =~ /$sep[\r]?$/;
236             }
237             }
238 10         60 return $config;
239             }
240              
241             #sub word { $_[0]->{$word} };
242 79     79 1 259 sub block { $_[0]->{$bloc} }
243 13451 50 66 13451 0 44608 sub seqn { $_[0]->{$seqn} || $_[0]->endpt->{$seqn} || confess };
244 226 100 100 226 1 784 sub subs { $_[0]->{$subs} || $_[0]->zoom->{$subs} || $undef };
245 28 100 66 28 1 78 sub next { $_[0]->{$next} || $_[0]->zoom->{$next} || $undef };
246             #sub undefined { $_[0] eq $undef }
247             #sub defined { $_[0] ne $undef }
248 78383 100   78383 0 219066 sub defined { $_[0]->{$debg} ? $_[0]->{$debg} ne $UNDEFDESC : 1 }
249              
250             sub destroy
251             {
252 0     0 0 0 warn "Cisco::Reconfig::destroy is deprecated";
253             }
254              
255             sub single
256             {
257 42     42 1 68 my ($self) = @_;
258 42 100       149 return $self if defined $self->{$text};
259 17         85 my (@p) = grep(! /$spec/o, keys %$self);
260 17 100       48 return undef if @p > 1;
261 16 50       38 return $self unless @p;
262 16   33     52 return $self->{$p[0]}->single || $self;
263             }
264              
265             sub kids
266             {
267 15     15 1 19 my ($self) = @_;
268 15 50       26 return $self if ! $self;
269 15         105 my (@p) = $self->sortit(grep(! /$spec/o, keys %$self));
270 15 100       55 return $self if ! @p;
271 3         9 return (map { $self->{$_} } @p);
  42         75  
272             }
273              
274             sub zoom
275             {
276 405     405 1 518 my ($self) = @_;
277 405 100       1306 return $self if defined $self->{$text};
278 240         2035 my (@p) = $self->sortit(grep(! /$spec/o, keys %$self));
279 240 100       1638 return $self if @p > 1;
280 74 50       164 return $self unless @p;
281 74         234 return $self->{$p[0]}->zoom;
282             }
283              
284             sub endpt
285             {
286 37172     37172 1 42904 my ($self) = @_;
287 37172 50       61919 return $self if ! $self;
288 37172         165398 my (@p) = grep(! /$spec/o, keys %$self);
289 37172 100 100     191543 return $self if defined($self->{$text}) && ! @p;
290 25542 50       44723 confess unless @p;
291 25542         51853 return $self->{$p[0]}->endpt;
292             }
293              
294              
295             sub text
296             {
297 430     430 1 713 my ($self) = @_;
298 430 100       682 return '' unless $self;
299 419 100       924 if (defined $self->{$text}) {
300 133 50       647 return $debug_text
301             ? $self->{$word} . " " . $self->{$text}
302             : $self->{$text};
303             }
304 286         1064 my (@p) = $self->sortit(grep(! /$spec/o, keys %$self));
305 286 100       911 if (@p > 1) {
    100          
306             #
307             # This is nasty because the lines may not be ordered
308             # in the tree-hiearchy used by Cisco::Reconfig
309             #
310 10         41 my %temp = map { $self->{$_}->sequenced_text(0) } @p;
  39         109  
311 10         51 return join('', map { $temp{$_} } sort keys %temp);
  48         142  
312             } elsif ($self->{$dupl}) {
313 6 50       15 return join('', map { $_->{$word} . " " . $_->{$text} } @{$self->{$dupl}})
  0         0  
  0         0  
314             if $debug_text;
315 6         8 return join('', map { $_->{$text} } @{$self->{$dupl}});
  34         93  
  6         12  
316             }
317 270 50       473 confess unless @p;
318 270         660 return $self->{$p[0]}->text;
319             }
320              
321             sub sequenced_text
322             {
323 284     284 0 358 my ($self, $all) = @_;
324 284         326 my @t = ();
325 284 100       542 if (defined $self->{$text}) {
326 100 50       259 push(@t, $debug_text
327             ? ($self->seqn => $self->{$word} . " " . $self->{$text})
328             : ($self->seqn => $self->{$text}));
329             }
330 284 100       536 if (exists $self->{$dupl}) {
331 0         0 push (@t, $debug_text
332 0         0 ? map { $_->seqn => $_->{$word} . " " . $_->{$text} } @{$self->{$dupl}}
  1         6  
333 1 50       5 : map { $_->seqn => $_->{$text} } @{$self->{$dupl}});
  1         3  
334             }
335 284         1253 my (@p) = $self->sortit(grep(! /$spec/o, keys %$self));
336 284 100       586 if (@p) {
337             #
338             # This is nasty because the lines may not be ordered
339             # in the tree-hiearchy used by Cisco::Reconfig
340             #
341 190         235 return (@t, map { $self->{$_}->sequenced_text($all) } @p);
  224         620  
342             }
343 94 100 100     314 push(@t, $self->{$subs}->sequenced_text($all))
344             if $all && $self->{$subs};
345 94 50       683 return @t if @t;
346 0 0       0 confess unless @p;
347 0         0 return $self->{$p[0]}->sequenced_text($all);
348             }
349              
350             sub alltext
351             {
352 6     6 1 16 my ($self) = @_;
353 6 100       13 return '' unless $self;
354 5         22 my %temp = $self->sequenced_text(1);
355 5         40 return join('', map { $temp{$_} } sort keys %temp);
  53         109  
356             }
357              
358             sub chomptext
359             {
360 0     0 0 0 my ($self) = @_;
361 0         0 my $t = $self->text;
362 0         0 chomp($t);
363 0         0 return $t;
364             }
365              
366             sub returns
367             {
368 16     16 0 43 my (@o) = @_;
369 16         43 for my $o (@o) {
370 55 50 33     245 $o .= "\n"
371             if defined($o) && $o !~ /\n$/;
372             }
373 16 50       37 return $o[0] unless wantarray;
374 16         123 return @o;
375             }
376              
377             sub openangle
378             {
379 9   33 9 0 97 my (@l) = grep(defined && /\S/, @_);
380 9         16 my $x = 0;
381 9         20 for my $l (@l) {
382 12         41 substr($l, 0, 0) = (' ' x $x++);
383             }
384 9 50       26 return $l[0] unless wantarray;
385 9         32 return @l;
386             }
387              
388             sub closeangle
389             {
390 11   33 11 0 88 my (@l) = grep(defined && /\S/, @_);
391 11         20 my $x = $#l;
392 11         24 for my $l (@l) {
393 14         48 substr($l, 0, 0) = (' ' x $x--);
394             }
395 11 50       35 return $l[0] unless wantarray;
396 11         27 return @l;
397             }
398              
399             sub context
400             {
401 127 100 33 127 1 631 defined($_[0]->{$cntx})
402             ? $_[0]->{$cntx}
403             : $_[0]->endpt->{$cntx}
404             || ($_[0] ? confess "$_[0]" : $undef)
405             };
406              
407             #
408             # interface Loopback7
409             # ip address x y
410             #
411              
412             sub setcontext
413             {
414 74     74 1 115 my ($self, @extras) = @_;
415 74 50       149 print STDERR "\nSETCONTEXT\n" if $debug_context;
416 74 100       155 unless ($self->block) {
417 10 50       34 print STDERR "\nNOT_A_BLOCK $self->{$debg}\n" if $debug_context;
418 10         24 $self = $self->context;
419             }
420 74 50       152 printf STDERR "\nSELF %sCONTEXT %sCCONTEXT %sEXTRAS$#extras @extras\n",
421             $self->{$debg}, $self->context->{$debg},
422             $self->context->context->{$debg}
423             if $debug_context;
424 74         142 my $x = $self->context;
425 74 100       140 return (grep defined,
426             $x->context->setcontext,
427             trim($x->zoom->{$text}),
428             @extras)
429             if $x;
430 38         123 return @extras;
431             }
432            
433             sub contextcount
434             {
435 27     27 0 43 my $self = shift;
436 27         81 my (@a) = $self->setcontext(@_);
437 27 50       66 printf STDERR "CONTEXTCOUNT = %d\n", scalar(@a) if $debug_context;
438 27 50       53 print STDERR map { "CC: $_\n" } @a if $debug_context;
  0         0  
439 27         97 return scalar(@a);
440             }
441              
442             sub unsetcontext
443             {
444 11     11 1 20 my $self = shift;
445 11         27 return (("exit") x $self->contextcount(@_));
446             }
447              
448             sub teql
449             {
450 27     27 0 50 my ($self, $b) = @_;
451 27         67 my $a = $self->text;
452 27         115 $a =~ s/^\s+/ /g;
453 27         75 $a =~ s/^ //;
454 27         42 $a =~ s/ $//;
455 27         48 chomp($a);
456 27         87 $b =~ s/^\s+/ /g;
457 27         76 $b =~ s/^ //;
458 27         39 $b =~ s/ $//;
459 27         32 chomp($b);
460 27         89 return $a eq $b;
461             }
462              
463             sub set
464             {
465 16     16 1 1925 my $self = shift;
466 16         36 my $new = pop;
467 16         38 my (@designators) = @_;
468             #my ($self, $designator, $new) = @_;
469 16 50       46 print STDERR "\nSET\n" if $debug_set;
470 16 50       34 return undef unless $self;
471 16         21 my $old;
472             #my @designators;
473 16 50       55 print STDERR "\nSELF $self->{$debg}" if $debug_set;
474             # move into the block if possible
475 16 100       70 $self = $self->subs
476             if $self->subs;
477 16 50       43 print STDERR "\nSELF $self->{$debg}" if $debug_set;
478             #if (ref $designator eq 'ARRAY') {
479             # @designators = @$designator;
480             # $old = $self->get(@designators);
481             # $designator = pop(@designators);
482             #} elsif ($designator) {
483             # $old = $self->get($designator);
484             #} else {
485             # $old = $self;
486             #}
487 16         23 my $designator;
488 16 100       41 if (@designators) {
489 10         35 $old = $self->get(@designators);
490 10         26 $designator = pop(@designators);
491             } else {
492 6         13 $old = $self;
493             }
494 16 50       54 print STDERR "\nOLD $old->{$debg}" if $debug_set;
495 16         208 my (@lines) = expand(grep(/./, split(/\n/, $new)));
496 16 100       1177 if ($lines[0] =~ /^(\s+)/) {
497 11         40 my $ls = $1;
498 11         59 my $m = 1;
499 11 50       19 map { substr($_, 0, length($ls)) eq $ls or $m = 0 } @lines;
  51         149  
500 11 50       35 map { substr($_, 0, length($ls)) = '' } @lines
  51         161  
501             if $m;
502             }
503 16         63 my $indent = (' ' x $self->contextcount(@designators));
504 16         38 for $_ (@lines) {
505 56         535 s/(\S)\s+/$1 /g;
506 56         167 s/\s+$//;
507 56 100       141 $_ = 'exit' if /^\s*!\s*$/;
508 56         119 $_ = "$indent$_";
509             }
510 16 50       46 print STDERR "SET TO {\n@lines\n}\n" if $debug_set;
511 16         33 my $desig = shift(@lines);
512 16         23 my @o;
513 16 100       36 undef $old
514             if ! $old;
515 16 100 100     36 if (! $old) {
    100          
    100          
516 1 50       5 print STDERR "NO OLD\n" if $debug_set;
517 1         12 push(@o, openangle($self->setcontext(@designators)));
518 1         2 push(@o, $desig);
519             } elsif (! $designator && ! looks_like_a_block($desig,@lines)) {
520 5 100 66     13 if ($self->block && $self->context) {
521 2         6 unshift(@lines, $desig);
522 2         6 $old = $self->context;
523 2         8 undef $desig;
524             } else {
525 3         12 unshift(@lines, $desig);
526 3 50       10 print STDERR "IN NASTY BIT\n" if $debug_set;
527             #
528             # this is a messy situation: we've got a random
529             # block of stuff to set inside a random block.
530             # In theorey we could avoid the die, I'll leave
531             # that as an exercise for the reader.
532             #
533 3 50       65 confess "You cannot set nested configurations with set(undef, \$config) -- use a designator on the set method"
534             if grep(/^$indent\s/, @lines);
535 3         13 my (@t) = split(/\n/, $self->text);
536 3         8 my (%t);
537 3         14 @t{strim(@t)} = @t;
538 3         13 while (@lines) {
539 23         74 my $l = strim(shift(@lines));
540 23 100       48 if ($t{$l}) {
541 22         57 delete $t{$l};
542             } else {
543 1         4 push(@o, "$indent$l");
544             }
545             }
546 3         11 for my $k (keys %t) {
547 2         8 unshift(@o, iinvert($indent, $k));
548             }
549 3 100       15 unshift(@o, $self->setcontext)
550             if @o;
551             }
552             } elsif ($old->teql($desig)) {
553 4 50       18 print STDERR "DESIGNATOR EQUAL\n" if $debug_set;
554             # okay
555             } else {
556 6 50       18 print STDERR "DESIGNATOR DIFERENT\n" if $debug_set;
557 6         21 push(@o, openangle($self->setcontext(@designators)));
558 6 100       28 if (defined $designator) {
559 5         24 push(@o, iinvert($indent, $designator));
560             } else {
561 1         5 push(@o, iinvert($indent, split(/\n/, $self->text)));
562             }
563 6         14 push(@o, $desig);
564             }
565 16 100       53 if (@lines) {
566 6 50 66     15 if ($old && ! @o && $old->subs && $old->subs->next) {
      66        
      33        
567 5 50       12 print STDERR "OLD= $old->{$debg}" if $debug_set;
568 5         11 my $ok = 1;
569 5         24 my $f = $old->subs->next;
570 5 50       22 print STDERR "F= $f->{$debg}" if $debug_set;
571 5         11 for my $l (@lines) {
572 19 100       55 next if $l =~ /^\s*exit\s*$/;
573 17 100       37 next if $f->teql($l);
574 2 50       10 print STDERR "LINE DIFF ON $l\n" if $debug_set;
575 2         3 $ok = 0;
576 2         5 last;
577             } continue {
578 17         34 $f = $f->next;
579 17 50       53 print STDERR "F= $f->{$debg}" if $debug_set;
580             }
581 5 100 66     19 if (! $ok || $f) {
582 2         7 push(@o, openangle($self->setcontext(@designators)));
583 2         10 push(@o, iinvert($indent, $designator));
584 2         5 push(@o, $desig);
585             }
586             }
587 6 100       27 push(@o, @lines) if @o;
588             }
589 16         64 @o = grep(defined, @o);
590 16 100       67 push(@o, closeangle($self->unsetcontext(@designators)))
591             if @o;
592 16 50       73 return join('', returns(@o)) unless wantarray;
593 0         0 return returns(@o);
594             }
595              
596             sub looks_like_a_block
597             {
598 6     6 0 30 my ($first, @l) = @_;
599 6         12 my $last = pop(@l);
600 6 100       21 return 1 if ! defined $last;
601 5 50       25 return 0 if grep(/^\S/, @l);
602 5 50       38 return 0 if $first =~ /^\s/;
603 0 0       0 return 0 if $last =~ /^\s/;
604 0         0 return 1;
605             }
606              
607             sub iinvert
608             {
609 10     10 0 63 my ($indent,@l) = @_;
610 10 50       28 confess unless @l;
611 10         25 for $_ (@l) {
612 10 100       23 next unless defined;
613 9 50       97 s/^\s*no /$indent/ or s/^\s*(\S)/${indent}no $1/
614             }
615 10 50       29 return $l[0] unless wantarray;
616 10         32 return @l;
617             }
618              
619             sub all
620             {
621 9     9 1 20 my ($self, $regex) = @_;
622 9         22 $self = $self->zoom;
623 9 100 66     170 return (map { $self->{$_} } $self->sortit(grep(/$regex/ && ! /$spec/o, keys %$self)))
  11         27  
624             if $regex;
625 6         44 return (map { $self->{$_} } $self->sortit(grep(! /$spec/o, keys %$self)));
  72         103  
626             }
627              
628             sub get
629             {
630 154     154 1 18953 my ($self, @designators) = @_;
631 154 100 100     507 return $self->mget(@designators)
632             if wantarray && @designators > 1;
633              
634 153 50       315 print STDERR "\nGET <@designators> $self->{$debg}" if $debug_get;
635              
636              
637 153 50       384 return $self unless $self;
638 153         381 my $zoom = $self->zoom->subs;
639 153 100       358 $self = $zoom if $zoom;
640              
641 153 50       353 print STDERR "\nZOOMSUB $self->{$debg}" if $debug_get;
642              
643 153         380 while (@designators) {
644 176         291 my $designator = shift(@designators);
645             # $self = $self->zoom;
646             # $self = $self->single || $self;
647 176 50       382 print STDERR "\nDESIGNATOR: $designator. ZOOMED: $self->{$debg}\n"
648             if $debug_get;
649 176         516 for my $d (split(' ',$designator)) {
650 275 50       479 print STDERR "\nDO WE HAVE A: $d?\n" if $debug_get;
651 275 100       657 return $undef unless $self->{$d};
652 261         462 $self = $self->{$d};
653 261 50       665 print STDERR "\nWE DO: $self->{$debg}\n" if $debug_get;
654             }
655 162 100       516 last unless @designators;
656 23 50       113 if ($self->single) {
657 23         52 $self = $self->subs;
658 23 50       111 print STDERR "\nSINGLETON: $self->{$debg}\n" if $debug_get;
659             } else {
660 0 0       0 print STDERR "\nNOT SINGLE\n" if $debug_get;
661 0         0 return $undef;
662             }
663             }
664 139 50       264 print STDERR "\nDONE\n" if $debug_get;
665 139 100       284 if (wantarray) {
666 15         35 $self = $self->zoom;
667 15         38 my (@k) = $self->kids;
668 15 50       72 return @k if @k;
669 0         0 return $self;
670             }
671 124         574 return $self;
672             }
673              
674             sub strim
675             {
676 26     26 0 47 my (@l) = @_;
677 26         33 for $_ (@l) {
678 47         136 s/^\s+//;
679 47         122 s/\s+$//;
680 47         84 s/\n$//;
681             }
682 26 100       80 return $l[0] unless wantarray;
683 3         31 return @l;
684             }
685              
686             sub trim
687             {
688 36     36 0 68 my (@l) = @_;
689 36         72 for $_ (@l) {
690 36         86 s/^\s+//;
691 36         186 s/\s+$//;
692             }
693 36 50       78 return $l[0] unless wantarray;
694 36         169 return @l;
695             }
696              
697             sub display
698             {
699 0     0 0 0 my ($self) = @_;
700 0         0 my @o;
701 0         0 push(@o, $self->setcontext);
702 0 0 0     0 push(@o, trim($self->single->{$text}))
      0        
703             if $self->single && $self->single->{$text}
704             && $self->subs->undefined;
705 0 0       0 push(@o, "! the whole enchalada")
706             if $self->context->undefined;
707 0         0 my (@r) = returns(openangle(@o));
708 0 0       0 return @r if wantarray;
709 0         0 return join('', @r);
710             }
711              
712             sub callerlevels
713             {
714 15     15 0 21 my $n = 1;
715 15         86 1 while caller($n++);
716 15         26 return $n;
717             }
718              
719             sub mget
720             {
721 15     15 0 28 my ($self, @designators) = @_;
722              
723 15         28 my $cl = callerlevels;
724 15         17 my @newset;
725 15 100       30 if (@designators > 1) {
726              
727 1 50       4 print STDERR "\nGET$cl $designators[0]----------\n" if $debug_mget;
728              
729 1         10 my (@set) = $self->get(shift @designators);
730 1         5 for my $item (@set) {
731              
732 14 50       27 print STDERR "\nMGET$cl $item ----------\n" if $debug_mget;
733 14 50       20 print STDERR "\nMGET$cl $item->{$debg}\n" if $debug_mget;
734              
735 14         48 my (@got) = $item->mget(@designators);
736              
737 14 50       26 print STDERR map { "\nRESULTS$cl: $_->{$debg}\n" } @got
  0         0  
738             if $debug_mget;
739              
740 14         28 push(@newset, @got);
741             }
742             } else {
743              
744 14 50       27 print STDERR "\nxGET$cl $designators[0] -------\n" if $debug_mget;
745              
746 14         32 (@newset) = $self->get(shift @designators);
747              
748 14 50       34 print STDERR map { "\nxRESULTS$cl: $_->{$debg}\n" } @newset
  0         0  
749             if $debug_mget;
750              
751             }
752 15         68 return @newset;
753             }
754              
755             sub sortit
756             {
757 834     834 0 1245 my $self = shift;
758 834         1983 return sort { $self->{$a}->seqn cmp $self->{$b}->seqn } @_;
  6675         32534  
759             }
760              
761             1;
762