package WrapSE2;

use strict;
use warnings;
# BELOW: require SqlEngine2; in &_se2_require

# $Id: WrapSE2.pm,v 1.16 2006/12/11 14:52:12 mca Exp $
our $VSN = (qw$Revision: 1.16 $)[1];
sub debug;


=head1 NAME

WrapSE2 - object to track an SqlEngine2/WrapDBI pair

=head1 SYNOPSIS

 use WrapSE2;
 WrapSE2->debug(1); # do this before instantiating anything

 # SqlEngine2 and WrapDBI need not be loaded until this point:
 my $wse2 = WrapSE2->new(reports => qw( fooqueries barqueries ));
 my $select = $wse2->getAll('fooqueries::countfoo', [ 42 ]);

 my $T = $wse2->getTransaction;
 my $rows = $T->do('barqueries::addone', [ "abcd", "goldfish" ]);
 $T->commit;

or

 use WrapSE2 -debug => 'FakeDBI_cgisave';
 # calls  WrapSE2->debug('FakeDBI_cgisave');

 # exact spec of debug setting hasn't settled yet

=head1 DESCRIPTION

Database hooks, aiming to avoid firing up a database handle for every
web request and barcode scanned into the system...

We only need "get me a SELECT" and (later) "insert all these and
commit" routines.  Just something small and tidy.

XXX: Class responsibilities need tidying up here

Loading of the L<SqlEngine2> and L<WrapDBI> modules is postponed until
an instance of this class is made.  This leaves plenty of time for
environment variables to be configured.


=head2 WrapSE2-E<gt>new($wrapdbi_login, @sql_lib_names)

Make a DBH using the given L<WrapDBI> login, via C<SqlEngine2::getDbh>.
Make an SE2 object, load the list of sql_lib into it.
(Note that these loaded sql_libs are slightly global.)

Return an object which associates the pair and provides minimal
methods to operate on the pair.

=cut

sub new {
    my ($proto, $login, @sql_lib) = @_;
    my $class = ref($proto) || $proto;

    $class->_se2_require();

    my $self = { SE2 => SqlEngine2->new(),
		 dblog => $login,
		 dbh => SqlEngine2::getDbh($login),
	       };
    $self->{SE2}->loadSqlLib(\@sql_lib);

    if (debug) {
# XXX: SE2 support in FakeDBI_summary is not implemented
#	FakeDBI_cgisave->see_engine($self->{SE2});
    }

    return bless $self, $class;
}

sub _dbh { return $_[0]->{dbh} }
sub _se2 { return $_[0]->{SE2} }



=head2 dbinfo()

Object method.  Returns a string telling something about this object's
database connection (but without revealing a password).

Contains assorted horribleness for extracting info about the other end
of the connection.

(If you need this data as key/value elements instead of a string, let
me know.)

=cut

sub dbinfo {
    my $self = shift;
    my $dbh = $self->_dbh;

    my $qname = $self->_se2->virtualSqlLib("WrapSE2", "$self+dbinfo", <<SQL);
SELECT user			dbuser,
  dbms_standard.database_name	dbname
FROM dual
SQL

    my $rows = $self->getAll($qname, []);
    die "dbinfo on $self: expected 1 row, got ".@$rows unless @$rows == 1;
    my @row = @{ $rows->[0] };

    my $dbhName = $$dbh{Name};

    return "dblog=$$self{dblog} TNSname(maybe)=$dbhName dbuser=$row[0] dbname=$row[1]";
}


{
    my $debug = 0;
    sub debug {
	return $debug if @_ < 2;

	die "Too late to set debug flag (SqlEngine2 already loaded)" if $INC{'SqlEngine2.pm'};
	(my $class, $debug) = @_;
    }
}


sub import {
    my ($pkg, @params) = @_;

    while (@params) {
	my $p = shift @params;

	if ($p eq '-debug') {
	    $pkg->debug(shift @params);

	} elsif ($p eq '-mkassoc') {
	    my $args = shift @params;

	    die 'Syntax: use $pkg -mkassoc => [ "pkgname::sub_name", @WrapSE2_new_args ]'
	      unless ref($args) eq 'ARRAY' && @$args > 1
		&& !ref($args->[0]) && $args->[0] =~ /::/;

	    my ($sub_name, @new_args) = @$args;
	    $pkg->mkassoc($sub_name, @new_args);

	} else {
	    die "Unrecognised import(... $p, @params)";
	}
    }
}


=head2 mkassoc($sub_name, @args_to_new)

Class method, also available via C<use WrapSE2>.  Create and stash
under symbol name C<$sub_name> a CODE block which works as a function
or class method of no arguments, and returns a memoised L<WrapSE2>
object.

 use WrapSE2 -mkassoc => [qw[ MyPkg::getDB  snpreport ExoSeq exocheck ]];
 my $select_rows = MyPkg->getDB->getAll('ExoSeq::get_person' => [ $id ]);

