#! /usr/bin/perl
# db-hash creates databases and queries it, 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-11 by Don Armstrong <don@donarmstrong.com>.


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
  --dump, -D dump dbname
  --missing-newline, -n output a newline for unhashed keys
  --include-key, -k output the key as well as the value
  --reverse, -r reverse (values to key)
  --key-to-itself map key to itself
  --debug, -d debugging level (Default 0)
  --help, -h display this help
  --man, -m display manual

=head1 OPTIONS

=over

=item B<--create,-c>

Create a database

=item B<--update,-u>

Update a database; replaces all keys with the values loaded from the
file, but keeps existing keys which were not replaced

=item B<--dump,-D>

Dump database to stdout

=item B<--include-key,-k>

Output the key as well as the value. (Off by default)

=item B<--reverse>

Map values to a key

=item B<--key-to-itself>

Map the key to itself (On by default in reverse hashes)

=item B<--missing-newline,-n>

If a key doesn't exist in the database, output a newline. (Forced on
when --include-key set)

=item B<--reverse,-r>

Reverse the database (value looks up keys instead); only useful during
creation/update

=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,
	       dump            => 0,
#	       include_key     => 0,
	       missing_newline => 1,
	       reverse         => 0,
	       );

GetOptions(\%options,
	   'create|c','update|u',
	   'dump|D',
	   'include_key|include-key|k!',
	   'reverse|r!',
	   'key_to_itself|key-to-itself|K',
	   'missing_newline|missing-newline|n!',
	   '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{reverse}) {
    if (not exists $options{key_to_itself}) {
	$options{key_to_itself} = 1;
    }
}

if (not defined $options{include_key}) {
    $options{include_key} = $options{dump} ? 0 : 1;
}


if ($options{update} or $options{create}) {
    my %fast_db;
    while (<STDIN>) {
	chomp;
	my ($key,@val) = split /\t/;
	if ($options{reverse}) {
	    for my $val_key (@val,$options{key_to_itself}?$key:()) {
		$fast_db{$val_key} = [make_list($fast_db{$val_key} // []),$key];
	    }
	}
	else {
	    $fast_db{$key} = [make_list($fast_db{$key} // [],@val)];
	}
    }
    for my $key (keys %fast_db) {
	$t_db{$key} = $fast_db{$key};
    }
}
elsif ($options{dump}) {
    for my $key (keys %t_db) {
	print "$key\t".join("\t",make_list($t_db{$key}))."\n";
    }
}
else {
    if (!@keys) {
	output_keys(<STDIN>);
    }
    else {
	output_keys(@keys);
    }
}

sub output_keys {
    my @temp = @_;
    for my $key (@temp) {
	if (not exists $t_db{$key}) {
	    chomp $key;
	}
	if ($options{include_key}) {
	    print $key."\t";
	}
	if (exists $t_db{$key}) {
	    print join("\t",make_list($t_db{$key}));
	    print "\n";
	}
	elsif ($options{missing_newline}) {
	    print "\n";
	}
    }
}

sub make_list {
     return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
}




__END__