File Coverage

blib/lib/Data/Interactive/Inspect.pm
Criterion Covered Total %
statement 143 418 34.2
branch 40 182 21.9
condition 3 21 14.2
subroutine 23 51 45.1
pod 13 21 61.9
total 222 693 32.0


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