#! /usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' if 0; # not running under some shell
BEGIN { $main::DEFA = "/usr/share/dbman"; }

use strict;
use vars qw($LANG $VERSION $VERNAME $quiet $ORIG_0 $DEFAULT_DIR $mylib $dbi
		$dbsys %Message %Config @driver_names %Statements $stid $DEFA
		@CHILDS $interface $port $DEBUG $main);
use POSIX "sys_wait_h";
require Storable;

BEGIN {
	sub help_cl {
                print <<EOF;
Usage: dbman-proxy [OPTIONS...]
	-d	Debug information (show transfer)
        -h      This little help
	-i	interface (host), e.g. chlapec.popelnik.cz
	-p	port, e.g. 2401
	-q      Quite output
        -v      Print version
EOF
	}       

	$DEBUG = 0;
	$LANG = 'en'; 
	$LANG = $ENV{LANG} if defined $ENV{LANG};   
	$LANG = $ENV{DBMAN_LANG} if defined $ENV{DBMAN_LANG};
	$VERSION = '0.0.9';
        $VERNAME = "dbMan-proxy $VERSION";  
	use FindBin;
	$ORIG_0 = $FindBin::RealScript;
	$0 = "dbman-proxy";
        $quiet = 0;  $interface = '';  $port = ''; 
        while (@ARGV and $ARGV[0] =~ /^-(.*)/) {
                if (uc $1 eq 'Q' || uc $1 eq 'QUIET' || uc $1 eq '-QUIET') {
                        ++$quiet;  shift @ARGV;
                } elsif (uc $1 eq 'V' || uc $1 eq 'VERSION'
	                        || uc $1 eq '-VERSION') {
			print "$VERNAME\n\n";  exit;
	        } elsif (uc $1 eq 'H' || uc $1 eq 'HELP' || uc $1 eq '-HELP') {
                        print "$VERNAME\n\n";  help_cl();  exit;
	        } elsif (uc $1 eq 'I' || uc $1 eq 'INTERFACE' 
				|| uc $1 eq '-INTERFACE') {
                       	shift @ARGV;  $interface = shift @ARGV; 
	        } elsif (uc $1 eq 'P' || uc $1 eq 'PORT' 
				|| uc $1 eq '-PORT') {
                       	shift @ARGV;  $port = shift @ARGV; 
	        } elsif (uc $1 eq 'D' || uc $1 eq 'DEBUG' 
				|| uc $1 eq '-DEBUG') {
                       	shift @ARGV;  ++$DEBUG;
		} else { last; }
	}
        if ($LANG eq 'cz' or $LANG eq 'cs') {
		print "$VERNAME\n\nStartuji Perl...\n" unless $quiet;
	} else {
	        print "$VERNAME\n\nStarting Perl...\n" unless $quiet;
	}
	$DEFAULT_DIR = $DEFA;
        if ($ORIG_0 !~ /\//) { $ORIG_0 = './' . $ORIG_0; }
        $mylib = $ORIG_0;  $mylib =~ s/\/[^\/]*$//;
        unshift @INC,".";
        unshift @INC,$DEFAULT_DIR;
        unshift @INC,$mylib;
        unshift @INC,$ENV{DBMAN_LIB} if $ENV{DBMAN_LIB};
}

$main = 1;

use nDBI;
use Compact;
require dbManLang;  dbManLang->import($LANG);

use Socket;
use IO::Socket;

print $Message{test} . "\n" unless $quiet;

sub sexit { exit; }

$SIG{QUIT} = \&sexit;  $SIG{ABRT} = \&sexit;  $SIG{KILL} = \&sexit;
$SIG{INT} = \&sexit;   $SIG{TERM} = \&sexit;  $SIG{HUP} = \&sexit;
$SIG{CHLD} = \&dispatcher;

END { $dbi->disconnect if defined $dbi; }

############################## SUBS ######################################

sub read_config  {
        my $config = $ENV{HOME}."/.dbman-proxyrc";
        unless (-e $config) {
                $config = $ORIG_0;  $config =~ s/\/[^\/]*//;
                $config .= 'dbman-proxyrc';  return unless -e $config;
        }
        if (open CONFIG,$config) {
                while (<CONFIG>) {
                        chomp;  s/#.*//;  s/^\s+//;  s/\s+$//;  next unless $_;
                        my ($tag,$value) = ('','');
                        if (/^(.*?)\s+(.*)/) {
                                ($tag,$value) = ($1,$2);
                        }
                        $Config{lc $tag} .= "\n" if exists $Config{lc $tag};
                        $Config{lc $tag} .= $value;
                }
                close CONFIG;
	}
}

sub drivers {
        my $proxy = shift;
        my @drivers = $proxy ? nDBI->all_drivers : sort nDBI->available_drivers;
        @driver_names = ();
        my @temporary = ();  my $preff = '';  my $cfg = $Config{driver};
        for (@drivers) {
                if (/^$cfg$/i) { $preff = $_;
                } elsif (/^(Pg|Oracle|mysql)$/i) { 
			push @driver_names,$_; $dbsys = $_;
                } else { push @temporary,$_; }
        }
        if ($preff) {
                @driver_names = ($preff,@driver_names,@temporary);
                $dbsys = $preff;
        } else { @driver_names = (@driver_names,@temporary); }
        $dbsys = $driver_names[0] unless $dbsys;
}

sub do_log {
	print STDERR scalar localtime;	
	print STDERR " ", join ',',@_;
	print STDERR "\n";
}

sub query {
	my ($func,$wantarray,@params) = @_;
	do_log "RCV $func " . compact [ @params ] if $DEBUG;
	my $res = $Message{dbpnoanswer};
	if ($func) {
		if ($func eq 'connect') {
			$dbi = nDBI->connect(@params);	
			if (defined $dbi) { $res = undef; } 
				else { $res = nDBI::errstr; }
		} elsif ($func =~ s/^proxycall//) {
			if (@params and shift @params eq 'debug') {
				$DEBUG = $DEBUG?0:1;	
				$res = $Message{$DEBUG?'debugseton':
					'debugsetoff'}.".\n";
			} else {
				$res = $VERNAME."\n";
			}
		} elsif ($func =~ s/^nDBI::st:://) {
			my ($id,$func) = split /::/,$func;
			my $q = $Statements{$id};
			if ($func =~ /^hash_get_(.*)/) {
				$res = $q->{$1};	
			} elsif ($wantarray) {
				$res = [ $q->$func(@params) ];
			} else {
				$res = $q->$func(@params);
			}
			delete $Statements{$id} if $func eq 'finish';
		} elsif ($func =~ s/^nDBI:://) {
			if ($wantarray) {
				$res = nDBI->$func(@params);	
			} else {
				$res = nDBI->$func(@params);
			}
		} else {
			if (defined $dbi) {
				if ($wantarray) {
					$res = [ $dbi->$func(@params) ];
				} else {
					$res = $dbi->$func(@params);
					if (ref $res eq 'DBI::st') {
						$Statements{$stid} = $res;
						$res = 'DBI::st::'.$stid++;
					}
				}
			} else {
				$res = $Message{dbpundef};
			}
		}
	} else { $res = $Message{dbpnull}; }

	do_log "SEND " . compact $res if $DEBUG;
	return \$res;	
}

sub dispatcher {
	my @CH = ();
	for (@CHILDS) {
		waitpid($_,WNOHANG);
		unless (kill 0 => $_) {
			waitpid $_,0;
		} else {
			push @CH,$_;
		}
	}	
	@CHILDS = @CH;
	alarm(10);	
}

############################## MAIN ######################################

print $Message{readconf}."\n" unless $quiet;  read_config;

print $Message{startdbi}."\n" unless $quiet;  $dbsys = '';  drivers;

my $sock = new IO::Socket::INET(LocalHost => $interface || $Config{host} 
		|| 'localhost',
		LocalPort => $port || $Config{port} || 2401, Proto => 'tcp',
		Listen => 5, Reuse => 1) or die $Message{socknot}.": $!";

print sprintf($Message{proxyaccept}."...\n",$interface || $Config{host} 
		|| 'localhost', $port || $Config{port} || 2401) unless $quiet;

%Statements = ();  $stid = 1;

$SIG{ALRM} = \&dispatcher;

@CHILDS = ();

alarm(10);

while (my $new_sock = $sock->accept()) {
	my $host = $new_sock->peerhost();
	$host = gethostbyaddr(inet_aton($host),AF_INET);
	if (defined $Config{maxchilds} and 
			scalar @CHILDS >= $Config{maxchilds}) {
		print STDERR sprintf($Message{toomany},$host) . "\n";
		close $new_sock;
		next;
	}
	my $pid = fork();
	if (not defined $pid) {
		print STDERR $Message{proxyerror}."\n";	
	} else {
		unless ($pid) {	# child
			$main = 0;
			print sprintf($Message{proxyconnect}."\n",$host) 
				unless $quiet;
			close $sock;  $| = 1;  undef $/;  
			$0 = "dbman-proxy-session $host";
			while (defined (my $ref = nDBI::_rcv $new_sock)) {
				next unless $ref;
				$0 = "dbman-proxy-session $host (work)";
				my ($func,$wantarray,@params) = @$ref;
				my $response = query($func,$wantarray,@params);
				nDBI::_send $new_sock,$response;
				last if $func eq 'disconnect';
				$0 = "dbman-proxy-session $host (wait)";
			}
			close $new_sock;
		       	print sprintf($Message{proxycancel}."\n",$host) 
				unless $quiet;
			exit(0);
		} 
		push @CHILDS,$pid;
	}
	dispatcher();
	close $new_sock;
}

END {
	if ($main) {
		close $sock if defined $sock;
		print $Message{dbpexit}."\n\n" unless $quiet;
	}
}
