File Coverage

blib/lib/Data/Interactive/Inspect.pm
Criterion Covered Total %
statement 143 412 34.7
branch 40 182 21.9
condition 3 21 14.2
subroutine 23 50 46.0
pod 13 21 61.9
total 222 686 32.3


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