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

#
# $Id: show_db,v 3.0 2006/03/06 22:26:14 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (c) 1997-2004 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: srezic@cpan.org
# WWW:  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 -d delim

The output delimiter between key and value, by default " : ".

=item -dbtype type

The type of the database. This is usually a class name like
C<DB_File>. In most cases C<show_db> may determine the database
type itself, so you do not have to always 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 DB_File,BTREE

The BTREE variant of a DB_File.

=item DB_File,HASH

The HASH variant of a DB_File (default for DB_File).

=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<sel> option may be given multiple times.

=back

=head1 HINTS

For a Apache::Session file with DB_File as database backend and
Storable as serializer use C<-val storable> to display the session
file contents.

=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.de>

=head1 AVAILABILITY

C<show_db> is available from the scripts section on L<http://www.cpan.org/>.

=head1 SEE ALSO

AnyDBM_File(3).

=cut

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

BEGIN {
    if ($] < 5.006) {
	$INC{"warnings.pm"} = "dummy";
	package warnings;
	*import = sub { };
	*unimport = sub { };
    }
}

no warnings 'once';

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

my $delim = " : ";
my $v;
my $dbtype; # auto
my $do_showtable;
my $keyspec;
my $valspec;
my $cant_each;
my $do_color;
my @select;
my $dd_indent = 1; # XXX make an option

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 $!;
    }
    close RDR;
    open(STDOUT, ">&WTR") or die $!;
}

my $selsub;
if (@select) {
    foreach my $sel (@select) {
	if ($keyspec) {
	    if ($keyspec =~ /^pack:(.*)/) {
		$sel = pack($1, $sel);
	    } # XXX other keyspec formats not supported
	}
	output_record($ref, $keysub, $valsub, $sel);
    }
} 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;
    {
	no warnings 'qw';
	@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;
	    my %db;
	    if ($type eq 'DB_File,RECNO' && eval "use DB_File; 1" &&
		tie my @db, "DB_File", $file, O_RDONLY, 0644, $DB_File::DB_RECNO) {
		last TRY;
	    } elsif ($type =~ /^DB_File,(BTREE|HASH)$/ && eval q{use DB_File; tie my @db, "DB_File", $file, O_RDONLY, 0644, ($1 eq 'BTREE' ? $DB_File::DB_BTREE : $DB_File::DB_HASH) }) {
		last TRY;
	    } elsif ($type eq 'CDB_File' && eval "use $type; 1" &&
		     tie %db, $type, $file) {
		last TRY;
	    } elsif (eval "use $type; 1" &&
		     tie %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 {
	my $subtype;
	if ($type =~ s/^([^,]+),(.*)$/$1/) {
	    $subtype = $2;
	}
	eval "use $type"; die $@ if $@;
	my @tie_args = ($file);
	if ($type ne 'CDB_File') {
	    push @tie_args, O_RDONLY, 0644;
	    if ($type eq 'DB_File' ||
		$type eq 'DB_File::Lock') {
		if ($subtype eq 'BTREE') {
		    push @tie_args, $DB_File::DB_BTREE;
		} elsif ($subtype eq 'HASH') {
		    push @tie_args, $DB_File::DB_HASH;
		} else {
		    if ($type eq 'DB_File::Lock') {
			die "Specification of subtype is mandatory, e.g. -dbtype DB_File::Lock,BTREE";
		    }
		}
		if ($type eq 'DB_File::Lock') {
		    push @tie_args, 'read'; # read lock
		}
	    }
	}
	my %db;
	tie %db, $type, @tie_args or
	    die sprintf("Can't tie $file as $type with flags=0x%x, mode=0%o%s: $!", $tie_args[1], $tie_args[2], ($#tie_args > 2 ? "(".join(",",@tie_args[3..$#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($dd_indent)->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>";
    }
}