#!/usr/bin/env perl
# -*- perl -*-

#
# $Id: show_db,v 2.3 2002/07/19 11:55:55 eserte Exp eserte $
# Author: Slaven Rezic
#
# Copyright (c) 1997-2002 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: <URL:mailto:slaven.rezic@berlin.de>
# WWW:  <URL:http://www.rezic.de/eserte/>
#

=head1 NAME

show_db - take a quick look into dbm files

=head1 SYNOPSIS

    show_db [-dbtype type] [-d delim] [-v] [-showtable]
            [-key spec] [-val spec] [-color] [-sel key]
            dbmfile

=head1 DESCRIPTION

C<show_db> lists the contents of a dbm database file (like DB_File,
GDBM_File, or CDB_File). There is also some support for MLDBM
databases.

=head2 OPTIONS

=over

=item -dbtype type

The type of the database. This is usually the class name like
C<DB_File>. Normally, C<show_db> tries to determine itself, so you do
not have to specify this option.

Variants of the database type may be specified with a comma-separated
list. Currently valid variants are:

=over

=item DB_File,RECNO

The keys are the array indexes of the recno database.

=item MLDBM,I<DB>,I<Serializer>

where I<DB> is C<DB_File> or another dbm class and I<Serializer> is
C<Data::Dumper> or another serializer class.

=back

=item -v

Be verbose. Multiple C<-v> cause more verbosity.

=item -showtable

Pipe the output to C<showtable> from the C<Data::ShowTable>
distribution.

=item -color

Color the key values. Needs the C<Term::ANSIColor> module installed.

=item -key spec

=item -val spec

Treat the keys or values as special data structures:

=over

=item pack:I<packspec>

C<unpack> will be used on the data. See L<perlfunc/pack> for the
format of I<packspec>.

=item storable

The data will be handled as serialized by Storable.

=item freezethaw

The data will be handled as serialized by FreezeThaw.

=item perldata

The data will be handled as a perl value or reference.

=back

The C<-key> and C<-val> specifications may be overriden by C<-color>.
The values of MLDBM databases are handled according to the
I<serializer> variant.

=item -sel key

Select the value for the specified C<key> from the database. The
C<select> option may be given multiple times.

=back

=head1 PREREQUISITES

any dbm module

=head1 COREQUISITES

C<Data::ShowTable>, C<Term::ANSIColor>

=head1 OSNAMES

OS independent

=head1 SCRIPT CATEGORIES

Database

=head1 AUTHOR

Slaven Rezic <slaven.rezic@berlin.de>

=head1 SEE ALSO

AnyDBM_File(3).

=cut

use strict;
use Fcntl;
use Getopt::Long;

my $delim = " => ";
my $v;
my $dbtype; # auto
my $do_showtable;
my $keyspec;
my $valspec;
my $cant_each;
my $do_color;
my @select;

if (!GetOptions(
		'dbtype=s' => \$dbtype,
		'd=s' => \$delim,
		'v+' => \$v,
		'showtable|table' => \$do_showtable,
		'key=s' => \$keyspec,
		'val=s' => \$valspec,
		'color' => \$do_color,
		'sel|select=s@' => \@select,
	       )) {
    require Pod::Usage;
    Pod::Usage::pod2usage(1);
}

my $file = shift || die "Specify db file";
my $db = defined $dbtype ? $dbtype : identify_db($file);
if (!defined $db) { die "Can't get DB type, please specify with -dbtype option" }
my $ref = open_db($file, $db);

my $keysub = sub { "<$_[0]>" };
my $valsub = sub { $_[0]     };

if (defined $keyspec) {
    $keysub = _spec_to_sub($keyspec);
}
if (defined $valspec) {
    $valsub = _spec_to_sub($valspec);
}

if ($db =~ /^MLDBM/) { # XXX overrides -val
    if ($db =~ /storable/i) {
	$valsub = _spec_to_sub("storable");
    } elsif ($db =~ /freezethaw/i) {
	$valsub = _spec_to_sub("freezethaw");
    } else {
	$valsub = _spec_to_sub("perldata");
    }
}

if ($do_color) { # XXX overrides -key
    require Term::ANSIColor;
    $keysub = sub { Term::ANSIColor::color('red') . $_[0] . Term::ANSIColor::color('reset') };
}

my $pid;
if ($do_showtable) {
    pipe(RDR, WTR);
    $pid = fork;
    if ($pid == 0) {
	close WTR;
	open(STDIN, "<&RDR") or die $!;
	exec "showtable", "-d$delim";
	die $@ if $@;
    }
    close RDR;
    open(STDOUT, ">&WTR") or die $!;
}

