package SQL::Preproc::Runtime;
#
#	SQL::Preproc::Runtime - runtime module for SQL::Preproc
#
#	Currently only a placeholder for a future version which
#	will use a packaged runtime, rather than emitting all the
#	DBI code directly into the translated source.
#
use DBI;
use DBI qw(:sql_types);

use strict;

our $VERSION = '0.20';

sub new {
	my $class = shift;
	
	my $obj = { 
		current_dbh => undef,
		current_sth => undef,
		dbhs => { },
		sths => { },
		cursors => { }
	};
	
	bless $obj, $class;
	
	return $obj;
}
#
#	install a syntax handler
#
sub sqlpp_install_syntax {
	my ($obj, $syntax) = @_;

}
#
#	runtime subroutines for
#	processing statements
#
sub sqlpp_connect {
	my ($obj, $dsn, $user, $password, $name, $attributes, $syntax) = @_;

"	${sqlpp_ctxt}->{current_dbh} = ${sqlpp_ctxt}->{dbhs}->{$args[9]} = 
		$driver->connect(\"$args[0]\", $args[5], $args[7],
		{ PrintError => 0, RaiseError => 0, AutoCommit => 1, $args[11] });

	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, \$DBI::err, \$DBI::state, \$DBI::errstr) :
		die \$DBI::errstr
		unless defined(${sqlpp_ctxt}->{current_dbh});
";
}

sub sqlpp_disconnect {
	my ($obj, $name) = @_;

	$remnant = 'default'
		unless defined($remnant);

	return undef
		unless ($remnant=~/^(\$*\w+)$/);
#
#	we need to clean out any assoc. stmts/cursors
#
	return ($1 ne 'ALL') ?
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"Unknown connection $1\") :
		die \"Unknown connection $1\"
		unless defined(${sqlpp_ctxt}->{dbhs}->{$1});

	${sqlpp_ctxt}->{dbhs}->{$1}->disconnect;
	${sqlpp_ctxt}->{current_dbh} = undef
		if (${sqlpp_ctxt}->{current_dbh} eq ${sqlpp_ctxt}->{dbhs}->{$1});
	delete ${sqlpp_ctxt}->{dbhs}->{$1};
" :
"	foreach (keys \%{${sqlpp_ctxt}->{dbhs}}) {
		${sqlpp_ctxt}->{dbhs}->{\$_}->disconnect;
		${sqlpp_ctxt}->{current_dbh} = undef
			if (${sqlpp_ctxt}->{current_dbh} eq ${sqlpp_ctxt}->{dbhs}->{\$_});
		delete ${sqlpp_ctxt}->{dbhs}->{\$_};
	}
";}

