use strict;

package DBP;

use IO::File; # any more libs forgotten?

BEGIN {
        $^W = 0;
}

use lib '/usr/lib/dbischema';
use XMLParser;
use Schema;
use Message;
use DBI;

BEGIN {
        $^W = 1;
}

use vars qw(@ISA @EXPORT);
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(build_dsn write_sql sql_insert sql_insert_commit_every read_sql sql_query escape_dump unescape_dump parse_row_dump format_row_dump write_file read_file write_string read_string write_dump read_dump write_dump_file read_dump_file append_dump_file all_db_tables all_dumped_tables write_html write_html_file append_html_file write_neatly write_file_neatly append_file_neatly write_tsv write_tsv_file append_tsv_file sort_dumpfile strip_trailing_spaces build_dsn);
# FIXME this module is not encapsulated

=head2 build_dsn

The idea is to build a DBI datasource specifier based on information that the
user has specified on the command line: the DBMS, user-name, password,
hostname, port.  In order for this to work properly, it needs to have built-in
support for the particular DBMS.  If it doesn't, you can still use the function,
by supplying a DBI DSN in place of the DBMS, but with a `_' instead of the
database name.  In that case, the function will substitute the database name
into the DSN.

=cut

my %dbi_drivers = map {lc $_, $_} DBI->available_drivers;

my %dbms_build_dsn = (
	Pg => sub {
		my ($database, $host, $port, $rest) = @_;
		my $ret = "dbname=$database";
		$ret .= ";host=$host" if defined $host;
		$ret .= ";port=$port" if defined $port;
		$ret .= ";$rest" if defined $rest;
		return $ret;
	},
	mSQL => sub {
		my ($database, $host, $port, $rest) = @_;
		$host = "localhost" if !defined $host; # I think this is not needed in general, just on my dodgy setup!
		my $ret = "database=$database";
		$ret .= ";host=$host" if defined $host;
		$ret .= ";port=$port" if defined $port;
		$ret .= ";$rest" if defined $rest;
		return $ret;
	},
	mysql => sub {
		my ($database, $host, $port, $rest) = @_;
		my $ret = "database=$database";
		$ret .= ";host=$host" if defined $host;
		$ret .= ";port=$port" if defined $port;
		$ret .= ";$rest" if defined $rest;
		return $ret;
	}
);
sub build_dsn {
        my ($dbms, $database, $host, $port) = @_;

        $host = "localhost" if defined $port && !defined $host;
        fatal "build_dsn: \$dbms and \$database are required parameters"
                if !defined $dbms || !defined $database;

        $dbms =~ s/^dbi://;
	my $rest;
        $rest = $1 if $dbms =~ s/:(.*)//;

	# be case-insensitive
	if (my $tmp = $dbi_drivers{lc $dbms}) {
		$dbms = $tmp;
	} else {
		fatal "There is no DBI driver for DBMS `$dbms'";
	}

	if (my $sub = $dbms_build_dsn{$dbms}) {
		$rest = $sub->($database, $host, $port, $rest);
	} else {
                if (defined $rest && !defined $host && !defined $port) {
                        if (defined $database && !($rest =~ s/(\_|\*|DB)/$database/)) {
                                fatal q{cannot substitute database into DSN - missing `_'.
You need to put an `_' in the DSN where the database name should be
substituted.};
                        }
		} else {
			fatal qq{The DBMS `$dbms' is not known to dbidump - you need to specify a
full DBI DSN in place of the DBMS, and put an `_' in this DSN
where the database name should be substituted.  If you need to
specify a host or port, put them directly into the DSN.};
		}
	}

	my $dsn = "dbi:$dbms:$rest";

	return ($dbms, $dsn);
}

sub write_sql {
	my ($dbh, $table, $fields, $numeric, $commit_every) = @_;
	my $sql = "INSERT INTO $table (".(join ',', @$fields).") VALUES (".'?,'x$#$fields.'?)';
	return $commit_every ?
		sql_insert_commit_every($dbh, $sql, $numeric, $commit_every) :
		sql_insert($dbh, $sql, $numeric);
}

sub sql_insert {
	my ($dbh, $sql, $numeric) = @_;
	my ($sth);

	my $n = @$numeric;
	
	$sth = $dbh->prepare($sql)
		or die "cannot prepare sql insert: ". $dbh->errstr.
		       "  $sql\n";
	return sub {
		my $row = shift;
		if (defined $row) {
			# make certain fields numeric if necessary - this is inefficient, I know
			for (my $i=0; $i<@$numeric; ++$i) {
				if ($numeric->[$i] && defined $row->[$i]) {
					$row->[$i] = 0 + $row->[$i];
				}
			}
			if ((my $N = @$row) != $n) {
				my $S = $N != 1;
				print STDERR "\nrow has $N field$S : should have $n\n";
				return 0;
			}
			$sth->execute(@$row)
				or return 0;
		} else {
			$sth->finish;
		}
		return 1;
	}
}