is equivalent to

 use WrapSE2;
 WrapSE2->mkassoc('MyPkg::getDB',         # name of subroutine to create
                  'snpreport',            # WrapDBI login
                  'ExoSeq', 'exocheck');  # sql_libs to load
 my $select_rows = MyPkg->getDB->getAll('ExoSeq::get_person' => [ $id ]);

and is an improvement on the following, where the C<$wse> variable
must be global or passed around:

 use WrapSE2;
 my $wse = WrapSE2->new(snpreport => qw[ ExoSeq exocheck ]);
 my $select_rows = $wse->getAll('ExoSeq::get_person' => [ $id ]);

but can be conveniently called without having a global variable or
often-passed parameter, and it only makes the connection when first
needed.

=over 4

=item -

The resulting function can be C<Exporter>ed to share with other code.
After the C<mkassoc>, the symbol is just another subroutine
definition.

=item -

When importing to OO packages, it may be better to consider it a class
method rather than a subroutine: it will then be easier to switch to
using a different WrapSE2 per object of the class.  (But watch out for
other class globals.)

=item -

nb. writing these in the form

 use WrapSE2 -mkassoc => [ MyPkg::getDB => ... ]; # WRONG

leaves the name of the new symbol as a bareword not a string, and this
is a recipe for trouble - and for some reason a very unhelpful error
which looks like failure to compile for no specific reason.

=back

=cut

sub mkassoc {
    my ($pkg, $sub_name, @new_args) = @_;

    my $instance_var;
    my $code = sub {
	# Check the caller isn't expecting us to do a query (would be a typo)
	unless (@_ == 0 || # no args (called as a function)
		@_ == 1) # called as class or object method
	  {
	      die "$sub_name (generated by $pkg) is a function or class method of no args";
	  }

	$instance_var ||= $pkg->new(@new_args);
	return $instance_var;
    };

    no strict 'refs';
    *{$sub_name} = $code;
}


### It's not proven that this method a) works or b) is useful
#
#  =head2 loadVirtual($libname, $fh)
#
#  The argument is a filehandle, as a variable or typeglob.  This allows
#  the DATA filehandle to be loaded as an sql_lib, for example.
#
#  The filehandle is parsed as any other sql_lib content, each query
#  marked with C<E<lt>querynameE<gt>> is passed to
#
#    $se2-E<gt>virtualSqlLib($libname, $queryname, $sql_text)
#
#  XXX: the parsing is done with code slightly ripped from SqlEngine2->loadSqlLib, it should be done by SqlEngine2 itself but the parser isn't separate from the file opener
#
#  =cut
#
#  sub loadVirtual {
#      my ($self, $libname, $fh) = @_;
#
#      local $/ = ""; # read a paragraph at a time
#      while (<$fh>) {
#  	next unless $_ =~ />(\S+)</;
#  	my $queryname = $1;
#  	my @sql;
#
#  	foreach my $line (split /[\n]/) {
#  	    next if $line =~ />(\S+)</;
#  	    next if $line =~ /^\s*--/ or $line =~ /^\s*#/;
#  	    next unless $line =~ /\S+/;
#  	    push @sql, $line;
#  	}
#
#  	$self->{SE2}->virtualSqlLib($libname, $queryname,
#  				    join " ", @sql);
#      }
#  }


=head2 getAll($qname, \@params)

Object method.  Apply C<getAll> to the L<SqlEngine2> and L<WrapDBI>
objects.

Passes the given query name and parameters, then returns a 2D array of
return values in the usual way.

=cut

sub getAll {
    my ($self, $qname, $params) = @_;

    return $self->{SE2}->getAll($qname, $params, $self->{dbh});
}


=head2 getAllDataset($qname, \@params)

Provided by L<Data::Dataset::SQL>.

Assumes the user has loaded L<Data::Dataset>, it is B<not> C<require>d
or C<use>d by this module.  It is an optional dependency.


=head2 getTransaction()

Object method.  Start a data modification transaction.  Return a
L<WrapSE2::Transaction> object to manage it.

Dies if a transaction is already in progress.

=cut

sub getTransaction {
    my ($wse2) = @_;

    # Ensure only one transaction running on a DBH.
    # This is easy when the DBH is private to our object.
    if ($wse2->{trans}) {
	my $T = $wse2->{trans};
	die "transaction already in progress" if $T->current;
    }

    # Start the transaction, return object to wrap it
    $wse2->{SE2}->beginTransaction($wse2->{dbh});
    my $T =  { wse2 => $wse2, current => 1 };
    bless $T, 'WrapSE2::Transaction';

    return $wse2->{trans} = $T;
}


=head2 rollback_and_die($message)

Object method, a convenience for mopping up bad transactions.

Attempt to rollback the transaction (even if this object doesn't have
one, or it is not current).  Catch any error that occurs and append it
to $message.

Then call C<die($message)>.

