mlmdb_munge

   1 #! /usr/bin/perl
   2 # , 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 by Don Armstrong <don@donarmstrong.com>.
   6 # $Id: perl_script 1432 2009-04-21 02:42:41Z don $
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 mldbm_munge - create a database and query using it
  18
  19 =head1 SYNOPSIS
  20
  21  mldbm_munge [options] dbname key
  22  mldbm_munge --create [options] dbname < key_value.txt
  23
  24  Options:
  25   --create, -c create dbname
  26   --update, -u update dbname, create if it doesn't exist
  27   --debug, -d debugging level (Default 0)
  28   --help, -h display this help
  29   --man, -m display manual
  30
  31 =head1 OPTIONS
  32
  33 =over
  34
  35 =item B<--debug, -d>
  36
  37 Debug verbosity. (Default 0)
  38
  39 =item B<--help, -h>
  40
  41 Display brief usage information.
  42
  43 =item B<--man, -m>
  44
  45 Display this manual.
  46
  47 =back
  48
  49 =head1 EXAMPLES
  50
  51
  52 =cut
  53
  54 use Fcntl qw/O_RDWR O_RDONLY O_CREAT O_TRUNC/;
  55 use MLDBM qw(DB_File Storable);
  56
  57 use vars qw($DEBUG);
  58
  59 my %options = (debug           => 0,
  60                help            => 0,
  61                man             => 0,
  62                create          => 0,
  63                update          => 0,
  64                );
  65
  66 GetOptions(\%options,
  67            'create|c','update|u',
  68            'debug|d+','help|h|?','man|m');
  69
  70 pod2usage() if $options{help};
  71 pod2usage({verbose=>2}) if $options{man};
  72
  73 $DEBUG = $options{debug};
  74
  75 my @USAGE_ERRORS;
  76 # if (1) {
  77 #      push @USAGE_ERRORS,"You must pass something";
  78 # }
  79
  80 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  81
  82
  83
  84 my ($db,@keys) = @ARGV;
  85
  86 my %t_db;
  87
  88 if (not ($options{create} or $options{update})) {
  89     tie %t_db, MLDBM => $db, O_RDONLY or
  90         die "Unable to open $db for reading: $!";
  91 }
  92 else {
  93     tie %t_db, MLDBM => $db, O_RDWR|O_CREAT|($options{update}?0:O_TRUNC), 0666 or
  94         die "Unable to open $db for writing: $!";
  95 }
  96
  97 if ($options{update}) {
  98     die "update currently not supported"
  99 }
 100 elsif ($options{create}) {
 101     my %fast_db;
 102     while (<STDIN>) {
 103         chomp;
 104         my ($key,@val) = split /\t/;
 105         $fast_db{$key} = [make_list($fast_db{$key} // [],@val)];
 106     }
 107     for my $key (keys %fast_db) {
 108         $t_db{$key} = $fast_db{$key};
 109     }
 110 }
 111 else {
 112     if (@keys) {
 113         print map {"$_\n"} map {make_list($t_db{$_} // [])} @keys;
 114     }
 115     else {
 116         print map {"$_\n"} map {make_list($t_db{$_} // [])} <STDIN>;
 117     }
 118 }
 119
 120 sub make_list {
 121      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 122 }
 123
 124
 125
 126
 127 __END__