libtangram-perl 2.10-2 / usr / share / perl5 / Tangram / Relational.pm

use Tangram::Relational::Engine;

package Tangram::Relational;

sub new { bless { }, shift }

sub connect
  {
	my ($pkg, $schema, $cs, $user, $pw, $opt) = @_;
	$opt ||= {};
	$opt->{driver} = $pkg->new();
	my $storage
	    = Tangram::Storage->connect( $schema, $cs, $user, $pw, $opt );
  }

sub schema
  {
	my $self = shift;
	return Tangram::Schema->new( @_ );
  }

sub _with_handle {
    my $self = shift;
  my $method = shift;
  my $schema = shift;

  if (@_) {
	my $arg = shift;

	if (ref $arg) {
	  Tangram::Relational::Engine->new($schema, driver => $self)->$method($arg)
	} else {
	  my $dbh = DBI->connect($arg, @_);
	  eval { Tangram::Relational::Engine->new($schema, driver => $self)->$method($dbh) };
	  $dbh->disconnect();
  
	  die $@ if $@;
	}
  } else {
	Tangram::Relational::Engine->new($schema, driver => $self)->$method();
  }
}

sub deploy
  {
      my $self = (shift) || __PACKAGE__;
      $self->_with_handle('deploy', @_);
  }

sub retreat
  {
      my $self = (shift) || __PACKAGE__;
      $self->_with_handle('retreat', @_);
  }

# handle virtual SQL types.  Isn't SQL silly?
our ($sql_t_qr, @sql_t);
BEGIN {
    @sql_t =
	(
	 'VARCHAR'     => 'varchar',       # variable width
	 'CHAR'        => 'char',          # fixed width
	 'BLOB'        => 'blob',          # generic, large data store
	 'DATE|TIME|DATETIME|TIMESTAMP'
	               => 'date',
	 'BOOL'        => 'bool',
	 'INT|SHORTINT|TINYINT|LONGINT|MEDIUMINT|SMALLINT'
                       => 'integer',
	 'DECIMAL|NUMERIC|FLOAT|REAL|DOUBLE|SINGLE|EXTENDED'
	               => 'number',
	 'ENUM|SET'    => 'special',
	 ''            => 'general',
	);

    # compile the types to a single regexp.
    {
	my $c = 0;
	$sql_t_qr = "^(?:".join("|", map { "($_)" } grep {(++$c)&1}
				@sql_t).")";

	$sql_t_qr = qr/$sql_t_qr/i;
    }
}

sub type {
    my $self = shift if ref $_[0] or UNIVERSAL::isa($_[0], __PACKAGE__);
    $self ||= __PACKAGE__;
    my $type = shift;

    my @x = ($type =~ m{$sql_t_qr});

    my $c = 1;
    $c+=2 while not defined shift @x;

    my $func = $sql_t[$c];
    return $self->$func($type);

}

# convert a value from an RDBMS format => an internal format
sub from_dbms {
    my $self = ( (ref $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__))
		 ? shift
		 : __PACKAGE__);
    my $type = shift;
    my $value = shift;
    #print STDERR "Relational: converting (TO) $type $value\n";

    my $method = "from_$type";
    if ( $self->can($method) ) {
	return $self->$method($value);
    } else {
	return $value;
    }
}

# convert a value from an internal format => an RDBMS format
sub to_dbms {
    my $self = ( (ref $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__))
		 ? shift
		 : __PACKAGE__);
    my $type = shift;
    my $value = shift;
    #print STDERR "Relational: converting (TO) $type $value\n";

    my $method = "to_$type";
    if ( $self->can($method) ) {
	return $self->$method($value);
    } else {
	return $value;
    }
}

# generic / fallback date handler.  Use Date::Manip to parse
# `anything' and return a full ISO date
sub from_date {
    my $self = shift;
    my $value = shift;
    require 'Date/Manip.pm';
    return Date::Manip::UnixDate($value, '%Y-%m-%dT%H:%M:%S');
}

# an alternate ISO-8601 form that databases are more likely to grok
sub to_date {
    my $self = shift;
    my $value = shift;
    require 'Date/Manip.pm';
    return Date::Manip::UnixDate($value, '%Y-%m-%d %H:%M:%S');
}

use Carp;

# return a query to get a sequence value
sub sequence_sql {
    my $self = shift;
    my $sequence_name = shift or confess "no sequence name?";
    return "SELECT $sequence_name.nextval";
}

sub mk_sequence_sql {
    my $self = shift;
    my $sequence_name = shift;
    return "CREATE SEQUENCE $sequence_name";
}

sub drop_sequence_sql {
    my $self = shift;
    my $sequence_name = shift;
    return "DROP SEQUENCE $sequence_name";
}

# default mappings are no-ops
BEGIN {
    no strict 'refs';
    my $c = 0;
    *{$_} = sub { shift if UNIVERSAL::isa($_[0], __PACKAGE__); shift; }
	foreach grep {($c++)&1} @sql_t;
}

1;