The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# (c) Sound Object Logic 2000-2001

use strict;
use Tangram::Core;

package Tangram::mysql;

use base qw( Tangram::Relational );

sub connect
  {
	shift;
	return Tangram::mysql::Storage->connect( @_ );
  }

package Tangram::mysql::Storage;

use Tangram::Storage;
use base qw( Tangram::Storage );

sub make_id
  {
    my ($storage, $class_id) = @_;

	if ($storage->{layout1}) {
	  my $table = $storage->{schema}{class_table};
	  $storage->sql_do("UPDATE $table SET lastObjectId = LAST_INSERT_ID(lastObjectId + 1) WHERE classId = $class_id");
	} else {
	  my $table = $storage->{schema}{control};
	  $storage->sql_do("UPDATE $table SET mark = LAST_INSERT_ID(mark + 1)");
	}

    return sprintf "%d%0$storage->{cid_size}d", $storage->sql_selectall_arrayref("SELECT LAST_INSERT_ID()")->[0][0], $class_id;
  }

sub tx_start
  {
    my $storage = shift;
    $storage->sql_do(q/SELECT GET_LOCK("tx", 10)/)
      unless @{ $storage->{tx} };
    $storage->SUPER::tx_start(@_);
  }

sub tx_commit
  {
    my $storage = shift;
    $storage->SUPER::tx_commit(@_);
    $storage->sql_do(q/SELECT RELEASE_LOCK("tx")/)
      unless @{ $storage->{tx} };
  }

sub tx_rollback
  {
    my $storage = shift;
    $storage->sql_do(q/SELECT RELEASE_LOCK("tx")/);
    $storage->SUPER::tx_rollback(@_);
  }

my %improved_date =
  (
   'Tangram::RawDateTime' => 'Tangram::mysql::DateExpr',
   'Tangram::RawDate' => 'Tangram::mysql::DateExpr',
  );

sub expr
  {
    my $self = shift;
    my $type = shift;
    my ($expr, @remotes) = @_;
	
	return Tangram::mysql::IntegerExpr->new($type, $expr, @remotes)
	  if ref($type) eq 'Tangram::Integer';

    my $improved_date = $improved_date{ref($type)};
    return $improved_date->new($type, $expr, @remotes)
	  if $improved_date;

	return $type->expr(@_);
  }

package Tangram::mysql::IntegerExpr;
use base qw( Tangram::Expr );

sub bitwise_and
{
	my ($self, $val) = @_;
	return Tangram::Integer->expr("$self->{expr} & $val", $self->objects);
}

sub bitwise_nand
{
	my ($self, $val) = @_;
	return Tangram::Integer->expr("~$self->{expr} & $val",
							 $self->objects);
}

sub bitwise_or
{
	my ($self, $val) = @_;
	return Tangram::Integer->expr("$self->{expr} | $val", $self->objects);
}

sub bitwise_nor
{
	my ($self, $val) = @_;
	return Tangram::Integer->expr("~$self->{expr} | $val", $self->objects);
}

package Tangram::mysql::DateExpr;
use base qw( Tangram::Expr );

my %autofun = (
			   dayofweek => 'Integer',
			   weekday => 'Integer',
			   dayofmonth => 'Integer',
			   dayofyear => 'Integer',
			   month => 'Integer',
			   dayname => 'String',
			   monthname => 'String',
			   quarter => 'Integer',
			   week => 'Integer',
			   year => 'Integer',
			   yearweek => 'Integer',
			   to_days => 'Integer',
			   unix_timestamp => 'Integer',
			  );

use vars qw( $AUTOLOAD );
use Carp;

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

   my ($fun) = $AUTOLOAD =~ /\:\:(\w+)$/;

   croak "Unknown method '$fun'"
	 unless exists $autofun{$fun};

	eval <<SUBDEF;
sub $fun
{
	my (\$self, \$part) = \@_;
	my \$expr = \$self->expr();

	return Tangram\:\:$autofun{$fun}->expr("\U$fun\E(\$expr)", \$self->objects);
}
SUBDEF

  goto &$fun;
}

1;