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