db-hash

   1 #! /usr/bin/perl
   2 # db-hash creates databases and queries it, and is released
   3 # under the terms of the GPL version 2, or any later version, at your
   4 # option. See the file README and COPYING for more information.
   5 # Copyright 2009-11 by Don Armstrong <don@donarmstrong.com>.
   6
   7
   8 use warnings;
   9 use strict;
  10
  11 use Getopt::Long;
  12 use Pod::Usage;
  13
  14 =head1 NAME
  15
  16 db-hash - create a database and query using it
  17
  18 =head1 SYNOPSIS
  19
  20  db-hash [options] dbname key
  21  db-hash --create [options] dbname < key_value.txt
  22
  23  Options:
  24   --create, -c create dbname
  25   --update, -u update dbname, create if it doesn't exist
  26   --dump, -D dump dbname
  27   --missing-newline, -n output a newline for unhashed keys
  28   --include-key, -k output the key as well as the value
  29   --reverse, -r reverse (values to key)
  30   --key-to-itself map key to itself
  31   --debug, -d debugging level (Default 0)
  32   --help, -h display this help
  33   --man, -m display manual
  34
  35 =head1 OPTIONS
  36
  37 =over
  38
  39 =item B<--create,-c>
  40
  41 Create a database
  42
  43 =item B<--update,-u>
  44
  45 Update a database; replaces all keys with the values loaded from the
  46 file, but keeps existing keys which were not replaced
  47
  48 =item B<--dump,-D>
  49
  50 Dump database to stdout
  51
  52 =item B<--include-key,-k>
  53
  54 Output the key as well as the value. (Off by default)
  55
  56 =item B<--reverse>
  57
  58 Map values to a key
  59
  60 =item B<--key-to-itself>
  61
  62 Map the key to itself (On by default in reverse hashes)
  63
  64 =item B<--missing-newline,-n>
  65
  66 If a key doesn't exist in the database, output a newline. (Forced on
  67 when --include-key set)
  68
  69 =item B<--reverse,-r>
  70
  71 Reverse the database (value looks up keys instead); only useful during
  72 creation/update
  73
  74 =item B<--debug, -d>
  75
  76 Debug verbosity. (Default 0)
  77
  78 =item B<--help, -h>
  79
  80 Display brief usage information.
  81
  82 =item B<--man, -m>
  83
  84 Display this manual.
  85
  86 =back
  87
  88 =head1 EXAMPLES
  89
  90
  91 =cut
  92
  93 use Fcntl qw/O_RDWR O_RDONLY O_CREAT O_TRUNC/;
  94 use MLDBM qw(DB_File Storable);
  95
  96 use vars qw($DEBUG);
  97
  98 my %options = (debug           => 0,
  99                help            => 0,
 100                man             => 0,
 101                create          => 0,
 102                update          => 0,
 103                dump            => 0,
 104 #              include_key     => 0,
 105                missing_newline => 1,
 106                reverse         => 0,
 107                );
 108
 109 GetOptions(\%options,
 110            'create|c','update|u',
 111            'dump|D',
 112            'include_key|include-key|k!',
 113            'reverse|r!',
 114            'key_to_itself|key-to-itself|K',
 115            'missing_newline|missing-newline|n!',
 116            'debug|d+','help|h|?','man|m');
 117
 118 pod2usage() if $options{help};
 119 pod2usage({verbose=>2}) if $options{man};
 120
 121 $DEBUG = $options{debug};
 122
 123 my @USAGE_ERRORS;
 124 # if (1) {
 125 #      push @USAGE_ERRORS,"You must pass something";
 126 # }
 127
 128 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
 129
 130
 131
 132 my ($db,@keys) = @ARGV;
 133
 134 my %t_db;
 135
 136 if (not ($options{create} or $options{update})) {
 137     tie %t_db, MLDBM => $db, O_RDONLY or
 138         die "Unable to open $db for reading: $!";
 139 }
 140 else {
 141     tie %t_db, MLDBM => $db, O_RDWR|O_CREAT|($options{update}?0:O_TRUNC), 0666 or
 142         die "Unable to open $db for writing: $!";
 143 }
 144
 145 if ($options{reverse}) {
 146     if (not exists $options{key_to_itself}) {
 147         $options{key_to_itself} = 1;
 148     }
 149 }
 150
 151 if (not defined $options{include_key}) {
 152     $options{include_key} = $options{dump} ? 0 : 1;
 153 }
 154
 155
 156 if ($options{update} or $options{create}) {
 157     my %fast_db;
 158     while (<STDIN>) {
 159         chomp;
 160         my ($key,@val) = split /\t/;
 161         if ($options{reverse}) {
 162             for my $val_key (@val,$options{key_to_itself}?$key:()) {
 163                 $fast_db{$val_key} = [make_list($fast_db{$val_key} // []),$key];
 164             }
 165         }
 166         else {
 167             $fast_db{$key} = [make_list($fast_db{$key} // [],@val)];
 168         }
 169     }
 170     for my $key (keys %fast_db) {
 171         $t_db{$key} = $fast_db{$key};
 172     }
 173 }
 174 elsif ($options{dump}) {
 175     for my $key (keys %t_db) {
 176         print "$key\t".join("\t",make_list($t_db{$key}))."\n";
 177     }
 178 }
 179 else {
 180     if (!@keys) {
 181         output_keys(<STDIN>);
 182     }
 183     else {
 184         output_keys(@keys);
 185     }
 186 }
 187
 188 sub output_keys {
 189     my @temp = @_;
 190     for my $key (@temp) {
 191         if (not exists $t_db{$key}) {
 192             chomp $key;
 193         }
 194         if ($options{include_key}) {
 195             print $key."\t";
 196         }
 197         if (exists $t_db{$key}) {
 198             print join("\t",make_list($t_db{$key}));
 199             print "\n";
 200         }
 201         elsif ($options{missing_newline}) {
 202             print "\n";
 203         }
 204     }
 205 }
 206
 207 sub make_list {
 208      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 209 }
 210
 211
 212
 213
 214 __END__