#!/usr/bin/perl -w


package DBM::Deep::Manager;

use Term::ReadLine;
use Data::Dumper;
use DBM::Deep 2.0;
use Getopt::Long;
use File::Temp qw(tempfile);

use strict;
no strict 'refs';

$DBM::Deep::Manager::VERSION = 0.01;
our ($dbfile, $cryptmodule, $compressmodule, $digestmodule, $debug, $version, $help, $export, $import);
our ($maindb, $db, $term, @prev, @path, $session);

Getopt::Long::Configure( qw(no_ignore_case));
if (! GetOptions (
		  "database|f=s"    => \$dbfile,
		  "encrypt|e=s"     => \$cryptmodule,
		  "compress|c=s"    => \$compressmodule,
		  "digest|d=s"      => \$digestmodule,
		  "export|E=s"      => \$export,
		  "import|I=s"      => \$import,
		  "version|v"       => \$version,
		  "help|h"          => \$help,
		  "verbose|V"       => \$debug
                 )    ) {
  &usage;
}

if ($help){
  &usage;
}

if ($version) {
  print STDERR "dmbdeep version $DBM::Deep::Manager::VERSION\n";
  exit;
}

if ($export) {
  &export($export);
  exit;
}
if ($import) {
  &import($import);
  exit;
}

if (!$dbfile) {
  $dbfile = shift;
  if (!$dbfile) {
    &usage;
  }
}

sub __main__{};
&opendb($dbfile);

if (-t STDIN) {
  $| = 1;
  $term = new Term::ReadLine 'ProgramName';
  $term->ornaments(0);
  &prompt;
  while ( defined ($_ = $term->readline("")) ) {
    &process($_);
    &prompt;
  }
}
else {
  while (<STDIN>) {
    &process($_);
  }
}

sub prompt {
  my $prompt = "$dbfile";
  if (@path) {
    $prompt .= " " . join('->', @path);
  }
  if ($session) {
    $prompt .= '%';
  }
  $prompt .= '> ';
  print $prompt;
}

