#!/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;

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 '  ', $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