File Coverage

blib/lib/Acme/BeyondPerl/ToSQL.pm

Criterion	Covered	Total	%
statement	83	111	74.7
branch	17	28	60.7
condition			n/a
subroutine	28	41	68.2
pod	0	22	0.0
total	128	202	63.3

package Acme::BeyondPerl::ToSQL;

use strict;
use DBI;
use Carp;

our $VERSION = 0.01;
our $DEBUG   = 0;

my $Dbh;   # database handle
my $Type;  # rdbm type

END {
	$Dbh->disconnect()
}

##############################################################################

sub import {
	my $class = shift;
	my %hash  = %{ $_[0] } if(@_ == 1);
	my ($dsn, $user, $pass, $opt) = (@_ > 1) ? @_ : @{$hash{dbi}};

	_connect($dsn, $user, $pass, $opt) unless($Dbh);

	_overload();

	overload::constant (
		integer => \&_integer_handler,
		float   => \&_float_handler,
	);

	if(defined $hash{debug}){ $DEBUG = $hash{debug}; }

}


my $OPs = {
	'+'    => sub { shift->add(@_) },
	'-'    => sub { shift->sub(@_) },
	'*'    => sub { shift->mul(@_) },
	'/'    => sub { shift->div(@_) },
	'%'    => sub { shift->mod(@_) },
	'**'   => sub { shift->pow(@_) },
	'log'  => sub { shift->log(@_) },
	'sqrt' => sub { shift->sqrt(@_)},
	'abs'  => sub { shift->abs(@_) },
	'cos'  => sub { shift->cos(@_) },
	'sin'  => sub { shift->sin(@_) },
	'exp'  => sub { shift->exp(@_) },
	'atan2'=> sub { shift->atan2(@_) },
	'<<'   => sub { shift->lshift(@_) },
	'>>'   => sub { shift->rshift(@_) },
	'&'    => sub { shift->and(@_) },
	'|'    => sub { shift->or(@_)  },
	'^'    => sub { shift->xor(@_) },
};


sub ops { return $OPs; }

sub Type { $Type; }

##############################################################################

sub _connect {
	my ($dsn, $user, $pass, $opts) = @_;

	$Dbh = DBI->connect($dsn, $user, $pass, $opts) or die $!;

	$Type = ($dsn =~ /dbi:(\w+)/)[0];
}


sub _overload {
	my $mod = __PACKAGE__ . '::' . $Type;

	eval qq| require $mod |;
	if($@){ croak "Can't load $mod."; }

	my $ops = $mod->ops;
	my %operators = (
		nomethod => \&_nomethod,
		'""'   => sub { ${$_[0]} },
		'<=>'  => sub { ${$_[0]} <=> ${$_[1]} },
		'0+'   => sub { ${$_[0]} },
		'bool' => sub { ${$_[0]} },
		'cmp'  => sub { ${$_[0]} cmp ${$_[1]} },
		%{ $ops }
	);

	eval q| use overload %operators |;
	if($@){ die $@; }

}


sub _integer_handler {
	my ($ori, $interp, $contect) = @_;
	return bless \$interp, __PACKAGE__ . "::$Type\::__Integer";
}

sub _float_handler {
	my ($ori, $interp, $contect) = @_;
	return bless \$interp, __PACKAGE__ . "::$Type\::__Float";
}


##############################################################################
# Use From Objects
##############################################################################

sub _calc_by_rdbm {
	if($DEBUG){ print "$_[0]\n"; }
	_float_handler( undef, $Dbh->selectrow_array($_[0]) );
}


sub _nomethod {
	my ($x, $y, $swap, $op) = @_;
	croak "This operator '$op' is not implemented in $Type";
}


sub _get_args {
	my ($x, $y, $swap) = @_;
	if($swap){ ($x, $y) = ($y, $x) }
	$x = $x->as_sql if(UNIVERSAL::can($x,'as_sql'));
	$y = $y->as_sql if(UNIVERSAL::can($y,'as_sql'));
	return ($x,$y);
}

sub _get_args_as_bits {
	my ($x, $y, $swap) = @_;
	if($swap){ ($x, $y) = ($y, $x) }
	$x = $x->as_bit if(UNIVERSAL::can($x,'as_sql'));
	$y = $y->as_bit if(UNIVERSAL::can($y,'as_sql'));
	return ($x,$y);
}

sub as_sql { ${$_[0]} }

sub as_bit { ${$_[0]} }

##############################################################################
# OPERATORS
##############################################################################

sub add {
	my ($x, $y) = _get_args(@_);
	_calc_by_rdbm("SELECT $x + $y");
}


sub sub {
	my ($x, $y) = _get_args(@_);
	_calc_by_rdbm("SELECT $x - $y");
}


sub mul {
	my ($x, $y) = _get_args(@_);
	_calc_by_rdbm("SELECT $x * $y");
}


sub div {
	my ($x, $y) = _get_args(@_);
	_calc_by_rdbm("SELECT $x / $y");
}


sub mod {
	my ($x, $y) = _get_args(@_);
	_calc_by_rdbm("SELECT $x % $y");
}


sub pow {
	my ($x, $y) = _get_args(@_);
	_calc_by_rdbm("SELECT pow($x, $y)");
}

sub abs {
	my ($x) = _get_args(@_);
	_calc_by_rdbm("SELECT abs($x)");
}

sub log {
	my ($x) = _get_args(@_);
	_calc_by_rdbm("SELECT ln($x)");
}

sub exp {
	my ($x) = _get_args(@_);
	_calc_by_rdbm("SELECT exp($x)");
}

sub sqrt {
	my ($x) = _get_args(@_);
	_calc_by_rdbm("SELECT sqrt($x)");
}

sub sin {
	my ($x) = _get_args(@_);
	_calc_by_rdbm("SELECT sin($x)");
}

sub cos {
	my ($x) = _get_args(@_);
	_calc_by_rdbm("SELECT cos($x)");
}

sub atan2 {
	my ($x, $y) = _get_args(@_);
	_calc_by_rdbm("SELECT atan2($x, $y)");
}

sub lshift {
	my ($x, $y) = _get_args_as_bits(@_);
	_calc_by_rdbm("SELECT $x << $y");
}

sub rshift {
	my ($x, $y) = _get_args_as_bits(@_);
	_calc_by_rdbm("SELECT $x >> $y");
}

sub and {
	my ($x, $y) = _get_args_as_bits(@_);
	_calc_by_rdbm("SELECT $x & $y");
}

sub or {
	my ($x, $y) = _get_args_as_bits(@_);
	_calc_by_rdbm("SELECT $x | $y");
}

sub xor {
	my ($x, $y) = _get_args_as_bits(@_);
	_calc_by_rdbm("SELECT $x ^ $y");
}

##############################################################################
1;
__END__