lib/SQL/Exec/Statement.pm

package SQL::Exec::Statement;
use strict;
use warnings;
use feature 'switch';
use Carp;
use Scalar::Util 'blessed', 'reftype', 'openhandle';
use List::MoreUtils 'any';

use parent 'SQL::Exec';

# Note: This file contains both a POD documentation which describes the public
# API of this package and a technical documentation (on the internal methods and
# how to subclasse this package) in standard Perl comments.

=encoding utf-8

=head1 NAME

SQL::Exec::Statement - Prepared statements support for SQL::Exec

=head1 SEE ALSO

For the documentation of this distribution please check the L<SQL::Exec> module.

=head1 COPYRIGHT & LICENSE

Copyright 2013 © Mathias Kende.  All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

our @CARP_NOT = ('DBIx::Connector');

			
# This variable stores the default instance of this class. It is set up in a
# BEGIN block.
my $default_handle;

# Return a reference of a new copy of the empty_handle hash, used by the
# constructors of the class.
sub get_empty {
	my $new_empty = SQL::Exec->get_empty();
	delete $new_empty->{auto_handle};
	return $new_empty;
}

# ->new($parent, {options})
# appeler seulement depuis Exec::prepare
sub new {
	my ($class) = shift @_;
	my $parent = &SQL::Exec::just_get_handle;

	my $c = get_empty();
	$c->{parent} = $parent;
	bless $c, $class;
	$c->set_options(%{$parent->{options}});
	$c->{db_con} = $parent->{db_con};
	$c->{is_connected} = $parent->{is_connected};
	# on ne copie pas les restore options exprès, ce qui est en vigueur quand
	# on crée l'objet le reste.
	# TODO: faire un cas de test pour ça.

	$c->check_conn() or return;
	
	my $req = $c->get_one_query(shift @_);

	my $proc = sub {
			if (!$c->low_level_prepare($req)) {
				die "EINT\n";
			}
		};

	if ($c->{options}{auto_transaction}) {
		eval { $c->{db_con}->txn($proc) };
	} else {
		eval { $proc->() };
	}
	if ($@ =~ m/^EINT$/) {
		return;
	} elsif ($@) {
		die $@;
	} else {
		return $c;
	}
}

sub DESTROY {
	my ($c) = shift;
	$c->low_level_finish() unless $c->{req_over};
	# we need to override the DESTROY function from SQL::Exec which disconnect
	# the library...
}

################################################################################
################################################################################
##                                                                            ##
##                            INTERNAL METHODS                                ##
##                                                                            ##
################################################################################
################################################################################


# The function below are responsible for the effective works of the library.
# Pretty much self-descriptive.

# Prepare a statement, return false on error (if die_on_error is false)
# only one statement may be prepared at a time in a database handle.
sub low_level_prepare {
	my ($c, $req_str) = @_;
	
	$req_str = $c->query($req_str) or return $c->error('No query to prepare');

	my $s = sub { 
			my $req = $_->prepare($req_str);
			if (!$req) {
				die $c->format_dbi_error("Cannot prepare the statement");
			} else {
				return $req;
			}
		};
	my $req = eval { $c->{db_con}->run($s) };
	if ($@) {
		return $c->error($@);
	}
	$c->{last_req} = $req;
	$c->{req_over} = 0;
	return 1;
}

sub low_level_bind {
	my $c = shift;

	if ($c->{last_req}->{NUM_OF_PARAMS} != @_) {
		$c->error("Invalid number of parameter (%d), expected %d", scalar(@_), $c->{last_req}->{NUM_OF_PARAMS});
	}

	my $i = 0;
	for (@_) {
		#TODO: gérer les différents type de paramètres
		if (not $c->{last_req}->bind_param(++$i, $_)) {
			$c->dbi_error("Cannot bind the parameters");
			return;
		}
	}

	return 1;
}

# execute the prepared statement of the handle. Return undef on failure (0 may
# be returned on success).
sub low_level_execute {
	my ($c) = @_;
	#confess "No statement currently prepared" if $c->{req_over};

	my $v = $c->{last_req}->execute();
	if (!$v) {
		$c->dbi_error("Cannot execute the statement");
		return;
	}
	
	return $v;
}


