package Relation::Tools;
# by Sam Watkins - CC0 public domain

use strict;
use DBI;
use IO::File;
# use L qw(In Or And Sub);

use Exporter;
use vars qw/@ISA @EXPORT @EXPORT_OK/;
@ISA = qw{Exporter};
@EXPORT_OK = qw(dsn dsn_hash header write_file read_file write_string read_string write_tsv read_tsv encode_tab_nl_nul_null decode_tab_nl_nul_null read_nosql write_nosql In Or And Sub nmin mmax smin smax lncmp lscmp write_kvp read_kvp);

our $default_kvp_sep = ": "; #"\t";

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

sub dsn {
	my @args = @_;
	
	if (@args == 1) {
		if ($args[0] =~ / /) {
			@args = split / /, $args[0];
		} elsif ($_[0] =~ /:/) {
			return $_[0];
		}
	}
	
	@args >= 2 && @args <= 7
		or die "dsn syntax: driver database host user pass port attr\n";
	
	my %hash;
	@hash{qw(driver database host user pass port attr)} = @args;
	return dsn_hash(%hash);
}

# TODO could use `dsns' to get list, then grep through it for the right
# one, if we do not know anything about the driver in question...?
sub dsn_hash {
	my %args = @_;
	my ($driver_input, $database, $host, $user, $pass, $port, $attr) =
		@args{qw(driver database host user pass port attr)};
	
	my $driver = $dbi_drivers{$driver_input} || $driver_input;
	
	# use TCP with stupid mSQL - perhaps just a config problem on my machine?
	$driver eq 'mSQL' and $host ||= 'localhost';
	
	my $dsn = "dbi:$driver:";
	$dsn .= $driver eq "Pg" ?  "dbname" : "database";
	$dsn .= "=$database";
	$host and $dsn .= ";host=$host";
	$port and $dsn .= ";port=$port";

    # garbage hack:
    if ($driver eq "InterBase") {
        $dsn .= ";ib_dialect=3";
    }
	
	return $dsn, $user, $pass, $attr;
}

sub header {
	my @fields = @_;
	print join "\t", @fields;
	print "\n";
	print join "\t", map {my $a = $_; $a=~s/./-/g; $a} @fields;
	print "\n";
}

# 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;
	
	defined $filespec or $filespec = \*STDOUT;
	
	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; # not "close $fh": you might want to pass in a $fh and leave it open after write_file is done
	}
}

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 = \$_[0];
	return (
		sub {
			defined $$text or return undef;
			my $line;
			($line, $$text) = split /\n/, $$text, 2;
			return $line;
		}
	);
}

sub write_array {
	my @array;
	return (
		sub {
			my $line = shift;
			defined $line and push @array, $line;
		},
		\@array
	);
}

sub read_array {
	my $array = shift;
	return (
		sub {
			@$array or return undef;
			return shift @$array; # not efficient, stupid perl
		},
	);
}

sub write_tsv {
	my $text_writer = shift;

	return sub {
		my $row = shift;
		if (defined $row) {
			&$text_writer(join("\t", @$row)."\n");
		} else {
			&$text_writer(undef);
		}
	}
}

sub read_tsv {
	my $text_reader = shift;

	return sub {
		my $line = &$text_reader;
		defined $line or return undef;
		chomp $line;
		return [split /\t/, $line, -1];
	}
}

sub encode_tab_nl_nul_null {
	my $ary = shift;
	for (@$ary) {
		if (defined $_) {
			s/\\/\\\\/g;
			s/\t/\\t/g;
			s/\n/\\n/g;
			s/\0/\\0/g;
		} else {
			$_ = "\\";
		}
	}
}

sub decode_tab_nl_nul_null {
	my $ary = shift;
	for (@$ary) {
		if ($_ eq "\\") {
			undef $_;
		} else {
			s/([^\\]|^)((?:\\\\)*)\\0/$1$2\0/g;
			s/([^\\]|^)((?:\\\\)*)\\n/$1$2\n/g;
			s/([^\\]|^)((?:\\\\)*)\\t/$1$2\t/g;
			s/\\\\/\\/g;
		}
	}
}

sub read_nosql {
	my $tsv_reader = shift;
	my $fields = &$tsv_reader;
	my $valid = $fields;
	if ($valid) {
		my $row = &$tsv_reader;
		$valid = $row;
		if ($valid) {
			$valid = @$row == @$fields;
			for (@$row) {
				/-+/ or $valid = 0;
			}
		}
	}
	$valid or
		die "invalid nosql table format - --- line";

	return sub {
		my $row = &$tsv_reader;
		defined $row or return undef;
		@$row == @$fields or
			die "invalid nosql table format - varying width";
		my %row;
		my $i = 0;
		for (@$fields) {
			$row{$_} = $row->[$i];
			++$i;
		}
		return \%row;
	}, $fields;
}

