package Yaa::LookupMap::Driver::SQL;

# inherit everything from Yaa::LookupMap
@ISA = qw(Yaa::LookupMap);

use strict;
use DBI;
use Carp::Heavy;
use vars qw ($VERSION);

# set debugging constant if YAA_DEBUG environment variable is set
BEGIN {
	use constant DEBUG => ((defined $ENV{YAA_DEBUG}) ? 1 : 0);
	require File::Basename if (DEBUG);
}

=head1 NAME

Yaa::LookupMap::Driver::SQL - sql lookup map driver

This driver queries SQL database backend in order to perform lookup.

WARNING: Do not use this class standalone!

=cut

=head1 SYNOPSIS

my $sql_map = Yaa::LookupMap->factory(

	driver => 'SQL',
	sql_dsn = 'dbi:mysql:database=mydb;hostname=mysql.example.org',
	sql_username => 'username',
	sql_password => 'secret',
	sql_select => "SELECT some_column FROM sometable where sth = %m AND sth2 = %d AND sth3 = %u AND sth4='x'"
);

my $result = $sql_map->lookup($key);

# prints out column some_column if sql query returned anything

print $result->getMatchValueByKey('some_column') if (defined $result);

B<Result keys>: This driver returns result object with keys B<named by columns returned by SQL query>.

=cut

######################################################
#                GLOBAL VARIABLES                    #
######################################################
my $VERSION = "0.1";

######################################################
#               OBJECT CONSTRUCTOR                   #
######################################################

=head1 OBJECT CONSTRUCTOR

Object constructor options:

B<sql_dsn> - ful DSN (driver source name) for connecting to the database. If you don't know how to specify
dsn, see perldoc DBI and perldoc DBD::YOUR_SQL_DRIVER (for example DBD::mysql for mysql type)

B<sql_username> - username used to connect to the SQL database

B<sql_password> - password secret

B<sql_select> - SQL select statement

The sql_select option can contain one or more of the following magic placeholders:

- B<%m>: complete email address (user@example.org)

- B<%u>: user part of email address (user)

- B<%d>: domain part of email address (example.org)

=cut
sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	
	# call parent constructor
	my $self = Yaa::LookupMap->new();

	##################################################
	#               PUBLIC VARS                      #
	##################################################
	
	##################################################
	#              PRIVATE VARS                      #
	##################################################
	
	# database connection
	$self->{_sql_conn} = undef;
	
	# compiled sql statements
	$self->{_sql_select} = undef;
	@{$self->{_sql_select_names}} = undef;

	bless($self, $class);
	
	# clear parameters
	$self->clearParams();

	# set object properties	
	$self->setParams(@_);

	return $self;
}

####################################################
#               PUBLIC METHODS                     #
####################################################

sub clearParams {
	my ($self) = @_;
	$self->_sqlDisconnect();
	$self->{sql_dsn} = undef;
	$self->{sql_username} = undef;
	$self->{sql_password} = undef;
	$self->{sql_select} = undef;
	return 1;
}

####################################################
#               PRIVATE METHODS                    #
####################################################

sub _lookup {
	my ($self, $key) = @_;
	
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": startup, query key '$key'\n" if (DEBUG);

	return undef unless ($self->_sqlConnect());
	
	# do we need to compile sql?
	return undef if (! (defined $self->{_sql_select} || $self->_sqlCompileQuery()));
	
	# ok, execute sql
	my $rs = $self->{_sql_select}->execute($self->_sqlGetQueryArray($key));
	
	unless (defined $rs) {
		$self->{error} = "Error executing SQL: " . $self->{_sql_conn}->errstr;
		return undef;
	}
	
	my $result = Yaa::LookupMap::Result->new();
	
	# fetch results
	while (my $row = $self->{_sql_select}->fetchrow_hashref()) {
		$result->addMatch($row);
	}
	
	return $result;
}

# connects to the sql backend
sub _sqlConnect {
	my ($self) = @_;
	# return immediately success, if we're already connected.
	return 1 if (defined $self->{_sql_conn});
	
	# check connection parameters
	return 0 unless ($self->_sqlCheckParams());
	
	# try to connect
	$self->{_sql_conn} = DBI->connect(
		$self->{sql_dsn},
		$self->{sql_username},
		$self->{sql_password},
		{PrintError => 0, AutoCommit => 1}
	);

	unless (defined $self->{_sql_conn}) {
		$self->{error} = "Unable to connect to SQL backend: " . DBI->errstr;
		return 0;
	}

	return 1;
}

sub _sqlDisconnect {
	my ($self) = @_;

	if (defined $self->{_sql_conn}) {
		my $result = $self->{_sql_conn}->disconnect();
		$self->{_sql_conn} = undef;
		return  $result;
	}

	return 1;
}

# checks sql parameters
sub _sqlCheckParams {
	my ($self) = @_;

	if (! defined $self->{sql_dsn}) {
		$self->{error} = "Parameter sql_dsn is not defined.";
		return 0;
	}
	elsif (! defined $self->{sql_username}) {
		$self->{error} = "Parameter sql_username is not defined.";
		return 0;
	}
	elsif (! defined $self->{sql_select}) {
		$self->{error} = "Parameter sql_select_recipient is not defined.";
		return 0;
	}
	
	return 1;
}

# compiles sql query
sub _sqlCompileQuery {
	my ($self) = @_;
	return 0 unless ($self->_sqlConnect());
	
	@{$self->{_sql_select_names}} = undef;

	my $sql = $self->{sql_select};
	$sql =~ s/%(\w{1})/ push @{$self->{_sql_select_names}}, $1; '?' /eg;
	
	unless (defined ($self->{_sql_select} = $self->{_sql_conn}->prepare($sql))) {
		$self->{error} = "Unable to compile sql_select statement: " . $self->{_sql_conn}->errstr;
		return 0;
	}
	
	return 1;
}

sub _sqlGetQueryArray {
	my ($self, $key) = @_;

	unless (defined $key) {
		$self->{error} = "Lookup key was not defined.";
		return undef;
	}

	return undef if (! (defined $self->{_sql_select} || $self->_sqlCompileQuery()));
	
	my ($user, $domain);
	my @results;
	
	if ($key =~ m/^([\w\-\.]+)@(.+)$/) {
		$user = $1; $domain = $2;
	} else {
		$user = $key;
	}
	
	foreach (@{$self->{_sql_select_names}}) {
		next unless (defined $_);

		if ($_ eq 'm') {
			push(@results, $key);
		}
		elsif ($_ eq 'u') {
			push(@results, $user);
		}
		elsif ($_ eq 'd') {
			push(@results, $domain);
		}
	}
	
	return @results;
}

sub DESTROY {
	my ($self) = @_;
	$self->_sqlDisconnect();
}

=head1 SEE ALSO

For general class usage, please see perldoc Yaa::LookupMap and perldoc DBI.

=cut

=head1 AUTHOR

Branko F. Gracnar <bfg@frost.ath.cx>
http://frost.ath.cx/~bfg

=cut

=head1 LICENSE

This software is released under BSD-style license. If you like this software, send me a nice postcard from somewhere to the snail mail address published on my website.

=cut