# Return one raw of result. The same array ref is returned for each call so
# its content must be copied somewhere before the next call.
sub low_level_fetchrow_arrayref {
	my ($c) = @_;
	#confess "No statement currently prepared" if $c->{req_over};

	my $row = $c->{last_req}->fetchrow_arrayref();
	if (!$row && $c->{last_req}->err) {
		$c->dbi_error("A row cannot be fetched");
		return;
	} elsif (!$row) {
		return 0;
	} else {
		return $row;
	}
}

# The returned hashref is safe: it will not be erased at the next call.
sub low_level_fetchrow_hashref {
	my ($c) = @_;
	#confess "No statement currently prepared" if $c->{req_over};

	my $row = $c->{last_req}->fetchrow_hashref('NAME_lc');
	if (!$row && $c->{last_req}->err) {
		$c->dbi_error("A row cannot be fetched");
		return;
	} elsif (!$row) {
		return 0;
	} else {
		return $row;
	}
}

sub low_level_finish {
	my ($c) = @_;
	#confess "No statement currently prepared" if $c->{req_over};

	$c->{last_req}->finish;
	$c->{req_over} = 1;

	return $1;
}

# Test whether there is one raw available in the prepared statement.
# this function destroy the raw so it should not be called if you actually
# want to read to raw.
sub test_next_row {
	my ($c) = @_;
	#confess "No statement currently prepared" if $c->{req_over};
	
	return $c->{last_req}->fetchrow_arrayref() || $c->{last_req}->err
}

sub __prepare_bind_params {
	my ($c, @p) = @_;

	my ($param, $d1);
	if (not @p or not ref $p[0]) {
		$param = [ \@p ];
		$d1 = 1;
	} elsif (reftype($p[0]) eq 'ARRAY' and (not @{$p[0]} or not ref $p[0][0])) {
		$param = [ @p ];
	} elsif (reftype($p[0]) eq 'ARRAY' and reftype($p[0][0]) eq 'ARRAY') {
		$param = $p[0];
	} else {
		$c->error('Invalid argument geometry');
	}
	
	return wantarray ? ($param, $d1) : $param
}


################################################################################
################################################################################
##                                                                            ##
##                          STANDARD QUERY FUNCTIONS                          ##
##                                                                            ##
################################################################################
################################################################################


sub __execute {
	my ($c, @pp) = @_;

	$c->check_conn() or return;

	my ($param, $d1) = $c->__prepare_bind_params(@pp);

	my $proc = sub {
			my $a = 0;
			
			if ($c->{last_req}->{NUM_OF_PARAMS} == 1 and $d1) {
				$param = [ map { [ $_ ] } @{$param->[0]} ];
			}

			for my $p (@{$param}) {
			# TODO: lever l'erreur strict seulement dans le mode stop_on_error
			# et s'il reste des requête à exécuter.
				if (not $c->low_level_bind(@{$p})) {
					$c->low_level_finish();
					$c->strict_error("The query has not been executed for all value due to an error") and die "EINT\n";
					die "ESTOP:$a\n" if $c->{options}{stop_on_error};
					next;
				}
				my $v = $c->low_level_execute();
				$c->low_level_finish();
				if (not defined $v) {
					$c->strict_error("The query has not been executed for all value due to an error") and die "EINT\n";
					die "ESTOP:$a\n" if $c->{options}{stop_on_error};
					next;
				}
				$a += $v;
			}
			return $a;
		};

	my $v;
	if ($c->{options}{auto_transaction}) {
		$v = eval { $c->{db_con}->txn($proc) };
	} else {
		$v = eval { $proc->() };
	}
	$c->low_level_finish() unless $c->{req_over}; # ???
	if ($@ =~ m/^EINT$/) {
		return;
	} elsif ($@ =~ m/^ESTOP:(\d+)$/) {
		return $c->{options}{auto_transaction} ? 0 : $1;
	} elsif ($@) {
		die $@;
	} else {
		return $v;
	}
}

sub execute {
	my $c = &SQL::Exec::check_options or return;
	return $c->__execute(@_);
}

