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