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

#
# $Id: show_db,v 2.8 2002/10/15 05:52:20 eserte Exp $
# 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> shows the content 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 README

show_db shows the content of a dbm database file (like DB_File,
GDBM_File, or CDB_File). There is also some support for MLDBM
databases.

=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;

use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 2.8 $ =~ /(\d+)\.(\d+)/);

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
    $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;
#XXX does not work with .dir/.pag files:
#      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;
	my @types = ($dbtype ne ""
		     ? ($dbtype)
		     : (qw(DB_File GDBM_File NDBM_File ODBM_File CDB_File))
		    );
	$MLDBM::Serializer = $serializer || "Data::Dumper";
	require MLDBM;
	my %db;
	for $MLDBM::UseDB (@types) {
	    warn "Try $MLDBM::UseDB for MLDBM ... " if $v;
	    local $^W = 0; # XXX if !$v;
	    eval {
		if ($MLDBM::UseDB eq 'CDB_File') {
		    tie %db, 'MLDBM', $file or
			die "Can't tie $file with $type: $!";
		} else {
		    tie %db, 'MLDBM', $file, O_RDONLY, 0644 or
			die "Can't tie $file with $type: $!";
		}
	    };
	    last if tied(%db);
	}
	if (!tied(%db)) {
	    warn $@;
	}
	\%db;
    } elsif ($type =~ /^(BerkeleyDB),(.*)$/) {
	($type, my $subtype) = ($1, $2);
	eval "use $type"; die $@ if $@;
	my %db;
	tie %db, $type."::".$subtype, -Filename => $file or
	    die "Can't tie $file with ${type}::$subtype: $BerkeleyDB::Error";
	\%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([$_[0]],[])->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;
#XXX?	$cant_each = 1;
	return sub { $dd->(Storable::thaw($_[0])) };
    } elsif ($spec =~ /^freezethaw$/i) {
	require FreezeThaw;
#XXX?	$cant_each = 1;
	return sub { $dd->(FreezeThaw::thaw($_[0])) }; # XXX check
    } elsif ($spec =~ /^perldata$/i) {
#XXX?	$cant_each = 1;
	return sub { ref $_[0] ? $dd->($_[0]) : $_[0] };
    } else {
	die "Can't parse specification <$spec>";
    }
}