#! /usr/bin/perl # , and is released # under the terms of the GPL version 2, or any later version, at your # option. See the file README and COPYING for more information. # Copyright 2009 by Don Armstrong . # $Id: perl_script 1432 2009-04-21 02:42:41Z don $ use warnings; use strict; use Getopt::Long; use Pod::Usage; =head1 NAME db-hash - create a database and query using it =head1 SYNOPSIS db-hash [options] dbname key db-hash --create [options] dbname < key_value.txt Options: --create, -c create dbname --update, -u update dbname, create if it doesn't exist --debug, -d debugging level (Default 0) --help, -h display this help --man, -m display manual =head1 OPTIONS =over =item B<--debug, -d> Debug verbosity. (Default 0) =item B<--help, -h> Display brief usage information. =item B<--man, -m> Display this manual. =back =head1 EXAMPLES =cut use Fcntl qw/O_RDWR O_RDONLY O_CREAT O_TRUNC/; use MLDBM qw(DB_File Storable); use vars qw($DEBUG); my %options = (debug => 0, help => 0, man => 0, create => 0, update => 0, ); GetOptions(\%options, 'create|c','update|u', 'debug|d+','help|h|?','man|m'); pod2usage() if $options{help}; pod2usage({verbose=>2}) if $options{man}; $DEBUG = $options{debug}; my @USAGE_ERRORS; # if (1) { # push @USAGE_ERRORS,"You must pass something"; # } pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS; my ($db,@keys) = @ARGV; my %t_db; if (not ($options{create} or $options{update})) { tie %t_db, MLDBM => $db, O_RDONLY or die "Unable to open $db for reading: $!"; } else { tie %t_db, MLDBM => $db, O_RDWR|O_CREAT|($options{update}?0:O_TRUNC), 0666 or die "Unable to open $db for writing: $!"; } if ($options{update}) { die "update currently not supported" } elsif ($options{create}) { my %fast_db; while () { chomp; my ($key,@val) = split /\t/; $fast_db{$key} = [make_list($fast_db{$key} // [],@val)]; } for my $key (keys %fast_db) { $t_db{$key} = $fast_db{$key}; } } else { if (@keys) { print map {"$_\n"} map {make_list($t_db{$_} // [])} @keys; } else { print map {"$_\n"} map {make_list($t_db{$_} // [])} ; } } sub make_list { return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_; } __END__