sub process {
  my $line = shift;
  my ($cmd, @args) = split /\s\s*/, $line;

  return if ($cmd =~ /^\s*$/);
  return if ($cmd =~ /^#/);

  if ($cmd eq '..') {
    &up;
  }
  elsif ($cmd eq 'pop') {
    &mypop(@args);
  }
  elsif ($cmd eq 'shift') {
    &myshift(@args);
  }
  elsif ($cmd eq '?') {
    &help;
  }
  else {
    $cmd->(@args);
  }
}

sub opendb {
  # FIXME: add hooks, like crypto, compress etc

  my %new = (
	     file => $dbfile,
	     locking   => 1,
	     autoflush => 1,
	     num_txns => 10,
	    );

  if ($compressmodule) {
    # FIXME: add parameters accordingly
  }

  if (tie my %db, 'DBM::Deep', %new) {
    $maindb = tied(%db);
    $db = \%db;
  }
  else {
    die "Could not open dbfile $dbfile: $!\n";
  }
}

sub load {
  my $mod = shift;
  eval "require $mod;";
  if ($@) {
    print "Module $mod not installed\n";
    return 0;
  }
  else {
    return 1;
  }
}

sub export {
  my $file = shift;
  if (&load('YAML')) {
    &opendb($dbfile);
    my $fd;
    if ($file eq '-') {
      $fd = *STDOUT;
    }
    else {
      open $fd, ">$file" or die "Could not open export file $file for writing: $!\n";
    }
    print $fd YAML::Dump(tied(%{$db})->export());
    close $fd;
  }
}

sub import {
  my $file = shift;
  if (&load('YAML')) {
    &opendb($dbfile);
    my $fd;
    if ($file eq '-') {
      $fd = *STDIN;
    }
    else {
      open $fd, "<$file" or die "Could not open import file $file for reading: $!\n";
    }
    my $yaml = join '', <$fd>;
    my $perl = YAML::Load($yaml);
    tied(%{$db})->import($perl);
    close $fd;
  }
}




# implementations
sub __interactive__ {};

sub set {
  my($key, @value) = @_;
  if (!$key) {
    print STDERR "<key> parameter missing\n";
    return;
  }

  my $var;
  my $code = "\$var = @value;";
  eval $code;
  if ($@) {
    print STDERR "failed to insert: $@\n";
  }
  else {
    $db->{$key} = $var;
    print "ok\n";
  }
}

sub append {
  my($key, @value) = @_;
  if (!$key) {
    print STDERR "<key> parameter missing\n";
    return;
  }

  if (exists $db->{$key}) {
    if (ref($db->{$key}) ne 'DBM::Deep::Array') {
      print STDERR "\"$key\" already exists and is not an array\n";
      return;
    }
  }

  my $var;
  my $code = "\$var = @value;";
  eval $code;
  if ($@) {
    print STDERR "failed to insert: $@\n";
  }
  else {
    push @{$db->{$key}}, $var;
    print "ok\n";
  }
}

sub drop {
  my($key) = @_;
  if (!$key) {
    print STDERR "<key> parameter missing\n";
    return;
  }

  if (exists $db->{$key}) {
    delete $db->{$key};
    print "ok\n";
  }
  else {
    print STDERR "no such key: \"$key\"\n";
  }
}

sub mypop {
  my($key) = @_;
  if (!$key) {
    print STDERR "<key> parameter missing\n";
    return;
  }

  if (exists $db->{$key}) {
    if (ref($db->{$key}) ne 'DBM::Deep::Array') {
      print STDERR "\"$key\" is not an array\n";
      return;
    }
  }
  my $ignore = pop @{$db->{$key}};
  print "ok\n";
}

sub myshift {
  my($key) = @_;
  if (!$key) {
    print STDERR "<key> parameter missing\n";
    return;
  }

  if (exists $db->{$key}) {
    if (ref($db->{$key}) ne 'DBM::Deep::Array') {
      print STDERR "\"$key\" is not an array\n";
      return;
    }
  }
  my $ignore = shift @{$db->{$key}};
  print "ok\n";
}

sub get {
  my($key, $norecurse) = @_;
  if (!$key) {
    print STDERR "<key> parameter missing\n";
    return;
  }

  if (exists $db->{$key}) {
    if (ref($db->{$key}) eq 'DBM::Deep::Hash' || ref($db->{$key}) eq 'DBM::Deep::Array') {
      # FIXME: something nicer
      &dump($db->{$key})
    }
    else {
      print "$key => \"$db->{$key}\"\n";
    }
  }
  else {
    print STDERR "no such key: \"$key\"\n";
  }
}

sub d {
  &dump;
}
sub dump {
  my $obj = shift;
  my $out;
  if ($obj) {
    $out = Dumper($obj->export());
  }
  else {
    $out = Dumper(tied(%{$db})->export());
  }
  $out =~ s/\$VAR1 = [\[{]\n?//;
  $out =~ s/[\]}];$//;
  $out =~ s/^          //gm;
  if (open LESS, "|more") { # FIXME: make customizable
    print LESS $out;
    close LESS;
  }
  else {
    print $out;
  }
}

sub edit {
  my $key = shift;
  if (!$key) {
    print STDERR "<key> parameter missing\n";
    return;
  }
  if (&load('YAML')) {
    if (exists $db->{$key}) {
      my $data = YAML::Dump(tied(%{$db->{$key}})->export());
      my ($fh, $filename) = tempfile();
      print $fh $data;
      close $fh;
      system("vi", $filename); # FIXME: make customizable
      open IN, "<$filename";
      my $newdata = join '', <IN>;
      close IN;
      if ($newdata eq $data) {
	# FIXME: use checksum or something else faster
	print "unchanged\n";
      }
      else {
	my $perl;
	eval {
	  $perl = YAML::Load($newdata);
	};
	if ($@) {
	  print STDERR "$@\n";
	}
	else {
	  $db->{$key} = $perl;
	  print "ok\n";
	}
      }
      unlink($filename);
    }
    else {
      print STDERR "no such key: \"$key\"\n";
    }
  }
}

sub l {
  &list(@_);
}
sub list {
  print join "\n", sort keys %{$db};
  print "\n";
}

sub sh {
  &show();
}
sub show {
  foreach my $key (sort keys %{$db}) {
    printf "%-30s", $key;
    if (ref($db->{$key}) eq 'DBM::Deep::Hash') {
      print "{ .. }\n";
    }
    elsif (ref($db->{$key}) eq 'DBM::Deep::Array') {
      print "[ .. ]\n";
    }
    else {
      print "\"$db->{$key}\"\n";
    }
  }
}

sub cd {
  &enter(@_);
}
sub enter {
  my $key = shift;
  if (!$key) {
    print STDERR "<key> parameter missing\n";
    return;
  }

  if ($key eq '..') {
    &up();
  }
  else {
    if (exists $db->{$key}) {
      if (ref($db->{$key}) eq 'DBM::Deep::Hash') {
	# "changedir" to the key
	push @prev, $db;
	push @path, $key;
	$db = $db->{$key};
	print "=> $key\n";
      }
      else {
	print STDERR "not a hash: \"$key\"\n";
      }
    }
    else {
      print STDERR "unknown command \"$key\"\n";
    }
  }
}

sub up {
  if (@prev) {
    $db = pop @prev;
    pop @path;
    print "<=\n";
  }
  else {
    print STDERR "already on top level\n";
  }
}

sub begin {
  if (!$session) {
    eval { $maindb->begin_work; };
    if ($@) {
      print STDERR "transactions not supported by $dbfile, re-create with 'num_txns' > 1\n"; 
    }
    else {
      $session = 1;
      print "ok\n";
    }
  }
}

sub commit {
  if ($session) {
    $maindb->commit();
    $session = 0;
    print "ok\n";
  }
}

sub rollback {
  if ($session) {
    $maindb->rollback();
    $session = 0;
    print "ok\n";
  }
}

sub h {
  &help;
}
sub help {
  print qq(Display commands:
  list                  - list keys of current level
  show                  - same as list but with values
  dump                  - dump everything from current level
  get <key>             - display value of <key>

Navigation commands:
  enter <key>           - change level into sub-hash of <key>

Edit commands:  
  set <key> <value>     - set <key> to <value> [1]
  edit <key>            - edit structure behind <key> [2]
  append <key> <value>  - append <value> to array <key>
  drop <key>            - delete key <key>
  pop <key>             - remove last element of array <key>
  shift <key>           - remove first element of array <key>

Transaction commands:
  begin                 - start a transaction session
  commit                - store everything changed within session
  rollback              - discard changes

Misc commands:
  help                  - get help
  ctrl-d                - exit dbmdeep

Shortcuts:
  ..                    - go one level up
  l                     - list
  d                     - dump
  sh                    - show
  cd                    - enter
  <key>                 - enter <key> [3]

Hints:
[1] the YAML module must be installed
[2] <value> can be perl code, e.g: set pw { user => 'max' }
[3] doesn't work if <key> correlates to a command
);
}


sub AUTOLOAD {
  # catch invalid commands
  my($caller, @args) = @_;

  my $cmd = $DBM::Deep::Manager::AUTOLOAD;
  $cmd =~ s/.*:://;

  if (exists $db->{$cmd}) {
    &enter($cmd);
  }
  else {
    print STDERR "no such command: $cmd\n";
  }
}



sub usage {
  print STDERR qq(Usage: dbmdeep [-fecdvhV] [<file>]
Manage a DBM::Deep database. Options:

  --database=<file>   | -f <file>      database file to manage
  --encrypt=<module>  | -e <module>    use encryption <module>
  --compress=<module> | -c <module>    use compression <module>
  --digest=<module>   | -d <module>    use hash digest <module>
  --export=<file>     | -E <file>      export db to <file>, YAML required
  --import=<file>     | -I <file>      import db from <file>, YAML required
  --verbose           | -V             enable debug output
  --help              | -h             this help message
  --version           | -v             print program version

If -f is not specified, program arg is considered to be the
database file, e.g. "dbmdeep -f my.db" is the same as "dbmdeep my.db".
If - is specified as <file>, STDIN or STDOUT is used respectively.
Interactive commands can be piped into dbmdeep as well, e.g.:
echo "drop users" | dbmdeep -f my.db.

dbmdeep version $DBM::Deep::Manager::VERSION.
);

  exit 1;
}