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
|
|
|
|
|
|
|
|