sub __query_one_value {
	my ($c, @p) = @_;

	$c->check_conn() or return;

	if (not $c->low_level_bind(@p)) {
		$c->low_level_finish();
		return;
	}

	if (not defined $c->low_level_execute())
	{ 
		$c->low_level_finish();
		return;
	}

	my $row = $c->low_level_fetchrow_arrayref();

	my $tmr = $c->test_next_row() if defined $c->{options}{strict};
	$c->low_level_finish();

	if (!$row) {
		return $c->error("Not enough data");
	} elsif ($#$row < 0) {
		return $c->error("Not enough column");
	}

	if (defined  $c->{options}{strict}) {
		$c->strict_error("Too much columns") and return if $#$row > 0;
		$c->strict_error("Too much rows") and return if $tmr;
	}
	
	return $row->[0];
}

sub query_one_value {
	my $c = &SQL::Exec::check_options or return;
	return $c->__query_one_value(@_);
}

# array ou array-ref selon le contexte (sûr, pas écraser au prochain appel).
sub __query_one_line {
	my ($c, @p) = @_;

	$c->check_conn() or return;
	
	if (not $c->low_level_bind(@p)) {
		$c->low_level_finish();
		return;
	}

	if (not defined $c->low_level_execute()) {
		$c->low_level_finish();
		return;
	}
	my $row = $c->low_level_fetchrow_arrayref();
	if (!$row) {
		$c->low_level_finish();
		return $c->error("Not enough data");
	}

	my $tmr = $c->test_next_row() if defined $c->{options}{strict};

	$c->low_level_finish();

	$c->strict_error("Too much rows") and return if $tmr;

	return wantarray ? @{$row} : [ @{$row} ];
}

sub query_one_line {
	my $c = &SQL::Exec::check_options or return;
	return $c->__query_one_line(@_);
}


# ! Si une erreur ignorée se produit dans fetchraw alors on renvoie un tableau tronqué
# Et non pas undef ou autre, donc il n'y a pas de moyen de savoir que l'appel a échoué.
# En mode stricte cependant, cette situation lève une erreur elle même (et donc on a un message
# propre si on ignore cette erreur).
# return un tableau ou un array-ref (pour économiser une recopie).
# renvoie toujours un tableau 2D même s'il n'y a qu'une colonne (pour assurer la cohérence du type),
# il faut utiliser query_one_column pour avoir une colonne.
sub __query_all_lines {
	my ($c, @p) = @_;

	$c->check_conn() or return;
	
	if (not $c->low_level_bind(@p)) {
		$c->low_level_finish();
		return;
	}

	if (not defined $c->low_level_execute()) {
		$c->low_level_finish();
		return;
	}
	
	my @rows;	
	while (my $row = $c->low_level_fetchrow_arrayref()) {
		push @rows, [ @{$row} ]; # Pour recopier la ligne sans quoi elle est écrasée au prochain appel.
	}

	$c->low_level_finish();

	if (defined $c->{options}{strict} && $c->{last_req}->err) {
		$c->strict_error("The data have been truncated due to an error") and return;
	}

	return wantarray() ? @rows : \@rows;
}

sub query_all_lines {
	my $c = &SQL::Exec::check_options or return;
	return $c->__query_all_lines(@_);
}

sub __query_one_column {
	my ($c, @p) = @_;

	$c->check_conn() or return;

	if ($c->{last_req}->{NUM_OF_FIELDS} < 1) {
		$c->low_level_finish();
		return $c->error("Not enough column");
	}

	if (defined $c->{options}{strict} && $c->{last_req}->{NUM_OF_FIELDS} > 1) {
		if ($c->strict_error("Too much columns")) {
			$c->low_level_finish();
			return;
		}
	}

	if (not $c->low_level_bind(@p)) {
		$c->low_level_finish();
		return;
	}

	if (not defined $c->low_level_execute()) {
		$c->low_level_finish();
		return;
	}
	
	my @data;

	while (my $row = $c->low_level_fetchrow_arrayref()) {
		push @data, $row->[0];
	}

	$c->low_level_finish();

	if (defined $c->{options}{strict} && $c->{last_req}->err) {
		$c->strict_error("The data have been truncated due to an error") and return;
	}
	
	return wantarray() ? @data : \@data;
}