sub write_nosql {
	my ($tsv_writer, $fields) = @_;
	if ($fields) {
		&$tsv_writer($fields);
		&$tsv_writer([map {my $a = $_; $a =~ s/./-/g; $a} @$fields]);
	}
	return sub {
		my $row = shift;
		unless ($fields) {
			$fields = [sort keys %$row];
			&$tsv_writer($fields);
			&$tsv_writer([map {my $a = $_; $a =~ s/./-/g; $a} @$fields]);
		}
		if (defined $row) {
			my @row;
			for (@$fields) {
				push @row, $row->{$_};
			}
			&$tsv_writer(\@row);
		} else {
			&$tsv_writer(undef);
		}
	}
}

sub nmin {
	return $_[0] < $_[1] ? $_[0] : $_[1];
}

sub nmax {
	return $_[0] > $_[1] ? $_[0] : $_[1];
}

sub smin {
	return $_[0] lt $_[1] ? $_[0] : $_[1];
}

sub smax {
	return $_[0] gt $_[1] ? $_[0] : $_[1];
}

sub lncmp {
	my ($a, $b) = @_;
	$a or return $b;
	$b or return $a;
	for my $i (0..nmin($#$a, $#$b)) {
		my $c = $$a[$i] <=> $$b[$i];
		$c and return $c;
	}
	return @$a <=> @$b;
}

sub lscmp {
	my ($a, $b) = @_;
	$a or return 1;
	$b or return -1;
	for my $i (0..nmin($#$a, $#$b)) {
		my $c = $$a[$i] cmp $$b[$i];
		$c and return $c;
	}
	return @$a <=> @$b;
}

sub write_kvp {
	my ($text_writer, $fields, $sep) = @_;

	$sep = $default_kvp_sep if !defined $sep;

	return sub {
		my $row = shift;
		if (defined $row) {
			my $rec = "";
			for my $field (@$fields) {
				$rec .= $field . $sep . $row->{$field} . "\n";
			}
			$rec .= "\n";
			&$text_writer($rec);
		} else {
			&$text_writer(undef);
		}
	}
}

sub read_kvp {
	my ($text_reader, $sep) = @_;

	$sep = $default_kvp_sep if !defined $sep;
	if (!ref $sep) { $sep = qr/$sep/; }

	my $read_record = sub {
		my $line = &$text_reader;
		defined $line or return undef;
		chomp $line;
		my (@fields, %values);
		while ($line ne "") {
			my ($k, $v) = split /$sep/, $line, 2;
			push @fields, $k;
			$values{$k} = $v;
			$line = &$text_reader;
			defined $line or die "invalid kvp format - EOF mid-record";
			chomp $line;
		}
		return (\@fields, \%values);
	};

	my ($fields, $values) = &$read_record;
	my $first = 1;
	return sub {
		if ($first) {
			$first = 0;
			return $values;
		} else {
			my ($_fields, $values) = &$read_record;
			if (!defined $values) {
				return undef;
			}
			for ($#$_fields) {
				if ($_fields->[$_] ne $fields->[$_]) {
					die "read_kvp: all records must have the same fields and order";
				}
			}
			return $values;
		}
	}, $fields;
}

sub In {
	my ($e, $l) = @_;
	$l eq "the universe!" and
		return 1;
	for (@$l) {
		$_ eq $e and
			return 1;
	}
	return 0;
}

sub Or {
	if (@_ == 2) {
		my ($l1, $l2) = @_;
		$l1 eq "the universe!" || $l2 eq "the universe!" and
			return "the universe!";
		my @ret = @$l1;
		for (@$l2) {
			In($_, $l1) or
				push @ret, $_;
		}
		return \@ret;
	}
	if (@_ > 2) { return Or(Or(shift, shift), @_); }
	if (@_ == 1) { return [@{$_[0]}] }
	if (@_ == 0) { return [] }
}

sub And {
	if (@_ == 2) {
		my ($l1, $l2) = @_;
		$l1 eq "the universe!" and
			return $l2;
		$l2 eq "the universe!" and
			return $l1;
		my @ret;
		for (@$l1) {
			In($_, $l2) and
				push @ret, $_;
		}
		return \@ret;
	}
	if (@_ > 2) { return And(And(shift, shift), @_); }
	if (@_ == 1) { return [@{$_[0]}] }
	if (@_ == 0) { return "the universe!" }
}

sub Sub {
	my ($l1, $l2) = @_;
	$l1 eq "the universe!" and
		die "sorry can't sub from the universe yet!";
	$l2 eq "the universe!" and
		return [];
	my @ret;
	for (@$l1) {
		In($_, $l2) or
			push @ret, $_;
	}
	return \@ret;
}

1