#!/usr/bin/perl

#
# dbcolmerge
# Copyright (C) 1991-1998 by John Heidemann <johnh@isi.edu>
# $Id: dbcolmerge,v 1.17 2003/05/23 04:15:42 johnh Exp $
#
# This program is distributed under terms of the GNU general
# public license, version 2.  See the file COPYING
# in $dblibdir for details.
#
sub usage {
    print <<END;
usage: $0 [-C ElementSeperator] [columns...]
    	For each row, merge elements from each column into a new column,
	joining elements with ElementSeperator (defaults to a single underscore).

Sample input:
#h      first   last
John    Heidemann
Greg    Johnson
Root
# this is a simple database
#  | /home/johnh/BIN/DB/dbcol fullname
#  | dbcolrename fullname first_last
#  | /home/johnh/BIN/DB/dbcolsplit -C _ first_last
#  | /home/johnh/BIN/DB/dbcol first last

Sample command:
cat data.jdb | dbcolmerge -C _ first last

Sample output:
#h      first   last    first_last
John    Heidemann       John_Heidemann
Greg    Johnson Greg_Johnson
Root            Root_
# this is a simple database
#  | /home/johnh/BIN/DB/dbcol fullname
#  | dbcolrename fullname first_last
#  | /home/johnh/BIN/DB/dbcolsplit first_last
#  | /home/johnh/BIN/DB/dbcol first last
#  | /home/johnh/BIN/DB/dbcolmerge -C _ first last

END
    exit 1;
}

BEGIN {
    $dblibdir = "/home/johnh/BIN/DB";
    push(@INC, $dblibdir);
}
require "$dblibdir/dblib.pl";
use DbGetopt;

@orig_argv = @ARGV;
my($prog) = &progname;
$elem_seperator = "_";
my($dbopts) = new DbGetopt("C:?", \@ARGV);
my($ch);
while ($dbopts->getopt) {
    $ch = $dbopts->opt;
    if ($ch eq 'C') {
    	$elem_seperator = $dbopts->optarg;
    } else {
	&usage;
    };
};

&usage if ($#ARGV < 0);

&readprocess_header;

$joiner = '';
$code = '$f[$newcolnum] = ';
foreach (@ARGV) {
    die ("$prog: unknown column ``$_''.\n")
    	if (!defined($colnametonum{$_}));
    push (@oldcolnums, $colnametonum{$_});
    push (@oldcolnames, $colnames[$colnametonum{$_}]);
    $code .= $joiner . '$f[' . $colnametonum{$_} . ']';
    $joiner = " . '$elem_seperator' . ";
};
$code .= ';';

$newcolname = join($elem_seperator, @oldcolnames);
&col_create($newcolname);
$newcolnum = $colnametonum{$newcolname};

&write_header();

my($loop) = q[
    while (<STDIN>) {
        &pass_comments && next;
        &split_cols;
] . $code . q[
        &write_cols;
    };
];
eval $loop;
$@ && die "$prog: interal eval error: $@.\n";

print "#  | $prog ", join(" ", @orig_argv), "\n";
exit 0;