sub sqlpp_select {
	my ($obj, $stmt) = @_;
#
#	fetch the results into specified variables, which may be any of
#	(hash, array, list of scalars)
#	OR default to @_
#	NOTE: may need better parsing of returned column list in future
#
	my @outphs = ($remnant=~/\bINTO\s+:([%@\$]\$*\w+)(\s*,\s*:[@\$]\$*\w+)*/i);
	pop @outphs
		while ((scalar @outphs) && (! defined($outphs[-1])));
	if (scalar @outphs) {
#
#	trim leading colon
#
		$outphs[$_]=~s/^(\s*,\s)?://
			foreach (1..$#outphs);
#
#	verify variable types
#
		my $first = substr($outphs[0], 0,1);
		warn "[SQL::Preproc] Invalid INTO list: only 1 hash variable permitted.",
		return undef
			if (($first eq '%') && (scalar @outphs > 1));

		foreach (1..$#outphs) {
			warn "[SQL::Preproc] Invalid INTO list: cannot mix scalars, arrays, and hashes.",
			return undef
				if (substr($outphs[$_], 0,1) ne $first);
		}
#
#	suss out the INTO clause
#
		$remnant=~s/\bINTO\s+:[%@\$]\$*\w+(\s*,\s*:[@\$]\$*\w+)*//i;
	}
#
#	locate all other PHs and remap to '?'
#		NOTE: we only support scalars for PH variables in SELECT
#	then prepare/execute statement
#		NOTE: in future we may need a way to bind type info
#
	my @inphs = ($remnant=~/:(\$+\w+)/g);
	$remnant=~s/:\$+\w+/\?/g;

	my $execsql = (scalar @inphs) ? 
		'execute(' . join(', ', @inphs) . ')' : 'execute()';

	my $replaced =
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"No current connection.\") :
		die \"No current connection.\"
		unless defined(${sqlpp_ctxt}->{current_dbh});

	${sqlpp_ctxt}->{current_sth} = ${sqlpp_ctxt}->{current_dbh}->prepare(\"SELECT $remnant\");

	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt,
			${sqlpp_ctxt}->{current_dbh}->err,
			${sqlpp_ctxt}->{current_dbh}->state,
			${sqlpp_ctxt}->{current_dbh}->errstr
			) :
		die ${sqlpp_ctxt}->{current_dbh}->errstr
		unless defined(${sqlpp_ctxt}->{current_sth});

	${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->$execsql;

	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt,
			${sqlpp_ctxt}->{current_sth}->err,
			${sqlpp_ctxt}->{current_sth}->state,
			${sqlpp_ctxt}->{current_sth}->errstr
			) :
		die ${sqlpp_ctxt}->{current_sth}->errstr
		unless defined(${sqlpp_ctxt}->{rows});

	${sqlpp_ctxt}->{NOTFOUND}->[-1]->catch($sqlpp_ctxt)
		if (${sqlpp_ctxt}->{NOTFOUND} && (! ${sqlpp_ctxt}->{rows}));
";

	unless (scalar @outphs) {
#
#	missing our INTO, use @_
#
		$replaced .= 
"	\@_ = ${sqlpp_ctxt}->{current_sth}->fetchrow_array();
";		
	}
	elsif (substr($outphs[0], 0, 1) eq '%') {
		$replaced .= 
"	$outphs[0] = ${sqlpp_ctxt}->{current_sth}->fetchrow_hash();
";
	}
	elsif (substr($outphs[0], 0, 1) eq '@') {
#
#	maybe we should use bind_cols here ?
#	also, should we throw exception if # of PHs <> NUM_OF_FIELDS ?
#
		$replaced .= 
"	${sqlpp_ctxt}->{results} = ${sqlpp_ctxt}->{current_sth}->->fetchall_arrayref();
";
		$replaced .= 
"	$outphs[$_] = \@{${sqlpp_ctxt}->{results}->[$_]};
"
			foreach (0..$#outphs);
		$replaced .= 
"	delete ${sqlpp_ctxt}->{results};
";
	}
	else {
#
#	get list and move the data into it; if it has
#	bad entries in the list, then perl runtime will choke
#	should we throw exception if # of PHs <> NUM_OF_FIELDS ?
#
		$replaced .= "	(" . join(', ', @outphs) . ") = 
		${sqlpp_ctxt}->{current_sth}->fetchrow_array();
";
	}
#
#	always clean up after ourselves
#
	$replaced .= 
"	${sqlpp_ctxt}->{current_sth}->finish();
	delete ${sqlpp_ctxt}->{current_sth};
";

	return $replaced;
}

sub sqlpp_begin_work {
	my ($obj, $stmt) = @_;

	return (defined($remnant) && ($remnant=~/^WORK$/i)) ? 
"	${sqlpp_ctxt}->{SQLERROR} ? 
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"No current connection\") :
		die \"No current connection\"
		unless defined(${sqlpp_ctxt}->{dbhs}->{$1});

	${sqlpp_ctxt}->{current_dbh}->{AutoCommit} = 0;
" : undef;
}

sub sqlpp_call {
	my ($obj, $stmt) = @_;

"	${sqlpp_ctxt}->{SQLERROR} ? 
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"No current connection\") :
		die \"No current connection\"
		unless defined(${sqlpp_ctxt}->{dbhs}->{$1});

	${sqlpp_ctxt}->{current_sth} = 
		${sqlpp_ctxt}->{current_dbh}->prepare(\"CALL $remnant\");

	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch($sqlpp_ctxt,
			${sqlpp_ctxt}->{current_dbh}->err,
			${sqlpp_ctxt}->{current_dbh}->state,
			${sqlpp_ctxt}->{current_dbh}->errstr
			) :
		die ${sqlpp_ctxt}->{current_dbh}->errstr
		unless defined(${sqlpp_ctxt}->{current_sth});

	${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->execute();
	
	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch($sqlpp_ctxt,
			${sqlpp_ctxt}->{current_sth}->err,
			${sqlpp_ctxt}->{current_sth}->state,
			${sqlpp_ctxt}->{current_sth}->errstr
			) :
		die ${sqlpp_ctxt}->{current_sth}->errstr
		unless defined(${sqlpp_ctxt}->{rows});
" : undef;
}

sub sqlpp_declare_cursor {
	my ($obj, $stmt) = @_;

	return undef
		unless ($stmt=~/^CURSOR\s+(\$?\w+)\s+AS\s+(.+)$/);

	if (defined($1)) {
#
#	cursor declaration:
#		extract PHs
#		prepare result
#
		return 
"	${sqlpp_ctxt}->{stmts}->{$2} = \"$3\";
" 
	}
}

sub sqlpp_open_cursor {
	my ($obj, $cursor) = @_;
#
#	open the named cursor
#
	return undef 
		unless ($remnant=~/^(\$*\w+)$/);

	return
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"Undefined cursor $1\") :
		die \"Undefined cursor $1\"
		unless defined(${sqlpp_ctxt}->{cursors}->{$1});

	${sqlpp_ctxt}->{current_sth} = ${sqlpp_ctxt}->{cursors}->{$1};
	${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->execute();
	
	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch($sqlpp_ctxt, 
			${sqlpp_ctxt}->{current_sth}->err,
			${sqlpp_ctxt}->{current_sth}->state,
			${sqlpp_ctxt}->{current_sth}->errstr) :
		die ${sqlpp_ctxt}->{current_sth}->errstr
		unless defined(${sqlpp_ctxt}->{rows});
";
}

sub sqlpp_fetch_cursor {
	my ($obj, $cursor) = @_;
#
#	fetch the results into specified variables, which may be any of
#	(hash, array, list of scalars)
#	OR default to @_
#
	my @phs = ($remnant=~/^\s*(\$*\w+)(\s+INTO\s+(:[%@\$]\$*\w+)(\s*,\s*(:[%@\$]\$*\w+))*)?$/i);
	pop @phs
		while ((scalar @phs) && (! defined($phs[-1])));
	return undef
		unless defined($phs[0]);

	my $replaced =
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"Undefined cursor $phs[0]\") :
		die \"Undefined cursor $phs[0]\"
		unless defined(${sqlpp_ctxt}->{cursors}->{$phs[0]});
";

#print "FETCH got ", scalar @phs, "PHs\n";
	if (1 == scalar @phs) {
#
#	missing our INTO, use @_
#
		$replaced .= 
"	\@_ = ${sqlpp_ctxt}->{cursors}->{$phs[0]}->fetchrow_array();
";		
	}
	elsif ($phs[2]=~/^%/) {
		$replaced .= 
"	$phs[2] = ${sqlpp_ctxt}->{cursors}->{$phs[0]}->fetchrow_hash();
";
	}
	elsif ($phs[2]=~/^@/) {
		$replaced .= 
"	$phs[2] = ${sqlpp_ctxt}->{cursors}->{$phs[0]}->fetchrow_array();
";
	}
	else {
#
#	get list and move the data into it; if it has
#	bad entries in the list, then perl runtime will choke
#
		my @targets = ();
		my $i = 2;
		push (@targets, $phs[$i]),
		$i += 2
			while ($i < scalar @phs);

		$replaced .= "	(" . join(', ', @targets) . 
			") = ${sqlpp_ctxt}->{cursors}->{$phs[0]}->fetchrow_array();
";
	}
	return $replaced;
}

sub sqlpp_close_cursor {
	my ($obj, $cursor) = @_;

	return 
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"Unknown cursor $1\") :
		die \"Unknown cursor $1\"
		unless defined(${sqlpp_ctxt}->{cursors}->{$1});

	${sqlpp_ctxt}->{cursors}->{$1}->finish();
";
}

sub sqlpp_prepare {
	my ($obj, $stmt, $name) = @_;
#
#	prepare a statement as a named entity
#	note we must extract placeholders of form ":\$+\w+"
#	and replace with '?'
#	also need to handle SELECT...INTO
#
	return undef 
		unless ($remnant=~/^(\$*\w+)\s+AS\s+(.+)$/);

	my $name = $1;
	$remnant = $2;
	my @phs = ($remnant=~/:([@\$]\$*\w+)/g);
	
	my $phlist = '';
	if (scalar @phs) {
		$remnant=~s/:([@\$]\$*\w+)/\?/g;
		my $first = substr($phs[0],0,1);
		$phlist = "'$phs[0]'";
		foreach (1..$#phs) {
			warn '[SQL::Preproc] Invalid statement: cannot mix scalar and array placeholders.',
			return undef
				unless ($first eq substr($phs[$_],0,1));
			$phlist .= ", '$phs[$_]'";
		}
	}

	return
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"No current connection.\") :
		die \"No current connection.\"
		unless defined(${sqlpp_ctxt}->{current_dbh});

	${sqlpp_ctxt}->{sths}->{$name} = ${sqlpp_ctxt}->{current_dbh}->prepare($remnant);
	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch($sqlpp_ctxt, 
			${sqlpp_ctxt}->{current_dbh}->err,
			${sqlpp_ctxt}->{current_dbh}->state,
			${sqlpp_ctxt}->{current_dbh}->errstr) :
		die ${sqlpp_ctxt}->{current_dbh}->errstr
		unless defined(${sqlpp_ctxt}->{sths}->{$name});

	${sqlpp_ctxt}->{phs}->{$name} = [ $phlist ];
";
}

sub sqlpp_describe {
	my ($obj, $stmt) = @_;

	my @phs = ($remnant=~/^\s*(\$*\w+)(\s+INTO\s+:([%@]?\$*\w+))?/i);

	return undef
		unless defined($phs[0]);

	my $xlated = 
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"Undefined statement/cursor $phs[0]\") :
		die \"Undefined statement/cursor $phs[0]\"
		unless defined(${sqlpp_ctxt}->{cursors}->{$phs[0]})
";

	unless (1 < scalar @phs) {
#
#	missing our INTO, use @_
#
		$xlated .=
"	\@_ = ();
	push \@_, { 
		Name => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{NAME}->[\$_],
		Type => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{TYPE}->[\$_],
		Precision => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{PRECISION}->[\$_],
		Scale => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{SCALE}->[\$_]
		}
		foreach (0..\$#{${sqlpp_ctxt}->{cursors}->{$phs[0]}->{NAME}});
";
		return $xlated;
	}

	$phs[2] = "\@$phs[2]" if ($phs[2]=~/^\$/);
	$xlated .= "\t$phs[2] = ();\n";
	$phs[2]=~s/^%/\$/;
	$xlated .= ($phs[2]=~/^\$/) ? 
"	$phs[2]{${sqlpp_ctxt}->{cursors}->{$phs[0]}->{NAME}->[\$_]} = { 
		Type => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{TYPE}->[\$_],
		Precision => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{PRECISION}->[\$_],
		Scale => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{SCALE}->[\$_]
		}
		foreach (0..\$#{${sqlpp_ctxt}->{cursors}->{$phs[0]}->{NAME}});
" : 
"	push $phs[2], { 
		Name => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{NAME}->[\$_],
		Type => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{TYPE}->[\$_],
		Precision => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{PRECISION}->[\$_],
		Scale => ${sqlpp_ctxt}->{cursors}->{$phs[0]}->{SCALE}->[\$_]
		}
		foreach (0..\$#{${sqlpp_ctxt}->{cursors}->{$phs[0]}->{NAME}});
";
	return $xlated;
}

sub sqlpp_commit {
	my ($obj, $stmt) = @_;

	return undef
		if (defined($remnant) && ($remnant!~/^(WORK)?$/));
	return 
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"No current connection.\") :
		die \"No current connection.\"
		unless defined(${sqlpp_ctxt}->{current_dbh});

	${sqlpp_ctxt}->{current_dbh}->commit();
	${sqlpp_ctxt}->{current_dbh}->{AutoCommit} = 1;
";
}

sub sqlpp_rollback {
	my $obj = shift;
#
#	rollback a xaction
#
	return (defined($remnant) && ($remnant!~/^WORK$/i)) ? undef :
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"No current connection.\") :
		die \"No current connection.\"
		unless defined(${sqlpp_ctxt}->{current_dbh});

	${sqlpp_ctxt}->{current_dbh}->rollback();
";
}

sub sqlpp_set_connection {
	my ($obj, $name) = @_;
#
#	only permits setting current connection for now
#
	return ($remnant=~/^CONNECTION\s+(\$?\w+)$/) ?
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"Undefined connection $1\") :
		die \"Undefined connection $1\"
		unless defined(${sqlpp_ctxt}->{dbhs}->{$1});

	${sqlpp_ctxt}->{current_dbh} = ${sqlpp_ctxt}->{dbhs}->{$1};
" : undef;
}

sub sqlpp_exec_immediate {
	my ($obj, $stmt) = @_;
#
# 	execute immediate: its an expression; just do() it
#	NOTE: no placeholders are supported,
#	and no data returning stmts either
#
	$remnant=~s/^IMMEDIATE\s+//i,
	return
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"No current connection.\") :
		die \"No current connection.\"
		unless defined(${sqlpp_ctxt}->{current_dbh});

	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch($sqlpp_ctxt, 
			${sqlpp_ctxt}->{current_dbh}->err,
			${sqlpp_ctxt}->{current_dbh}->state,
			${sqlpp_ctxt}->{current_dbh}->errstr) :
		die ${sqlpp_ctxt}->{current_dbh}->errstr
		unless defined(${sqlpp_ctxt}->{current_dbh}->do($remnant));
"
}

sub sqlpp_exec_prepared {
	my ($obj, $stmt) = @_;
#
#	otherwise its a prepared stmt
#	collect any PH values to be applied
#	NOTE: should NOTFOUND be tested ???
#
	my $execsql = defined(${sqlpp_ctxt}->{phs}->{$1}) ?
		'execute(' . join(', ', @{${sqlpp_ctxt}->{phs}->{$1}}) . ')' : 
		'execute()';
	return
"	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch(
			$sqlpp_ctxt, -1, 'S1000', \"Unknown statement $1.\") :
		die \"Unknown statement $1.\"
		unless defined(${sqlpp_ctxt}->{sths}->{$1});

	${sqlpp_ctxt}->{SQLERROR} ?
		${sqlpp_ctxt}->{SQLERROR}->[-1]->catch($sqlpp_ctxt, 
			${sqlpp_ctxt}->{current_dbh}->err,
			${sqlpp_ctxt}->{current_dbh}->state,
			${sqlpp_ctxt}->{current_dbh}->errstr) :
		die ${sqlpp_ctxt}->{current_dbh}->errstr
		unless defined(${sqlpp_ctxt}->{sths}->{$1}->$execsql);
";
}

sub sqlpp_exec_sql {
	my ($obj, $stmt) = @_;
}

sub sqlpp_whenever {
	my ($obj, $cond) = @_;
#
#	declare an exception handler;
#	note that we need to handle multistmts if we're scoped
#
	return undef 
		unless ($remnant=~/^(SQLERROR|(NOT\s+FOUND))\s+(.+)$/);
	my $cond = ($1 eq 'SQLERROR') ? 'SQLERROR' : 'NOTFOUND';
	return
"	push \@{${sqlpp_ctxt}->{$cond}}, 
		SQL::Preproc::Exception->new_$cond(${sqlpp_ctxt}, 
			sub { $3 });
";
}

sub DESTROY {
	my $obj = shift;
	
	delete $obj->{_ctxt};
	1;
}

1;