This API is safe to use, even when the creation of the transaction
failed:

 my $wse2 = WrapSE2->new(foodb => "querieslib");
 my $T;
 eval {
   $T = $wse2->getTransaction;

   my $rows = $T->do("updatequery", [ 42 ]);
   die "Expected to update 3 rows, but changed $rows instead" unless $rows == 3;

   $T->commit;
 };

 if ($@) {
   $wse2->rollback_and_die("Magic thing failed: $@");
 } else {
   print "Magic thing succeeded\n";
 }

=cut

sub rollback_and_die {
    my ($wse2, $message) = @_;

    $message = "Transaction cancelled (and rollback_and_die was called with no message)"
      if !defined $message;

    if ($wse2->{trans}) {
	eval {
	    $wse2->{trans}->rollback;
	};
	$message .= "\nAlso, $@ while rolling back" if $@;
    } else {
	$message .= "\n(No transaction to rollback)";
    }

    die $message;
}


=head2 _se2_require()

Cause L<SqlEngine2> to be loaded by C<require> and verbosity switched
off.  This in turn loads L<WrapDBI>.

If debugging flag is set, the WrapDBI interceptor will be configured
to do profiling of SQL statements.

When doing profiling, we have to mess with the session (keep a copy of
the L<SangerWeb> around after C<cgi_main> has finished with it, so it
remains during C<END>).  This has caused session save failure problems
in the past.

=cut

sub _se2_require {

    # Maybe set up ja1 style WrapDBI interceptor with this summary module
    if (debug) {
die "Easy-access debug and CGI hooks are broken (lack of upkeep maintenance)";
#	$ENV{BENCHMARK_DBI} = 1;
#	require FakeDBI_cgisave;
#	$FakeDBI_cgisave::SANGERWEB = CGIutils->sangerweb();
#	@myDBI::ANALYSE = @thingieDBI::ANALYSE = qw( FakeDBI_cgisave );
    }

    # Load SE2 - the purpose of this sub
    require SqlEngine2; # will use WrapDBI
    $SqlEngine2::verbosity = 0; # avoid noise in error_log
    $SqlEngine2::verbosity = 0; # do it twice to avoid single-use warning
}



package WrapSE2::Transaction; # we construct instances of this

=head1 NAME

WrapSE2::Transaction - object to represent lifetime of a transaction


=head2 commit

Object method to commit the transaction.  Dies if transaction is not
current.  Catching SQL errors is the caller's responsibility.

=cut

sub commit {
    my $self = shift;
    die "transaction $self is not current" unless $self->current;

    $self->{wse2}->{SE2}->commitTransaction($self->{wse2}->{dbh});
    $self->{current} = 0;
}


=head2 rollback

Object method to roll back the transaction.  Dies if transaction is
not current.  Catching SQL errors is the caller's responsibility.

See also the L<WrapSE2> method C<rollback_and_die> for convenience.

=cut

sub rollback {
    my $self = shift;
    die "transaction $self is not current" unless $self->current;

    $self->{wse2}->{SE2}->rollbackTransaction($self->{wse2}->{dbh});
    $self->{current} = 0;
}


=head2 current

Returns true iff this object's transaction is still current.

You can't do much with a non-current transaction, it has already
happened.

=cut

sub current {
    my $self = shift;
    return $self->{current};
}


=head2 do($qname, $params)

Object method.  Requires this transaction to be current.

Do a DML query.  Returns number of rows affected, in the usual way.

Calls

 $se2->do($qname, $params, $dbh, 1)

with $se2 and $dbh from the L<WrapSE2> object which made this
transaction.

Note that this sets the "quietly" flag.  Errors are thrown in the
usual way, but no additional warnings are made.

=cut

sub do {
    my ($self, $qname, $params) = @_;
    die "transaction $self is not current" unless $self->current;

    my $wse2 = $self->{wse2};
    return $wse2->{SE2}->do($qname, $params, $wse2->{dbh}, 1);
}


=head2 DESTROY

Object destructor, not for calling by normal code.

When destroyed, this object will rollback the transaction if it is
current.  SQL errors are caught and reported as a warning.  A warning
is issued even if the rollback succeeds, because we expected the user
to have committed or rolled back before forgetting the object.

Note that you cannot rely 100% on this to rollback a transaction on
program exit, it's just another layer of protection.  The Oracle
library may well commit if the program manages to exit without
requesting rollback.

=cut

sub DESTROY {
    my $self = shift;
    if ($self->current) {
	local $@; # avoid trashing other people's $@ during object destruction
	eval {
	    $self->rollback();
	};
	if ($@) {
	    # Well it failed, there's not much we can do
	    warn "Rollback on $self failed: $@";
	} else {
	    warn "Rolled back incomplete transaction $self";
	}
    }
}


=head1 SEE ALSO

ja1 points out that L<Class::DBI> or L<DBIx::Class> may be a better
solution.  Integration of these with L<SqlEngine2> and/or the
sometimes discussed SqlEngine3 might be useful to investigate...

=head1 AUTHOR

mca@sanger.ac.uk

=cut

1;