sub sql_insert_commit_every {
	my ($dbh, $sql, $numeric, $commit_every) = @_;
	my $inserter = sql_insert($dbh, $sql, $numeric);
	my $count = 0;
	return sub {
		my $row = shift;
		my $success = &$inserter($row);
		$dbh->commit if (not defined $row or $success and ++$count % $commit_every == 0);
		return $success;
	}
}

sub read_sql {
	my ($dbh, $table) = @_;
	return sql_query($dbh, "SELECT * FROM $table");
}

sub sql_query {
	my ($dbh, $sql) = @_;
	my $sth;
	
	$sth = $dbh->prepare($sql)
		or die "cannot prepare sql query: ", $dbh->errstr,
		"  $sql\n";
	
	$sth->execute
		or die "cannot execute query: ", $dbh->errstr,
		"  $sql\n";
	
	return
		sub {
			my $row = $sth->fetchrow_arrayref;
			if (defined $row) {
				return [@{$row}];
			} else {
				undef $sth; #->finish;
				return undef;
			}
		},
        [@{$sth->{NAME}}];
}

# this function escapes tabs to \t, newlines to \n, null to \0, \ to \\, and undef to null
sub escape_dump {
	my $v = shift;
	return "\0" unless defined $v;
	for ($v) {
		s/\\/\\\\/g;
		s/\t/\\t/g;
		s/\n/\\n/g;
		s/\0/\\0/g;
	}
	return $v;
}

sub unescape_dump {
	my $v = shift;
	return undef if $v eq "\0";
	for ($v) {
		s/(?:(?<=[^\\])|^)((?:\\\\)*)\\0/$1\0/g;
		s/(?:(?<=[^\\])|^)((?:\\\\)*)\\n/$1\n/g;
		s/(?:(?<=[^\\])|^)((?:\\\\)*)\\t/$1\t/g;
		s/\\\\/\\/g;
	}
	return $v;
}

sub parse_row_dump {
	my $row = shift;
	return undef unless $row =~ s/^\t//;
	chomp $row;
	my @row = split /\t/, $row, -1;
	for (@row) { $_ = unescape_dump($_); }
	return \@row;
}

sub format_row_dump {
	my $ra_row = shift;
	return defined $ra_row
		? (join '', (map {"\t".escape_dump($_)} @$ra_row)) . "\n"
		: undef;
}

# returns a function which can be used to output text to a file
# parameter may be a filehandle ref, or nothing (for STDOUT), '>filename' or '>>filename'
sub write_file {
	my $filespec = shift;
	my $fh;
	
	$filespec = \*STDOUT unless defined $filespec;
	
	if (ref $filespec) {
		$fh = $filespec;
	} else {
		$fh = new IO::File($filespec)
			or die "cannot open $filespec: $!";
	}
	
	return sub {
		my $line = shift;
		defined $line
			? print $fh $line
			: undef $fh; # or close $fh
	}
}

sub read_file {
	my $filespec = shift || \*STDIN;
	
	my $fh;
	if (ref $filespec) {
		$fh = $filespec;
	} else {
		$fh = new IO::File($filespec)
		or die "cannot open $filespec: $!";
	}
	
	return sub { scalar(<$fh>) }
}

sub write_string {
	my $text = '';
	return (
		sub {
			my $line = shift;
			defined $line and $text .= $line;
		},
		\$text
        );
}

sub read_string {
	my $text = shift; # local copy
	return (
		sub {
			return undef unless defined $text;
			my $line;
			($line, $text) = split /\n/, $text, 2;
			return $line;
		},
		\$text
        );
}

sub write_dump {
	my $text_writer = shift;
	
	return sub {
		my $row = shift;
		&$text_writer(format_row_dump($row));
	}
}

# read_dump ignores comments (lines that don't start with a tab)
sub read_dump {
	my $text_reader = shift;
	
	return sub {
		my ($line, $row);
		do {
			$line = &$text_reader;
			return undef unless defined $line;
			$row = parse_row_dump($line);
		} until (defined $row);
		
		return $row;
	}
}

sub write_dump_file {
	my ($table, $fields) = @_;
	my $dump_writer = write_dump(write_file(">$table"));
	&$dump_writer($fields);
	return $dump_writer;
}