sub query_one_column {
	my $c = &SQL::Exec::check_options or return;
	return $c->__query_one_column(@_);
}


# low_level_query_to_file(req, FH, sep, nl)
# s'il n'y a qu'un argument effectif c'est la requête
# le suivant est le FH, etc. Ils peuvent être omis en partant de la fin.
# FH peut être une chaîne, éventuellement préfixé par '>>' pour append et non pas troncation
# du fichier. Sinon c'est STDOUT. sinon une ref à un IO ou GLOB
# sep est ";" par défaut et nl est '\n' par défaut).
# renvoie le nombre de lignes lues.
# On a les même limitations en cas d'erreur que pour la fonction request_all
# Particulièrement, on renvoie toujours le  nombre de lignes lues
# même si une erreur se produit (à condition qu'on l'ignore, of course).
# Par contre on renvoie undef si on ne peut pas ouvrir le fichier demandé.
# ou pas écrire dedans.
sub __query_to_file {
	my ($c, $fh, @p) = @_;

	my ($fout, $to_close);
	if (not defined $fh) {
		$fout = \*STDOUT;
	} elsif (openhandle($fh)) {
		$fout = $fh;
	} elsif (!ref($fh)) {
		$fh =~ m{^\s*(>{1,2})?\s*(.*)$};
		if (!open $fout, ($1 // '>'), $2) { # //
			return $c->error("Cannot open file '$fh': $!");
		}
		$to_close = 1;
	} else {
		return $c->error("Don't know what to do with fh argument '$fh'");
	}
	
	$c->check_conn() or return;

	if (not $c->low_level_bind(@p)) {
		$c->low_level_finish();
		return;
	}

	if (not defined $c->low_level_execute()) {
		$c->low_level_finish();
		return;
	}

	my $count = 0;
	{
		local $, = $c->{options}{value_separator} // ';';
		local $\ = $c->{options}{line_separator} // "\n";
		while (my $row = $c->low_level_fetchrow_arrayref()) {
			if (not (print $fout @{$row})) {
				close $fout if $to_close;
				$c->low_level_finish();
				$c->error("Cannot write to file: $!");
				return $count;
			}
			$count++;
		}
		close $fout if $to_close;
	}

	$c->low_level_finish();

	if (defined $c->{options}{strict} && $c->{last_req}->err) {
		$c->strict_error("The data have been truncated due to an error") and return;
	}
	
	return $count;
}

sub query_to_file {
	my $c = &SQL::Exec::check_options or return;
	return $c->__query_to_file(@_);
}

sub __query_one_hash {
	my ($c, @p) = @_;

	$c->check_conn() or return;
	
	if (not $c->low_level_bind(@p)) {
		$c->low_level_finish();
		return;
	}

	if (not defined $c->low_level_execute()) {
		$c->low_level_finish();
		return;
	}
	my $row = $c->low_level_fetchrow_hashref();
	if (!$row) {
		$c->low_level_finish();
		return $c->error("Not enough data");
	}

	my $tmr = $c->test_next_row() if defined $c->{options}{strict};

	$c->low_level_finish();

	$c->strict_error("Too much rows") and return if $tmr;

	return wantarray ? %{$row} : $row; # no need to copy the pointer has for array (Cf DBI doc).
}

sub query_one_hash {
	my $c = &SQL::Exec::check_options or return;
	return $c->__query_one_hash(@_);
}

sub __query_all_hashes {
	my ($c, @p) = @_;

	$c->check_conn() or return;
	
	if (not $c->low_level_bind(@p)) {
		$c->low_level_finish();
		return;
	}

	if (not defined $c->low_level_execute()) {
		$c->low_level_finish();
		return;
	}
	
	my @rows;	
	while (my $row = $c->low_level_fetchrow_hashref()) {
		push @rows, $row; # pas besoin de recopier le hash.
	}

	$c->low_level_finish();

	if (defined $c->{options}{strict} && $c->{last_req}->err) {
		$c->strict_error("The data have been truncated due to an error") and return;
	}

	return wantarray() ? @rows : \@rows;
}

sub query_all_hashes {
	my $c = &SQL::Exec::check_options or return;
	return $c->__query_all_hashes(@_);
}


1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)