1 2 3package Tangram::Relational; 4 5use Tangram::Relational::Engine; 6 7use Carp qw(cluck); 8use strict; 9 10sub new { bless { }, shift } 11 12# XXX - not tested by test suite 13sub connect 14 { 15 my ($pkg, $schema, $cs, $user, $pw, $opt) = @_; 16 $opt ||= {}; 17 $opt->{driver} = $pkg->new(); 18 my $storage 19 = Tangram::Storage->connect( $schema, $cs, $user, $pw, $opt ); 20 } 21 22sub schema 23 { 24 my $self = shift; 25 return Tangram::Schema->new( @_ ); 26 } 27 28sub _with_handle { 29 my $self = shift; 30 my $method = shift; 31 my $schema = shift; 32 33 if (@_) { 34 my $arg = shift; 35 36 if (ref $arg) { 37 Tangram::Relational::Engine->new($schema, driver => $self)->$method($arg) 38 } else { 39 # try to automatically select the correct driver 40 if ( !ref $self and $self eq __PACKAGE__ ) { 41 $self = $self->detect($arg); 42 } 43 my $dbh = DBI->connect($arg, @_); 44 eval { Tangram::Relational::Engine->new($schema, driver => $self)->$method($dbh) }; 45 $dbh->disconnect(); 46 47 die $@ if $@; 48 } 49 } else { 50 Tangram::Relational::Engine->new($schema, driver => $self)->$method(); 51 } 52} 53 54# XXX - not tested by test suite 55sub detect 56 { 57 my $self = shift; 58 my $dbi_cs = shift; 59 $dbi_cs =~ m{dbi:(\w+):} or return (ref $self || $self); 60 my $pkg = "Tangram::Driver::$1"; 61 eval "use $pkg"; 62 if ( !$@ ) { 63 print $Tangram::TRACE 64 __PACKAGE__.": using the $pkg driver for $dbi_cs\n" 65 if $Tangram::TRACE; 66 return $pkg; 67 } else { 68 return (ref $self || $self); 69 } 70 } 71 72# XXX - not tested by test suite 73sub name 74 { 75 my $self = shift; 76 my $pkg = (ref $self || $self); 77 if ( $pkg eq __PACKAGE__ ) { 78 return "vanilla"; 79 } elsif ( $pkg =~ m{::Driver::(.*)} ) { 80 return $1; 81 } else { 82 return $pkg; 83 } 84 } 85 86sub deploy 87 { 88 my $self = (shift) || __PACKAGE__; 89 $self->_with_handle('deploy', @_); 90 } 91 92sub retreat 93 { 94 my $self = (shift) || __PACKAGE__; 95 $self->_with_handle('retreat', @_); 96 } 97 98# handle virtual SQL types. Isn't SQL silly? 99our ($sql_t_qr, @sql_t); 100BEGIN { 101 @sql_t = 102 ( 103 'VARCHAR\s*(?:\(\s*\d+\s*\))?' => 'varchar', # variable width 104 'CHAR\s*(?:\(\s*\d+\s*\))?' => 'char', # fixed width 105 'BLOB' => 'blob', # generic, large data store 106 'DATE|TIME|DATETIME|TIMESTAMP' 107 => 'date', 108 'BOOL' => 'bool', 109 'INT(?:EGER)?|SHORTINT|TINYINT|LONGINT|MEDIUMINT|SMALLINT' 110 => 'integer', 111 'DECIMAL|NUMERIC|FLOAT|REAL|DOUBLE|SINGLE|EXTENDED' 112 => 'number', 113 'ENUM|SET' => 'special', 114 '\w+\s*(?:\(\s*\d+\s*\))?' => 'general', 115 ); 116 117 # compile the types to a single regexp. 118 { 119 my $c = 0; 120 $sql_t_qr = "^(?:".join("|", map { "($_)" } grep {(++$c)&1} 121 @sql_t).")\\s*(?i:(?i:NOT\\s+)?NULL)?\\s*\$"; 122 123 $sql_t_qr = qr/$sql_t_qr/i; 124 } 125} 126 127sub type { 128 my $self = shift if ref $_[0] or UNIVERSAL::isa($_[0], __PACKAGE__); 129 $self ||= __PACKAGE__; 130 my $type = shift; 131 132 my @x = ($type =~ m{$sql_t_qr}); 133 134 my $c = @x ? 1 : @sql_t; 135 $c+=2 while not defined shift @x and @x; 136 137 my $func = $sql_t[$c] or do { 138 cluck "type '$type' didn't match $sql_t_qr"; 139 return $type; 140 }; 141 my $new_type = $self->$func($type); 142 if ( $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 1 ) { 143 print $Tangram::TRACE 144 __PACKAGE__.": re-wrote $type to $new_type via " 145 .ref($self)."::$func\n"; 146 } 147 return $new_type; 148} 149 150# convert a value from an RDBMS format => an internal format 151sub from_dbms { 152 my $self = ( UNIVERSAL::isa($_[0], __PACKAGE__) 153 ? shift 154 : __PACKAGE__); 155 my $type = shift; 156 my $value = shift; 157 #print STDERR "Relational: converting (TO) $type $value\n"; 158 159 my $method = "from_$type"; 160 if ( $self->can($method) ) { 161 return $self->$method($value); 162 } else { 163 return $value; 164 } 165} 166 167# convert a value from an internal format => an RDBMS format 168sub to_dbms { 169 my $self = ( UNIVERSAL::isa($_[0], __PACKAGE__) 170 ? shift 171 : __PACKAGE__); 172 my $type = shift; 173 my $value = shift; 174 #print STDERR "Relational: converting (TO) $type $value\n"; 175 176 my $method = "to_$type"; 177 if ( $self->can($method) ) { 178 return $self->$method($value); 179 } else { 180 return $value; 181 } 182} 183 184# generic / fallback date handler. Use Date::Manip to parse 185# `anything' and return a full ISO date 186sub from_date { 187 my $self = shift; 188 my $value = shift; 189 require 'Date/Manip.pm'; 190 return Date::Manip::UnixDate($value, '%Y-%m-%dT%H:%M:%S'); 191} 192 193# an alternate ISO-8601 form that databases are more likely to grok 194sub to_date { 195 my $self = shift; 196 my $value = shift; 197 require 'Date/Manip.pm'; 198 return Date::Manip::UnixDate($value, '%Y-%m-%d %H:%M:%S'); 199} 200 201# generic / fallback date handler. Use Date::Manip to parse 202# `anything' and return a full ISO date 203# XXX - not tested by test suite 204sub from_date_hires { 205 my $self = shift; 206 my $value = shift; 207 $value =~ s{ }{T}; 208 return $value; 209} 210 211# this one is a lot more restrictive. Assume that no DBs understand T 212# in a date 213# XXX - not tested by test suite 214sub to_date_hires { 215 my $self = shift; 216 my $value = shift; 217 $value =~ s{T}{ }; 218 return $value; 219} 220 221use Carp; 222 223# return a query to get a sequence value 224# XXX - not tested by test suite 225sub sequence_sql { 226 my $self = shift; 227 my $sequence_name = shift or confess "no sequence name?"; 228 return "SELECT $sequence_name.nextval"; 229} 230 231# XXX - not tested by test suite 232sub mk_sequence_sql { 233 my $self = shift; 234 my $sequence_name = shift; 235 return "CREATE SEQUENCE $sequence_name"; 236} 237 238# XXX - not tested by test suite 239sub drop_sequence_sql { 240 my $self = shift; 241 my $sequence_name = shift; 242 return "DROP SEQUENCE $sequence_name"; 243} 244 245# default mappings are no-ops 246BEGIN { 247 no strict 'refs'; 248 my $c = 0; 249 *{$_} = sub { shift if UNIVERSAL::isa($_[0], __PACKAGE__); shift; } 250 foreach grep {($c++)&1} @sql_t; 251} 252 2531; 254