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;
our $digest_opened = 0;
sub unshard {
        my ( $o, $v ) = @_;
        return $v unless $o->{path}->[0] =~ m{#};
        $digest_opened ||= Sack::Digest->open(0);
#       warn "### ",$o->{path}->[0], " $v\n";
        Sack::Digest->from_int($v);
}

sub new {
        my $o=shift;
        my $class=(ref($o) || $o);
        my $newo=bless {}, $class;
        $newo->init(@_);
        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->unshard($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	dpavlin	32	#!/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	dpavlin	37
46			use lib 'lib';
47			use Sack::Digest;
48			our $digest_opened = 0;
49			sub unshard {
50			my ( $o, $v ) = @_;
51			return $v unless $o->{path}->[0] =~ m{#};
52			$digest_opened \|\|= Sack::Digest->open(0);
53			# warn "### ",$o->{path}->[0], " $v\n";
54			Sack::Digest->from_int($v);
55			}
56
57	dpavlin	32	sub new {
58			my $o=shift;
59			my $class=(ref($o) \|\| $o);
60			my $newo=bless {}, $class;
61			$newo->init(@_);
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	dpavlin	37	print ' ', $o->unshard($ky), ' => ', $tt, "\n";
368	dpavlin	32	} 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