my $selsub;
if (@select) {
    foreach (@select) {
	output_record($ref, $keysub, $valsub, $_);
    }
} else {
    output_db($ref, $keysub, $valsub, $selsub);
}

sub identify_db {
    my $file = shift;
    if (!-e $file) {
	die "File $file does not exist";
    }
    if (!-r $file) {
	die "File $file is not readable";
    }
    my @types = qw(DB_File GDBM_File NDBM_File SDBM_File
		   ODBM_File CDB_File DB_File,RECNO);
    my $type;
 TRY: {
	foreach my $_type (@types) {
	    $type = $_type;
	    print STDERR "Try $type ... " if $v;
	    if ($type eq 'DB_File,RECNO' && eval "use $type; 1" &&
		tie my @db, $type, $file, O_RDONLY, 0644, $DB_File::DB_RECNO) {
		last TRY;
	    } elsif ($type eq 'CDB_File' && eval "use $type; 1" &&
		     tie my %db, $type, $file) {
		last TRY;
	    } elsif (eval "use $type; 1" &&
		     tie my %db, $type, $file, O_RDONLY, 0644) {
		last TRY;
	    }
	    if ($v > 1) {
		warn "\$\@=$@, \$!=$!";
	    }
	    print STDERR "\n" if $v;
	}
	return undef;
    }

    print STDERR "OK!\n" if $v;
    return $type;
}

sub open_db {
    my($file, $type, %args) = @_;
    if ($type eq 'DB_File,RECNO') {
	require DB_File;
	my @db;
	tie @db, "DB_File", $file, O_RDONLY, 0644, $DB_File::DB_RECNO or
	    die "Can't type $file with $type: $!";
	\@db;
    } elsif ($type =~ /^MLDBM/) {
	my(undef,$dbtype,$serializer) = split /,/, $type;
	$MLDBM::UseDB = $dbtype || "DB_File";
	$MLDBM::Serializer = $serializer || "Data::Dumper";
	require MLDBM;
	my %db;
	tie %db, 'MLDBM', $file, O_RDONLY, 0644 or
	    die "Can't tie $file with $type: $!";
	\%db;
    } else {
	eval "use $type"; die $@ if $@;
	my @tie_args = ($file);
	if ($type ne 'CDB_File') {
	    push @tie_args, O_RDONLY, 0644;
	}
	my %db;
	tie %db, $type, @tie_args or
	    die "Can't tie $file with @tie_args: $!";
	\%db;
    }
}

sub output_db {
    my($dbref, $keysub, $valsub, $selsub) = @_;
    if (ref $dbref eq 'ARRAY') {
	my $i = 0;
	foreach my $l (@$dbref) {
	    print $keysub->($i) . $delim . $valsub->($l) . "\n"
		if !$selsub || $selsub->($i);
	    $i++;
	}
    } elsif (ref $dbref eq 'HASH') {
	if ($cant_each) {
	    foreach my $key (keys %$dbref) {
		my $val = $dbref->{$key};
		print $keysub->($key) . $delim . $valsub->($val) . "\n"
		    if !$selsub || $selsub->($key);
	    }
	} else {
	    while(my($key,$val) = each %$dbref) {
		print $keysub->($key) . $delim . $valsub->($val) . "\n"
		    if !$selsub || $selsub->($key);
	    }
	}
    }
}

sub output_record {
    my($dbref, $keysub, $valsub, $key) = @_;
    if (ref $dbref eq 'ARRAY') {
	print $keysub->($key) . $delim . $valsub->($dbref->[$key]) . "\n";
    } elsif (ref $dbref eq 'HASH') {
	print $keysub->($key) . $delim . $valsub->($dbref->{$key}) . "\n";
    }
}

sub _spec_to_sub {
    my($spec) = @_;

    require Data::Dumper;
    my $dd = sub {
	my $out = Data::Dumper->new([$ref],[])->Useqq(1)->Indent(0)->Dump;
	$out =~ s/\$VAR1\s*=\s*//;
	$out;
    };

    if ($spec =~ /^pack:(.*)/) {
	my $pack = $1;
	return sub { unpack($pack, $_[0]) };
    } elsif ($spec =~ /^storable$/i) {
	require Storable;
	$cant_each = 1;
	return sub { $dd->(Storable::thaw($_[0])) };
    } elsif ($spec =~ /^freezethaw$/i) {
	require FreezeThaw;
	$cant_each = 1;
	return sub { $dd->(FreezeThaw::thaw($_[0])) }; # XXX check
    } elsif ($spec =~ /^perldata$/i) {
	$cant_each = 1;
	return sub { ref $_[0] ? $dd->($_[0]) : $_[0] };
    } else {
	die "Can't parse specification <$spec>";
    }
}

######################################################################
# obsolete, will be deleted some day

