#!/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:[email protected]>
# 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 <[email protected]>

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

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.