/usr/share/perl5/Tangram/Relational.pm is in libtangram-perl 2.10-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | 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;
|