no strict;

# old getopt options
#  		'key=s' => \$key,
#  		'val=s' => \$val,
#  		'mldbm!' => \$mldbm,
#  		'showkey=s' => \$showkey,
#  		'packed=s' => \$packed, # l, L, etc. (see pack)
#  		'dbtype=s' => \$dbtype,
#  		'freezethaw!' => \$freezethaw,
#  		'datadump!'   => \$datadump,
#  		'db2!'        => \$berkeley_db2,
#  		'dbmethod=s'  => \$method,


sub old {
    if (defined $packed && defined $showkey) {
	$showkey = pack("$packed", $showkey);
    }

    if ($mldbm) {
	require MLDBM;
	require Data::Dumper;
	my $berkeley_db2_method;
	if ($berkeley_db2) {
	    require BerkeleyDB;
	    if (defined $method) {
		if ($method =~ /^recno/i) {
		    $berkeley_db2_method = 'BerkeleyDB::Recno';
		} elsif ($method =~ /^btree/i) {
		    $berkeley_db2_method = 'BerkeleyDB::Btree';
		}
	    }
	    if (!defined $berkeley_db2_method) {
		$berkeley_db2_method = 'BerkeleyDB::Hash';
	    }
	}

	$MLDBM::UseDB      = ($berkeley_db2 ? $berkeley_db2_method : 'DB_File');
	$MLDBM::Serializer = ($freezethaw ? "FreezeThaw"
			      : ($datadump ? "Data::Dumper" : "Storable"));
    }

    my($k,$v);
    my $out = sub {
	if ($packed) {
	    print "<" . join(",", unpack("$packed*", $k)) . "> = ";
	} else {
	    print "<$k> = ";
	}
	if ($mldbm) {
	    print Data::Dumper->Dumpxs([$v], [""]);
	} else {
	    if ($packed) {
		print join(",", unpack("$packed*", $v));
	    } else {
		$v =~ s/[\r\013]/\n/g;
		print $v;
	    }
	}
	print "\n";
    };


    $db = shift || die "DB?";

    if ($dbtype) {
	try_other();
	exit();
    }

    if ($method =~ /^recno$/i) {
	$db = tie @db, 'DB_File', $db, O_RDONLY, 0, $DB_RECNO
	    or die "Can't open $db";
	my $l = $db->length;
	for (my $i = 0; $i < $l; $i++) {
	    print "$i: $db[$i]\n";
	}
    } else {
	$success = 0;
	@try_methods = ($method, 'hash', 'btree');
	my $edit = (defined $key && defined $val);
	my $flags = ($edit ? O_RDWR : O_RDONLY);
	if ($mldbm) {
	    my @mldbm_args;
	    if ($berkeley_db2) {
		@mldbm_args = ("-Filename", $db);
	    } else {
		@mldbm_args = ($db, $flags, 0);
	    }
	    if (tie(%db, 'MLDBM', @mldbm_args)) {
		$success++;
	    }
	}
	if (!$success) {
	    foreach (@try_methods) {
		if (tie %db, 'DB_File', $db, $flags, 0, ($_ =~ /^btree$/i
							 ? $DB_BTREE
							 : $DB_HASH)) {
		    $success++;
		    last;
		} else {
		    warn "Can't open as $_: $!\n";
		}
	    }
	}
	if (!$success) {
	    try_other();
	}
	if (defined $showkey) {
	    $k = $showkey;
	    $v = $db{$v};
	    $out->();
	} else {
	    while (($k,$v) = each %db) {
		$out->();
		#$v =~ s/[\r\013]/\n/g;
		#print "<$k> = $v\n";
	    }
	}

	if ($edit) {
	    $db{$key} = $val;
	}

    }
}

sub try_other {
    my @types;
    if (defined $dbtype) {
	push @types, $dbtype;
    } else {
	@types = qw(GDBM_File NDBM_File SDBM_File CDB_File);
    }
    if ($mldbm) {
	@types = qw(MLDBM);
	$MLDBM::UseDB = 'GDBM_File';
    }
    foreach my $type (@types) {
	my $code = '
	    use Fcntl;
	    use ' . $type . ';
	    tie %db, ' . $type . ', $db' . ($type ne 'CDB_File' ? ', O_RDONLY, 0644' : '') . ';
	    if (tied %db) {
                if (defined $showkey) {
                    $k = $showkey;
                    $v = $db{$k};
                    $out->();
                } else {
	            while (($k,$v) = each %db) {
                        $out->();
                    }
    	        }
	    }
	    untie %db;
        ';
	#warn $code;
	eval $code;
	if ($@) {
	    warn "Can't open as $type: $@";
	} else {
	    last;
	}
    }
}