line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/bin/perl |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Copyright (c) 2015-2017 T.v.Dein . All |
4
|
|
|
|
|
|
|
# Rights Reserved. Std. disclaimer applies. Artistic License, same as |
5
|
|
|
|
|
|
|
# perl itself. Have fun. |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
package Data::Interactive::Inspect; |
10
|
|
|
|
|
|
|
|
11
|
1
|
|
|
1
|
|
1029
|
use Carp::Heavy; |
|
1
|
|
|
|
|
114
|
|
|
1
|
|
|
|
|
23
|
|
12
|
1
|
|
|
1
|
|
3
|
use Carp; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
61
|
|
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
418
|
use Term::ReadLine; |
|
1
|
|
|
|
|
2082
|
|
|
1
|
|
|
|
|
31
|
|
15
|
1
|
|
|
1
|
|
601
|
use File::Temp qw(tempfile); # required by the 'edit' command |
|
1
|
|
|
|
|
14514
|
|
|
1
|
|
|
|
|
85
|
|
16
|
1
|
|
|
1
|
|
652
|
use YAML; # config + export/import + 'edit' command |
|
1
|
|
|
|
|
5053
|
|
|
1
|
|
|
|
|
48
|
|
17
|
|
|
|
|
|
|
|
18
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
34
|
|
19
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
21
|
|
20
|
1
|
|
|
1
|
|
3
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
23
|
|
21
|
|
|
|
|
|
|
|
22
|
1
|
|
|
1
|
|
545
|
use Data::Dumper; |
|
1
|
|
|
|
|
4492
|
|
|
1
|
|
|
|
|
79
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
$Data::Interactive::Inspect::VERSION = 0.06; |
25
|
|
|
|
|
|
|
|
26
|
1
|
|
|
1
|
|
8
|
use vars qw(@ISA); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
48
|
|
27
|
|
|
|
|
|
|
|
28
|
1
|
|
|
1
|
|
3
|
use vars qw(@ISA @EXPORT @EXPORT_OK); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1402
|
|
29
|
|
|
|
|
|
|
require Exporter; |
30
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
31
|
|
|
|
|
|
|
@EXPORT = qw(); |
32
|
|
|
|
|
|
|
@EXPORT_OK = qw(); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub new { |
36
|
1
|
|
|
1
|
1
|
709
|
my ($class, @param) = @_; |
37
|
|
|
|
|
|
|
|
38
|
1
|
|
33
|
|
|
7
|
$class = ref($class) || $class; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# defaults (= valid parameters) |
41
|
|
|
|
|
|
|
my $self = { |
42
|
|
|
|
|
|
|
name => '', |
43
|
0
|
|
|
0
|
|
0
|
begin => sub { print STDERR "unsupported\n"; }, |
44
|
0
|
|
|
0
|
|
0
|
commit => sub { print STDERR "unsupported\n"; }, |
45
|
0
|
|
|
0
|
|
0
|
rollback => sub { print STDERR "unsupported\n"; }, |
46
|
0
|
|
|
0
|
|
0
|
export => sub { my ($db) = @_; return $db; }, |
|
0
|
|
|
|
|
0
|
|
47
|
0
|
|
|
0
|
|
0
|
serialize => sub { my $db = shift; return YAML::Dump($db); }, |
|
0
|
|
|
|
|
0
|
|
48
|
0
|
|
|
0
|
|
0
|
deserialize => sub { my $db = shift; return YAML::Load($db); }, |
|
0
|
|
|
|
|
0
|
|
49
|
1
|
|
|
|
|
18
|
struct => {}, |
50
|
|
|
|
|
|
|
editor => 'vi', |
51
|
|
|
|
|
|
|
more => 'more', |
52
|
|
|
|
|
|
|
silent => 0, |
53
|
|
|
|
|
|
|
}; |
54
|
|
|
|
|
|
|
|
55
|
1
|
|
|
|
|
2
|
bless $self, $class; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# by default unsupported |
58
|
1
|
|
|
|
|
6
|
$self->{transactions} = 0; |
59
|
|
|
|
|
|
|
|
60
|
1
|
50
|
|
|
|
6
|
if ($#param >= 1) { |
|
|
50
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# hash interface |
62
|
0
|
|
|
|
|
0
|
my %p = @param; |
63
|
0
|
|
|
|
|
0
|
foreach my $k (keys %{$self}) { |
|
0
|
|
|
|
|
0
|
|
64
|
0
|
0
|
|
|
|
0
|
if (exists $p{$k}) { |
65
|
0
|
|
|
|
|
0
|
$self->{$k} = $p{$k}; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
} |
68
|
0
|
0
|
0
|
|
|
0
|
if (exists $p{begin} && $p{commit} && $p{rollback}) { |
|
|
|
0
|
|
|
|
|
69
|
|
|
|
|
|
|
# user supplied the relevant functions |
70
|
0
|
|
|
|
|
0
|
$self->{transactions} = 1; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
elsif ($#param == 0) { |
74
|
|
|
|
|
|
|
# 1 param, the struct |
75
|
1
|
|
|
|
|
3
|
$self->{struct} = $param[0]; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
# else: no params given, work with defaults |
78
|
|
|
|
|
|
|
|
79
|
1
|
50
|
|
|
|
4
|
if (! $self->{struct}) { |
80
|
0
|
|
|
|
|
0
|
croak "Sorry param 'struct' must be set to a perl data structure\n"; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# map commands+shortcuts to functions |
84
|
|
|
|
|
|
|
$self->{command} = { |
85
|
1
|
|
|
|
|
19
|
l => 'list', |
86
|
|
|
|
|
|
|
list => 'list', |
87
|
|
|
|
|
|
|
show => 'show', |
88
|
|
|
|
|
|
|
sh => 'show', |
89
|
|
|
|
|
|
|
dump => 'dump', |
90
|
|
|
|
|
|
|
d => 'dump', |
91
|
|
|
|
|
|
|
get => 'get', |
92
|
|
|
|
|
|
|
g => 'get', |
93
|
|
|
|
|
|
|
enter => 'enter', |
94
|
|
|
|
|
|
|
cd => 'enter', |
95
|
|
|
|
|
|
|
set => 'set', |
96
|
|
|
|
|
|
|
edit => 'edit', |
97
|
|
|
|
|
|
|
e => 'edit', |
98
|
|
|
|
|
|
|
append=> 'append', |
99
|
|
|
|
|
|
|
drop => 'drop', |
100
|
|
|
|
|
|
|
pop => 'mypop', |
101
|
|
|
|
|
|
|
shift => 'myshift', |
102
|
|
|
|
|
|
|
search=> 'search', |
103
|
|
|
|
|
|
|
'/' => 'search', |
104
|
|
|
|
|
|
|
help => 'help', |
105
|
|
|
|
|
|
|
h => 'help', |
106
|
|
|
|
|
|
|
'?' => 'help', |
107
|
|
|
|
|
|
|
quit => 'quit', |
108
|
|
|
|
|
|
|
q => 'quit', |
109
|
|
|
|
|
|
|
}; |
110
|
|
|
|
|
|
|
|
111
|
1
|
50
|
|
|
|
4
|
if ($self->{transactions}) { |
112
|
|
|
|
|
|
|
# map if supported |
113
|
0
|
|
|
|
|
0
|
foreach my $c (qw(begin commit rollback)) { |
114
|
0
|
|
|
|
|
0
|
$self->{command}->{$c} = $c; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
1
|
50
|
|
|
|
2
|
if (! $self->{name}) { |
119
|
1
|
|
|
|
|
9
|
$self->{name} = sprintf "data\@0x%x", $self->{struct}; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
# map which commands take a key param |
123
|
1
|
|
|
|
|
4
|
$self->{commandargs} = [qw(get set edit show append pop shift drop enter cd search /)]; |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# holds current level |
126
|
1
|
|
|
|
|
3
|
$self->{db} = $self->{struct}; |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# path to current level |
129
|
1
|
|
|
|
|
2
|
$self->{path} = []; |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
# set to 1 if transactions supported and implemented |
132
|
1
|
|
|
|
|
2
|
$self->{session} = 0; |
133
|
|
|
|
|
|
|
|
134
|
1
|
|
|
|
|
1
|
$self->{quit} = 0; |
135
|
|
|
|
|
|
|
|
136
|
1
|
|
|
|
|
3
|
return $self; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub inspect { |
143
|
7
|
|
|
7
|
1
|
3038
|
my ($self, $__cmds) = @_; |
144
|
|
|
|
|
|
|
|
145
|
7
|
50
|
|
|
|
15
|
if ($__cmds) { |
146
|
|
|
|
|
|
|
# unit tests und scripts |
147
|
7
|
|
|
|
|
10
|
$self->{silent} = 1; |
148
|
7
|
|
|
|
|
19
|
foreach (split /\n/, $__cmds) { |
149
|
9
|
50
|
|
|
|
18
|
if (! $self->process($_, 1) ) { |
150
|
0
|
|
|
|
|
0
|
last; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
} |
153
|
7
|
|
|
|
|
15
|
return $self->{struct}; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
0
|
0
|
|
|
|
0
|
if (-t STDIN) { |
157
|
|
|
|
|
|
|
# interactive with prompt and history |
158
|
0
|
|
|
|
|
0
|
$| = 1; |
159
|
0
|
|
|
|
|
0
|
my $term = new Term::ReadLine 'Data::Interactive::Inspect'; |
160
|
0
|
|
|
|
|
0
|
$term->ornaments(0); |
161
|
0
|
|
|
|
|
0
|
my $attribs = $term->Attribs; |
162
|
|
|
|
|
|
|
|
163
|
0
|
|
|
|
|
0
|
$self->{term} = $term; |
164
|
0
|
0
|
|
|
|
0
|
$self->{complete_words} = [ map { if (length($_) > 2 ) {$_} } keys %{$self->{command}} ]; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
165
|
0
|
|
|
|
|
0
|
$attribs->{completion_entry_function} = $attribs->{list_completion_function}; # avoid file completion |
166
|
|
|
|
|
|
|
$attribs->{attempted_completion_function} = sub { |
167
|
0
|
|
|
0
|
|
0
|
my ($begin, $line, $start, $end, $term) = @_; |
168
|
0
|
|
|
|
|
0
|
return $self->complete($begin, $line, $start, $end, $term); |
169
|
0
|
|
|
|
|
0
|
}; |
170
|
|
|
|
|
|
|
|
171
|
0
|
|
|
|
|
0
|
my $prompt = $self->prompt; |
172
|
0
|
|
|
|
|
0
|
while ( defined ($_ = $term->readline($prompt)) ) { |
173
|
0
|
0
|
|
|
|
0
|
if (! $self->process($_) ) { |
174
|
0
|
|
|
|
|
0
|
print "last\n"; |
175
|
0
|
|
|
|
|
0
|
last; |
176
|
|
|
|
|
|
|
} |
177
|
0
|
|
|
|
|
0
|
$prompt = $self->prompt; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
else { |
181
|
0
|
|
|
|
|
0
|
while () { |
182
|
0
|
0
|
|
|
|
0
|
if (! $self->process($_, 1) ) { |
183
|
0
|
|
|
|
|
0
|
last; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
} |
187
|
0
|
|
|
|
|
0
|
return $self->{struct}; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub prompt { |
191
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
192
|
0
|
|
|
|
|
0
|
my $prompt = $self->{name}; |
193
|
|
|
|
|
|
|
|
194
|
0
|
0
|
|
|
|
0
|
if (@{$self->{path}}) { |
|
0
|
|
|
|
|
0
|
|
195
|
0
|
|
|
|
|
0
|
$prompt .= " " . join('->', @{$self->{path}}); |
|
0
|
|
|
|
|
0
|
|
196
|
|
|
|
|
|
|
} |
197
|
0
|
0
|
|
|
|
0
|
if ($self->{session}) { |
198
|
0
|
|
|
|
|
0
|
$prompt .= '%'; |
199
|
|
|
|
|
|
|
} |
200
|
0
|
|
|
|
|
0
|
$prompt .= '> '; |
201
|
0
|
|
|
|
|
0
|
return $prompt; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub complete { |
205
|
0
|
|
|
0
|
0
|
0
|
my ($self, $begin, $line, $start, $end, $term) = @_; |
206
|
|
|
|
|
|
|
|
207
|
0
|
|
|
|
|
0
|
my @matches = (); |
208
|
|
|
|
|
|
|
|
209
|
0
|
|
|
|
|
0
|
my $cmd = $line; |
210
|
0
|
|
|
|
|
0
|
$cmd =~ s/\s\s*.*$//; |
211
|
0
|
|
|
|
|
0
|
$cmd =~ s/\s*$//; |
212
|
|
|
|
|
|
|
|
213
|
0
|
0
|
|
|
|
0
|
if ($start == 0) { |
|
|
0
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# match on a command |
215
|
|
|
|
|
|
|
@matches = $self->{term}->completion_matches ($begin, sub { |
216
|
0
|
|
|
0
|
|
0
|
my ($text, $state) = @_; |
217
|
0
|
|
|
|
|
0
|
my @name = @{$self->{complete_words}}; |
|
0
|
|
|
|
|
0
|
|
218
|
0
|
0
|
|
|
|
0
|
unless ($state) { |
219
|
0
|
|
|
|
|
0
|
$self->{complete_idx} = 0; |
220
|
|
|
|
|
|
|
} |
221
|
0
|
|
|
|
|
0
|
while ($self->{complete_idx} <= $#name) { |
222
|
0
|
|
|
|
|
0
|
$self->{complete_idx}++; |
223
|
|
|
|
|
|
|
return $name[$self->{complete_idx} - 1] |
224
|
0
|
0
|
|
|
|
0
|
if ($name[$self->{complete_idx} - 1] =~ /^$text/); |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
# no match |
227
|
0
|
|
|
|
|
0
|
return undef; |
228
|
0
|
|
|
|
|
0
|
}); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
elsif ($line =~ /[^\s]+\s+[^\s]+\s+/) { |
231
|
|
|
|
|
|
|
# command line is complete ($cmd $arg), stop with completion |
232
|
0
|
|
|
|
|
0
|
@matches = undef; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
else { |
235
|
|
|
|
|
|
|
# match on a command arg |
236
|
0
|
0
|
|
|
|
0
|
if (grep {$cmd eq $_} @{$self->{commandargs}}) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
237
|
|
|
|
|
|
|
# only match for commands which support args |
238
|
|
|
|
|
|
|
@matches = $self->{term}->completion_matches ($begin, sub { |
239
|
0
|
|
|
0
|
|
0
|
my ($text, $state) = @_; |
240
|
0
|
|
|
|
|
0
|
my @name = keys %{$self->{db}}; |
|
0
|
|
|
|
|
0
|
|
241
|
0
|
0
|
|
|
|
0
|
unless ($state) { |
242
|
0
|
|
|
|
|
0
|
$self->{complete_idxp} = 0; |
243
|
|
|
|
|
|
|
} |
244
|
0
|
|
|
|
|
0
|
while ($self->{complete_idxp} <= $#name) { |
245
|
0
|
|
|
|
|
0
|
$self->{complete_idxp}++; |
246
|
|
|
|
|
|
|
return $name[$self->{complete_idxp} - 1] |
247
|
0
|
0
|
|
|
|
0
|
if ($name[$self->{complete_idxp} - 1] =~ /^$text/); |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
# no match |
250
|
0
|
|
|
|
|
0
|
return undef; |
251
|
0
|
|
|
|
|
0
|
}); |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
else { |
254
|
|
|
|
|
|
|
# command doesn't support args |
255
|
0
|
|
|
|
|
0
|
@matches = undef; |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
0
|
|
|
|
|
0
|
return @matches; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
sub process { |
263
|
9
|
|
|
9
|
0
|
8
|
my ($self, $line, $failonerr) = @_; |
264
|
|
|
|
|
|
|
|
265
|
9
|
50
|
|
|
|
16
|
return 1 if(!defined $line); |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
# special treatment to search command |
268
|
9
|
|
|
|
|
24
|
$line =~ s|^/(.+)|/ $1|; |
269
|
|
|
|
|
|
|
|
270
|
9
|
|
|
|
|
7
|
my $r; |
271
|
9
|
|
|
|
|
41
|
my ($cmd, @args) = split /\s\s*/, $line; |
272
|
|
|
|
|
|
|
|
273
|
9
|
50
|
|
|
|
15
|
return 1 if (!defined $cmd); |
274
|
9
|
50
|
|
|
|
53
|
return 1 if ($cmd =~ /^\s*$/); |
275
|
9
|
50
|
|
|
|
11
|
return 1 if ($cmd =~ /^#/); |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
|
279
|
9
|
50
|
|
|
|
17
|
if ($cmd eq '..') { |
280
|
0
|
|
|
|
|
0
|
$self->up; |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
else { |
283
|
9
|
50
|
|
|
|
15
|
if (exists $self->{command}->{$cmd}) { |
284
|
9
|
|
|
|
|
9
|
my $func = $self->{command}->{$cmd}; |
285
|
9
|
50
|
|
|
|
7
|
if (! grep {$cmd eq $_} @{$self->{commandargs}}) { |
|
108
|
|
|
|
|
105
|
|
|
9
|
|
|
|
|
16
|
|
286
|
0
|
|
|
|
|
0
|
@args = (); |
287
|
|
|
|
|
|
|
} |
288
|
9
|
|
|
|
|
28
|
$r = $self->$func(@args); |
289
|
9
|
50
|
33
|
|
|
39
|
return 0 if($failonerr && !$r); # fail if not interactive |
290
|
9
|
50
|
|
|
|
15
|
return 0 if($self->{quit}); # finish |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
else { |
293
|
0
|
0
|
|
|
|
0
|
if (ref($self->{db}) =~ /hash/i) { |
294
|
0
|
0
|
|
|
|
0
|
if (exists $self->{db}->{$cmd}) { |
295
|
0
|
|
|
|
|
0
|
$r = $self->enter($cmd); |
296
|
0
|
0
|
0
|
|
|
0
|
return 0 if($failonerr && !$r); # fail if not interactive |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
else { |
299
|
0
|
|
|
|
|
0
|
print STDERR "no such command: $cmd\n"; |
300
|
0
|
0
|
|
|
|
0
|
return 0 if $failonerr; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
else { |
304
|
0
|
|
|
|
|
0
|
print STDERR "no such command: $cmd\n"; |
305
|
0
|
0
|
|
|
|
0
|
return 0 if $failonerr; |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
} |
309
|
9
|
|
|
|
|
21
|
return 1; |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# command implementations |
315
|
|
|
|
0
|
|
|
sub __interactive__ {}; |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
sub _fail { |
318
|
0
|
|
|
0
|
|
0
|
my ($self, $msg) = @_; |
319
|
0
|
|
|
|
|
0
|
print STDERR $msg; |
320
|
0
|
|
|
|
|
0
|
return 0; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
sub _failkey { |
324
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
325
|
0
|
|
|
|
|
0
|
return $self->_fail(" parameter missing\n"); |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub _failidx { |
329
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
330
|
0
|
|
|
|
|
0
|
return $self->_fail(" must be a number, since we're inside an array\n"); |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
sub quit { |
334
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
335
|
0
|
|
|
|
|
0
|
$self->{quit} = 1; |
336
|
0
|
|
|
|
|
0
|
return 0; |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub set { |
340
|
3
|
|
|
3
|
1
|
6
|
my($self, $key, @value) = @_; |
341
|
|
|
|
|
|
|
|
342
|
3
|
50
|
|
|
|
5
|
return $self->_failkey() if(! defined $key); |
343
|
|
|
|
|
|
|
|
344
|
3
|
|
|
|
|
3
|
my $var; |
345
|
3
|
|
|
|
|
8
|
my $code = "\$var = @value;"; |
346
|
|
|
|
|
|
|
{ |
347
|
1
|
|
|
1
|
|
7
|
no strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
24
|
|
|
3
|
|
|
|
|
4
|
|
348
|
1
|
|
|
1
|
|
3
|
no warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2004
|
|
349
|
3
|
|
|
|
|
161
|
eval $code; |
350
|
|
|
|
|
|
|
} |
351
|
3
|
50
|
|
|
|
10
|
if ($@) { |
352
|
0
|
|
|
|
|
0
|
return $self->_fail("failed to insert: $@\n"); |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
else { |
355
|
3
|
|
|
|
|
7
|
$self->{db}->{$key} = $var; |
356
|
3
|
|
|
|
|
5
|
$self->done; |
357
|
|
|
|
|
|
|
} |
358
|
3
|
|
|
|
|
4
|
return 1; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
sub append { |
362
|
1
|
|
|
1
|
1
|
2
|
my($self, $key, @value) = @_; |
363
|
|
|
|
|
|
|
|
364
|
1
|
50
|
|
|
|
5
|
if (ref($self->{db}) !~ /array/i) { |
365
|
1
|
50
|
|
|
|
4
|
return $self->_failkey() if(! defined $key); |
366
|
|
|
|
|
|
|
|
367
|
1
|
50
|
|
|
|
4
|
if (exists $self->{db}->{$key}) { |
368
|
1
|
50
|
|
|
|
4
|
if (ref($self->{db}->{$key}) !~ /array/i) { |
369
|
0
|
|
|
|
|
0
|
return $self->_fail("\"$key\" already exists and is not an array\n"); |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
else { |
374
|
|
|
|
|
|
|
# inside an array, ignore $key |
375
|
0
|
|
|
|
|
0
|
@value = ($key, @value); |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
1
|
|
|
|
|
1
|
my $var; |
379
|
1
|
|
|
|
|
4
|
my $code = "\$var = @value;"; |
380
|
1
|
|
|
|
|
65
|
eval $code; |
381
|
1
|
50
|
|
|
|
4
|
if ($@) { |
382
|
0
|
|
|
|
|
0
|
return $self->_fail("failed to evaluate: $@\n"); |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
else { |
385
|
1
|
50
|
|
|
|
3
|
if (ref($self->{db}) =~ /array/i) { |
386
|
0
|
|
|
|
|
0
|
push @{$self->{db}}, $var; |
|
0
|
|
|
|
|
0
|
|
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
else { |
389
|
1
|
|
|
|
|
1
|
push @{$self->{db}->{$key}}, $var; |
|
1
|
|
|
|
|
2
|
|
390
|
|
|
|
|
|
|
} |
391
|
1
|
|
|
|
|
2
|
$self->done; |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
1
|
|
|
|
|
2
|
return 1; |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
sub drop { |
398
|
1
|
|
|
1
|
1
|
3
|
my($self, $key) = @_; |
399
|
|
|
|
|
|
|
|
400
|
1
|
50
|
|
|
|
4
|
if (ref($self->{db}) =~ /array/i) { |
401
|
0
|
0
|
|
|
|
0
|
return $self->_failidx if($key !~ /^\d*$/); |
402
|
0
|
0
|
|
|
|
0
|
if (scalar @{$self->{db}} -1 < $key) { |
|
0
|
|
|
|
|
0
|
|
403
|
0
|
|
|
|
|
0
|
return $self->_fail("array element $key exceeds number of elements in current array\n"); |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
else { |
406
|
0
|
|
|
|
|
0
|
splice @{$self->{db}}, $key, 1; |
|
0
|
|
|
|
|
0
|
|
407
|
0
|
|
|
|
|
0
|
$self->done; |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
else { |
411
|
1
|
50
|
|
|
|
2
|
return $self->_failkey() if(! defined $key); |
412
|
|
|
|
|
|
|
|
413
|
1
|
50
|
|
|
|
3
|
if (exists $self->{db}->{$key}) { |
414
|
1
|
|
|
|
|
2
|
delete $self->{db}->{$key}; |
415
|
1
|
|
|
|
|
2
|
$self->done; |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
else { |
418
|
0
|
|
|
|
|
0
|
return $self->_fail("no such key: \"$key\"\n"); |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
1
|
|
|
|
|
1
|
return 1; |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
sub mypop { |
426
|
1
|
|
|
1
|
0
|
3
|
my($self, $key) = @_; |
427
|
|
|
|
|
|
|
|
428
|
1
|
50
|
|
|
|
4
|
if (ref($self->{db}) !~ /array/i) { |
429
|
1
|
50
|
|
|
|
4
|
return $self->_failkey() if(! defined $key); |
430
|
|
|
|
|
|
|
|
431
|
1
|
50
|
|
|
|
2
|
if (exists $self->{db}->{$key}) { |
432
|
1
|
50
|
|
|
|
5
|
if (ref($self->{db}->{$key}) !~ /array/i) { |
433
|
0
|
|
|
|
|
0
|
return $self->_fail("\"$key\" is not an array\n"); |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
} |
436
|
1
|
|
|
|
|
2
|
my $ignore = pop @{$self->{db}->{$key}}; |
|
1
|
|
|
|
|
2
|
|
437
|
1
|
|
|
|
|
2
|
$self->done; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
else { |
440
|
0
|
|
|
|
|
0
|
my $ignore = pop @{$self->{db}}; |
|
0
|
|
|
|
|
0
|
|
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
|
443
|
1
|
|
|
|
|
2
|
return 1; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
sub myshift { |
447
|
1
|
|
|
1
|
0
|
2
|
my($self, $key) = @_; |
448
|
|
|
|
|
|
|
|
449
|
1
|
50
|
|
|
|
5
|
if (ref($self->{db}) !~ /array/i) { |
450
|
1
|
50
|
|
|
|
3
|
return $self->_failkey() if(! defined $key); |
451
|
|
|
|
|
|
|
|
452
|
1
|
50
|
|
|
|
2
|
if (exists $self->{db}->{$key}) { |
453
|
1
|
50
|
|
|
|
5
|
if (ref($self->{db}->{$key}) !~ /array/i) { |
454
|
0
|
|
|
|
|
0
|
return $self->_fail("\"$key\" is not an array\n"); |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
} |
457
|
1
|
|
|
|
|
1
|
my $ignore = shift @{$self->{db}->{$key}}; |
|
1
|
|
|
|
|
2
|
|
458
|
1
|
|
|
|
|
19
|
$self->done; |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
else { |
461
|
0
|
|
|
|
|
0
|
my $ignore = shift @{$self->{db}}; |
|
0
|
|
|
|
|
0
|
|
462
|
|
|
|
|
|
|
} |
463
|
1
|
|
|
|
|
3
|
return 1; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
sub get { |
467
|
0
|
|
|
0
|
1
|
0
|
my($self, $key, $search) = @_; |
468
|
|
|
|
|
|
|
|
469
|
0
|
0
|
|
|
|
0
|
return $self->_failkey() if(! defined $key); |
470
|
|
|
|
|
|
|
|
471
|
0
|
|
|
|
|
0
|
my $out; |
472
|
|
|
|
|
|
|
my @K; |
473
|
0
|
0
|
|
|
|
0
|
if ($key =~ /^\/.*\/$/) { |
474
|
|
|
|
|
|
|
# regex |
475
|
0
|
|
|
|
|
0
|
$key =~ s#^/##; |
476
|
0
|
|
|
|
|
0
|
$key =~ s#/$##; |
477
|
0
|
|
|
|
|
0
|
foreach my $k (keys %{$self->{db}}) { |
|
0
|
|
|
|
|
0
|
|
478
|
0
|
0
|
|
|
|
0
|
if ($k =~ /$key/) { |
479
|
0
|
|
|
|
|
0
|
push @K, $k; |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
else { |
484
|
0
|
0
|
|
|
|
0
|
if (ref($self->{db}) =~ /array/i) { |
|
|
0
|
|
|
|
|
|
485
|
0
|
0
|
|
|
|
0
|
return $self->_failidx if($key !~ /^\d*$/); |
486
|
0
|
0
|
|
|
|
0
|
if (scalar @{$self->{db}} -1 < $key) { |
|
0
|
|
|
|
|
0
|
|
487
|
0
|
|
|
|
|
0
|
return $self->_fail("array element $key exceeds number of elements in current array\n"); |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
else { |
490
|
0
|
|
|
|
|
0
|
$out .= "[$key] =>\n" . $self->dump($self->{db}->[$key], 1) |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
elsif (exists $self->{db}->{$key}) { |
494
|
0
|
|
|
|
|
0
|
push @K, $key; |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
else { |
497
|
0
|
|
|
|
|
0
|
return $self->_fail("no such key: \"$key\"\n"); |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
0
|
|
|
|
|
0
|
foreach my $key (@K) { |
502
|
0
|
0
|
0
|
|
|
0
|
if (ref($self->{db}->{$key}) =~ /hash/i || ref($self->{db}->{$key}) =~ /array/i) { |
503
|
|
|
|
|
|
|
# FIXME: something nicer |
504
|
0
|
|
|
|
|
0
|
$out .= "$key =>\n" . $self->dump($self->{db}->{$key}, 1) |
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
else { |
507
|
0
|
|
|
|
|
0
|
$out .= "$key => \"$self->{db}->{$key}\"\n"; |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
} |
510
|
0
|
|
|
|
|
0
|
print $out; |
511
|
|
|
|
|
|
|
|
512
|
0
|
|
|
|
|
0
|
return 1; |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
sub dump { |
516
|
0
|
|
|
0
|
1
|
0
|
my ($self, $obj, $noprint) = @_; |
517
|
0
|
|
|
|
|
0
|
my $out; |
518
|
0
|
0
|
|
|
|
0
|
if ($obj) { |
519
|
0
|
|
|
|
|
0
|
$out = $self->{serialize}->($self->{export}->($obj)); |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
else { |
522
|
0
|
|
|
|
|
0
|
$out = $self->{serialize}->($self->{export}->($self->{db})); |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
0
|
0
|
|
|
|
0
|
if ($noprint) { |
526
|
0
|
|
|
|
|
0
|
return $out; |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
else { |
529
|
0
|
0
|
|
|
|
0
|
if (open LESS, "|$self->{more}") { |
530
|
0
|
|
|
|
|
0
|
print LESS $out; |
531
|
0
|
|
|
|
|
0
|
close LESS; |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
else { |
534
|
0
|
|
|
|
|
0
|
print $out; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
0
|
|
|
|
|
0
|
return 1; |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
sub edit { |
542
|
0
|
|
|
0
|
1
|
0
|
my ($self, $key) = @_; |
543
|
|
|
|
|
|
|
|
544
|
0
|
0
|
|
|
|
0
|
return $self->_failkey() if(! defined $key); |
545
|
|
|
|
|
|
|
|
546
|
0
|
0
|
|
|
|
0
|
if (exists $self->{db}->{$key}) { |
547
|
0
|
|
|
|
|
0
|
my $data = $self->{serialize}->($self->{export}->($self->{db}->{$key})); |
548
|
0
|
|
|
|
|
0
|
my ($fh, $filename) = tempfile(); |
549
|
0
|
|
|
|
|
0
|
print $fh $data; |
550
|
0
|
|
|
|
|
0
|
close $fh; |
551
|
0
|
|
|
|
|
0
|
system("$self->{editor}", $filename); |
552
|
0
|
|
|
|
|
0
|
open IN, "<$filename"; |
553
|
0
|
|
|
|
|
0
|
my $newdata = join '', ; |
554
|
0
|
|
|
|
|
0
|
close IN; |
555
|
0
|
0
|
|
|
|
0
|
if ($newdata eq $data) { |
556
|
|
|
|
|
|
|
# FIXME: use checksum or something else which is faster |
557
|
0
|
|
|
|
|
0
|
print "unchanged\n"; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
else { |
560
|
0
|
|
|
|
|
0
|
my $perl; |
561
|
0
|
|
|
|
|
0
|
eval { |
562
|
0
|
|
|
|
|
0
|
$perl = $self->{deserialize}->($newdata); |
563
|
|
|
|
|
|
|
}; |
564
|
0
|
0
|
|
|
|
0
|
if ($@) { |
565
|
0
|
|
|
|
|
0
|
return $self->_fail("$@\n"); |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
else { |
568
|
0
|
|
|
|
|
0
|
$self->{db}->{$key} = $perl; |
569
|
0
|
|
|
|
|
0
|
$self->done; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
} |
572
|
0
|
|
|
|
|
0
|
unlink($filename); |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
else { |
575
|
0
|
|
|
|
|
0
|
return $self->_fail("no such key: \"$key\"\n"); |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
|
578
|
0
|
|
|
|
|
0
|
return 1; |
579
|
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
sub list { |
582
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
583
|
|
|
|
|
|
|
|
584
|
0
|
0
|
|
|
|
0
|
if (ref($self->{db}) eq 'ARRAY') { |
585
|
|
|
|
|
|
|
# already implements array listing |
586
|
0
|
|
|
|
|
0
|
$self->show; |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
else { |
589
|
0
|
|
|
|
|
0
|
print join "\n", sort keys %{$self->{db}}; |
|
0
|
|
|
|
|
0
|
|
590
|
0
|
|
|
|
|
0
|
print "\n"; |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
|
593
|
0
|
|
|
|
|
0
|
return 1; |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
sub show { |
597
|
0
|
|
|
0
|
1
|
0
|
my ($self, $indent) = @_; |
598
|
|
|
|
|
|
|
|
599
|
0
|
0
|
|
|
|
0
|
if (ref($self->{db}) =~ /array/i) { |
600
|
0
|
|
|
|
|
0
|
my $pos = 0; |
601
|
0
|
|
|
|
|
0
|
foreach my $item (@{$self->{db}}) { |
|
0
|
|
|
|
|
0
|
|
602
|
0
|
|
|
|
|
0
|
print "$pos:\n"; |
603
|
0
|
0
|
|
|
|
0
|
if (ref($item)) { |
604
|
0
|
|
|
|
|
0
|
$self->_showhash($item, " "); |
605
|
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
|
else { |
607
|
0
|
|
|
|
|
0
|
print " $item\n"; |
608
|
|
|
|
|
|
|
} |
609
|
0
|
|
|
|
|
0
|
$pos++; |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
else { |
613
|
0
|
|
|
|
|
0
|
$self->_showhash($self->{db}); |
614
|
|
|
|
|
|
|
} |
615
|
|
|
|
|
|
|
|
616
|
0
|
|
|
|
|
0
|
return 1; |
617
|
|
|
|
|
|
|
} |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
sub _showhash { |
620
|
0
|
|
|
0
|
|
0
|
my($self, $db, $indent) = @_; |
621
|
|
|
|
|
|
|
|
622
|
0
|
0
|
|
|
|
0
|
if (!defined $indent) { |
623
|
0
|
|
|
|
|
0
|
$indent = ''; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
|
626
|
0
|
|
|
|
|
0
|
foreach my $key (sort keys %{$db}) { |
|
0
|
|
|
|
|
0
|
|
627
|
0
|
|
|
|
|
0
|
printf "%s%-30s", $indent, $key; |
628
|
0
|
0
|
|
|
|
0
|
if (ref($db->{$key}) =~ /hash/i) { |
|
|
0
|
|
|
|
|
|
629
|
0
|
|
|
|
|
0
|
print "{ .. }\n"; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
elsif (ref($db->{$key}) =~ /array/i) { |
632
|
0
|
|
|
|
|
0
|
print "[ .. ]\n"; |
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
else { |
635
|
0
|
|
|
|
|
0
|
print "\"$db->{$key}\"\n"; |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
sub enter { |
641
|
2
|
|
|
2
|
1
|
3
|
my ($self, $key) = @_; |
642
|
|
|
|
|
|
|
|
643
|
2
|
50
|
|
|
|
4
|
return $self->_failkey() if(! defined $key); |
644
|
|
|
|
|
|
|
|
645
|
2
|
50
|
|
|
|
4
|
if ($key eq '..') { |
646
|
0
|
|
|
|
|
0
|
$self->up; |
647
|
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
else { |
649
|
2
|
50
|
33
|
|
|
15
|
if (ref($self->{db}) =~ /array/i) { |
|
|
50
|
|
|
|
|
|
650
|
|
|
|
|
|
|
# "cd" into array element |
651
|
0
|
0
|
|
|
|
0
|
return $self->_failidx if($key !~ /^\d*$/); |
652
|
0
|
|
|
|
|
0
|
push @{$self->{path}}, "[${key}]"; |
|
0
|
|
|
|
|
0
|
|
653
|
0
|
|
|
|
|
0
|
push @{$self->{prev}}, $self->{db}; |
|
0
|
|
|
|
|
0
|
|
654
|
0
|
|
|
|
|
0
|
$self->{db} = $self->{db}->[$key]; |
655
|
|
|
|
|
|
|
} |
656
|
|
|
|
|
|
|
elsif (ref($self->{db}->{$key}) =~ /hash/i || ref($self->{db}->{$key}) =~ /array/i) { |
657
|
|
|
|
|
|
|
# "cd" into the hash pointed at by $key |
658
|
2
|
|
|
|
|
2
|
push @{$self->{prev}}, $self->{db}; |
|
2
|
|
|
|
|
4
|
|
659
|
2
|
|
|
|
|
1
|
push @{$self->{path}}, $key; |
|
2
|
|
|
|
|
4
|
|
660
|
2
|
|
|
|
|
2
|
$self->{db} = $self->{db}->{$key}; |
661
|
2
|
|
|
|
|
239
|
print "=> $key\n"; |
662
|
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
else { |
664
|
0
|
|
|
|
|
0
|
return $self->_fail("not a hash: \"$key\"\n"); |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
2
|
|
|
|
|
6
|
return 1; |
669
|
|
|
|
|
|
|
} |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
sub up { |
672
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
673
|
0
|
0
|
|
|
|
0
|
if (@{$self->{prev}}) { |
|
0
|
|
|
|
|
0
|
|
674
|
0
|
|
|
|
|
0
|
$self->{db} = pop @{$self->{prev}}; |
|
0
|
|
|
|
|
0
|
|
675
|
0
|
|
|
|
|
0
|
pop @{$self->{path}}; |
|
0
|
|
|
|
|
0
|
|
676
|
0
|
|
|
|
|
0
|
print "<=\n"; |
677
|
|
|
|
|
|
|
} |
678
|
|
|
|
|
|
|
else { |
679
|
0
|
|
|
|
|
0
|
return $self->_fail("already on top level\n"); |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
|
682
|
0
|
|
|
|
|
0
|
return 1; |
683
|
|
|
|
|
|
|
} |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
sub search { |
686
|
0
|
|
|
0
|
1
|
0
|
my ($self, $regex) = @_; |
687
|
|
|
|
|
|
|
|
688
|
0
|
0
|
|
|
|
0
|
if (! defined $regex) { |
689
|
0
|
|
|
|
|
0
|
$self->_fail(" parameter missing\n"); |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
|
692
|
0
|
|
|
|
|
0
|
$self->{spath} = []; |
693
|
|
|
|
|
|
|
|
694
|
0
|
|
|
|
|
0
|
return $self->_search($self->{db}, $regex); |
695
|
|
|
|
|
|
|
} |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
sub _search { |
698
|
0
|
|
|
0
|
|
0
|
my($self, $db, $regex) = @_; |
699
|
|
|
|
|
|
|
|
700
|
0
|
0
|
|
|
|
0
|
if (ref($db) =~ /hash/i) { |
|
|
0
|
|
|
|
|
|
701
|
0
|
|
|
|
|
0
|
foreach my $key (sort keys %{$db}) { |
|
0
|
|
|
|
|
0
|
|
702
|
0
|
|
|
|
|
0
|
$self->_searchmatch($key, $regex, 0); |
703
|
0
|
|
|
|
|
0
|
push @{$self->{spath}}, $key; |
|
0
|
|
|
|
|
0
|
|
704
|
0
|
|
|
|
|
0
|
$self->_search($db->{$key}, $regex); |
705
|
0
|
|
|
|
|
0
|
pop @{$self->{spath}}; |
|
0
|
|
|
|
|
0
|
|
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
elsif (ref($db) =~ /array/i) { |
709
|
0
|
|
|
|
|
0
|
my $pos = 0; |
710
|
0
|
|
|
|
|
0
|
foreach my $item (@{$db}) { |
|
0
|
|
|
|
|
0
|
|
711
|
0
|
|
|
|
|
0
|
push @{$self->{spath}}, "[${pos}]"; |
|
0
|
|
|
|
|
0
|
|
712
|
0
|
|
|
|
|
0
|
$self->_search($item, $regex); |
713
|
0
|
|
|
|
|
0
|
pop @{$self->{spath}}; |
|
0
|
|
|
|
|
0
|
|
714
|
0
|
|
|
|
|
0
|
$pos++; |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
else { |
718
|
0
|
|
|
|
|
0
|
$self->_searchmatch($db, $regex, 1); |
719
|
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
|
|
721
|
0
|
|
|
|
|
0
|
return 1; |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
sub _searchmatch { |
725
|
0
|
|
|
0
|
|
0
|
my ($self, $key, $regex, $quote) = @_; |
726
|
0
|
0
|
|
|
|
0
|
$quote = $quote ? '"' : ''; |
727
|
0
|
0
|
|
|
|
0
|
if ($key =~ /$regex/) { |
728
|
0
|
|
|
|
|
0
|
print join(' => ', @{$self->{spath}}) . ": ${quote}$ {key}${quote}\n"; |
|
0
|
|
|
|
|
0
|
|
729
|
|
|
|
|
|
|
} |
730
|
|
|
|
|
|
|
} |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
sub done { |
733
|
7
|
|
|
7
|
0
|
8
|
my $self = shift; |
734
|
7
|
50
|
|
|
|
16
|
if (! $self->{silent}) { |
735
|
0
|
|
|
|
|
|
print "ok\n"; |
736
|
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
|
} |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
sub help { |
740
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
741
|
0
|
|
|
|
|
|
print qq(Display commands: |
742
|
|
|
|
|
|
|
list - list keys of current level |
743
|
|
|
|
|
|
|
show - same as list but with values |
744
|
|
|
|
|
|
|
dump - dump everything from current level |
745
|
|
|
|
|
|
|
get | /regex/ - display value of , or the value |
746
|
|
|
|
|
|
|
of all keys matching /regex/ |
747
|
|
|
|
|
|
|
search - search for |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
Navigation commands: |
750
|
|
|
|
|
|
|
enter - change level into sub-hash of |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
Edit commands: |
753
|
|
|
|
|
|
|
set - set to |
754
|
|
|
|
|
|
|
edit - edit structure behind [1] |
755
|
|
|
|
|
|
|
append [] - append to array , leave |
756
|
|
|
|
|
|
|
if you are currently inside an array |
757
|
|
|
|
|
|
|
drop - delete key , use a number if inside |
758
|
|
|
|
|
|
|
an array |
759
|
|
|
|
|
|
|
pop [] - remove last element of array , |
760
|
|
|
|
|
|
|
shift [] - remove first element of array |
761
|
|
|
|
|
|
|
leave if inside an array |
762
|
|
|
|
|
|
|
); |
763
|
|
|
|
|
|
|
|
764
|
0
|
0
|
|
|
|
|
if ($self->{transactions}) { |
765
|
0
|
|
|
|
|
|
print qq( |
766
|
|
|
|
|
|
|
Transaction commands: |
767
|
|
|
|
|
|
|
begin - start a transaction session |
768
|
|
|
|
|
|
|
commit - store everything changed within session |
769
|
|
|
|
|
|
|
rollback - discard changes |
770
|
|
|
|
|
|
|
); |
771
|
|
|
|
|
|
|
} |
772
|
|
|
|
|
|
|
|
773
|
0
|
|
|
|
|
|
print qq( |
774
|
|
|
|
|
|
|
Misc commands: |
775
|
|
|
|
|
|
|
help - get help |
776
|
|
|
|
|
|
|
ctrl-d | quit - exit |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
Shortcuts: |
779
|
|
|
|
|
|
|
.. - go one level up |
780
|
|
|
|
|
|
|
l - list |
781
|
|
|
|
|
|
|
d - dump |
782
|
|
|
|
|
|
|
sh - show |
783
|
|
|
|
|
|
|
cd - enter |
784
|
|
|
|
|
|
|
- enter [2] |
785
|
|
|
|
|
|
|
/ - search |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
Hints: |
788
|
|
|
|
|
|
|
[1] can be perl code, e.g: set pw { user => 'max' } |
789
|
|
|
|
|
|
|
[2] doesn't work if correlates to a command |
790
|
|
|
|
|
|
|
); |
791
|
|
|
|
|
|
|
} |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
1; |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
=head1 NAME |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
Data::Interactive::Inspect - Inspect and manipulate perl data structures interactively |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
=head1 SYNOPSIS |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
use Data::Interactive::Inspect; |
803
|
|
|
|
|
|
|
my $data = foo(); # get a hash ref from somewhere |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
# new shell object, the simple way |
806
|
|
|
|
|
|
|
my $shell = Data::Interactive::Inspect->new($data); |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
# or |
809
|
|
|
|
|
|
|
my $shell = Data::Interactive::Inspect->new( |
810
|
|
|
|
|
|
|
struct => $data, |
811
|
|
|
|
|
|
|
name => 'verkehrswege', |
812
|
|
|
|
|
|
|
begin => sub { .. }, |
813
|
|
|
|
|
|
|
commit => sub { .. }, |
814
|
|
|
|
|
|
|
rollback => sub { .. }, |
815
|
|
|
|
|
|
|
serialize => sub { .. }, |
816
|
|
|
|
|
|
|
deserialize => sub { .. }, |
817
|
|
|
|
|
|
|
editor => 'emacs', |
818
|
|
|
|
|
|
|
more => 'less' |
819
|
|
|
|
|
|
|
); |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
$data = $shell->inspect(); # opens a shell and returns modified hash ref on quit |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
=head1 DESCRIPTION |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
This module provides an interactive shell which can be used to inspect and modify |
827
|
|
|
|
|
|
|
a perl data structure. |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
You can browse the structure like a directory, display the contents, add and remove |
830
|
|
|
|
|
|
|
items, whatever you like. It is possible to include complete perl data structures. |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
The module works with hash and array references. |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
=head1 METHODS |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
=head2 new |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
The B function takes either one parameter (a reference to a hash or array) |
839
|
|
|
|
|
|
|
or a hash reference with parameters. The following parameters are supported: |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
=over |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
=item B |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
The hash or array reference to inspect. |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
=item B |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
Will be displayed on the prompt of the shell. |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
=item B |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
By default L opens B if the user issues the B |
854
|
|
|
|
|
|
|
command. Use this parameter to instruct it otherwise. |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
=item B |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
By default L uses B to display data which doesn't |
859
|
|
|
|
|
|
|
fit the terminal window. Use this parameter to instruct it otherwise. |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
=item B, B, B |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
If your data is tied to some backend which supports transactions, you can provide |
864
|
|
|
|
|
|
|
functions to implement this. If all three are defined, the user can use transaction |
865
|
|
|
|
|
|
|
commands in the shell. |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
Look at L for an example implementation. |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
=item B, B |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
By default L uses L for serialization, which |
872
|
|
|
|
|
|
|
is used in the B and B commands. You can change this by assigning |
873
|
|
|
|
|
|
|
code refs to these parameters. |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
B will be called with the structure to be serialized as its sole |
876
|
|
|
|
|
|
|
parameter and is expected to return a string. |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
B will be called with a string as parameter and is expected to |
879
|
|
|
|
|
|
|
return a structure. |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
=back |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
=head2 inspect |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
The B method starts the shell. Ii does return if the user leaves it, otherwise |
886
|
|
|
|
|
|
|
it runs forever. |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
The shell runs on a terminal and with STDIN. |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
The interactive shell supports command line editing, history and completion (for |
891
|
|
|
|
|
|
|
commands and hash keys), if L or L is |
892
|
|
|
|
|
|
|
installed. |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
=head1 INTERACTIVE COMMANDS |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
=head2 DISPLAY COMMANDS |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
=over |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
=item B |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
Lists the keys of the current level of the structure. |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
Shortcut: B. |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
=item B |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
Does nearly the same as B but also shows the content of the |
909
|
|
|
|
|
|
|
keys. If a key points to a structure (like a hash or an array), B |
910
|
|
|
|
|
|
|
whill not display anything of it, but instead indicate, that there'e |
911
|
|
|
|
|
|
|
more behind that key. |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
For arrays the array indices are displayed as well. |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
Shortcut: B. |
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
=item B |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
Dumps out everything of the current level of the structure. |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
Shortcut: B. |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
=item B key | /regex/> |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
Displays the value of B. If you specify a regex, the values of |
926
|
|
|
|
|
|
|
all matching keys will be shown. |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
If the current structure is an array you can specify the array index |
929
|
|
|
|
|
|
|
as the parameter. |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
=item B regex | / |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
Search for B through the current structure. Looks for |
934
|
|
|
|
|
|
|
keys an values. |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
Beware that this make take some time depending on the size |
937
|
|
|
|
|
|
|
of the structure. |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
=back |
940
|
|
|
|
|
|
|
|
941
|
|
|
|
|
|
|
=head2 NAVIGATION COMMANDS |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
=over |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
=item B key |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
You can use this command to enter a sub hash of the current hash. |
948
|
|
|
|
|
|
|
It works like browsing a directory structure. You can only enter |
949
|
|
|
|
|
|
|
keys which point to sub hashes. |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
Shortcuts: B |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
If the key you want to enter doesn't collide with a command, then |
954
|
|
|
|
|
|
|
you can also just directly enter the key without 'enter' or 'cd' in |
955
|
|
|
|
|
|
|
front of it, eg: |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
my.db> list |
958
|
|
|
|
|
|
|
subhash |
959
|
|
|
|
|
|
|
my.db> subhash |
960
|
|
|
|
|
|
|
my.db subhash> dump |
961
|
|
|
|
|
|
|
my.db subhash> .. |
962
|
|
|
|
|
|
|
my.db>^D |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
If the current structure is an array you can use the array index |
965
|
|
|
|
|
|
|
to enter a specific array item. |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
If you specify B<..> as parameter (or as its own command like in the |
968
|
|
|
|
|
|
|
example below), you go one level up and leave the current sub hash. |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
=back |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
=head2 EDIT COMMANDS |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
=over |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
=item B key value |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
Use the B command to add a new key or to modify the value |
979
|
|
|
|
|
|
|
of a key. B may be a valid perl structure, which you can |
980
|
|
|
|
|
|
|
use to create sub hashes or arrays. Example: |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
my.db> set users [ { name => 'max'}, { name => 'joe' } ] |
983
|
|
|
|
|
|
|
ok |
984
|
|
|
|
|
|
|
mydb> get users |
985
|
|
|
|
|
|
|
users => |
986
|
|
|
|
|
|
|
{ |
987
|
|
|
|
|
|
|
'name' => 'max' |
988
|
|
|
|
|
|
|
}, |
989
|
|
|
|
|
|
|
{ |
990
|
|
|
|
|
|
|
'name' => 'joe' |
991
|
|
|
|
|
|
|
} |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
B command overwrites existing values |
994
|
|
|
|
|
|
|
without asking>. |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
=item B key |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
You can edit a whole structure pointed at by B with the |
999
|
|
|
|
|
|
|
B command. It opens an editor with the structure converted |
1000
|
|
|
|
|
|
|
to L. Modify whatever you wish, save, and the structure will |
1001
|
|
|
|
|
|
|
be saved to the database. |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
=item B key value |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
This command can be used to append a value to an array. As with the |
1006
|
|
|
|
|
|
|
B command, B can be any valid perl structure. |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
If you are currently inside an array, leave the B parameter. |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
=item B key |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
Delete a key. |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
Again, note that all commands are executed without further asking |
1015
|
|
|
|
|
|
|
or warning! |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
If you are currently inside an array, the B parameter must be |
1018
|
|
|
|
|
|
|
an array index. |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
=item B key |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
Remove the last element of the array pointed at by B. |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
If you are currently inside an array, leave the B parameter. |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
=item B key |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
Remove the first element of the array pointed at by B. |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
If you are currently inside an array, leave the B parameter. |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
=back |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
=head2 TRANSACTION COMMANDS |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
B. |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
=over |
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
=item B |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
Start a transaction. |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
=item B |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
Save all changes made since the transaction began. |
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
=item B |
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
Discard all changes of the transaction. |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
=back |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
=head2 MISC COMMANDS |
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
=over |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
=item B |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
Display a short command help. |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
Shortcuts: B or B>. |
1063
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
=item B |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
Quit the interactive shell |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
Shortcuts: B. |
1069
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
=back |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
=head1 LIMITATIONS |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
The data structure you are inspecting with L may |
1075
|
|
|
|
|
|
|
contain code refs. That's not a problem as long as you don't touch them. |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
Sample: |
1078
|
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
|
my $c = { |
1080
|
|
|
|
|
|
|
opt => 'value', |
1081
|
|
|
|
|
|
|
hook => sub { return 1; }, |
1082
|
|
|
|
|
|
|
}; |
1083
|
|
|
|
|
|
|
my $shell = Data::Interactive::Inspect->new($c); |
1084
|
|
|
|
|
|
|
$shell->inspect(); |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
Execute: |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
data@0x80140a468> dump |
1089
|
|
|
|
|
|
|
--- |
1090
|
|
|
|
|
|
|
hook: !!perl/code '{ "DUMMY" }' |
1091
|
|
|
|
|
|
|
opt: value |
1092
|
|
|
|
|
|
|
data@0x80140a468> set hook blah |
1093
|
|
|
|
|
|
|
data@0x80140a468> edit hook |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
Both commands would destroy the code ref. The first one would just overwrite it |
1096
|
|
|
|
|
|
|
while the other one would remove the code (in fact it remains a code ref but |
1097
|
|
|
|
|
|
|
it will contain dummy code only). |
1098
|
|
|
|
|
|
|
|
1099
|
|
|
|
|
|
|
=head1 TODO |
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
=over |
1102
|
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
=item Add some kind of select command |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
Example: |
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
struct: |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
{ |
1110
|
|
|
|
|
|
|
users => [ |
1111
|
|
|
|
|
|
|
{ login => 'max', uid => 1 }, |
1112
|
|
|
|
|
|
|
{ login => 'leo', uid => 2 }, |
1113
|
|
|
|
|
|
|
] |
1114
|
|
|
|
|
|
|
} |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
> select login from users where uid = 1 |
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
which should return 'max'. |
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
(may require a real world parser) |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
=item Add some kind of schema support |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
Given the same structure as above: |
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
> update users set uid = 4 where login = 'max' |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
=back |
1129
|
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
|
=head1 AUTHOR |
1131
|
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
|
T.v.Dein |
1133
|
|
|
|
|
|
|
|
1134
|
|
|
|
|
|
|
=head1 BUGS |
1135
|
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
|
Report bugs to |
1137
|
|
|
|
|
|
|
http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Data::Interactive::Inspect |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
=head1 COPYRIGHT |
1140
|
|
|
|
|
|
|
|
1141
|
|
|
|
|
|
|
Copyright (c) 2015-2017 by T.v.Dein . All rights |
1142
|
|
|
|
|
|
|
reserved. |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
=head1 LICENSE |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
This program is free software; you can redistribute it |
1147
|
|
|
|
|
|
|
and/or modify it under the same terms as Perl itself. |
1148
|
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
=head1 VERSION |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
This is the manual page for L Version 0.06. |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
=cut |