sub read_dump_file {
	my ($table) = @_;
	my $text_reader = read_file("<$table");
	my $dump_reader = read_dump($text_reader);
	return $dump_reader, &$dump_reader;
}

# append to a DUMP file

sub append_dump_file {
	my ($table, $fields) = @_;
	# verify that the fields provided match those at the head of this file
	my ($dummy, $file_fields) = read_dump_file($table, $fields);
	unless (format_row_dump($file_fields) eq format_row_dump($fields)) {
		fatal "\ncannot --append to $table - fields do not match";
	}
	my $dump_writer = write_dump(write_file(">>$table"));
	return $dump_writer;
}

sub all_db_tables {
	my $dbh = shift;
	return $dbh->tables;
}

sub all_dumped_tables {
	my @tables = <*.dump>;
	for (@tables) { s/\.dump$// }
	# TODO - should this ignore .C.dump and .X.dump files?
	return @tables;
}

sub write_html {
	my $text_writer = shift;
	
	&$text_writer("<html><body>\n<table>\n");
	
	return sub {
		my $row = shift;
		if (defined $row) {
			&$text_writer("<tr>".(join '', map {"<td>".(defined $_ ? encode_entities($_) : "<i>NULL</i>")."</td>"} @$row)."</tr>\n");
		} else {
			&$text_writer("</table>\n</body></html>\n");
			&$text_writer(undef);
		}
	}
}

sub write_html_file {
	my ($table, $fields) = @_;
	my $html_writer = write_html(write_file(">$table"));
	&$html_writer($fields);
	return $html_writer;
}

sub append_html_file {
	my ($table, $fields) = @_;
	my $html_writer = write_html(write_file(">>$table"));
	&$html_writer($fields);
	return $html_writer;
}

sub write_neatly {
	my ($text_writer) = @_;
	my @rows = ();
	
	my @maxlen = ();
	
	return sub {
		my $row = shift;
		
		if (defined $row) {
			push @rows, $row;
			for my $i (0..$#$row) {
				my $l = defined $row->[$i] ? length($row->[$i]) : 4;
				$maxlen[$i] = $l if $l > ($maxlen[$i] || 0);
			}
		} else {
			for my $row (@rows) {
				my @line = ();
				for (0..$#$row) {
					my $t = $row->[$_]; $t = 'NULL' unless defined $t;
					push @line, $t . ' ' x ($maxlen[$_] - length($t));
				}
				&$text_writer((join ' ', @line) . "\n");
			}
			&$text_writer(undef);
		}
	}
		
}

sub write_file_neatly {
	my ($table, $fields) = @_;
	my $neat_writer = write_neatly(write_file(">$table"));
	&$neat_writer($fields);
	return $neat_writer;
}

sub append_file_neatly {
	my ($table, $fields) = @_;
	my $neat_writer = write_neatly(write_file(">>$table"));
	&$neat_writer($fields);
	return $neat_writer;
}

sub write_tsv {
	my $text_writer = shift;
	
	return sub {
		my $row = shift;
		local $_ = format_row_dump($row);
		if (defined $_) {
			s/\r/\\r/;
			tr/\x01-\x08\x0a\x0b-\x1f\x7f//d;
			s/^\t//;
			chomp;
			$_ = "$_\r\n";
		}
		&$text_writer($_);
	}
}

sub write_tsv_file {
	my ($table, $fields) = @_;
	my $tsv_writer = write_tsv(write_file(">$table"));
	&$tsv_writer($fields);
	return $tsv_writer;
}

sub append_tsv_file {
	my ($table, $fields) = @_;
	my $tsv_writer = write_tsv(write_file(">>$table"));
	&$tsv_writer($fields);
	return $tsv_writer;
}

sub sort_dumpfile {
	my ($file_in, $file_out) = @_;
	$file_out = $file_in unless defined $file_out;
	
	my $in = IO::File->new($file_in);
	
	unlink $file_out; # so can write to same filename if necessary
	
	my $out = IO::File->new(">$file_out");
	print $out scalar(<$in>);
	close $out;

	open $out, "| sort >> $file_out";
	while (<$in>) { print $out $_ }
	close $out;
	close $in;
}

sub strip_trailing_spaces {
	my ($file_in, $file_out) = @_;
	$file_out = $file_in unless defined $file_out;
	
	my $in = IO::File->new($file_in);
	
	unlink $file_out; # so can write to same filename if necessary
	
	my $out = IO::File->new(">$file_out");
	
	while (<$in>) { s/ +(\t|$)/$1/g; print $out $_ }

	close $out;
	close $in;
}

1
