trunk/bin/storableedit.pl

#!/usr/bin/perl
use strict;
use Storable;
my $VERSION = 1.5;

#=Description
# Simple editor for files saved with storable.

# Read file
my $filename=shift;
my $data;
if (! $filename) {
        print 'This is storableedit.pl, version ', $VERSION, "\n";
        print "\n";
        print 'Usage: storableedit.pl FILE', "\n";
        print '       where FILE is a Perl Storable file', "\n";
        print "\n";
        print 'For more information, check out', "\n";
        print '    perldoc storableedit.pl', "\n";
        exit;
} elsif (-f $filename) {
        StorableEdit->done('Opening file: ', $filename);
        $data=retrieve($filename);
} else {
        StorableEdit->done('Creating new file: ', $filename);
        $data={};
}

# Edit
my $e=StorableEdit->new($data);
my $dosave=$e->edit();

# Save
if ($dosave) {
        store $e->data(), $filename;
        StorableEdit->done('File saved: ', $filename);
}

exit;

package StorableEdit;
use Storable;
use Term::ReadLine;


use lib 'lib';
use Sack::Digest;
sub undigest {
        my ( $o, $v ) = @_;
        my $k = $o->{path}->[0] || return $v;
        return $v unless $k =~ m{#};
#       warn "## $k = $v\n";
        $o->{_digest_}->undigest_node_k_v(0, $k, $v);
}

sub new {
        my $o=shift;
        my $class=(ref($o) || $o);
        my $newo=bless {}, $class;
        $newo->init(@_);
        $newo->{_digest_} = Sack::Digest->new( port => 0 );
        return $newo;
}

# Initializing.
sub init {
        my $o=shift;
        my $data=shift;

        $o->data($data);
        $o->{'changed'}=0;
        $o->{'readline'}=Term::ReadLine->new('StorableEdit');
        return;
}

# Returns the data.
sub data {
        my $o=shift;
        if (my $set=shift) {
                $o->{'data'}=$set;              # Data
                $o->{'pathobjects'}=[]; # Path objects
                $o->{'path'}=[];                # Path to cur
                $o->{'cur'}=$set;               # Currently selected branch
        }
        return $o->{'data'};
}

# Sets the changed flag.
sub setchanged {
        my $o=shift;
        $o->{'changed'}=1;
        return;
}

# Returns the changed flag.
sub changed {
        my $o=shift;
        return $o->{'changed'};
}

# Lets the user edit the structure.
sub edit {
        my $o=shift;
        
        # Show contents
        $o->show($o->{'data'}, 50);

        # Command loop
        while (1) {
                my $cmd=$o->input();

                if (($cmd eq 'quit') || ($cmd eq 'q')) {
                        if ($o->changed()) {
                                $o->error('Changes were made. Use "q!" to quit without saving or "x" to save and quit.');
                        } else {
                                return 0;
                        }
                } elsif (($cmd eq 'quit!') || ($cmd eq 'q!')) {
                        return 0;
                } elsif (($cmd eq 'exit') || ($cmd eq 'x')) {
                        return 1;
                } elsif ($cmd eq 'help') {
                        print 'Commands:', "\n";
                        print '  x, exit:  save and quit', "\n";
                        print '  q, quit:  quit without saving', "\n";
                        print '  l, ls:    list items in current object/reference', "\n";
                        print '  cd ITEM:  dive into item (must be reference)', "\n";
                        print '  cd ..:    go up', "\n";
                        print '  cd ...:   go 2 steps up', "\n";
                        print '  other:    evaled as perl code', "\n";
                        print '            $cur: variable of current object/reference', "\n";
                        print '            $base: variable of base object/reference', "\n";
                        print '', "\n";
                        print 'Examples:', "\n";
                        print '  $cur->{\'test\'}=\'hello world\'', "\n";
                        print '  $cur->{\'fruits\'}=[\'apple\', \'banana\']', "\n";
                        print '  $cur->{\'available\'}={\'apple\' => 1, \'banana\' => 5}', "\n";
                        print '  cd available', "\n";
                        print '  l', "\n";
                        print '  bless $cur, \'MyObject\'', "\n";
                        print '  $cur->{\'imported\'}=retrieve(\'importfile.store\')', "\n";
                        print '  store($cur, \'exportfile.store\')', "\n";
                        print '  $data=$cur', "\n";
                        print '', "\n";
                        print 'For a more complete help, see', "\n";
                        print '    perldoc storableedit.pl', "\n";
                } elsif ($cmd eq 'l') {
                        $o->show($o->{'cur'}, 50);
                } elsif ($cmd eq 'ls') {
                        $o->show($o->{'cur'});
                } elsif ($cmd =~ /^cd\s+(.*?)$/) {
                        my $cd=$1;
                        $o->cd($cd);
                } elsif ($cmd eq 'cd') {
                } elsif ($cmd eq '..') {
                        $o->cd('..')
                } elsif ($cmd eq '...') {
                        $o->cd('...')
                } elsif ($cmd) {
                        $o->setchanged();
                        my $cur=$o->{'cur'};
                        my $data=$o->{'data'};

                        undef $@;
                        undef $!;
                        eval $cmd;

                        if ($@) {
                                $o->error('Eval error: ', $@);
                        } elsif ($!) {
                                $o->error('Eval error: ', $!);
                        } elsif ($data!=$o->{'data'}) {
                                if (ref $data) {
                                        $o->data($data);
                                        $o->done('New base object set!');
                                } else {
                                        $o->error('The base object must be a reference (HASH, ARRAY or REF).');
                                }
                        } elsif ($cur!=$o->{'cur'}) {
                                $o->error('You cannot change the current branch this way. Use "cd" instead.');
                        }
                }
        }
        
        return;
}

sub cd {        # cd($cdpath)
        my $o=shift;
        my $cdpath=shift;
        
        my $pathinfo={
                'node'  => $o->{'cur'},
                'path'  => [@{$o->{'path'}}],
                'pathobjects'   => [@{$o->{'pathobjects'}}],
                };
        
        $pathinfo=$o->cdpath($pathinfo, $cdpath);
        return if (! ref $pathinfo);
        
        $o->{'cur'}=$pathinfo->{'node'};
        $o->{'path'}=$pathinfo->{'path'};
        $o->{'pathobjects'}=$pathinfo->{'pathobjects'};
        return;
}

sub cdpath {    # $node = cdpath($pathinfo, $cdpath)
        my $o=shift;
        my $pathinfo=shift;
        my $cdpath=shift;
        
        my @path=split(/\//, $cdpath);
        foreach my $label (@path) {
                $pathinfo=$o->cdstep($pathinfo, $label);
                return if (! ref $pathinfo);
        }
        
        return $pathinfo;
}

# Change directory.
sub cdstep {    # $node = cdstep($node, $cd)
        my $o=shift;
        my $pathinfo=shift;
        my $cd=shift;
        
        my $node=$pathinfo->{'node'};
        my $path=$pathinfo->{'path'};
        my $pathobjects=$pathinfo->{'pathobjects'};

        my $type=$o->type($node);
        if ($cd eq '..') {
                if (scalar(@$path)>0) {
                        pop @$path;
                        $pathinfo->{'node'}=pop @$pathobjects;
                        return $pathinfo;
                }
        } elsif ($cd eq '...') {
                $pathinfo=$o->cdstep($pathinfo, '..');
                $pathinfo=$o->cdstep($pathinfo, '..');
                return $pathinfo;
        } elsif ($type eq 'ARRAY') {
                my $newcur=$node->[$cd];
                if (ref $newcur) {
                        push @$path, $cd;
                        push @$pathobjects, $node;
                        $pathinfo->{'node'}=$newcur;
                        return $pathinfo;
                } else {
                        $o->error('Cannot change into non-reference (', $cd, ').');
                }
        } elsif ($type eq 'HASH') {
                my $newcur=$node->{$cd};
                if (ref $newcur) {
                        push @$path, $cd;
                        push @$pathobjects, $node;
                        $pathinfo->{'node'}=$newcur;
                        return $pathinfo;
                } else {
                        $o->error('Cannot change into non-reference (', $cd, ').');
                }
        } elsif ($type eq 'REF') {
                my $newcur=$$node;
                if (ref $newcur) {
                        push @$path, 'ref';
                        push @$pathobjects, $node;
                        $pathinfo->{'node'}=$newcur;
                        return $pathinfo;
                } else {
                        $o->error('Cannot change into non-reference (', $cd, ').');
                }
        } else {
                $o->error('Unexpected error.');
        }

        return;
}

# Lets the user give an input.
sub input {
        my $o=shift;
        
        my @cmd;
        my $line=$o->inputline(1);
        while ($line =~ /^\s*(.*)\s*\\$/) {
                push @cmd, $1;
                $line=$o->inputline(0);
        }
        $line=$1 if ($line =~ /^\s*(.*)\s*$/);
        push @cmd, $line;
        return join("\n", @cmd);
}


# Lets the user give an input.
sub inputline { # $cmd = inputline($showpath)
        my $o=shift;
        my $showpath=shift;
        my $path=$o->{'path'};
        my $cur=$o->{'cur'};
        my $readline=$o->{'readline'};

        # Path
        print "\n" if ($showpath);
        my $prompt=chr(033).'[0;33m';
        $prompt.='/'.join('/', @$path) if ($showpath);
        $prompt.=' ('.ref($cur).')' if ($showpath);
        $prompt.='> '.chr(033).'[0m';

        # Get user input
        my $cmd=$readline->readline($prompt);
        return if (! defined $cmd);
        while (chomp $cmd) {}
        $readline->addhistory($cmd);
        return $cmd;
}

# Displays contents.
sub show {
        my $o=shift;
        my $data=shift;
        my $textlimit=shift;
        
        # Data
        my $type=$o->type($data);
        if ($type eq 'ARRAY') {
                return $o->show_array($data, $textlimit);
        } elsif ($type eq 'HASH') {
                return $o->show_hash($data, $textlimit);
        } elsif ($type eq 'REF') {
                return $o->show_ref($data, $textlimit);
        }

        $o->error('Unexpected error.');
        return;
}

# Displays the contents of an array.
sub show_array {
        my $o=shift;
        my $data=shift;
        my $textlimit=shift;

        my $i=0;
        foreach my $item (@$data) {
                my $tt=scalar($item);
                $tt=substr($tt, 0, $textlimit).'...' if (($textlimit) && (length($tt)>$textlimit));
                print '  ', $i, ' => ', $tt, "\n";
        } continue {
                $i++;
        }

        $o->info('  (empty array)') if ($i==0);
        return;
}

# Displays the contents of a hash.
sub show_hash {
        my $o=shift;
        my $data=shift;
        my $textlimit=shift;

        my $i=0;
        foreach my $ky (sort keys %$data) {
                my $tt=scalar($data->{$ky});
                $tt=substr($tt, 0, $textlimit).'...' if (($textlimit) && (length($tt)>$textlimit));
                print '  ', $o->undigest($ky), ' => ', $tt, "\n";
        } continue {
                $i++;
        }

        $o->info('  (empty hash)') if ($i==0);
        return;
}

# Displays the contents of a reference.
sub show_ref {
        my $o=shift;
        my $data=shift;
        my $textlimit=shift;
        
        my $tt=scalar($$data);
        $tt=substr($tt, 0, $textlimit).'...' if (($textlimit) && (length($tt)>$textlimit));
        print '  ref => ', $tt, "\n";
        return;
}

# Returns the reference type.
sub type {
        my $o=shift;
        my $obj=shift;

        my $type;
        if (ref $obj) {
                $type=scalar($obj);
                $type=(($type=~/=(.*)\(/) ? $1 : ref $obj);
        }

        return $type;
}

# Prints out a colored line of text.
sub colorline {
        my $o=shift;
        my $color=shift;
        print chr(033), '[', $color, 'm', @_, chr(033), '[0m', "\n";
        return;
}

# Displays an error message.
sub error {
        my $o=shift;
        $o->colorline('31', @_);
        return;
}

# Displays a done message.
sub done {
        my $o=shift;
        $o->colorline('32', @_);
        return;
}

# Displays an info message.
sub info {
        my $o=shift;
        $o->colorline('34;1', @_);
        return;
}

=head1 NAME

storableedit.pl - Edit Perl Storable Files

=head1 SYNOPSIS

storableedit.pl PERL_STORABLE_FILE

=head1 DESCRIPTION

B<storableedit.pl> is a simple command line editor for Perl Storable files. Its interface is similar to a shell.

When the program is started, it reads the whole file and displays the first level of the data structure. One can then dive into the structure with the B<cd> command and display values with the B<ls> or B<l> commands.

The data can be modified with usual Perl expressions, where
  I<$cur>  is a reference to the current node
  I<$data> is a reference to the root node of the data

To save the data back to file and exit, type B<x> or B<exit>. To exit without saving, type B<q> or B<quit>. If you have modified the data, you can force discarding the changes with B<q!> or B<quit!>.

=head1 BUILT-IN COMMANDS

=over 4

=item cd ELEMENT

Moves into ELEMENT. If the current node is a hashref, ELEMENT must be a key. The new current node will be $cur->{'ELEMENT'}. If the current node is an arrayref, ELEMENT must be an index and $cur->[ELEMENT] becomes the new current node. If the current node is a reference to a reference, type B<cd ref>. Note that you can only move into new references (hashref, arrayref or ref, but not scalars).

To move up to the parent, type B<cd ..> (or just B<..>). To move up two steps, type B<cd ...> (or just B<...>).

=item ..

Shortcut for B<cd ..>

=item ...

Shortcut for B<cd ...>

=item ls

Displays the contents of the current node. For hashrefs, all key/value pairs are listed. For arrayrefs, all elements are listed.

Note that ls doesn't take any arguments, i.e. you can't use regexes to display only parts of the content.

=item l

Similar as B<ls>, but cuts all values that are longer than 50.

=item x, exit

Saves the (modified) data structure and quits.

=item q, quit

Quits without saving. If the data structure has been modified, a warning is shown.

=item q!, quit!

Forces quiting without saving.

=back

=head1 PERL EXPRESSIONS

If a command is not recognized as a built-in command, the whole line is passed to the Perl eval() function. Two variables are provided to access the data structure:
  I<$cur>  is a reference to the current node
  I<$data> is a reference to the root node of the data

Note that this script does not check what you are doing. It does NOT ask to confirm when you delete values. But keep in mind that you can always quit with B<q!> to discard all changes.

In case of syntax or runtime errors, the Perl error messages are shown.

Simple examples:

    $cur->{'foo'} = 'bar';    # if $cur is a hashref
    $cur->[0] = 'bar';        # if $cur is an arrayref
    $cur->[1] = {'a' => 'b'}; # creates new hashref
    $cur->[2] = ['a', 'b'];   # creates new arrayref

Fancy examples:

    push @$cur, 'bar';
        # adds a new value to the current arrayref

    push @$data, pop @$cur;
        # more array ops

    $cur->{'list'} = split(/,/, $cur->{'string'};   
        # splitting a string

    $cur->{'list'} = [sort values %{$cur->{'hashref'}}];
        # sorted values of a hashref

    print join("\n", grep {/abc/} keys %$cur)
        # grep, join ... it's Perl!

    $data = $cur;
        # sets the current node as new root
        # note that you might loose data ...

    $cur->{'imported'}=retrieve('otherfile.store');
        # imports from another Storable file

    store($cur, 'otherfile.store');
        # exports to another Storable file

Perl-OO examples:

    use My::Module;
        # load My::Module

    $cur->{'obj'} = My::Module->new();
        # create a new My::Module object

    $cur->{'obj'}->my_method();
        # call a method

    bless $cur, 'My::Module';
        # blessing manually

To enter multiline Perl expressions, put a backslash (\) at the end of each line. Example:

    open(my $fh, '<', 'myfile.txt');\
    $cur->{'firstline'}=<$fh>;\
    close $fh;

=head1 CAVEATS

=over 4

=item Cyclic Structures

B<storableedit.pl> also handles cyclic structures.

=item File Handles 

File handles are not stored by the Storable module (for obvious reasons).

=item Objects

When loading storable files with (blessed) objects, the corresponding modules are not automatically loaded. If you need to invoke methods, type B<use My::Module;> or B<require "/path/to/module.pm";> to load the necessary module(s).

=back

=head1 AUTHORS

Thomas Lochmatter <thl@lothosoft.ch>.

=head1 README

A simple command line editor for Perl Storable files. The interface is similar to a shell. It allows to easily walk through the data structure of the file and to list and change values.

=begin comment

=pod PREREQUISITES

strict
Storable
Term::ReadLine

=pod OSNAMES

any

=pod SCRIPT CATEGORIES

Unix/System_administration

=end comment

=cut
1	#!/usr/bin/perl
2	use strict;
3	use Storable;
4	my $VERSION = 1.5;
5
6	#=Description
7	# Simple editor for files saved with storable.
8
9	# Read file
10	my $filename=shift;
11	my $data;
12	if (! $filename) {
13	print 'This is storableedit.pl, version ', $VERSION, "\n";
14	print "\n";
15	print 'Usage: storableedit.pl FILE', "\n";
16	print ' where FILE is a Perl Storable file', "\n";
17	print "\n";
18	print 'For more information, check out', "\n";
19	print ' perldoc storableedit.pl', "\n";
20	exit;
21	} elsif (-f $filename) {
22	StorableEdit->done('Opening file: ', $filename);
23	$data=retrieve($filename);
24	} else {
25	StorableEdit->done('Creating new file: ', $filename);
26	$data={};
27	}
28
29	# Edit
30	my $e=StorableEdit->new($data);
31	my $dosave=$e->edit();
32
33	# Save
34	if ($dosave) {
35	store $e->data(), $filename;
36	StorableEdit->done('File saved: ', $filename);
37	}
38
39	exit;
40
41	package StorableEdit;
42	use Storable;
43	use Term::ReadLine;
44
45
46	use lib 'lib';
47	use Sack::Digest;
48	sub undigest {
49	my ( $o, $v ) = @_;
50	my $k = $o->{path}->[0] \|\| return $v;
51	return $v unless $k =~ m{#};
52	# warn "## $k = $v\n";
53	$o->{_digest_}->undigest_node_k_v(0, $k, $v);
54	}
55
56	sub new {
57	my $o=shift;
58	my $class=(ref($o) \|\| $o);
59	my $newo=bless {}, $class;
60	$newo->init(@_);
61	$newo->{_digest_} = Sack::Digest->new( port => 0 );
62	return $newo;
63	}
64
65	# Initializing.
66	sub init {
67	my $o=shift;
68	my $data=shift;
69
70	$o->data($data);
71	$o->{'changed'}=0;
72	$o->{'readline'}=Term::ReadLine->new('StorableEdit');
73	return;
74	}
75
76	# Returns the data.
77	sub data {
78	my $o=shift;
79	if (my $set=shift) {
80	$o->{'data'}=$set; # Data
81	$o->{'pathobjects'}=[]; # Path objects
82	$o->{'path'}=[]; # Path to cur
83	$o->{'cur'}=$set; # Currently selected branch
84	}
85	return $o->{'data'};
86	}
87
88	# Sets the changed flag.
89	sub setchanged {
90	my $o=shift;
91	$o->{'changed'}=1;
92	return;
93	}
94
95	# Returns the changed flag.
96	sub changed {
97	my $o=shift;
98	return $o->{'changed'};
99	}
100
101	# Lets the user edit the structure.
102	sub edit {
103	my $o=shift;
104
105	# Show contents
106	$o->show($o->{'data'}, 50);
107
108	# Command loop
109	while (1) {
110	my $cmd=$o->input();
111
112	if (($cmd eq 'quit') \|\| ($cmd eq 'q')) {
113	if ($o->changed()) {
114	$o->error('Changes were made. Use "q!" to quit without saving or "x" to save and quit.');
115	} else {
116	return 0;
117	}
118	} elsif (($cmd eq 'quit!') \|\| ($cmd eq 'q!')) {
119	return 0;
120	} elsif (($cmd eq 'exit') \|\| ($cmd eq 'x')) {
121	return 1;
122	} elsif ($cmd eq 'help') {
123	print 'Commands:', "\n";
124	print ' x, exit: save and quit', "\n";
125	print ' q, quit: quit without saving', "\n";
126	print ' l, ls: list items in current object/reference', "\n";
127	print ' cd ITEM: dive into item (must be reference)', "\n";
128	print ' cd ..: go up', "\n";
129	print ' cd ...: go 2 steps up', "\n";
130	print ' other: evaled as perl code', "\n";
131	print ' $cur: variable of current object/reference', "\n";
132	print ' $base: variable of base object/reference', "\n";
133	print '', "\n";
134	print 'Examples:', "\n";
135	print ' $cur->{\'test\'}=\'hello world\'', "\n";
136	print ' $cur->{\'fruits\'}=[\'apple\', \'banana\']', "\n";
137	print ' $cur->{\'available\'}={\'apple\' => 1, \'banana\' => 5}', "\n";
138	print ' cd available', "\n";
139	print ' l', "\n";
140	print ' bless $cur, \'MyObject\'', "\n";
141	print ' $cur->{\'imported\'}=retrieve(\'importfile.store\')', "\n";
142	print ' store($cur, \'exportfile.store\')', "\n";
143	print ' $data=$cur', "\n";
144	print '', "\n";
145	print 'For a more complete help, see', "\n";
146	print ' perldoc storableedit.pl', "\n";
147	} elsif ($cmd eq 'l') {
148	$o->show($o->{'cur'}, 50);
149	} elsif ($cmd eq 'ls') {
150	$o->show($o->{'cur'});
151	} elsif ($cmd =~ /^cd\s+(.*?)$/) {
152	my $cd=$1;
153	$o->cd($cd);
154	} elsif ($cmd eq 'cd') {
155	} elsif ($cmd eq '..') {
156	$o->cd('..')
157	} elsif ($cmd eq '...') {
158	$o->cd('...')
159	} elsif ($cmd) {
160	$o->setchanged();
161	my $cur=$o->{'cur'};
162	my $data=$o->{'data'};
163
164	undef $@;
165	undef $!;
166	eval $cmd;
167
168	if ($@) {
169	$o->error('Eval error: ', $@);
170	} elsif ($!) {
171	$o->error('Eval error: ', $!);
172	} elsif ($data!=$o->{'data'}) {
173	if (ref $data) {
174	$o->data($data);
175	$o->done('New base object set!');
176	} else {
177	$o->error('The base object must be a reference (HASH, ARRAY or REF).');
178	}
179	} elsif ($cur!=$o->{'cur'}) {
180	$o->error('You cannot change the current branch this way. Use "cd" instead.');
181	}
182	}
183	}
184
185	return;
186	}
187
188	sub cd { # cd($cdpath)
189	my $o=shift;
190	my $cdpath=shift;
191
192	my $pathinfo={
193	'node' => $o->{'cur'},
194	'path' => [@{$o->{'path'}}],
195	'pathobjects' => [@{$o->{'pathobjects'}}],
196	};
197
198	$pathinfo=$o->cdpath($pathinfo, $cdpath);
199	return if (! ref $pathinfo);
200
201	$o->{'cur'}=$pathinfo->{'node'};
202	$o->{'path'}=$pathinfo->{'path'};
203	$o->{'pathobjects'}=$pathinfo->{'pathobjects'};
204	return;
205	}
206
207	sub cdpath { # $node = cdpath($pathinfo, $cdpath)
208	my $o=shift;
209	my $pathinfo=shift;
210	my $cdpath=shift;
211
212	my @path=split(/\//, $cdpath);
213	foreach my $label (@path) {
214	$pathinfo=$o->cdstep($pathinfo, $label);
215	return if (! ref $pathinfo);
216	}
217
218	return $pathinfo;
219	}
220
221	# Change directory.
222	sub cdstep { # $node = cdstep($node, $cd)
223	my $o=shift;
224	my $pathinfo=shift;
225	my $cd=shift;
226
227	my $node=$pathinfo->{'node'};
228	my $path=$pathinfo->{'path'};
229	my $pathobjects=$pathinfo->{'pathobjects'};
230
231	my $type=$o->type($node);
232	if ($cd eq '..') {
233	if (scalar(@$path)>0) {
234	pop @$path;
235	$pathinfo->{'node'}=pop @$pathobjects;
236	return $pathinfo;
237	}
238	} elsif ($cd eq '...') {
239	$pathinfo=$o->cdstep($pathinfo, '..');
240	$pathinfo=$o->cdstep($pathinfo, '..');
241	return $pathinfo;
242	} elsif ($type eq 'ARRAY') {
243	my $newcur=$node->[$cd];
244	if (ref $newcur) {
245	push @$path, $cd;
246	push @$pathobjects, $node;
247	$pathinfo->{'node'}=$newcur;
248	return $pathinfo;
249	} else {
250	$o->error('Cannot change into non-reference (', $cd, ').');
251	}
252	} elsif ($type eq 'HASH') {
253	my $newcur=$node->{$cd};
254	if (ref $newcur) {
255	push @$path, $cd;
256	push @$pathobjects, $node;
257	$pathinfo->{'node'}=$newcur;
258	return $pathinfo;
259	} else {
260	$o->error('Cannot change into non-reference (', $cd, ').');
261	}
262	} elsif ($type eq 'REF') {
263	my $newcur=$$node;
264	if (ref $newcur) {
265	push @$path, 'ref';
266	push @$pathobjects, $node;
267	$pathinfo->{'node'}=$newcur;
268	return $pathinfo;
269	} else {
270	$o->error('Cannot change into non-reference (', $cd, ').');
271	}
272	} else {
273	$o->error('Unexpected error.');
274	}
275
276	return;
277	}
278
279	# Lets the user give an input.
280	sub input {
281	my $o=shift;
282
283	my @cmd;
284	my $line=$o->inputline(1);
285	while ($line =~ /^\s(.)\s*\\$/) {
286	push @cmd, $1;
287	$line=$o->inputline(0);
288	}
289	$line=$1 if ($line =~ /^\s(.)\s*$/);
290	push @cmd, $line;
291	return join("\n", @cmd);
292	}
293
294
295	# Lets the user give an input.
296	sub inputline { # $cmd = inputline($showpath)
297	my $o=shift;
298	my $showpath=shift;
299	my $path=$o->{'path'};
300	my $cur=$o->{'cur'};
301	my $readline=$o->{'readline'};
302
303	# Path
304	print "\n" if ($showpath);
305	my $prompt=chr(033).'[0;33m';
306	$prompt.='/'.join('/', @$path) if ($showpath);
307	$prompt.=' ('.ref($cur).')' if ($showpath);
308	$prompt.='> '.chr(033).'[0m';
309
310	# Get user input
311	my $cmd=$readline->readline($prompt);
312	return if (! defined $cmd);
313	while (chomp $cmd) {}
314	$readline->addhistory($cmd);
315	return $cmd;
316	}
317
318	# Displays contents.
319	sub show {
320	my $o=shift;
321	my $data=shift;
322	my $textlimit=shift;
323
324	# Data
325	my $type=$o->type($data);
326	if ($type eq 'ARRAY') {
327	return $o->show_array($data, $textlimit);
328	} elsif ($type eq 'HASH') {
329	return $o->show_hash($data, $textlimit);
330	} elsif ($type eq 'REF') {
331	return $o->show_ref($data, $textlimit);
332	}
333
334	$o->error('Unexpected error.');
335	return;
336	}
337
338	# Displays the contents of an array.
339	sub show_array {
340	my $o=shift;
341	my $data=shift;
342	my $textlimit=shift;
343
344	my $i=0;
345	foreach my $item (@$data) {
346	my $tt=scalar($item);
347	$tt=substr($tt, 0, $textlimit).'...' if (($textlimit) && (length($tt)>$textlimit));
348	print ' ', $i, ' => ', $tt, "\n";
349	} continue {
350	$i++;
351	}
352
353	$o->info(' (empty array)') if ($i==0);
354	return;
355	}
356
357	# Displays the contents of a hash.
358	sub show_hash {
359	my $o=shift;
360	my $data=shift;
361	my $textlimit=shift;
362
363	my $i=0;
364	foreach my $ky (sort keys %$data) {
365	my $tt=scalar($data->{$ky});
366	$tt=substr($tt, 0, $textlimit).'...' if (($textlimit) && (length($tt)>$textlimit));
367	print ' ', $o->undigest($ky), ' => ', $tt, "\n";
368	} continue {
369	$i++;
370	}
371
372	$o->info(' (empty hash)') if ($i==0);
373	return;
374	}
375
376	# Displays the contents of a reference.
377	sub show_ref {
378	my $o=shift;
379	my $data=shift;
380	my $textlimit=shift;
381
382	my $tt=scalar($$data);
383	$tt=substr($tt, 0, $textlimit).'...' if (($textlimit) && (length($tt)>$textlimit));
384	print ' ref => ', $tt, "\n";
385	return;
386	}
387
388	# Returns the reference type.
389	sub type {
390	my $o=shift;
391	my $obj=shift;
392
393	my $type;
394	if (ref $obj) {
395	$type=scalar($obj);
396	$type=(($type=~/=(.*)\(/) ? $1 : ref $obj);
397	}
398
399	return $type;
400	}
401
402	# Prints out a colored line of text.
403	sub colorline {
404	my $o=shift;
405	my $color=shift;
406	print chr(033), '[', $color, 'm', @_, chr(033), '[0m', "\n";
407	return;
408	}
409
410	# Displays an error message.
411	sub error {
412	my $o=shift;
413	$o->colorline('31', @_);
414	return;
415	}
416
417	# Displays a done message.
418	sub done {
419	my $o=shift;
420	$o->colorline('32', @_);
421	return;
422	}
423
424	# Displays an info message.
425	sub info {
426	my $o=shift;
427	$o->colorline('34;1', @_);
428	return;
429	}
430
431	=head1 NAME
432
433	storableedit.pl - Edit Perl Storable Files
434
435	=head1 SYNOPSIS
436
437	storableedit.pl PERL_STORABLE_FILE
438
439	=head1 DESCRIPTION
440
441	B<storableedit.pl> is a simple command line editor for Perl Storable files. Its interface is similar to a shell.
442
443	When the program is started, it reads the whole file and displays the first level of the data structure. One can then dive into the structure with the B<cd> command and display values with the B<ls> or B<l> commands.
444
445	The data can be modified with usual Perl expressions, where
446	I<$cur> is a reference to the current node
447	I<$data> is a reference to the root node of the data
448
449	To save the data back to file and exit, type B<x> or B<exit>. To exit without saving, type B<q> or B<quit>. If you have modified the data, you can force discarding the changes with B<q!> or B<quit!>.
450
451	=head1 BUILT-IN COMMANDS
452
453	=over 4
454
455	=item cd ELEMENT
456
457	Moves into ELEMENT. If the current node is a hashref, ELEMENT must be a key. The new current node will be $cur->{'ELEMENT'}. If the current node is an arrayref, ELEMENT must be an index and $cur->[ELEMENT] becomes the new current node. If the current node is a reference to a reference, type B<cd ref>. Note that you can only move into new references (hashref, arrayref or ref, but not scalars).
458
459	To move up to the parent, type B<cd ..> (or just B<..>). To move up two steps, type B<cd ...> (or just B<...>).
460
461	=item ..
462
463	Shortcut for B<cd ..>
464
465	=item ...
466
467	Shortcut for B<cd ...>
468
469	=item ls
470
471	Displays the contents of the current node. For hashrefs, all key/value pairs are listed. For arrayrefs, all elements are listed.
472
473	Note that ls doesn't take any arguments, i.e. you can't use regexes to display only parts of the content.
474
475	=item l
476
477	Similar as B<ls>, but cuts all values that are longer than 50.
478
479	=item x, exit
480
481	Saves the (modified) data structure and quits.
482
483	=item q, quit
484
485	Quits without saving. If the data structure has been modified, a warning is shown.
486
487	=item q!, quit!
488
489	Forces quiting without saving.
490
491	=back
492
493	=head1 PERL EXPRESSIONS
494
495	If a command is not recognized as a built-in command, the whole line is passed to the Perl eval() function. Two variables are provided to access the data structure:
496	I<$cur> is a reference to the current node
497	I<$data> is a reference to the root node of the data
498
499	Note that this script does not check what you are doing. It does NOT ask to confirm when you delete values. But keep in mind that you can always quit with B<q!> to discard all changes.
500
501	In case of syntax or runtime errors, the Perl error messages are shown.
502
503	Simple examples:
504
505	$cur->{'foo'} = 'bar'; # if $cur is a hashref
506	$cur->[0] = 'bar'; # if $cur is an arrayref
507	$cur->[1] = {'a' => 'b'}; # creates new hashref
508	$cur->[2] = ['a', 'b']; # creates new arrayref
509
510	Fancy examples:
511
512	push @$cur, 'bar';
513	# adds a new value to the current arrayref
514
515	push @$data, pop @$cur;
516	# more array ops
517
518	$cur->{'list'} = split(/,/, $cur->{'string'};
519	# splitting a string
520
521	$cur->{'list'} = [sort values %{$cur->{'hashref'}}];
522	# sorted values of a hashref
523
524	print join("\n", grep {/abc/} keys %$cur)
525	# grep, join ... it's Perl!
526
527	$data = $cur;
528	# sets the current node as new root
529	# note that you might loose data ...
530
531	$cur->{'imported'}=retrieve('otherfile.store');
532	# imports from another Storable file
533
534	store($cur, 'otherfile.store');
535	# exports to another Storable file
536
537	Perl-OO examples:
538
539	use My::Module;
540	# load My::Module
541
542	$cur->{'obj'} = My::Module->new();
543	# create a new My::Module object
544
545	$cur->{'obj'}->my_method();
546	# call a method
547
548	bless $cur, 'My::Module';
549	# blessing manually
550
551	To enter multiline Perl expressions, put a backslash (\) at the end of each line. Example:
552
553	open(my $fh, '<', 'myfile.txt');\
554	$cur->{'firstline'}=<$fh>;\
555	close $fh;
556
557	=head1 CAVEATS
558
559	=over 4
560
561	=item Cyclic Structures
562
563	B<storableedit.pl> also handles cyclic structures.
564
565	=item File Handles
566
567	File handles are not stored by the Storable module (for obvious reasons).
568
569	=item Objects
570
571	When loading storable files with (blessed) objects, the corresponding modules are not automatically loaded. If you need to invoke methods, type B<use My::Module;> or B<require "/path/to/module.pm";> to load the necessary module(s).
572
573	=back
574
575	=head1 AUTHORS
576
577	Thomas Lochmatter <thl@lothosoft.ch>.
578
579	=head1 README
580
581	A simple command line editor for Perl Storable files. The interface is similar to a shell. It allows to easily walk through the data structure of the file and to list and change values.
582
583	=begin comment
584
585	=pod PREREQUISITES
586
587	strict
588	Storable
589	Term::ReadLine
590
591	=pod OSNAMES
592
593	any
594
595	=pod SCRIPT CATEGORIES
596
597	Unix/System_administration
598
599	=end comment
600
601	=cut