File Coverage

blib/lib/Basset/DB/Table.pm
Criterion Covered Total %
statement 59 411 14.3
branch 21 236 8.9
condition 2 36 5.5
subroutine 12 46 26.0
pod 35 39 89.7
total 129 768 16.8


line stmt bran cond sub pod time code
1             package Basset::DB::Table;
2              
3             #Basset::DB::Table Copyright and (c) 2002, 2003, 2004, 2005, 2006 James A Thomason III
4             #Basset::DB::Table is distributed under the terms of the Perl Artistic License.
5              
6             our $VERSION = '1.02';
7              
8             =pod
9              
10             =head1 NAME
11              
12             Basset::DB::Table - used to define database tables, ways to load that data into memory
13             and build queries based upon the table information
14              
15             =head1 AUTHOR
16              
17             Jim Thomason, jim@jimandkoka.com
18              
19             =head1 SYNOPSIS
20              
21             For example,
22              
23             my $table = Basset::DB::Table->new(
24             'name' => 'user',
25             'primary_column' => 'id',
26             'autogenerated' => 1,
27             'definition' => {
28             'id' => 'SQL_INTEGER',
29             'username' => 'SQL_VARCHAR',
30             'password' => 'SQL_VARCHAR',
31             'name' => 'SQL_VARCHAR'
32             }
33             );
34              
35             print $table->insert_query, "\n";
36             print $table->update_query, "\n";
37             print $table->delete_query, "\n";
38              
39             =head1 DESCRIPTION
40              
41             Basset::DB::Table provides an abstract and consistent location for defining database tables,
42             building queries based upon them, and so on. It is rarely (if ever) used directly in code, but is
43             used extensively in packages which subclass from Basset::Object::Persistent.
44              
45             Any queries returned by the query methods are simply strings that must be prepared by DBI
46             in order bo be used.
47              
48             =cut
49              
50 3     3   37360 use Basset::Object;
  3         9  
  3         252  
51             our @ISA = Basset::Object->pkg_for_type('object');
52              
53 3     3   20 use strict;
  3         7  
  3         141  
54 3     3   16 use warnings;
  3         6  
  3         23388  
55              
56             =pod
57              
58             =head1 ATTRIBUTES
59              
60             =over
61              
62             =cut
63              
64             =pod
65              
66             =item name
67              
68             The name of the database table.
69              
70             For example, if you're creating an object to reference the table "foo",
71              
72             $table->name('foo');
73              
74             =cut
75              
76             =pod
77              
78             =begin btest name
79             $| = 1;
80             my $o = __PACKAGE__->new();
81             $test->ok($o, "Created object");
82             $test->ok($o->name('test name'), "Set name");
83             $test->is($o->name, 'test name', "retrieved name");
84             $test->is($o->name('test name 2'), 'test name 2', 're-set name');
85             $test->is($o->name, 'test name 2', 'retrieved reset name');
86              
87             $test->is(scalar(__PACKAGE__->name('invalid name')), undef, 'Could not set name for class attribute');
88              
89             =end btest
90              
91             =cut
92              
93             __PACKAGE__->add_attr('name');
94              
95             =pod
96              
97             =item primary_column
98              
99             Stores the primary column or columns for this table. Either passed a single scalar or
100             an array ref.
101              
102             $table->primary_column('id'); #id is the primary column
103             $table2->primary_column(['id', 'name']) #id & name are the primary columns
104              
105             It is recommended to access the primary columns of a table via the primary_cols method, since that
106             method will always return an array.
107              
108             $table->primary_cols #returns ('id')
109             $table2->primary_cols #returns ('id', 'name')
110              
111             $table->primary_column #returns 'id'
112             $table2->primary_column #returns ['id', 'name']
113              
114             =cut
115              
116             =pod
117              
118             =begin btest primary_column
119              
120             my $o = __PACKAGE__->new();
121             $test->ok($o, "Created object");
122             $test->ok($o->primary_column('id'), "Set primary column");
123             $test->is($o->primary_column, 'id', "retrieved primary column");
124             $test->is($o->primary_column('id2'), 'id2', 're-set primary column');
125             $test->is($o->primary_column, 'id2', 'retrieved reset primary column');
126              
127             my $a = [qw(id id2)];
128             $test->ok($a, "created arrayref");
129             $test->is($a->[0], 'id', 'proper array element 0');
130             $test->is($a->[1], 'id2', 'proper array element 1');
131             $test->is($o->primary_column($a), $a, 'set primary column to arrayref');
132              
133             $test->is(scalar(__PACKAGE__->primary_column('invalid name')), undef, 'Could not set primary column for class attribute');
134              
135             =end btest
136              
137             =cut
138              
139              
140             __PACKAGE__->add_attr('primary_column');
141              
142             =pod
143              
144             =item autogenerated
145              
146             boolean flag, 1/0
147              
148             Sometimes, you may have your database auto-generate a column value for you. If you are using
149             unique IDs for instance, it may be easier to have the database manage the auto-generation of new
150             unique IDs for you. Set this flag if that's the case.
151              
152             #in your db
153             create table foo (id int unsigned not null primary key auto_generated);
154              
155             #in your code
156             $table->name('foo');
157             $table->primary_column('id');
158             $table->autogenerated(1);
159              
160             =cut
161              
162             =pod
163              
164             =begin btest autogenerated
165              
166             my $o = __PACKAGE__->new();
167              
168             $test->ok($o, "created object");
169             $test->is($o->autogenerated(1), 1, "set autogenerated");
170             $test->is($o->autogenerated(), 1, "accessed autogenerated");
171             $test->is($o->autogenerated(0), 0, "shut off autogenerated");
172             $test->is($o->autogenerated, 0, "accessed autogenerated");
173              
174             $test->is(scalar(__PACKAGE__->autogenerated(1)), undef, "Could not set autogenerated for class");
175              
176             =end btest
177              
178             =cut
179              
180              
181             __PACKAGE__->add_attr('autogenerated');
182              
183             =pod
184              
185             =item definition
186              
187             This is the actual definition of your table. It should be given a hashref, with the keys being
188             your column names, and the values being the sql_type as defined in DBI for that column.
189              
190             $table->definition(
191             {
192             'name' => 'SQL_VARCHAR',
193             'id' => 'SQL_INTEGER'
194             }
195             );
196              
197             Note that the type should be a quoted string containing the value, not the actual constant
198             defined in DBI. If there is no corresponding sql_type for your column (for a MySQL text column,
199             for example), then pass undef.
200              
201             $table->definition(
202             {
203             'name' => 'SQL_INTEGER',
204             'bigcomment' => undef
205             }
206             );
207              
208             Alternatively, if you happen to know the SQL type in advance, you can just pass that along.
209              
210             $table->definition(
211             {
212             'name' => SQL_INTEGER, #if DBI was used here
213             'bigcomment' => undef
214             }
215             );
216              
217             $table->definition(
218             {
219             'name' => 4, #if you just know it's 4
220             'bigcomment' => undef
221             }
222             );
223              
224             You should always use the quoted version unless you've received the numeric type from an authoritative
225             source, such as having it returned from the database as the column type.
226              
227             Alternatively, if you don't want to use a definition, you can explicitly tell the constructor your non primary columns
228              
229             $table = Basset::DB::Table->new(
230             'primary_column' => 'id',
231             'non_primary_columns' => [qw(name age serial_number)],
232             );
233              
234             That takes the place of using the definition. It does a discover call behind the scenes, but only looks for the columns
235             that you've specified, not everything in the table.
236              
237             =cut
238              
239             =pod
240              
241             =begin btest definition
242              
243             my $o = __PACKAGE__->new();
244             $test->ok($o, "Got object");
245              
246             my $h = {'foo' => 'bar', 'baz' => 'yee'};
247             $test->ok($h, 'got hashref');
248             $test->is($h->{'foo'}, 'bar', 'foo is bar');
249             $test->is($h->{'baz'}, 'yee', 'baz is yee');
250             $test->is($o->definition($h), $h, "Set definition");
251             $test->is($o->definition(), $h, 'reset definition');
252             $test->is(scalar(__PACKAGE__->definition(1)), undef, 'Could not set definition for class');
253              
254             =end btest
255              
256             =cut
257              
258              
259             __PACKAGE__->add_attr('definition');
260              
261             =pod
262              
263             =item references
264              
265             Naturally, since you're using a relational database, you're going to have tables referencing other tables. You can store
266             them in your Basset::DB::Table object inside the references parameter.
267              
268             $table->references(
269             {
270             'user_id' => 'user.id',
271             'food_type' => 'food.type',
272             }
273             );
274              
275             That says that the 'user_id' column in your table is a foreign key into the user table and references its id column. 'food_type'
276             is a foreign key into the food table and references its type column.
277              
278             Any foreign keys referencing primary columns can be used to auto-join the tables in a multiselect_query.
279              
280             =cut
281              
282             =pod
283              
284             =begin btest references
285              
286             my $o = __PACKAGE__->new();
287             $test->ok($o, "Got object");
288              
289             my $h = {'foo' => 'bar', 'baz' => 'yee'};
290             $test->ok($h, 'got hashref');
291             $test->is($h->{'foo'}, 'bar', 'foo is bar');
292             $test->is($h->{'baz'}, 'yee', 'baz is yee');
293             $test->is($o->references($h), $h, "Set references");
294             $test->is($o->references(), $h, 'reset references');
295             $test->is(scalar(__PACKAGE__->references(1)), undef, 'Could not set references for class');
296              
297             =end btest
298              
299             =cut
300              
301             __PACKAGE__->add_attr('references');
302              
303             =pod
304              
305             =item extra_select
306              
307             Okay, as of v1.01 (heh, I finally incremented a version number!) Basset::DB::Table has gotten a power boost. It's
308             now arbitrary out the ying-yang. Much more power in terms of what you can and cannot select, insert, update, etc.
309              
310             The first of the new toys is extra_select.
311              
312             Let's assume the following definition:
313              
314             $table->name('test');
315             $table->definition(
316             {
317             'name' => 'SQL_INTEGER',
318             'bigcomment' => undef
319             }
320             );
321              
322             That means that if you called select_query on that table, you'd get back this:
323              
324             select test.bigcomment, test.name from test
325              
326             Which is peachy and marvelous. You can now initialize your object with the values from 'name' and 'bigcomment'. But
327             what if you want more information from the database? Perhaps a value from a function, or some calculation upon the
328             columns? Up until now, you'd have to do that stuff externally in Perl. Either calculating things yourself, or calling
329             arbitrary_sql to get the data you need out of there.
330              
331             No more. extra_select does what it sounds like, it allows you to pass in extra information to select. Takes a hashref.
332              
333             $table->extra_select(
334             {
335             'current_time' => 'NOW()'
336             }
337             );
338              
339             Now, if you called select_query, you'd get back:
340              
341             select test.bigcomment, test.name, NOW() as current_time from test
342              
343             And voila. Instant extra information.
344              
345             Keep in mind, naturally, that if you want that extra column you're getting out to *go* anywhere, that your object
346             must have a method by that name ("current_time" in this case). Otherwise, the data will be loaded and then silently forgotten.
347              
348             If you're skipping ahead, you'll see that there are attributes called "db_write_translation", and "db_read_translation".
349             Use whichever thing is appropriate for you.
350              
351             extra_select only affects select queries.
352              
353             =cut
354              
355             =begin btest extra_select
356              
357             my $o = __PACKAGE__->new();
358             $test->ok($o, "Got object");
359              
360             my $h = {'foo' => 'bar', 'baz' => 'yee'};
361             $test->ok($h, 'got hashref');
362             $test->is($h->{'foo'}, 'bar', 'foo is bar');
363             $test->is($h->{'baz'}, 'yee', 'baz is yee');
364             $test->is($o->extra_select($h), $h, "Set extra_select");
365             $test->is($o->extra_select(), $h, 'reset extra_select');
366             $test->is(scalar(__PACKAGE__->extra_select(1)), undef, 'Could not set extra_select for class');
367              
368             =end btest
369              
370             =cut
371              
372             __PACKAGE__->add_attr('extra_select');
373              
374             =pod
375              
376             =item db_read_translation
377              
378             =cut
379              
380             =pod
381              
382             New addition to the various things, since I finally thought of a use for it. The db_read_translation alters your columns as they
383             come back from the database. Takes a hash of the form I => I
384              
385             $table->db_read_translation(
386             {
387             'name' => 'lower(name)'
388             }
389             );
390              
391             And that would change as follows:
392              
393             print $table->select_query; #prints select table.name as name from table
394              
395             with the translation:
396              
397             print $table->select_query; #prints select lower(table.name) as name from table
398              
399             Useful if you know at the database level that you'll need your data transformed in some fashion.
400              
401             =cut
402              
403             =begin btest db_read_translation
404              
405             my $o = __PACKAGE__->new();
406             $test->ok($o, "Got object");
407              
408             my $h = {'foo' => 'bar', 'baz' => 'yee'};
409             $test->ok($h, 'got hashref');
410             $test->is($h->{'foo'}, 'bar', 'foo is bar');
411             $test->is($h->{'baz'}, 'yee', 'baz is yee');
412             $test->is($o->db_read_translation($h), $h, "Set db_read_translation");
413             $test->is($o->db_read_translation(), $h, 'reset db_read_translation');
414             $test->is(scalar(__PACKAGE__->db_read_translation(1)), undef, 'Could not set db_read_translation for class');
415              
416             =end btest
417              
418             =cut
419              
420             __PACKAGE__->add_attr(['db_read_translation', '_isa_translation_accessor']);
421              
422             =pod
423              
424             =item db_write_translation
425              
426             This is the closest thing to an inverse method to extra_select. db_write_translation takes a hashref which decides how
427             to re-write your insert, update, replace, or delete queries. Or all of them. An example is easiest.
428              
429             Let's assume the following definition:
430              
431             $table->name('test');
432             $table->definition(
433             {
434             'name' => 'SQL_INTEGER',
435             'bigcomment' => undef,
436             'current_time' => 'SQL_DATETIME',
437             }
438             );
439             update test set current_time = ?, bigcomment = ?, name = ?
440              
441             Then, if you called update_query, you'd get back:
442              
443             update test set current_time = ?, bigcomment = ?, name = ?
444              
445             And your update_bindables are:
446              
447             current_time, bigcomment, name, name
448              
449             However, that wouldn't be setting current_time to the proper current time: it's just relaying through the value in the object.
450             So it's up to you, the programmer, to set it yourself.
451              
452             sub commit {
453             my $self = shift;
454             my ($sec,$min,$hour,$day,$mon,$year) = (localtime(time))[0..5];
455             $mon++;
456             $year+= 1900;
457             $self->current_time("$year-$mon-$day $hour:$min:$sec");
458              
459             $self->SUPER::commit(@_);
460             };
461              
462             It works, it's effective, but it's a pain in the butt. More work for you. This is an instance where db_write_translation
463             can come in handy.
464              
465             $table->db_write_translation(
466             {
467             'current_time' => {
468             'A' => {
469             'val' => 'NOW()',
470             'binds' => 0
471             }
472             }
473             }
474             );
475              
476             Now, your update_query is:
477              
478             update test set current_time = NOW(), bigcomment = ?, name = ?
479              
480             And your update_bindables are:
481              
482             bigcomment, name, name
483              
484             Voila. You no longer need to worry about setting current_time, the db does it for you.
485              
486             The hashref that db_write_translation uses is of a specific format:
487              
488             method => {
489             query_type => {
490             'val' => new_value
491             'binds' => 0/1
492             }
493             }
494              
495             "method" is obviously the name of the method that's being re-written.
496             "query_type" is the flag to indicate the type of query. "I" for insert, "U" for update, "D" for delete, "R" for replace,
497             or "A" for all.
498             "binds" is a boolean flag, 0 or 1. Set to 0 if you're inserting a new value that doesn't need a binded param, such as "NOW()".
499             Set it to 1 if you're inserting a new value that does need a binded param, such as "LCASE(?)" to insert the value in lower case.
500              
501             And voila. When the query is constructed, internally it first looks for a re-write of the method for the given query type. If
502             it doesn't find one, it looks for a re-write of type "A" (all queries), if it doesn't find one of those, then it just leaves it
503             alone and preps the query to insert the value in as is, unchanged.
504              
505             One useful example that I will include, is to make a column read-only:
506              
507             $table->db_write_translation(
508             {
509             $column => {
510             'U' => {
511             'val' => $column,
512             'binds' => 0
513             }
514             }
515             }
516             );
517              
518             That way, when an object is committed on an update, $column's value will not change.
519              
520             Also, please note that return values are not quoted. So you can't use a db_write_translation to set a value that the database
521             wouldn't understand.
522              
523             'val' => 'some constant value'
524              
525             will fail. Your query would become:
526              
527             update....set foo = some constant value...
528              
529             which chokes, of course. Use a wrapper to alter the value you pass in at a higher level, or quote it yourself.
530             The db_write_translation only alters your actual SQL statement.
531              
532             =cut
533              
534             =begin btest db_write_translation
535              
536             my $o = __PACKAGE__->new();
537             $test->ok($o, "Got object");
538              
539             my $h = {'foo' => 'bar', 'baz' => 'yee'};
540             $test->ok($h, 'got hashref');
541             $test->is($h->{'foo'}, 'bar', 'foo is bar');
542             $test->is($h->{'baz'}, 'yee', 'baz is yee');
543             $test->is($o->db_write_translation($h), $h, "Set db_write_translation");
544             $test->is($o->db_write_translation(), $h, 'reset db_write_translation');
545             $test->is(scalar(__PACKAGE__->db_write_translation(1)), undef, 'Could not set db_write_translation for class');
546              
547             =end btest
548              
549             =cut
550              
551             __PACKAGE__->add_attr(['db_write_translation', '_isa_translation_accessor']);
552              
553             =pod
554              
555             =item column_aliases
556              
557             You can define different aliases for columns as they come out of your table.
558              
559             $table->select_columns('id');
560              
561             print $table->select_query; #prints select id from foo
562              
563             $table->column_aliases(
564             {
565             'id' => 'user_id'
566             }
567             );
568              
569             print $table->select_query #prints select id as user_id from foo
570              
571             Note that Basset::Object::Persistent assumes that if you're aliasing a column, that the aliased value is your method name.
572             So in this case, any objects using that as a primary table would have a method name of 'user_id' that stores in the 'id'
573             column in the table.
574              
575             =cut
576              
577             =pod
578              
579             =begin btest column_aliases
580              
581             my $aliases = {
582             'able' => 'aliased_able',
583             'baker' => 'aliased_baker',
584             'charlie' => 'aliased_charlie',
585             'delta' => 'aliased_delta'
586             };
587              
588             my $o = __PACKAGE__->new();
589             $test->ok($o, "Created object");
590              
591             $test->is($o->column_aliases($aliases), $aliases, "Set column aliases");
592             $test->is($o->column_aliases(), $aliases, "Got column aliases");
593              
594             =end btest
595              
596             =cut
597              
598             __PACKAGE__->add_attr('column_aliases');
599              
600             # internally stores all previously built queries for this table, for speed.
601             # caches are generated per table/query/columns
602             __PACKAGE__->add_attr('_cached_queries');
603              
604             =pod
605              
606             =begin btest _cached_queries
607              
608             my $o = __PACKAGE__->new();
609             $test->ok($o, "Got object");
610             $test->is(scalar(__PACKAGE__->_cached_queries), undef, "could not call object method as class method");
611             $test->is(__PACKAGE__->errcode, "BO-08", "proper error code");
612             $test->is(ref($o->_cached_queries), 'HASH', '_cached_queries is hashref');
613             $test->is($o->_cached_queries('abc'), 'abc', 'set _cached_queries to abc');
614             $test->is($o->_cached_queries(), 'abc', 'read value of _cached_queries - abc');
615             my $h = {};
616             $test->ok($h, 'got hashref');
617             $test->is($o->_cached_queries($h), $h, 'set _cached_queries to hashref');
618             $test->is($o->_cached_queries(), $h, 'read value of _cached_queries - hashref');
619             my $a = [];
620             $test->ok($a, 'got arrayref');
621             $test->is($o->_cached_queries($a), $a, 'set _cached_queries to arrayref');
622             $test->is($o->_cached_queries(), $a, 'read value of _cached_queries - arrayref');
623              
624             =end btest
625              
626             =cut
627              
628             # internally stores all previously built bindables for this table, for speed.
629             # caches are generated per table/query/columns
630             __PACKAGE__->add_attr('_cached_bindables');
631              
632             =pod
633              
634             =begin btest _cached_bindables
635              
636             my $o = __PACKAGE__->new();
637             $test->ok($o, "Got object");
638             $test->is(scalar(__PACKAGE__->_cached_bindables), undef, "could not call object method as class method");
639             $test->is(__PACKAGE__->errcode, "BO-08", "proper error code");
640             $test->is(ref($o->_cached_bindables), 'HASH', '_cached_bindables is hashref');
641             $test->is($o->_cached_bindables('abc'), 'abc', 'set _cached_bindables to abc');
642             $test->is($o->_cached_bindables(), 'abc', 'read value of _cached_bindables - abc');
643             my $h = {};
644             $test->ok($h, 'got hashref');
645             $test->is($o->_cached_bindables($h), $h, 'set _cached_bindables to hashref');
646             $test->is($o->_cached_bindables(), $h, 'read value of _cached_bindables - hashref');
647             my $a = [];
648             $test->ok($a, 'got arrayref');
649             $test->is($o->_cached_bindables($a), $a, 'set _cached_bindables to arrayref');
650             $test->is($o->_cached_bindables(), $a, 'read value of _cached_bindables - arrayref');
651              
652             =end btest
653              
654             =cut
655              
656              
657             =pod
658              
659             =item *_columns
660              
661             insert_columns
662             update_columns
663             delete_columns
664             replace_columns
665             select_columns
666              
667             Normally, when you get back an insert_query, update_query, etc. from the various DB::Table methods here, all columns
668             in the table are included. You can use these methods to restrict the queries to only be called on particular methods.
669              
670             print $table->insert_query; #prints insert into foo (this, that, those) values (?,?,?) for example
671             $table->insert_columns('this');
672             print $table->insert-query; #prints insert into foo (this) values (?) for example
673              
674             These methods are not thread-safe.
675              
676             You also have a set of negative non_*_columns that do an inverse.
677              
678             print $table->insert_query; #prints insert into foo (this, that, those) values (?,?,?) for example
679             $table->non_insert_columns('this');
680             print $table->insert-query; #prints insert into foo (that, those) values (?,?,?) for example
681              
682             You may also use both at the same time
683              
684             print $table->insert_query; #prints insert into foo (this, that, those) values (?,?,?) for example
685             $table->insert_columns('that', 'those');
686             $table->non_insert_columns('that');
687             print $table->insert-query; #prints insert into foo (those) values (?,?) for example
688              
689             =cut
690              
691             =pod
692              
693             =item last_insert_query
694              
695             All databases grab the last inserted ID in a different fashion. last_insert_query allows us to specify the query we use to grab
696             the last inserted ID for a given insert. This should probably be specified in the conf file, but you can do it in the individual
697             modules, if you prefer. Note that this is a trickling class accessor, so you can re-define it as many times as you want, or
698             just use the default specified for Basset::Object::Persistent.
699              
700             Certain databases don't need differeing queries. MySQL, for instance, is happy with just "SELECT LAST_INSERT_ID()" defined for
701             the super class.
702              
703             =cut
704              
705             __PACKAGE__->add_attr('last_insert_query');
706              
707             =pod
708              
709             =begin btest last_insert_query
710              
711             my $o = __PACKAGE__->new();
712             $test->ok($o, "got object");
713              
714             $test->ok(! scalar(__PACKAGE__->last_insert_query), "Cannot call object method as class method");
715              
716             $test->is($o->last_insert_query('foo'), 'foo', "set query to foo");
717             $test->is($o->last_insert_query(), 'foo', 'got insert query');
718              
719             =end btest
720              
721             =cut
722              
723             =pod
724              
725             =begin btest insert_columns
726              
727             my $o = __PACKAGE__->new();
728             $test->ok($o, "Created object");
729             my $def = {
730             'able' => 'SQL_INTEGER',
731             'baker' => 'SQL_INTEGER',
732             'charlie' => 'SQL_INTEGER',
733             'delta' => 'SQL_INTEGER'
734             };
735              
736             $test->is($o->definition($def), $def, "Set definition");
737             $test->is($o->definition, $def, "Got definition");
738              
739             {
740             my %icols = map {$_, 1} $o->insert_columns();
741              
742             $test->is($icols{'able'}, 1, 'able is an insert col');
743             $test->is($icols{'baker'}, 1, 'baker is an insert col');
744             $test->is($icols{'charlie'}, 1, 'charlie is an insert col');
745             $test->is($icols{'delta'}, 1, 'delta is an insert col');
746             $test->is(scalar(keys %icols), 4, 'only 4 insert columns');
747             }
748              
749             {
750             my $icols = [qw(able charlie)];
751              
752             $test->is(join(',',$o->insert_columns($icols)), join(',',@$icols), "set new insert columns");
753             $test->is(join(',',$o->insert_columns), join(',',@$icols), "got new insert columns");
754              
755              
756             my %icols = map {$_, 1} $o->insert_columns();
757              
758             $test->is($icols{'able'}, 1, 'able is an insert col');
759             $test->is($icols{'baker'}, undef, 'baker is not an insert col');
760             $test->is($icols{'charlie'}, 1, 'charlie is an insert col');
761             $test->is($icols{'delta'}, undef, 'delta is not an insert col');
762             $test->is(scalar(keys %icols), 2, 'only 2 insert columns');
763             }
764              
765             {
766             my $icols = [qw()];
767              
768             $o->insert_columns($icols);
769              
770             my %icols = map {$_, 1} $o->insert_columns();
771              
772             $test->is($icols{'able'}, 1, 'able is an insert col');
773             $test->is($icols{'baker'}, 1, 'baker is an insert col');
774             $test->is($icols{'charlie'}, 1, 'charlie is an insert col');
775             $test->is($icols{'delta'}, 1, 'delta is an insert col');
776             $test->is(scalar(keys %icols), 4, '4 insert columns');
777             }
778              
779             {
780             $o->insert_columns(undef);
781             my %icols = map {$_, 1} $o->insert_columns();
782              
783             $test->is($icols{'able'}, 1, 'able is an insert col');
784             $test->is($icols{'baker'}, 1, 'baker is an insert col');
785             $test->is($icols{'charlie'}, 1, 'charlie is an insert col');
786             $test->is($icols{'delta'}, 1, 'delta is an insert col');
787             $test->is(scalar(keys %icols), 4, '4 insert columns');
788             }
789              
790             $test->is(scalar($o->insert_columns(['junk'])), undef, 'could not insert unknown column');
791             $test->is($o->errcode, 'BDT-13', 'proper error code');
792              
793             =end btest
794              
795             =cut
796              
797             =pod
798              
799             =begin btest update_columns
800              
801             my $o = __PACKAGE__->new();
802             $test->ok($o, "Created object");
803             my $def = {
804             'able' => 'SQL_INTEGER',
805             'baker' => 'SQL_INTEGER',
806             'charlie' => 'SQL_INTEGER',
807             'delta' => 'SQL_INTEGER'
808             };
809              
810             $test->is($o->definition($def), $def, "Set definition");
811             $test->is($o->definition, $def, "Got definition");
812              
813             {
814             my %icols = map {$_, 1} $o->update_columns();
815              
816             $test->is($icols{'able'}, 1, 'able is an update col');
817             $test->is($icols{'baker'}, 1, 'baker is an update col');
818             $test->is($icols{'charlie'}, 1, 'charlie is an update col');
819             $test->is($icols{'delta'}, 1, 'delta is an update col');
820             $test->is(scalar(keys %icols), 4, 'only 4 update columns');
821             }
822              
823             {
824             my $icols = [qw(able charlie)];
825              
826             $test->is(join(',',$o->update_columns($icols)), join(',',@$icols), "set new update columns");
827             $test->is(join(',',$o->update_columns), join(',',@$icols), "got new update columns");
828              
829              
830             my %icols = map {$_, 1} $o->update_columns();
831              
832             $test->is($icols{'able'}, 1, 'able is an update col');
833             $test->is($icols{'baker'}, undef, 'baker is not an update col');
834             $test->is($icols{'charlie'}, 1, 'charlie is an update col');
835             $test->is($icols{'delta'}, undef, 'delta is not an update col');
836             $test->is(scalar(keys %icols), 2, 'only 2 update columns');
837             }
838              
839             {
840             my $icols = [qw()];
841              
842             $o->update_columns($icols);
843              
844             my %icols = map {$_, 1} $o->update_columns();
845              
846             $test->is($icols{'able'}, 1, 'able is an update col');
847             $test->is($icols{'baker'}, 1, 'baker is an update col');
848             $test->is($icols{'charlie'}, 1, 'charlie is an update col');
849             $test->is($icols{'delta'}, 1, 'delta is an update col');
850             $test->is(scalar(keys %icols), 4, '4 update columns');
851             }
852              
853             {
854             $o->update_columns(undef);
855             my %icols = map {$_, 1} $o->update_columns();
856              
857             $test->is($icols{'able'}, 1, 'able is an update col');
858             $test->is($icols{'baker'}, 1, 'baker is an update col');
859             $test->is($icols{'charlie'}, 1, 'charlie is an update col');
860             $test->is($icols{'delta'}, 1, 'delta is an update col');
861             $test->is(scalar(keys %icols), 4, '4 update columns');
862             }
863              
864             $test->is(scalar($o->update_columns(['junk'])), undef, 'could not update unknown column');
865             $test->is($o->errcode, 'BDT-13', 'proper error code');
866              
867             =end btest
868              
869             =cut
870              
871             =pod
872              
873             =begin btest delete_columns
874              
875             my $o = __PACKAGE__->new();
876             $test->ok($o, "Created object");
877             my $def = {
878             'able' => 'SQL_INTEGER',
879             'baker' => 'SQL_INTEGER',
880             'charlie' => 'SQL_INTEGER',
881             'delta' => 'SQL_INTEGER'
882             };
883              
884             $test->is($o->definition($def), $def, "Set definition");
885             $test->is($o->definition, $def, "Got definition");
886              
887             {
888             my %icols = map {$_, 1} $o->delete_columns();
889              
890             $test->is($icols{'able'}, 1, 'able is an delete col');
891             $test->is($icols{'baker'}, 1, 'baker is an delete col');
892             $test->is($icols{'charlie'}, 1, 'charlie is an delete col');
893             $test->is($icols{'delta'}, 1, 'delta is an delete col');
894             $test->is(scalar(keys %icols), 4, 'only 4 delete columns');
895             }
896              
897             {
898             my $icols = [qw(able charlie)];
899              
900             $test->is(join(',',$o->delete_columns($icols)), join(',',@$icols), "set new delete columns");
901             $test->is(join(',',$o->delete_columns), join(',',@$icols), "got new delete columns");
902              
903              
904             my %icols = map {$_, 1} $o->delete_columns();
905              
906             $test->is($icols{'able'}, 1, 'able is an delete col');
907             $test->is($icols{'baker'}, undef, 'baker is not an delete col');
908             $test->is($icols{'charlie'}, 1, 'charlie is an delete col');
909             $test->is($icols{'delta'}, undef, 'delta is not an delete col');
910             $test->is(scalar(keys %icols), 2, 'only 2 delete columns');
911             }
912              
913             {
914             my $icols = [qw()];
915              
916             $o->delete_columns($icols);
917              
918             my %icols = map {$_, 1} $o->delete_columns();
919              
920             $test->is($icols{'able'}, 1, 'able is an delete col');
921             $test->is($icols{'baker'}, 1, 'baker is an delete col');
922             $test->is($icols{'charlie'}, 1, 'charlie is an delete col');
923             $test->is($icols{'delta'}, 1, 'delta is an delete col');
924             $test->is(scalar(keys %icols), 4, '4 delete columns');
925             }
926              
927             {
928             $o->delete_columns(undef);
929             my %icols = map {$_, 1} $o->delete_columns();
930              
931             $test->is($icols{'able'}, 1, 'able is an delete col');
932             $test->is($icols{'baker'}, 1, 'baker is an delete col');
933             $test->is($icols{'charlie'}, 1, 'charlie is an delete col');
934             $test->is($icols{'delta'}, 1, 'delta is an delete col');
935             $test->is(scalar(keys %icols), 4, '4 delete columns');
936             }
937              
938             $test->is(scalar($o->delete_columns(['junk'])), undef, 'could not delete unknown column');
939             $test->is($o->errcode, 'BDT-13', 'proper error code');
940              
941             =end btest
942              
943             =cut
944              
945             =pod
946              
947             =begin btest replace_columns
948              
949             my $o = __PACKAGE__->new();
950             $test->ok($o, "Created object");
951             my $def = {
952             'able' => 'SQL_INTEGER',
953             'baker' => 'SQL_INTEGER',
954             'charlie' => 'SQL_INTEGER',
955             'delta' => 'SQL_INTEGER'
956             };
957              
958             $test->is($o->definition($def), $def, "Set definition");
959             $test->is($o->definition, $def, "Got definition");
960              
961             {
962             my %icols = map {$_, 1} $o->replace_columns();
963              
964             $test->is($icols{'able'}, 1, 'able is an replace col');
965             $test->is($icols{'baker'}, 1, 'baker is an replace col');
966             $test->is($icols{'charlie'}, 1, 'charlie is an replace col');
967             $test->is($icols{'delta'}, 1, 'delta is an replace col');
968             $test->is(scalar(keys %icols), 4, 'only 4 replace columns');
969             }
970              
971             {
972             my $icols = [qw(able charlie)];
973              
974             $test->is(join(',',$o->replace_columns($icols)), join(',',@$icols), "set new replace columns");
975             $test->is(join(',',$o->replace_columns), join(',',@$icols), "got new replace columns");
976              
977              
978             my %icols = map {$_, 1} $o->replace_columns();
979              
980             $test->is($icols{'able'}, 1, 'able is an replace col');
981             $test->is($icols{'baker'}, undef, 'baker is not an replace col');
982             $test->is($icols{'charlie'}, 1, 'charlie is an replace col');
983             $test->is($icols{'delta'}, undef, 'delta is not an replace col');
984             $test->is(scalar(keys %icols), 2, 'only 2 replace columns');
985             }
986              
987             {
988             my $icols = [qw()];
989              
990             $o->replace_columns($icols);
991              
992             my %icols = map {$_, 1} $o->replace_columns();
993              
994             $test->is($icols{'able'}, 1, 'able is an replace col');
995             $test->is($icols{'baker'}, 1, 'baker is an replace col');
996             $test->is($icols{'charlie'}, 1, 'charlie is an replace col');
997             $test->is($icols{'delta'}, 1, 'delta is an replace col');
998             $test->is(scalar(keys %icols), 4, '4 replace columns');
999             }
1000              
1001             {
1002             $o->replace_columns(undef);
1003             my %icols = map {$_, 1} $o->replace_columns();
1004              
1005             $test->is($icols{'able'}, 1, 'able is an replace col');
1006             $test->is($icols{'baker'}, 1, 'baker is an replace col');
1007             $test->is($icols{'charlie'}, 1, 'charlie is an replace col');
1008             $test->is($icols{'delta'}, 1, 'delta is an replace col');
1009             $test->is(scalar(keys %icols), 4, '4 replace columns');
1010             }
1011              
1012             $test->is(scalar($o->replace_columns(['junk'])), undef, 'could not replace unknown column');
1013             $test->is($o->errcode, 'BDT-13', 'proper error code');
1014              
1015             =end btest
1016              
1017             =cut
1018              
1019             =pod
1020              
1021             =begin btest select_columns
1022              
1023             my $o = __PACKAGE__->new();
1024             $test->ok($o, "Created object");
1025             my $def = {
1026             'able' => 'SQL_INTEGER',
1027             'baker' => 'SQL_INTEGER',
1028             'charlie' => 'SQL_INTEGER',
1029             'delta' => 'SQL_INTEGER'
1030             };
1031              
1032             $test->is($o->definition($def), $def, "Set definition");
1033             $test->is($o->definition, $def, "Got definition");
1034              
1035             {
1036             my %icols = map {$_, 1} $o->select_columns();
1037              
1038             $test->is($icols{'able'}, 1, 'able is an select col');
1039             $test->is($icols{'baker'}, 1, 'baker is an select col');
1040             $test->is($icols{'charlie'}, 1, 'charlie is an select col');
1041             $test->is($icols{'delta'}, 1, 'delta is an select col');
1042             $test->is(scalar(keys %icols), 4, 'only 4 select columns');
1043             }
1044              
1045             {
1046             my $icols = [qw(able charlie)];
1047              
1048             $test->is(join(',',$o->select_columns($icols)), join(',',@$icols), "set new select columns");
1049             $test->is(join(',',$o->select_columns), join(',',@$icols), "got new select columns");
1050              
1051              
1052             my %icols = map {$_, 1} $o->select_columns();
1053              
1054             $test->is($icols{'able'}, 1, 'able is an select col');
1055             $test->is($icols{'baker'}, undef, 'baker is not an select col');
1056             $test->is($icols{'charlie'}, 1, 'charlie is an select col');
1057             $test->is($icols{'delta'}, undef, 'delta is not an select col');
1058             $test->is(scalar(keys %icols), 2, 'only 2 select columns');
1059             }
1060              
1061             {
1062             my $icols = [qw(able charlie)];
1063             my $nicols = [qw(able)];
1064              
1065             $test->is(join(',',$o->select_columns($icols)), join(',',@$icols), "set new select columns");
1066             $test->is(join(',',$o->select_columns), join(',',@$icols), "got new select columns");
1067              
1068             $test->is(join(',',$o->nonselect_columns($nicols)), join(',',@$nicols), "set new non-select columns");
1069             $test->is(join(',',$o->nonselect_columns), join(',',@$nicols), "got new non-select columns");
1070              
1071              
1072             my %icols = map {$_, 1} $o->select_columns();
1073              
1074             $test->is($icols{'able'}, undef, 'able is a select col');
1075             $test->is($icols{'baker'}, undef, 'baker is not an select col');
1076             $test->is($icols{'charlie'}, 1, 'charlie is an select col');
1077             $test->is($icols{'delta'}, undef, 'delta is not an select col');
1078             $test->is(scalar(keys %icols), 1, 'only 1 select column');
1079             }
1080              
1081              
1082              
1083             {
1084             my $icols = [qw()];
1085              
1086             $o->select_columns($icols);
1087             $o->nonselect_columns([]);
1088              
1089             my %icols = map {$_, 1} $o->select_columns();
1090              
1091             $test->is($icols{'able'}, 1, 'able is an select col');
1092             $test->is($icols{'baker'}, 1, 'baker is an select col');
1093             $test->is($icols{'charlie'}, 1, 'charlie is an select col');
1094             $test->is($icols{'delta'}, 1, 'delta is an select col');
1095             $test->is(scalar(keys %icols), 4, '4 select columns');
1096             }
1097              
1098             {
1099             $o->select_columns(undef);
1100             my %icols = map {$_, 1} $o->select_columns();
1101              
1102             $test->is($icols{'able'}, 1, 'able is an select col');
1103             $test->is($icols{'baker'}, 1, 'baker is an select col');
1104             $test->is($icols{'charlie'}, 1, 'charlie is an select col');
1105             $test->is($icols{'delta'}, 1, 'delta is an select col');
1106             $test->is(scalar(keys %icols), 4, '4 select columns');
1107             }
1108              
1109             $test->is(scalar($o->select_columns(['junk'])), undef, 'could not select unknown column');
1110             $test->is($o->errcode, 'BDT-13', 'proper error code');
1111              
1112             =end btest
1113              
1114             =cut
1115              
1116             __PACKAGE__->add_attr(['insert_columns', '_isa_column_list_accessor']);
1117             __PACKAGE__->add_attr(['update_columns', '_isa_column_list_accessor']);
1118             __PACKAGE__->add_attr(['delete_columns', '_isa_column_list_accessor']);
1119             __PACKAGE__->add_attr(['replace_columns', '_isa_column_list_accessor']);
1120             __PACKAGE__->add_attr(['select_columns', '_isa_column_list_accessor']);
1121              
1122             __PACKAGE__->add_attr(['noninsert_columns', '_isa_column_list_accessor']);
1123             __PACKAGE__->add_attr(['nonupdate_columns', '_isa_column_list_accessor']);
1124             __PACKAGE__->add_attr(['nondelete_columns', '_isa_column_list_accessor']);
1125             __PACKAGE__->add_attr(['nonreplace_columns', '_isa_column_list_accessor']);
1126             __PACKAGE__->add_attr(['nonselect_columns', '_isa_column_list_accessor']);
1127              
1128             =pod
1129              
1130             =begin btest _column_list_accessor
1131              
1132             $test->ok("testing is implied", "testing is implied");
1133              
1134             =end btest
1135              
1136             =cut
1137              
1138             sub _isa_column_list_accessor {
1139 30     30   50 my $pkg = shift;
1140 30         36 my $attr = shift;
1141 30         42 my $prop = shift;
1142              
1143             return sub {
1144 46     46   5989 my $self = shift;
1145            
1146 46         139 my $prefix = $self->system_prefix;
1147 46         302 (my $propname = $prop) =~ s/^$prefix//;
1148            
1149 46 100       118 if (@_) {
1150 7         10 foreach my $col (@{$_[0]}) {
  7         166  
1151 6 50       18 return $self->error("Cannot add $col for $propname - not a column", "BDT-13")
1152             unless $self->is_column($col);
1153             }
1154            
1155 6         26 $self->$prop(@_);
1156             }
1157            
1158 45   100     158 my $vals = $self->$prop() || [];
1159            
1160 45 100       156 my @vals = @$vals ? @$vals : $self->cols;
1161            
1162             #weed out our non-columns, if they were provided.
1163 45 50       140 if ($propname !~ /non/) {
1164 45         105 my $nonprop = $prefix . 'non' . $propname;
1165 45 50       10672 my $nonvals = {map {$_, 1} @{$self->$nonprop() || []}};
  0         0  
  45         161  
1166            
1167 45         104 @vals = grep {! $nonvals->{$_}} @vals;
  67         242  
1168             }
1169            
1170 45         182 return @vals;
1171             }
1172 30         211 }
1173              
1174             sub _isa_translation_accessor {
1175 6     6   11 my $pkg = shift;
1176 6         12 my $attr = shift;
1177 6         17 my $prop = shift;
1178              
1179             return sub {
1180 38     38   4720 my $self = shift;
1181 38 100       172 $self->_cached_queries({}) if @_;
1182 38 100       163 $self->_cached_bindables({}) if @_;
1183 38         156 return $self->$prop(@_);
1184 6         31 };
1185             }
1186              
1187              
1188             =pod
1189              
1190             =begin btest init
1191              
1192             my $o = __PACKAGE__->new();
1193             $test->ok($o, "got object");
1194             $test->is(ref $o->definition, 'HASH', 'definition initialized to hash');
1195             $test->is(ref $o->extra_select, 'HASH', 'extra_select initialized to hash');
1196             $test->is(ref $o->db_write_translation, 'HASH', 'db_write_translation initialized to hash');
1197             $test->is(ref $o->db_read_translation, 'HASH', 'db_read_translation initialized to hash');
1198             $test->is(ref $o->column_aliases, 'HASH', 'column_aliases initialized to hash');
1199             $test->is(ref $o->references, 'HASH', 'references initialized to hash');
1200              
1201             =end btest
1202              
1203             =cut
1204              
1205             #just a bubble-up initializer. Initializes some values and passes them through.
1206             sub init {
1207 16     16 1 36 my $self = shift;
1208              
1209 16         234 my %init = (
1210             'definition' => {},
1211             'extra_select' => {},
1212             'db_write_translation' => {},
1213             'db_read_translation' => {},
1214             'column_aliases' => {},
1215             'references' => {},
1216             '_cached_queries' => {},
1217             '_cached_bindables' => {},
1218             'attributes_not_to_create' => [],
1219             'create_attributes' => 0,
1220             'last_insert_query' => 'SELECT LAST_INSERT_ID()',
1221             @_
1222             );
1223              
1224 16 50       115 if ($init{'discover'}) {
    50          
1225 0 0       0 $init{'definition'} = $self->discover_columns($init{'name'}) or return;
1226             } elsif ($init{'non_primary_columns'}) {
1227 0 0       0 my @primary = ref $init{'primary_column'} ? @{$init{'primary_column'}} : ($init{'primary_column'});
  0         0  
1228 0 0       0 $init{'definition'} = $self->discover_columns($init{'name'}, (@primary, @{$init{'non_primary_columns'}})) or return;
  0         0  
1229             }
1230              
1231             #$self->definition($init{'definition'});
1232              
1233 16         161 return $self->SUPER::init(
1234             'definition' => $init{'definition'},
1235             %init
1236             );
1237             };
1238              
1239             __PACKAGE__->add_attr('_attributes_to_create');
1240             __PACKAGE__->add_attr('attributes_not_to_create');
1241              
1242             __PACKAGE__->add_attr('create_attributes');
1243              
1244             sub attributes_to_create {
1245 0     0 0 0 my $self = shift;
1246 0 0       0 if (@_) {
1247 0         0 $self->_attributes_to_create($_[0]);
1248             };
1249            
1250 0         0 my %not = map {$_, 1} @{$self->attributes_not_to_create};
  0         0  
  0         0  
1251            
1252 0 0       0 return grep {! $not{$_} } $self->alias_column($self->_attributes_to_create ? @{$self->_attributes_to_create} : $self->cols);
  0         0  
  0         0  
1253             }
1254              
1255             =pod
1256              
1257             =back
1258              
1259             =head1 METHODS
1260              
1261             =over
1262              
1263             =pod
1264              
1265             =item cols
1266              
1267             Returns the columns defined for this table, in an unspecified order
1268              
1269             my @cols = $table->cols();
1270              
1271             =cut
1272              
1273             =pod
1274              
1275             =begin btest cols
1276              
1277             my $o = __PACKAGE__->new();
1278             $test->ok($o, "Created object");
1279             my $def = {
1280             'able' => 'SQL_INTEGER',
1281             'baker' => 'SQL_VARCHAR',
1282             'charlie' => 'SQL_DATE',
1283             'delta' => 'SQL_UNKNOWN_TYPE'
1284             };
1285              
1286             $test->is($o->definition($def), $def, "Set definition");
1287             $test->is($o->definition, $def, "Got definition");
1288              
1289             my %cols = map {$_, 1} $o->cols();
1290              
1291             $test->is(scalar(keys %cols), scalar(keys %$def), "proper number of columns");
1292             $test->is($cols{'able'}, 1, 'able is column');
1293             $test->is($cols{'baker'}, 1, 'baker is column');
1294             $test->is($cols{'charlie'}, 1, 'charlie is column');
1295             $test->is($cols{'delta'}, 1, 'delta is column');
1296             $test->is($cols{'edgar'}, undef, 'edgar is not column');
1297             $test->is($cols{'foxtrot'}, undef, 'foxtrot is not column');
1298             $test->is($cols{'goat'}, undef, 'goat is not column');
1299              
1300             =end btest
1301              
1302             =cut
1303              
1304             sub cols {
1305 14     14 1 19 my $self = shift;
1306 14         17 return keys %{$self->definition};
  14         37  
1307             };
1308              
1309             =item defs
1310              
1311             Returns the column definitions defined for this table, in an unspecified order, but
1312             the same order as the columns returned by cols
1313              
1314             my @defs = $table->defs();
1315              
1316             =cut
1317              
1318             =pod
1319              
1320             =begin btest defs
1321              
1322             my $o = __PACKAGE__->new();
1323             $test->ok($o, "Created object");
1324             my $def = {
1325             'able' => 'SQL_INTEGER',
1326             'baker' => 'SQL_VARCHAR',
1327             'charlie' => 'SQL_DATE',
1328             'delta' => 'SQL_UNKNOWN_TYPE'
1329             };
1330              
1331             $test->is($o->definition($def), $def, "Set definition");
1332             $test->is($o->definition, $def, "Got definition");
1333              
1334             my @cols = $o->cols();
1335             my @defs = $o->defs();
1336              
1337             $test->is(scalar(@defs), scalar(keys %$def), "proper number of definitions");
1338             $test->is($defs[0], $o->definition->{$cols[0]}, "Definition matches column 0");
1339             $test->is($defs[1], $o->definition->{$cols[1]}, "Definition matches column 1");
1340             $test->is($defs[2], $o->definition->{$cols[2]}, "Definition matches column 2");
1341             $test->is($defs[3], $o->definition->{$cols[3]}, "Definition matches column 3");
1342              
1343             =end btest
1344              
1345             =cut
1346              
1347             sub defs {
1348 0     0 1 0 my $self = shift;
1349 0         0 return values %{$self->definition};
  0         0  
1350             };
1351              
1352             =pod
1353              
1354             =item is_bindable
1355              
1356             Fairly straightforward method, given a column and a query type, will tell you if the column is bindable.
1357              
1358             $table->is_bindable('U', 'foo'); #returns 1 or 0, whether or not 'foo' can be bound on an update.
1359              
1360             Valid query types are 'U', 'I', 'R', 'D', 'S', and 'A'
1361              
1362             =cut
1363              
1364             =pod
1365              
1366             =begin btest is_bindable
1367              
1368             my $o = __PACKAGE__->new();
1369             $test->ok($o, "Created object");
1370             my $def = {
1371             'able' => 'SQL_INTEGER',
1372             'baker' => 'SQL_INTEGER',
1373             'charlie' => 'SQL_INTEGER',
1374             'delta' => 'SQL_INTEGER'
1375             };
1376              
1377             $test->is($o->definition($def), $def, "Set definition");
1378             $test->is($o->definition, $def, "Got definition");
1379              
1380             $test->is(scalar($o->is_bindable()), undef, 'Cannot bind w/o type');
1381             $test->is($o->errcode, 'BDT-31', 'proper error code for is_bindable (type)');
1382             $test->is(scalar($o->is_bindable('able')), undef, 'Cannot bind w/o col');
1383             $test->is($o->errcode, 'BDT-30', 'proper error code for is_bindable (col)');
1384              
1385             $test->is($o->is_bindable('I', 'able'), 1, 'able binds on insert');
1386             $test->is($o->is_bindable('I', 'baker'), 1, 'baker binds on insert');
1387             $test->is($o->is_bindable('I', 'charlie'), 1, 'charlie binds on insert');
1388             $test->is($o->is_bindable('I', 'delta'), 1, 'delta binds on insert');
1389              
1390             $test->is($o->is_bindable('U', 'able'), 1, 'able binds on update');
1391             $test->is($o->is_bindable('U', 'baker'), 1, 'baker binds on update');
1392             $test->is($o->is_bindable('U', 'charlie'), 1, 'charlie binds on update');
1393             $test->is($o->is_bindable('U', 'delta'), 1, 'delta binds on update');
1394              
1395             $test->is($o->is_bindable('R', 'able'), 1, 'able binds on replace');
1396             $test->is($o->is_bindable('R', 'baker'), 1, 'baker binds on replace');
1397             $test->is($o->is_bindable('R', 'charlie'), 1, 'charlie binds on replace');
1398             $test->is($o->is_bindable('R', 'delta'), 1, 'delta binds on replace');
1399              
1400             $test->is($o->is_bindable('D', 'able'), 1, 'able binds on delete');
1401             $test->is($o->is_bindable('D', 'baker'), 1, 'baker binds on delete');
1402             $test->is($o->is_bindable('D', 'charlie'), 1, 'charlie binds on delete');
1403             $test->is($o->is_bindable('D', 'delta'), 1, 'delta binds on delete');
1404              
1405             $test->is($o->is_bindable('S', 'able'), 1, 'able binds on select');
1406             $test->is($o->is_bindable('S', 'baker'), 1, 'baker binds on select');
1407             $test->is($o->is_bindable('S', 'charlie'), 1, 'charlie binds on select');
1408             $test->is($o->is_bindable('S', 'delta'), 1, 'delta binds on select');
1409              
1410             $test->is($o->is_bindable('A', 'able'), 1, 'able binds on all');
1411             $test->is($o->is_bindable('A', 'baker'), 1, 'baker binds on all');
1412             $test->is($o->is_bindable('A', 'charlie'), 1, 'charlie binds on all');
1413             $test->is($o->is_bindable('A', 'delta'), 1, 'delta binds on all');
1414              
1415             my $translator = {
1416             'able' => {
1417             'I' => {
1418             'val' => 'NOW()',
1419             'binds' => 0
1420             },
1421             },
1422             'baker' => {
1423             'U' => {
1424             'val' => 'NOW()',
1425             'binds' => 0,
1426             },
1427             },
1428             'charlie' => {
1429             'R' => {
1430             'val' => 'NOW()',
1431             'binds' => 0,
1432             },
1433             },
1434             'delta' => {
1435             'D' => {
1436             'val' => 'NOW()',
1437             'binds' => 0,
1438             },
1439             },
1440             };
1441              
1442             $test->is($o->db_write_translation($translator), $translator, "Set translator");
1443              
1444             $test->is($o->is_bindable('I', 'able'), 0, 'able does not bind on insert');
1445             $test->is($o->is_bindable('I', 'baker'), 1, 'baker binds on insert');
1446             $test->is($o->is_bindable('I', 'charlie'), 1, 'charlie binds on insert');
1447             $test->is($o->is_bindable('I', 'delta'), 1, 'delta binds on insert');
1448              
1449             $test->is($o->is_bindable('U', 'able'), 1, 'able binds on update');
1450             $test->is($o->is_bindable('U', 'baker'), 0, 'baker does not bind on update');
1451             $test->is($o->is_bindable('U', 'charlie'), 1, 'charlie binds on update');
1452             $test->is($o->is_bindable('U', 'delta'), 1, 'delta binds on update');
1453              
1454             $test->is($o->is_bindable('R', 'able'), 1, 'able binds on replace');
1455             $test->is($o->is_bindable('R', 'baker'), 1, 'baker binds on replace');
1456             $test->is($o->is_bindable('R', 'charlie'), 0, 'charlie does not bind on replace');
1457             $test->is($o->is_bindable('R', 'delta'), 1, 'delta binds on replace');
1458              
1459             $test->is($o->is_bindable('D', 'able'), 1, 'able binds on delete');
1460             $test->is($o->is_bindable('D', 'baker'), 1, 'baker binds on delete');
1461             $test->is($o->is_bindable('D', 'charlie'), 1, 'charlie binds on delete');
1462             $test->is($o->is_bindable('D', 'delta'), 0, 'delta does not bind on delete');
1463              
1464             $test->is($o->is_bindable('S', 'able'), 1, 'able binds on select');
1465             $test->is($o->is_bindable('S', 'baker'), 1, 'baker binds on select');
1466             $test->is($o->is_bindable('S', 'charlie'), 1, 'charlie binds on select');
1467             $test->is($o->is_bindable('S', 'delta'), 1, 'delta binds on select');
1468              
1469             $test->is($o->is_bindable('A', 'able'), 1, 'able binds on all');
1470             $test->is($o->is_bindable('A', 'baker'), 1, 'baker binds on all');
1471             $test->is($o->is_bindable('A', 'charlie'), 1, 'charlie binds on all');
1472             $test->is($o->is_bindable('A', 'delta'), 1, 'delta binds on all');
1473              
1474             my $translator2 = {
1475             'able' => {
1476             'S' => {
1477             'val' => 'NOW()',
1478             'binds' => 0
1479             },
1480             },
1481             'baker' => {
1482             'A' => {
1483             'val' => 'NOW()',
1484             'binds' => 0,
1485             },
1486             },
1487             'charlie' => {
1488             'I' => {
1489             'val' => 'NOW()',
1490             'binds' => 1,
1491             },
1492             'A' => {
1493             'val' => 'NOW()',
1494             'binds' => 0,
1495             },
1496             },
1497             'delta' => {
1498             'A' => {
1499             'val' => '?',
1500             'binds' => 1,
1501             }
1502             },
1503             };
1504              
1505             $test->is($o->db_write_translation($translator2), $translator2, "Set translator again");
1506              
1507             $test->is($o->is_bindable('I', 'able'), 1, 'able binds on insert');
1508             $test->is($o->is_bindable('I', 'baker'), 0, 'baker does not bind on insert');
1509             $test->is($o->is_bindable('I', 'charlie'), 1, 'charlie binds on insert');
1510             $test->is($o->is_bindable('I', 'delta'), 1, 'delta binds on insert');
1511              
1512             $test->is($o->is_bindable('U', 'able'), 1, 'able binds on update');
1513             $test->is($o->is_bindable('U', 'baker'), 0, 'baker does not bind on update');
1514             $test->is($o->is_bindable('U', 'charlie'), 0, 'charlie does not bind on update');
1515             $test->is($o->is_bindable('U', 'delta'), 1, 'delta binds on update');
1516              
1517             $test->is($o->is_bindable('R', 'able'), 1, 'able binds on replace');
1518             $test->is($o->is_bindable('R', 'baker'), 0, 'baker does not bind replace');
1519             $test->is($o->is_bindable('R', 'charlie'), 0, 'charlie does not bind on replace');
1520             $test->is($o->is_bindable('R', 'delta'), 1, 'delta binds on replace');
1521              
1522             $test->is($o->is_bindable('D', 'able'), 1, 'able binds on delete');
1523             $test->is($o->is_bindable('D', 'baker'), 0, 'baker does not bind delete');
1524             $test->is($o->is_bindable('D', 'charlie'), 0, 'charlie does not bind on delete');
1525             $test->is($o->is_bindable('D', 'delta'), 1, 'delta binds on delete');
1526              
1527             $test->is($o->is_bindable('S', 'able'), 0, 'able does not bind on select');
1528             $test->is($o->is_bindable('S', 'baker'), 0, 'baker does not bind on select');
1529             $test->is($o->is_bindable('S', 'charlie'), 0, 'charlie does not bind on select');
1530             $test->is($o->is_bindable('S', 'delta'), 1, 'delta binds on select');
1531              
1532             $test->is($o->is_bindable('A', 'able'), 1, 'able binds on all');
1533             $test->is($o->is_bindable('A', 'baker'), 0, 'baker does not bind on all');
1534             $test->is($o->is_bindable('A', 'charlie'), 0, 'charlie does not bind on all');
1535             $test->is($o->is_bindable('A', 'delta'), 1, 'delta binds on all');
1536              
1537             =end btest
1538              
1539             =cut
1540              
1541             sub is_bindable {
1542 0     0 1 0 my $self = shift;
1543 0 0       0 my $type = shift or return $self->error("Cannot check bindableness w/o type", "BDT-31");
1544 0 0       0 my $col = shift or return $self->error("Cannot check bindableness w/o column", "BDT-30");
1545              
1546 0         0 my $db_write_translation = $self->db_write_translation;
1547              
1548 0 0       0 if (defined $db_write_translation->{$col}) {
1549 0 0       0 if (defined $db_write_translation->{$col}->{$type}){
    0          
1550 0         0 return $db_write_translation->{$col}->{$type}->{'binds'};
1551             }
1552             elsif (defined $db_write_translation->{$col}->{'A'}){
1553 0         0 return $db_write_translation->{$col}->{'A'}->{'binds'};
1554             }
1555             };
1556 0         0 return 1;
1557             };
1558              
1559             =pod
1560              
1561             =item is_selectable
1562              
1563             =cut
1564              
1565             =pod
1566              
1567             =begin btest is_selectable
1568              
1569             my $o = __PACKAGE__->new();
1570             $test->ok($o, "Created object");
1571             my $def = {
1572             'able' => 'SQL_INTEGER',
1573             'baker' => 'SQL_INTEGER',
1574             'charlie' => 'SQL_INTEGER',
1575             'delta' => 'SQL_INTEGER'
1576             };
1577              
1578             $test->is($o->definition($def), $def, "Set definition");
1579             $test->is($o->definition, $def, "Got definition");
1580              
1581             $test->is(scalar($o->is_selectable), undef, 'Could not determine selectableness w/o value');
1582             $test->is($o->errcode, 'BDT-44', 'proper error code');
1583              
1584             $test->is($o->is_selectable('able'), 1, 'selects column');
1585             $test->is($o->is_selectable('7'), 1, 'selects integer');
1586             $test->is($o->is_selectable('7 as seven'), 1, 'selects aliased integer');
1587             $test->is($o->is_selectable('98.6'), 1, 'selects float');
1588             $test->is($o->is_selectable('98.6 as temp'), 1, 'selects aliased float');
1589             $test->is($o->is_selectable('.778'), 1, 'selects decimal started float');
1590             $test->is($o->is_selectable('.778 as small'), 1, 'selects decimal started float');
1591             $test->is($o->is_selectable("'string'"), 1, 'selects single quoted string');
1592             $test->is($o->is_selectable("'string' as alias"), 1, 'selects aliased single quoted string');
1593             $test->is($o->is_selectable('"string"'), 1, 'selects double quoted string');
1594             $test->is($o->is_selectable('"string" as alias'), 1, 'selects aliased double quoted string');
1595             $test->is($o->is_selectable('NOW()'), 1, 'selects empty function');
1596             $test->is($o->is_selectable('NOW() as "now"'), 1, 'selects aliased empty function');
1597             $test->is($o->is_selectable('lc("able")'), 1, 'selects single arg function');
1598             $test->is($o->is_selectable('lc("able") as "lc able"'), 1, 'selects aliased single arg function');
1599             $test->is($o->is_selectable('lc("able")'), 1, 'selects double arg function');
1600             $test->is($o->is_selectable('lc("able") as "lc able"'), 1, 'selects aliased double arg function');
1601              
1602             =end btest
1603              
1604             =cut
1605              
1606             sub is_selectable {
1607 0     0 1 0 my $self = shift;
1608              
1609 0 0       0 my $value = shift or return $self->error("Cannot determine selectable-ness w/o value", "BDT-44");
1610              
1611 0 0       0 return 1 if $self->is_column($value); #columns are selectable
1612              
1613 0 0       0 return 1 if $value =~ /^(\d+(\.\d+)?|\.\d+)(\s+(as|AS)\s*.+)?$/; #numbers are selectable
1614              
1615 0 0       0 return 1 if $value =~ /^(['"]).*\1(\s+(as|AS)\s*.+)?$/; #quoted strings are selectable
1616              
1617 0 0       0 return 1 if $value =~ /^[a-zA-Z]+\(.*\)(\s+(as|AS)\s*.+)?$/; #functions are selectable
1618              
1619 0         0 return 0;
1620              
1621             }
1622              
1623             # this is used internally to do translations required by db_write_translation
1624             #
1625             # gets two args, $type and $col, and returns the 'val' in the hash if it is specified.
1626             # otherwise, there is no change, so it returns a normal '?' placeholder.
1627              
1628             =pod
1629              
1630             =begin btest db_translate_write
1631              
1632             my $o = __PACKAGE__->new();
1633             $test->ok($o, "Created object");
1634             my $def = {
1635             'able' => 'SQL_INTEGER',
1636             'baker' => 'SQL_INTEGER',
1637             'charlie' => 'SQL_INTEGER',
1638             'delta' => 'SQL_INTEGER'
1639             };
1640              
1641             $test->is($o->definition($def), $def, "Set definition");
1642             $test->is($o->definition, $def, "Got definition");
1643              
1644             $test->is(scalar($o->db_translate_write()), undef, 'Cannot db_translate_write w/o type');
1645             $test->is($o->errcode, 'BDT-33', 'proper error code for db_translate_write (col)');
1646             $test->is(scalar($o->db_translate_write('I')), undef, 'Cannot db_translate_write w/o cols');
1647             $test->is($o->errcode, 'BDT-32', 'proper error code for db_translate_write (type)');
1648              
1649             $test->is($o->db_translate_write('I', 'able'), '?', 'db_translate_write for able on insert');
1650             $test->is($o->db_translate_write('I', 'baker'), '?', 'db_translate_write for baker on insert');
1651             $test->is($o->db_translate_write('I', 'charlie'), '?', 'db_translate_write for charlie on insert');
1652             $test->is($o->db_translate_write('I', 'delta'), '?', 'db_translate_write for delta on insert');
1653              
1654             $test->is($o->db_translate_write('U', 'able'), '?', 'db_translate_write for able on update');
1655             $test->is($o->db_translate_write('U', 'baker'), '?', 'db_translate_write for baker on update');
1656             $test->is($o->db_translate_write('U', 'charlie'), '?', 'db_translate_write for charlie on update');
1657             $test->is($o->db_translate_write('U', 'delta'), '?', 'db_translate_write for delta on update');
1658              
1659             $test->is($o->db_translate_write('R', 'able'), '?', 'db_translate_write for able on replace');
1660             $test->is($o->db_translate_write('R', 'baker'), '?', 'db_translate_write for baker on replace');
1661             $test->is($o->db_translate_write('R', 'charlie'), '?', 'db_translate_write for charlie on replace');
1662             $test->is($o->db_translate_write('R', 'delta'), '?', 'db_translate_write for delta on replace');
1663              
1664             $test->is($o->db_translate_write('D', 'able'), '?', 'db_translate_write for able on delete');
1665             $test->is($o->db_translate_write('D', 'baker'), '?', 'db_translate_write for baker on delete');
1666             $test->is($o->db_translate_write('D', 'charlie'), '?', 'db_translate_write for charlie on delete');
1667             $test->is($o->db_translate_write('D', 'delta'), '?', 'db_translate_write for delta on delete');
1668              
1669             $test->is($o->db_translate_write('S', 'able'), '?', 'db_translate_write for able on select');
1670             $test->is($o->db_translate_write('S', 'baker'), '?', 'db_translate_write for baker on select');
1671             $test->is($o->db_translate_write('S', 'charlie'), '?', 'db_translate_write for charlie on select');
1672             $test->is($o->db_translate_write('S', 'delta'), '?', 'db_translate_write for delta on select');
1673              
1674             $test->is($o->db_translate_write('A', 'able'), '?', 'db_translate_write for able on all');
1675             $test->is($o->db_translate_write('A', 'baker'), '?', 'db_translate_write for baker on all');
1676             $test->is($o->db_translate_write('A', 'charlie'), '?', 'db_translate_write for charlie on all');
1677             $test->is($o->db_translate_write('A', 'delta'), '?', 'db_translate_write for delta on all');
1678              
1679             {
1680             my @insert_all = $o->db_translate_write('I', sort $o->cols);
1681             $test->is($insert_all[0], '?', 'able is ? on insert in multi pass');
1682             $test->is($insert_all[1], '?', 'baker is ? on insert in multi pass');
1683             $test->is($insert_all[2], '?', 'charlie is ? on insert in multi pass');
1684             $test->is($insert_all[3], '?', 'delta is ? on insert in multi pass');
1685            
1686             my @update_all = $o->db_translate_write('U', sort $o->cols);
1687             $test->is($update_all[0], '?', 'able is ? on update in multi pass');
1688             $test->is($update_all[1], '?', 'baker is ? on update in multi pass');
1689             $test->is($update_all[2], '?', 'charlie is ? on update in multi pass');
1690             $test->is($update_all[3], '?', 'delta is ? on update in multi pass');
1691            
1692             my @replace_all = $o->db_translate_write('R', sort $o->cols);
1693             $test->is($replace_all[0], '?', 'able is ? on replace in multi pass');
1694             $test->is($replace_all[1], '?', 'baker is ? on replace in multi pass');
1695             $test->is($replace_all[2], '?', 'charlie is ? on replace in multi pass');
1696             $test->is($replace_all[3], '?', 'delta is ? on replace in multi pass');
1697            
1698             my @delete_all = $o->db_translate_write('D', sort $o->cols);
1699             $test->is($delete_all[0], '?', 'able is ? on delete in multi pass');
1700             $test->is($delete_all[1], '?', 'baker is ? on delete in multi pass');
1701             $test->is($delete_all[2], '?', 'charlie is ? on delete in multi pass');
1702             $test->is($delete_all[3], '?', 'delta is ? on delete in multi pass');
1703            
1704             my @all_all = $o->db_translate_write('A', sort $o->cols);
1705             $test->is($all_all[0], '?', 'able is ? on all in multi pass');
1706             $test->is($all_all[1], '?', 'baker is ? on all in multi pass');
1707             $test->is($all_all[2], '?', 'charlie is ? on all in multi pass');
1708             $test->is($all_all[3], '?', 'delta is ? on all in multi pass');
1709             }
1710              
1711             my $translator = {
1712             'able' => {
1713             'I' => {
1714             'val' => 'ableprime',
1715             'binds' => 0
1716             },
1717             },
1718             'baker' => {
1719             'U' => {
1720             'val' => 'bakerprime',
1721             'binds' => 0,
1722             },
1723             },
1724             'charlie' => {
1725             'R' => {
1726             'val' => 'charlieprime',
1727             'binds' => 1,
1728             },
1729             },
1730             'delta' => {
1731             'D' => {
1732             'val' => 'deltaprime',
1733             'binds' => 0,
1734             },
1735             },
1736             };
1737              
1738             $test->is($o->db_write_translation($translator), $translator, "Set translator");
1739              
1740             $test->is($o->db_translate_write('I', 'able'), 'ableprime', 'db_translate_write for able on insert');
1741             $test->is($o->db_translate_write('I', 'baker'), '?', 'db_translate_write for baker on insert');
1742             $test->is($o->db_translate_write('I', 'charlie'), '?', 'db_translate_write for charlie on insert');
1743             $test->is($o->db_translate_write('I', 'delta'), '?', 'db_translate_write for delta on insert');
1744              
1745             $test->is($o->db_translate_write('U', 'able'), '?', 'db_translate_write for able on update');
1746             $test->is($o->db_translate_write('U', 'baker'), 'bakerprime', 'db_translate_write for baker on update');
1747             $test->is($o->db_translate_write('U', 'charlie'), '?', 'db_translate_write for charlie on update');
1748             $test->is($o->db_translate_write('U', 'delta'), '?', 'db_translate_write for delta on update');
1749              
1750             $test->is($o->db_translate_write('R', 'able'), '?', 'db_translate_write for able on replace');
1751             $test->is($o->db_translate_write('R', 'baker'), '?', 'db_translate_write for baker on replace');
1752             $test->is($o->db_translate_write('R', 'charlie'), 'charlieprime', 'db_translate_write for charlie on replace');
1753             $test->is($o->db_translate_write('R', 'delta'), '?', 'db_translate_write for delta on replace');
1754              
1755             $test->is($o->db_translate_write('D', 'able'), '?', 'db_translate_write for able on delete');
1756             $test->is($o->db_translate_write('D', 'baker'), '?', 'db_translate_write for baker on delete');
1757             $test->is($o->db_translate_write('D', 'charlie'), '?', 'db_translate_write for charlie on delete');
1758             $test->is($o->db_translate_write('D', 'delta'), 'deltaprime', 'db_translate_write for delta on delete');
1759              
1760             $test->is($o->db_translate_write('S', 'able'), '?', 'db_translate_write for able on select');
1761             $test->is($o->db_translate_write('S', 'baker'), '?', 'db_translate_write for baker on select');
1762             $test->is($o->db_translate_write('S', 'charlie'), '?', 'db_translate_write for charlie on select');
1763             $test->is($o->db_translate_write('S', 'delta'), '?', 'db_translate_write for delta on select');
1764              
1765             $test->is($o->db_translate_write('A', 'able'), '?', 'db_translate_write for able on all');
1766             $test->is($o->db_translate_write('A', 'baker'), '?', 'db_translate_write for baker on all');
1767             $test->is($o->db_translate_write('A', 'charlie'), '?', 'db_translate_write for charlie on all');
1768             $test->is($o->db_translate_write('A', 'delta'), '?', 'db_translate_write for delta on all');
1769              
1770             {
1771             my @insert_all = $o->db_translate_write('I', sort $o->cols);
1772             $test->is($insert_all[0], 'ableprime', 'able is ableprime on insert in multi pass');
1773             $test->is($insert_all[1], '?', 'baker is ? on insert in multi pass');
1774             $test->is($insert_all[2], '?', 'charlie is ? on insert in multi pass');
1775             $test->is($insert_all[3], '?', 'delta is ? on insert in multi pass');
1776            
1777             my @update_all = $o->db_translate_write('U', sort $o->cols);
1778              
1779             $test->is($update_all[0], '?', 'able is ? on update in multi pass');
1780             $test->is($update_all[1], 'bakerprime', 'baker is bakerprime on update in multi pass');
1781             $test->is($update_all[2], '?', 'charlie is ? on update in multi pass');
1782             $test->is($update_all[3], '?', 'delta is ? on update in multi pass');
1783            
1784             my @replace_all = $o->db_translate_write('R', sort $o->cols);
1785             $test->is($replace_all[0], '?', 'able is ? on replace in multi pass');
1786             $test->is($replace_all[1], '?', 'baker is ? on replace in multi pass');
1787             $test->is($replace_all[2], 'charlieprime', 'charlie is charlieprime on replace in multi pass');
1788             $test->is($replace_all[3], '?', 'delta is ? on replace in multi pass');
1789            
1790             my @delete_all = $o->db_translate_write('D', sort $o->cols);
1791             $test->is($delete_all[0], '?', 'able is ? on delete in multi pass');
1792             $test->is($delete_all[1], '?', 'baker is ? on delete in multi pass');
1793             $test->is($delete_all[2], '?', 'charlie is ? on delete in multi pass');
1794             $test->is($delete_all[3], 'deltaprime', 'delta is deltaprime on delete in multi pass');
1795            
1796             my @all_all = $o->db_translate_write('A', sort $o->cols);
1797             $test->is($all_all[0], '?', 'able is ? on all in multi pass');
1798             $test->is($all_all[1], '?', 'baker is ? on all in multi pass');
1799             $test->is($all_all[2], '?', 'charlie is ? on all in multi pass');
1800             $test->is($all_all[3], '?', 'delta is ? on all in multi pass');
1801             }
1802              
1803             my $translator2 = {
1804             'able' => {
1805             'S' => {
1806             'val' => 'ableselectorprime',
1807             'binds' => 0
1808             },
1809             },
1810             'baker' => {
1811             'A' => {
1812             'val' => 'bakerallprime',
1813             'binds' => 0,
1814             },
1815             },
1816             'charlie' => {
1817             'I' => {
1818             'val' => 'charlieinsertprime',
1819             'binds' => 1,
1820             },
1821             'A' => {
1822             'val' => 'charlieallprime',
1823             'binds' => 0,
1824             },
1825             },
1826             };
1827              
1828             $test->is($o->db_write_translation($translator2), $translator2, "Set translator again");
1829              
1830             $test->is($o->db_translate_write('I', 'able'), '?', 'db_translate_write for able on insert');
1831             $test->is($o->db_translate_write('I', 'baker'), 'bakerallprime', 'db_translate_write for baker on insert');
1832             $test->is($o->db_translate_write('I', 'charlie'), 'charlieinsertprime', 'db_translate_write for charlie on insert');
1833             $test->is($o->db_translate_write('I', 'delta'), '?', 'db_translate_write for delta on insert');
1834              
1835             $test->is($o->db_translate_write('U', 'able'), '?', 'db_translate_write for able on update');
1836             $test->is($o->db_translate_write('U', 'baker'), 'bakerallprime', 'db_translate_write for baker on update');
1837             $test->is($o->db_translate_write('U', 'charlie'), 'charlieallprime', 'db_translate_write for charlie on update');
1838             $test->is($o->db_translate_write('U', 'delta'), '?', 'db_translate_write for delta on update');
1839              
1840             $test->is($o->db_translate_write('R', 'able'), '?', 'db_translate_write for able on replace');
1841             $test->is($o->db_translate_write('R', 'baker'), 'bakerallprime', 'db_translate_write for baker on replace');
1842             $test->is($o->db_translate_write('R', 'charlie'), 'charlieallprime', 'db_translate_write for charlie on replace');
1843             $test->is($o->db_translate_write('R', 'delta'), '?', 'db_translate_write for delta on replace');
1844              
1845             $test->is($o->db_translate_write('D', 'able'), '?', 'db_translate_write for able on delete');
1846             $test->is($o->db_translate_write('D', 'baker'), 'bakerallprime', 'db_translate_write for baker on delete');
1847             $test->is($o->db_translate_write('D', 'charlie'), 'charlieallprime', 'db_translate_write for charlie on delete');
1848             $test->is($o->db_translate_write('D', 'delta'), '?', 'db_translate_write for delta on delete');
1849              
1850             $test->is($o->db_translate_write('S', 'able'), 'ableselectorprime', 'db_translate_write for able on select');
1851             $test->is($o->db_translate_write('S', 'baker'), 'bakerallprime', 'db_translate_write for baker on select');
1852             $test->is($o->db_translate_write('S', 'charlie'), 'charlieallprime', 'db_translate_write for charlie on select');
1853             $test->is($o->db_translate_write('S', 'delta'), '?', 'db_translate_write for delta on select');
1854              
1855             $test->is($o->db_translate_write('A', 'able'), '?', 'db_translate_write for able on all');
1856             $test->is($o->db_translate_write('A', 'baker'), 'bakerallprime', 'db_translate_write for baker on all');
1857             $test->is($o->db_translate_write('A', 'charlie'), 'charlieallprime', 'db_translate_write for charlie on all');
1858             $test->is($o->db_translate_write('A', 'delta'), '?', 'db_translate_write for delta on all');
1859              
1860             {
1861             my @insert_all = $o->db_translate_write('I', sort $o->cols);
1862             $test->is($insert_all[0], '?', 'able is ? on insert in multi pass');
1863             $test->is($insert_all[1], 'bakerallprime', 'baker is bakerallprime on insert in multi pass');
1864             $test->is($insert_all[2], 'charlieinsertprime', 'charlie is charlieinsertprime on insert in multi pass');
1865             $test->is($insert_all[3], '?', 'delta is ? on insert in multi pass');
1866            
1867             my @update_all = $o->db_translate_write('U', sort $o->cols);
1868             $test->is($update_all[0], '?', 'able is ? on update in multi pass');
1869             $test->is($update_all[1], 'bakerallprime', 'baker is bakerallprime on update in multi pass');
1870             $test->is($update_all[2], 'charlieallprime', 'charlie is charlieallprime on update in multi pass');
1871             $test->is($update_all[3], '?', 'delta is ? on update in multi pass');
1872            
1873             my @replace_all = $o->db_translate_write('R', sort $o->cols);
1874             $test->is($replace_all[0], '?', 'able is ? on replace in multi pass');
1875             $test->is($replace_all[1], 'bakerallprime', 'baker is bakerallprime on replace in multi pass');
1876             $test->is($replace_all[2], 'charlieallprime', 'charlie is charlieallprime on replace in multi pass');
1877             $test->is($replace_all[3], '?', 'delta is ? on replace in multi pass');
1878            
1879             my @delete_all = $o->db_translate_write('D', sort $o->cols);
1880             $test->is($delete_all[0], '?', 'able is ? on delete in multi pass');
1881             $test->is($delete_all[1], 'bakerallprime', 'baker is bakerallprime on delete in multi pass');
1882             $test->is($delete_all[2], 'charlieallprime', 'charlie is charlieallprime on delete in multi pass');
1883             $test->is($delete_all[3], '?', 'delta is ? on delete in multi pass');
1884            
1885             my @all_all = $o->db_translate_write('A', sort $o->cols);
1886             $test->is($all_all[0], '?', 'able is ? on all in multi pass');
1887             $test->is($all_all[1], 'bakerallprime', 'baker is bakerallprime on all in multi pass');
1888             $test->is($all_all[2], 'charlieallprime', 'charlie is charlieallprime on all in multi pass');
1889             $test->is($all_all[3], '?', 'delta is ? on all in multi pass');
1890             }
1891              
1892              
1893             =end btest
1894              
1895             =cut
1896              
1897             sub db_translate_write {
1898 0     0 0 0 my $self = shift;
1899 0 0       0 my $type = shift or return $self->error("Cannot do db_translate_write w/o type", "BDT-33");
1900 0 0       0 my @cols = @_ or return $self->error("Cannot do db_translate_write w/o column", "BDT-32");
1901              
1902 0         0 my $db_write_translation = $self->db_write_translation;
1903              
1904 0         0 foreach my $col (@cols) {
1905              
1906 0 0       0 if (defined $db_write_translation->{$col}) {
1907 0 0       0 if (defined $db_write_translation->{$col}->{$type}){
    0          
1908 0         0 $col = $db_write_translation->{$col}->{$type}->{'val'};
1909             }
1910             elsif (defined $db_write_translation->{$col}->{'A'}){
1911 0         0 $col = $db_write_translation->{$col}->{'A'}->{'val'};
1912             } else {
1913 0         0 $col = '?';
1914             }
1915             } else {
1916 0         0 $col = '?';
1917             };
1918             }
1919              
1920 0 0       0 return wantarray ? @cols : $cols[0];
1921             };
1922              
1923             # this is used internally to do translations required by db_read_translation
1924             #
1925             # gets one argument, $col, and returns the 'val' in the hash if it is specified.
1926             # otherwise, there is no change, so it returns the column
1927              
1928             =pod
1929              
1930             =begin btest db_translate_read
1931              
1932             my $o = __PACKAGE__->new();
1933             $test->ok($o, "Created object");
1934             my $def = {
1935             'able' => 'SQL_INTEGER',
1936             'baker' => 'SQL_INTEGER',
1937             'charlie' => 'SQL_INTEGER',
1938             'delta' => 'SQL_INTEGER'
1939             };
1940              
1941             $test->is($o->definition($def), $def, "Set definition");
1942             $test->is($o->definition, $def, "Got definition");
1943             $test->is($o->name('table'), 'table', 'Set table name');
1944              
1945             $test->is(scalar($o->db_translate_read()), undef, 'Cannot db_translate_read w/o col');
1946             $test->is($o->errcode, 'BDT-34', 'proper error code for db_translate_read (col)');
1947              
1948             $test->is($o->db_translate_read('able'), 'table.able', 'db_translate_read for able on select');
1949             $test->is($o->db_translate_read('baker'), 'table.baker', 'db_translate_read for baker on select');
1950             $test->is($o->db_translate_read('charlie'), 'table.charlie', 'db_translate_read for charlie on select');
1951             $test->is($o->db_translate_read('delta'), 'table.delta', 'db_translate_read for delta on select');
1952              
1953             my $translator = {
1954             'able' => 'ableselectorprime',
1955             'baker' => 'bakerallprime',
1956             'charlie' => 'charlieselectprime',
1957             };
1958              
1959             $test->is($o->db_read_translation($translator), $translator, "Set translator again");
1960              
1961             $test->is($o->db_translate_read('able'), 'ableselectorprime', 'db_translate_read for able on select');
1962             $test->is($o->db_translate_read('baker'), 'bakerallprime', 'db_translate_read for baker on select');
1963             $test->is($o->db_translate_read('charlie'), 'charlieselectprime', 'db_translate_read for charlie on select');
1964             $test->is($o->db_translate_read('delta'), 'table.delta', 'db_translate_read for delta on select');
1965              
1966             =end btest
1967              
1968             =cut
1969              
1970             sub db_translate_read {
1971 0     0 0 0 my $self = shift;
1972 0 0       0 my @cols = @_ or return $self->error("Cannot do db_translate_read w/o col", "BDT-34");
1973              
1974 0         0 my $db_read_translation = $self->db_read_translation;
1975              
1976 0         0 foreach my $col (@cols) {
1977 0 0       0 if (defined $db_read_translation->{$col}) {
1978 0         0 $col = $db_read_translation->{$col};
1979             } else {
1980 0         0 $col = $self->qualified_name($col);
1981             }
1982             }
1983              
1984 0 0       0 return wantarray ? @cols : $cols[0];
1985             };
1986              
1987             =pod
1988              
1989             =item alias_column
1990              
1991             Returns the aliased version of the column if one is defined in the column_aliases hash. Returns the column otherwise.
1992              
1993             $table->column_aliases(
1994             {
1995             'id' => 'user_id'
1996             }
1997             );
1998              
1999             print $table->alias_column('id'); #prints user_id (uses alias)
2000             print $table->alias_column('name'); #prints name (no alias)
2001              
2002             =cut
2003              
2004             =pod
2005              
2006             =begin btest alias_column
2007              
2008             my $o = __PACKAGE__->new('name' => 'testtable1');
2009             $test->ok($o, "Created object");
2010             my $def = {
2011             'able' => 'SQL_INTEGER',
2012             'baker' => 'SQL_INTEGER',
2013             'charlie' => 'SQL_INTEGER',
2014             'delta' => 'SQL_INTEGER'
2015             };
2016              
2017             my $aliases = {
2018             'able' => 'aliased_able',
2019             'baker' => 'aliased_baker',
2020             'charlie' => 'aliased_charlie',
2021             };
2022              
2023             $test->is($o->definition($def), $def, "Set definition");
2024             $test->is($o->definition, $def, "Got definition");
2025              
2026             $test->is($o->column_aliases($aliases), $aliases, "Set column aliases");
2027             $test->is($o->column_aliases(), $aliases, "Got column aliases");
2028              
2029             $test->is(scalar($o->alias_column()), undef, "Could not alias_column w/o column");
2030             $test->is($o->errcode, 'BDT-36', 'proper error code for alias_column (col)');
2031              
2032             $test->is($o->alias_column('able'), 'aliased_able', 'properly aliased able');
2033             $test->is($o->alias_column('baker'), 'aliased_baker', 'properly aliased baker');
2034             $test->is($o->alias_column('charlie'), 'aliased_charlie', 'properly aliased charlie');
2035             $test->is($o->alias_column('delta'), 'delta', 'properly aliased able (no alias)');
2036              
2037             $test->is($o->alias_column('testtable1.able'), 'aliased_able', 'properly aliased able');
2038             $test->is($o->alias_column('testtable1.baker'), 'aliased_baker', 'properly aliased baker');
2039             $test->is($o->alias_column('testtable1.charlie'), 'aliased_charlie', 'properly aliased charlie');
2040             $test->is($o->alias_column('testtable1.delta'), 'delta', 'properly aliased able (no alias)');
2041              
2042             =end btest
2043              
2044             =cut
2045              
2046             sub alias_column {
2047 45     45 1 54 my $self = shift;
2048 45 50       118 my @cols = @_ or return $self->error('Cannot alias column w/o column', "BDT-36");
2049              
2050 45         116 my $aliases = $self->column_aliases;
2051              
2052 45         84 foreach my $col (@cols) {
2053              
2054 45         189 $col = $self->nonqualified_name($col);
2055 45 100       152 $col = $aliases->{$col}
2056             if defined $aliases->{$col};
2057             }
2058              
2059 45 50       246 return wantarray ? @cols : $cols[0];
2060             };
2061              
2062             =pod
2063              
2064             =item column_for_alias
2065              
2066             Returns the non-aliased version of the column if one is defined in the column_aliases hash. Returns the column otherwise.
2067              
2068             $table->column_aliases(
2069             {
2070             'id' => 'user_id'
2071             }
2072             );
2073              
2074             print $table->alias_column('user_id'); #prints id (undoes alias)
2075             print $table->alias_column('name'); #prints name (no alias)
2076              
2077             =cut
2078              
2079             =pod
2080              
2081             =begin btest column_for_alias
2082              
2083             my $o = __PACKAGE__->new('name' => 'testtable2');
2084             $test->ok($o, "Created object");
2085             my $def = {
2086             'able' => 'SQL_INTEGER',
2087             'baker' => 'SQL_INTEGER',
2088             'charlie' => 'SQL_INTEGER',
2089             'delta' => 'SQL_INTEGER'
2090             };
2091              
2092             my $aliases = {
2093             'able' => 'aliased_able',
2094             'baker' => 'aliased_baker',
2095             'charlie' => 'aliased_charlie',
2096             };
2097              
2098             $test->is($o->definition($def), $def, "Set definition");
2099             $test->is($o->definition, $def, "Got definition");
2100              
2101             $test->is($o->column_aliases($aliases), $aliases, "Set column aliases");
2102             $test->is($o->column_aliases(), $aliases, "Got column aliases");
2103              
2104             $test->is(scalar($o->column_for_alias()), undef, "Could not get column_for_alias w/o alias");
2105             $test->is($o->errcode, 'BDT-35', 'proper error code for column_for_alias (alias)');
2106              
2107             $test->is($o->column_for_alias('aliased_able'), 'able', 'properly unaliased able');
2108             $test->is($o->column_for_alias('aliased_baker'), 'baker', 'properly unaliased baker');
2109             $test->is($o->column_for_alias('aliased_charlie'), 'charlie', 'unproperly aliased charlie');
2110             $test->is($o->column_for_alias('delta'), 'delta', 'properly aliased able (no alias)');
2111              
2112             $test->is($o->column_for_alias('testtable2.aliased_able'), 'able', 'properly unaliased able');
2113             $test->is($o->column_for_alias('testtable2.aliased_baker'), 'baker', 'properly unaliased baker');
2114             $test->is($o->column_for_alias('testtable2.aliased_charlie'), 'charlie', 'unproperly aliased charlie');
2115             $test->is($o->column_for_alias('testtable2.delta'), 'delta', 'properly aliased able (no alias)');
2116              
2117             =end btest
2118              
2119             =cut
2120              
2121             sub column_for_alias {
2122 0     0 1 0 my $self = shift;
2123 0 0       0 my $col = shift or return $self->error("Cannot get column w/o alias", "BDT-35");
2124              
2125 0         0 $col = $self->nonqualified_name($col);
2126              
2127 0         0 my %rev;
2128 0         0 @rev{values %{$self->column_aliases}} = keys %{$self->column_aliases};
  0         0  
  0         0  
2129 0 0       0 if (defined $rev{$col}) {
2130 0         0 return $rev{$col};
2131             } else {
2132 0         0 return $col;
2133             };
2134             };
2135              
2136             =pod
2137              
2138             =item insert_bindables
2139              
2140             Returns the columns in this table that should be bound with values upon an insert.
2141              
2142             my @insertables = $table->insert_bindables();
2143              
2144             =cut
2145              
2146             =pod
2147              
2148             =begin btest insert_bindables
2149              
2150             my $o = __PACKAGE__->new();
2151             $test->ok($o, "Created object");
2152              
2153             my $def = {
2154             'able' => 'SQL_INTEGER',
2155             'baker' => 'SQL_INTEGER',
2156             'charlie' => 'SQL_INTEGER',
2157             'delta' => 'SQL_INTEGER'
2158             };
2159              
2160             $test->is($o->definition($def), $def, "Set definition");
2161             $test->is($o->definition, $def, "Got definition");
2162              
2163             my %bindable = map {$_, 1} $o->insert_bindables();
2164              
2165             $test->is($bindable{'able'}, 1, 'able is insert bindable');
2166             $test->is($bindable{'baker'}, 1, 'baker is insert bindable');
2167             $test->is($bindable{'charlie'}, 1, 'charlie is insert bindable');
2168             $test->is($bindable{'delta'}, 1, 'delta is insert bindable');
2169              
2170             my $translator = {
2171             'able' => {
2172             'I' => {
2173             'val' => 'lc(?)',
2174             'binds' => 1
2175             },
2176             'A' => {
2177             'val' => 'NOW()',
2178             'binds' => 0,
2179             },
2180             },
2181             'baker' => {
2182             'I' => {
2183             'val' => 'NOW()',
2184             'binds' => 0
2185             },
2186             'A' => {
2187             'val' => '?',
2188             'binds' => 1,
2189             },
2190             },
2191             'charlie' => {
2192             'I' => {
2193             'val' => 'NOW()',
2194             'binds' => 0
2195             },
2196             },
2197             'delta' => {
2198             'A' => {
2199             'val' => 'NOW()',
2200             'binds' => 0
2201             },
2202             },
2203             };
2204              
2205             $test->is($o->db_write_translation($translator), $translator, 'set db_write_translation');
2206              
2207             my %bindable2 = map {$_, 1} $o->insert_bindables();
2208              
2209             $test->is($bindable2{'able'}, 1, 'able is insert bindable');
2210             $test->is($bindable2{'baker'}, undef, 'baker is not insert bindable');
2211             $test->is($bindable2{'charlie'}, undef, 'charlie is not insert bindable');
2212             $test->is($bindable2{'delta'}, undef, 'delta is not insert bindable');
2213              
2214             =end btest
2215              
2216             =cut
2217              
2218             sub insert_bindables {
2219 0     0 1 0 my $self = shift;
2220 0 0       0 if (my $bindables = $self->_cached_bindables->{'insert'}) {
2221 0         0 return @$bindables;
2222             } else {
2223 0         0 my @bindables = grep {$self->is_bindable('I', $_)} $self->insert_columns;
  0         0  
2224 0         0 $self->_cached_bindables->{'insert'} = \@bindables;
2225 0         0 return @bindables;
2226             };
2227             };
2228              
2229             =pod
2230              
2231             =item replace_bindables
2232              
2233             Returns the columns in this table that should be bound with values upon a replace.
2234              
2235             my @replaceables = $table->replace_bindables();
2236              
2237             =cut
2238              
2239             =pod
2240              
2241             =begin btest replace_bindables
2242              
2243             my $o = __PACKAGE__->new();
2244             $test->ok($o, "Created object");
2245              
2246             my $def = {
2247             'able' => 'SQL_INTEGER',
2248             'baker' => 'SQL_INTEGER',
2249             'charlie' => 'SQL_INTEGER',
2250             'delta' => 'SQL_INTEGER'
2251             };
2252              
2253             $test->is($o->definition($def), $def, "Set definition");
2254             $test->is($o->definition, $def, "Got definition");
2255              
2256             my %bindable = map {$_, 1} $o->replace_bindables();
2257              
2258             $test->is($bindable{'able'}, 1, 'able is replace bindable');
2259             $test->is($bindable{'baker'}, 1, 'baker is replace bindable');
2260             $test->is($bindable{'charlie'}, 1, 'charlie is replace bindable');
2261             $test->is($bindable{'delta'}, 1, 'delta is replace bindable');
2262              
2263             my $translator = {
2264             'able' => {
2265             'R' => {
2266             'val' => 'lc(?)',
2267             'binds' => 1
2268             },
2269             'A' => {
2270             'val' => 'NOW()',
2271             'binds' => 0,
2272             },
2273             },
2274             'baker' => {
2275             'R' => {
2276             'val' => 'NOW()',
2277             'binds' => 0
2278             },
2279             'A' => {
2280             'val' => '?',
2281             'binds' => 1,
2282             },
2283             },
2284             'charlie' => {
2285             'R' => {
2286             'val' => 'NOW()',
2287             'binds' => 0
2288             },
2289             },
2290             'delta' => {
2291             'A' => {
2292             'val' => 'NOW()',
2293             'binds' => 0
2294             },
2295             },
2296             };
2297              
2298             $test->is($o->db_write_translation($translator), $translator, 'set db_write_translation');
2299              
2300             my %bindable2 = map {$_, 1} $o->replace_bindables();
2301              
2302             $test->is($bindable2{'able'}, 1, 'able is replace bindable');
2303             $test->is($bindable2{'baker'}, undef, 'baker is not replace bindable');
2304             $test->is($bindable2{'charlie'}, undef, 'charlie is not replace bindable');
2305             $test->is($bindable2{'delta'}, undef, 'delta is not replace bindable');
2306              
2307             =end btest
2308              
2309             =cut
2310              
2311             sub replace_bindables {
2312 0     0 1 0 my $self = shift;
2313 0         0 return grep {$self->is_bindable('R', $_)} $self->replace_columns;
  0         0  
2314             };
2315              
2316             =pod
2317              
2318             =item update_bindables
2319              
2320             Returns the columns in this table that should be bound with values upon an update.
2321              
2322             my @updatables = $table->update_bindables();
2323              
2324             =cut
2325              
2326             =pod
2327              
2328             =begin btest update_bindables
2329              
2330             my $o = __PACKAGE__->new();
2331             $test->ok($o, "Created object");
2332              
2333             my $def = {
2334             'able' => 'SQL_INTEGER',
2335             'baker' => 'SQL_INTEGER',
2336             'charlie' => 'SQL_INTEGER',
2337             'delta' => 'SQL_INTEGER'
2338             };
2339              
2340             $test->is($o->definition($def), $def, "Set definition");
2341             $test->is($o->definition, $def, "Got definition");
2342              
2343             my %bindable = map {$_, 1} $o->update_bindables();
2344              
2345             $test->is($bindable{'able'}, 1, 'able is update bindable');
2346             $test->is($bindable{'baker'}, 1, 'baker is update bindable');
2347             $test->is($bindable{'charlie'}, 1, 'charlie is update bindable');
2348             $test->is($bindable{'delta'}, 1, 'delta is update bindable');
2349              
2350             my $translator = {
2351             'able' => {
2352             'U' => {
2353             'val' => 'lc(?)',
2354             'binds' => 1
2355             },
2356             'A' => {
2357             'val' => 'NOW()',
2358             'binds' => 0,
2359             },
2360             },
2361             'baker' => {
2362             'U' => {
2363             'val' => 'NOW()',
2364             'binds' => 0
2365             },
2366             'A' => {
2367             'val' => '?',
2368             'binds' => 1,
2369             },
2370             },
2371             'charlie' => {
2372             'U' => {
2373             'val' => 'NOW()',
2374             'binds' => 0
2375             },
2376             },
2377             'delta' => {
2378             'A' => {
2379             'val' => 'NOW()',
2380             'binds' => 0
2381             },
2382             },
2383             };
2384              
2385             $test->is($o->db_write_translation($translator), $translator, 'set db_write_translation');
2386              
2387             my %bindable2 = map {$_, 1} $o->update_bindables();
2388              
2389             $test->is($bindable2{'able'}, 1, 'able is update bindable');
2390             $test->is($bindable2{'baker'}, undef, 'baker is not update bindable');
2391             $test->is($bindable2{'charlie'}, undef, 'charlie is not update bindable');
2392             $test->is($bindable2{'delta'}, undef, 'delta is not update bindable');
2393              
2394             =end btest
2395              
2396             =cut
2397              
2398             __PACKAGE__->add_attr('_cached_bindables');
2399              
2400             sub update_bindables {
2401 0     0 1 0 my $self = shift;
2402 0 0       0 if (my $bindables = $self->_cached_bindables->{'update'}) {
2403 0         0 return @$bindables;
2404             } else {
2405 0         0 my @excess = $self->primary_cols;
2406 0         0 my @bindables = grep {$self->is_bindable('U', $_)} ($self->update_columns, @excess);
  0         0  
2407 0         0 $self->_cached_bindables->{'update'} = \@bindables;
2408 0         0 return @bindables;
2409             };
2410             }
2411              
2412             =pod
2413              
2414             =item delete_bindables
2415              
2416             Returns the columns in this table that should be bound with values upon an delete.
2417              
2418             my @deletables = $table->delete_bindables();
2419              
2420             =cut
2421              
2422             =pod
2423              
2424             =begin btest delete_bindables
2425              
2426             my $o = __PACKAGE__->new();
2427             $test->ok($o, "Created object");
2428              
2429             my $def = {
2430             'able' => 'SQL_INTEGER',
2431             'baker' => 'SQL_INTEGER',
2432             'charlie' => 'SQL_INTEGER',
2433             'delta' => 'SQL_INTEGER'
2434             };
2435              
2436             $test->is($o->definition($def), $def, "Set definition");
2437             $test->is($o->definition, $def, "Got definition");
2438              
2439             my %bindable = map {$_, 1} grep {defined} $o->delete_bindables();
2440              
2441             $test->is($bindable{'able'}, undef, 'able is not delete bindable');
2442             $test->is($bindable{'baker'}, undef, 'baker is not delete bindable');
2443             $test->is($bindable{'charlie'}, undef, 'charlie is not delete bindable');
2444             $test->is($bindable{'delta'}, undef, 'delta is not delete bindable');
2445              
2446             $o->primary_column('able');
2447              
2448             my %bindable2 = map {$_, 1} $o->delete_bindables();
2449              
2450             $test->is($bindable2{'able'}, 1, 'able is delete bindable');
2451             $test->is($bindable2{'baker'}, undef, 'baker is not delete bindable');
2452             $test->is($bindable2{'charlie'}, undef, 'charlie is not delete bindable');
2453             $test->is($bindable2{'delta'}, undef, 'delta is not delete bindable');
2454              
2455             $o->primary_column(['charlie', 'delta']);
2456              
2457             my %bindable3 = map {$_, 1} $o->delete_bindables();
2458              
2459             $test->is($bindable3{'able'}, undef, 'able is not delete bindable');
2460             $test->is($bindable3{'baker'}, undef, 'baker is not delete bindable');
2461             $test->is($bindable3{'charlie'}, 1, 'charlie is delete bindable');
2462             $test->is($bindable3{'delta'}, 1, 'delta is delete bindable');
2463              
2464              
2465             =end btest
2466              
2467             =cut
2468              
2469             sub delete_bindables {
2470 0     0 1 0 my $self = shift;
2471 0         0 return $self->primary_cols;
2472             };
2473              
2474             =pod
2475              
2476             =begin btest select_bindables
2477              
2478             my $o = __PACKAGE__->new();
2479             $test->ok($o, "Created object");
2480              
2481             my $def = {
2482             'able' => 'SQL_INTEGER',
2483             'baker' => 'SQL_INTEGER',
2484             'charlie' => 'SQL_INTEGER',
2485             'delta' => 'SQL_INTEGER'
2486             };
2487              
2488             $test->is($o->definition($def), $def, "Set definition");
2489             $test->is($o->definition, $def, "Got definition");
2490              
2491             my %bindable = map {$_, 1} grep {defined} $o->select_bindables;
2492              
2493             $test->is($bindable{'able'}, undef, 'able is not select bindable');
2494             $test->is($bindable{'baker'}, undef, 'baker is not select bindable');
2495             $test->is($bindable{'charlie'}, undef, 'charlie is not select bindable');
2496             $test->is($bindable{'delta'}, undef, 'delta is not select bindable');
2497              
2498             $o->primary_column('able');
2499              
2500             my %bindable2 = map {$_, 1} $o->select_bindables();
2501              
2502             $test->is($bindable2{'able'}, 1, 'able is select bindable');
2503             $test->is($bindable2{'baker'}, undef, 'baker is not select bindable');
2504             $test->is($bindable2{'charlie'}, undef, 'charlie is not select bindable');
2505             $test->is($bindable2{'delta'}, undef, 'delta is not select bindable');
2506              
2507             $o->primary_column(['charlie', 'delta']);
2508              
2509             my %bindable3 = map {$_, 1} $o->select_bindables();
2510              
2511             $test->is($bindable3{'able'}, undef, 'able is not select bindable');
2512             $test->is($bindable3{'baker'}, undef, 'baker is not select bindable');
2513             $test->is($bindable3{'charlie'}, 1, 'charlie is select bindable');
2514             $test->is($bindable3{'delta'}, 1, 'delta is select bindable');
2515              
2516             =end btest
2517              
2518             =cut
2519              
2520             sub select_bindables {
2521 0     0 0 0 my $self = shift;
2522              
2523 0         0 return $self->primary_cols;
2524             }
2525              
2526             =pod
2527              
2528             =item insert_query
2529              
2530             Returns an insert query for this table.
2531              
2532             my $insert_query = $table->insert_query();
2533              
2534             The query is a full insert with columns defined in the query. You may also pass
2535             in an array of columns to use in the insert. Otherwise, all columns defined in the
2536             table will be used.
2537              
2538             my $insert_qery = $table->insert_query('foo');
2539              
2540             Returns the insert query but only to be able to insert into column 'foo'. If you try
2541             to use a column that is not in the table, you'll get an error.
2542              
2543             =cut
2544              
2545             =pod
2546              
2547             =begin btest insert_query
2548              
2549             my $o = __PACKAGE__->new();
2550             $test->ok($o, "Created object");
2551              
2552             my $def = {
2553             'able' => 'SQL_INTEGER',
2554             'baker' => 'SQL_INTEGER',
2555             'charlie' => 'SQL_INTEGER',
2556             'delta' => 'SQL_INTEGER'
2557             };
2558              
2559             $test->is($o->definition($def), $def, "Set definition");
2560             $test->is($o->definition, $def, "Got definition");
2561              
2562             $test->is($o->name('mytable'), 'mytable', "set tablename");
2563              
2564             {
2565             my @insert = $o->insert_columns;
2566              
2567             $test->is($o->insert_query, "insert into mytable (" . join(', ', @insert)
2568             . ") values (?, ?, ?, ?)", "got default insert query");
2569             }
2570              
2571             {
2572             my @insert = $o->insert_columns(['able']);
2573              
2574             $test->is($o->insert_query, "insert into mytable (" . join(', ', @insert)
2575             . ") values (?)", "got able insert query");
2576             $o->insert_columns(undef);
2577             }
2578              
2579             {
2580             my @insert = $o->insert_columns(['able', 'baker']);
2581              
2582             $test->is($o->insert_query, "insert into mytable (" . join(', ', @insert)
2583             . ") values (?, ?)", "got able, baker insert query");
2584             $o->insert_columns(undef);
2585             }
2586              
2587             {
2588              
2589             $test->is(scalar($o->insert_query('foo')), undef, "Could not get insert query w/invalid column");
2590             $test->is($o->errcode, 'BDT-07', 'proper error code');
2591             }
2592              
2593             {
2594             $test->is($o->insert_query('able', 'baker'), "insert into mytable (able, baker) values (?, ?)", "got able, baker insert query");
2595             }
2596              
2597             {
2598             my $translator = {
2599             'able' => {
2600             'I' => {
2601             'val' => 'lc(?)',
2602             'binds' => 0
2603             },
2604             },
2605             'baker' => {
2606             'A' => {
2607             'val' => 'uc(?)',
2608             'binds' => 0,
2609             },
2610             },
2611             };
2612              
2613             $test->is($o->db_write_translation($translator), $translator, "Set translator");
2614              
2615             my @insert = $o->insert_columns;
2616              
2617             my $q = "insert into mytable (" . join(', ', @insert)
2618             . ") values (" . join(', ', map{$_ eq 'able' ? 'lc(?)' : $_ eq 'baker' ? 'uc(?)' : '?'} @insert) . ")";
2619              
2620             $test->is($o->insert_query, $q, "got re-written default insert query");
2621              
2622             }
2623              
2624             =end btest
2625              
2626             =cut
2627              
2628             sub insert_query {
2629 0     0 1 0 my $self = shift;
2630              
2631 0         0 my @cols = @_;
2632              
2633 0 0       0 if (@cols){
2634 0         0 foreach my $col (@cols){
2635 0 0       0 return $self->error("Cannot insert column not in table : $col", "BDT-07")
2636             unless $self->is_column($col);
2637             };
2638             } else {
2639 0         0 @cols = $self->insert_columns;
2640             }
2641              
2642 0         0 my $querykey = join(',', 'insert', @cols);
2643              
2644 0   0     0 my $query = $self->_cached_queries->{$querykey} || "insert into " . $self->name . " ("
2645             . join(', ', @cols)
2646             . ") values ("
2647             . join(", ", $self->db_translate_write('I', @cols)) #map { $self->db_translate_write($_, 'I') } @cols)
2648             . ")";
2649              
2650 0         0 $self->_cached_queries->{$querykey} = $query;
2651              
2652 0         0 return $query;
2653             };
2654              
2655             =pod
2656              
2657             =item replace_query
2658              
2659             Returns an replace query for this table.
2660              
2661             my $replace_query = $table->replace_query();
2662              
2663             The query is a full replace with columns defined in the query. You may also pass
2664             in an array of columns to use in the insert. Otherwise, all columns defined in the
2665             table will be used.
2666              
2667             my $replace_qery = $table->replace_query('foo');
2668              
2669             Returns the replace query but only to be able to replace into column 'foo'. If you try
2670             to use a column that is not in the table, you'll get an error.
2671              
2672             =cut
2673              
2674             =pod
2675              
2676             =begin btest replace_query
2677              
2678             my $o = __PACKAGE__->new();
2679             $test->ok($o, "Created object");
2680              
2681             my $def = {
2682             'able' => 'SQL_INTEGER',
2683             'baker' => 'SQL_INTEGER',
2684             'charlie' => 'SQL_INTEGER',
2685             'delta' => 'SQL_INTEGER'
2686             };
2687              
2688             $test->is($o->definition($def), $def, "Set definition");
2689             $test->is($o->definition, $def, "Got definition");
2690              
2691             $test->is($o->name('mytable'), 'mytable', "set tablename");
2692              
2693             {
2694             my @replace = $o->replace_columns;
2695              
2696             $test->is($o->replace_query, "replace into mytable (" . join(', ', @replace)
2697             . ") values (?, ?, ?, ?)", "got default replace query");
2698             }
2699              
2700             {
2701             my @replace = $o->replace_columns(['able']);
2702              
2703             $test->is($o->replace_query, "replace into mytable (" . join(', ', @replace)
2704             . ") values (?)", "got able replace query");
2705             $o->replace_columns(undef);
2706             }
2707              
2708             {
2709             my @replace = $o->replace_columns(['able', 'baker']);
2710              
2711             $test->is($o->replace_query, "replace into mytable (" . join(', ', @replace)
2712             . ") values (?, ?)", "got able, baker replace query");
2713             $o->replace_columns(undef);
2714             }
2715              
2716             {
2717              
2718             $test->is(scalar($o->replace_query('foo')), undef, "Could not get replace query w/invalid column");
2719             $test->is($o->errcode, 'BDT-08', 'proper error code');
2720             }
2721              
2722             {
2723             $test->is($o->replace_query('able', 'baker'), "replace into mytable (able, baker) values (?, ?)", "got able, baker replace query");
2724             }
2725              
2726             {
2727             my $translator = {
2728             'able' => {
2729             'R' => {
2730             'val' => 'lc(?)',
2731             'binds' => 0
2732             },
2733             },
2734             'baker' => {
2735             'A' => {
2736             'val' => 'uc(?)',
2737             'binds' => 0,
2738             },
2739             },
2740             };
2741              
2742             $test->is($o->db_write_translation($translator), $translator, "Set translator");
2743              
2744             my @replace = $o->replace_columns;
2745              
2746             my $q = "replace into mytable (" . join(', ', @replace)
2747             . ") values (" . join(', ', map{$_ eq 'able' ? 'lc(?)' : $_ eq 'baker' ? 'uc(?)' : '?'} @replace) . ")";
2748              
2749             $test->is($o->replace_query, $q, "got re-written default replace query");
2750              
2751             }
2752              
2753             =end btest
2754              
2755             =cut
2756              
2757             sub replace_query {
2758 0     0 1 0 my $self = shift;
2759              
2760 0         0 my @cols = @_;
2761              
2762 0 0       0 if (@cols){
2763 0         0 foreach my $col (@cols){
2764 0 0       0 return $self->error("Cannot replace column not in table : $col", "BDT-08")
2765             unless $self->is_column($col);
2766             };
2767             };
2768              
2769 0 0       0 @cols = $self->replace_columns unless @cols;
2770              
2771 0         0 my $querykey = join(',', 'replace', @cols);
2772              
2773 0   0     0 my $query = $self->_cached_queries->{$querykey} || "replace into " . $self->name . " ("
2774             . join(', ', @cols)
2775             . ") values ("
2776             . join(", ", $self->db_translate_write('R', @cols)) #map { $self->db_translate_write($_, 'R') } @cols)
2777             . ")";
2778              
2779 0         0 $self->_cached_queries->{$querykey} = $query;
2780              
2781 0         0 return $query;
2782             };
2783              
2784             =pod
2785              
2786             =item update_query
2787              
2788             Returns an update_query query for this table.
2789              
2790             my $update_query = $table->update_query();
2791              
2792             The query is a full update with columns defined in the query. You may also pass
2793             in an array of columns to use in the insert. Otherwise, all columns defined in the
2794             table will be used.
2795              
2796             my $update_query = $table->update_query('foo');
2797              
2798             Returns the update query but only to be able to update column 'foo'. If you try
2799             to use a column that is not in the table, you'll get an error.
2800              
2801             Be warned that no where clause is attached
2802              
2803             =cut
2804              
2805             =pod
2806              
2807             =begin btest update_query
2808              
2809             my $o = __PACKAGE__->new();
2810             $test->ok($o, "Created object");
2811              
2812             my $def = {
2813             'able' => 'SQL_INTEGER',
2814             'baker' => 'SQL_INTEGER',
2815             'charlie' => 'SQL_INTEGER',
2816             'delta' => 'SQL_INTEGER'
2817             };
2818              
2819             $test->is($o->definition($def), $def, "Set definition");
2820             $test->is($o->definition, $def, "Got definition");
2821              
2822             $test->is($o->name('mytable'), 'mytable', "set tablename");
2823              
2824             {
2825             my @update = $o->update_columns;
2826              
2827             $test->is($o->update_query, "update mytable set " . join(', ', map {"$_ = ?"} @update), "got default update query");
2828             }
2829              
2830             {
2831             my @update = $o->update_columns(['able']);
2832              
2833             $test->is($o->update_query, "update mytable set " . join(', ', map {"$_ = ?"} @update), "got able update query");
2834              
2835             $o->update_columns(undef);
2836             }
2837              
2838             {
2839             my @update = $o->update_columns(['able', 'baker']);
2840              
2841             $test->is($o->update_query, "update mytable set " . join(', ', map {"$_ = ?"} @update), "got able, baker update query");
2842             $o->update_columns(undef);
2843             }
2844              
2845             {
2846              
2847             $test->is(scalar($o->update_query('foo')), undef, "Could not get update query w/invalid column");
2848             $test->is($o->errcode, 'BDT-06', 'proper error code');
2849             }
2850              
2851             {
2852             $test->is($o->update_query('able', 'baker'), "update mytable set able = ?, baker = ?", "got able, baker update query");
2853             }
2854              
2855             {
2856             my $translator = {
2857             'able' => {
2858             'U' => {
2859             'val' => 'lc(?)',
2860             'binds' => 0
2861             },
2862             },
2863             'baker' => {
2864             'A' => {
2865             'val' => 'uc(?)',
2866             'binds' => 0,
2867             },
2868             },
2869             };
2870              
2871             $test->is($o->db_write_translation($translator), $translator, "Set translator");
2872              
2873             my @update = $o->update_columns;
2874              
2875             my $q = "update mytable set " . join(', ', map{$_ . ' = ' . ($_ eq 'able' ? 'lc(?)' : $_ eq 'baker' ? 'uc(?)' : '?')} @update);
2876              
2877             $test->is($o->update_query, $q, "got re-written default update query");
2878              
2879             }
2880              
2881             =end btest
2882              
2883             =cut
2884              
2885             sub update_query {
2886 0     0 1 0 my $self = shift;
2887              
2888 0         0 my @cols = @_;
2889              
2890 0 0       0 if (@cols){
2891 0         0 foreach my $col (@cols){
2892 0 0       0 return $self->error("Cannot update column not in table : $col", "BDT-06")
2893             unless $self->is_column($col);
2894             };
2895             } else {
2896 0         0 @cols = $self->update_columns;
2897             }
2898              
2899             #my $where = " where " . join(' and ', map {"$_ = ?"} $self->primary_cols);
2900              
2901 0         0 my $querykey = join(',', 'update', @cols);
2902              
2903             my $query = $self->_cached_queries->{$querykey} || "update " . $self->name . " set "
2904 0   0     0 . join(', ', map {$_ . " = " . $self->db_translate_write('U', $_)} @cols)
2905             ;# . $where;
2906              
2907 0         0 $self->_cached_queries->{$querykey} = $query;
2908              
2909 0         0 return $query;
2910             };
2911              
2912             =pod
2913              
2914             =item delete_query
2915              
2916             returns a delete query for this table.
2917              
2918             my $delete_query = $table->delete_query
2919              
2920             Be warned that no where clause is attached
2921              
2922             =cut
2923              
2924             =pod
2925              
2926             =begin btest delete_query
2927              
2928             my $o = __PACKAGE__->new();
2929             $test->ok($o, "Created object");
2930              
2931             $test->is($o->name('mytable'), 'mytable', "set tablename");
2932              
2933             $test->is($o->delete_query, 'delete from mytable', 'proper delete query');
2934              
2935             =end btest
2936              
2937             =cut
2938              
2939             sub delete_query {
2940 0     0 1 0 my $self = shift;
2941              
2942 0         0 return "delete from " . $self->name;
2943             };
2944              
2945             =pod
2946              
2947             =item select_query
2948              
2949             Returns an select_query query for this table.
2950              
2951             my $select_query = $table->select_query();
2952              
2953             The query is a full update with columns defined in the query. You may also pass
2954             in an array of columns to use in the select. Otherwise, all columns defined in the
2955             table will be used.
2956              
2957             my $select_query = $table->select_query('foo');
2958              
2959             Returns the select query but only to be able to select column 'foo'. If you try
2960             to use a column that is not in the table, you'll get an error.
2961              
2962             Be warned that no where clause is attached
2963              
2964             =cut
2965              
2966             =pod
2967              
2968             =begin btest select_query
2969              
2970             my $o = __PACKAGE__->new();
2971             $test->ok($o, "Created object");
2972              
2973             my $def = {
2974             'able' => 'SQL_INTEGER',
2975             'baker' => 'SQL_INTEGER',
2976             'charlie' => 'SQL_INTEGER',
2977             'delta' => 'SQL_INTEGER'
2978             };
2979              
2980             $test->is($o->definition($def), $def, "Set definition");
2981             $test->is($o->definition, $def, "Got definition");
2982              
2983             $test->is($o->name('mytable'), 'mytable', "set tablename");
2984              
2985             $test->is(scalar($o->select_query('fake')), undef, 'Could not select unknown column');
2986             $test->is($o->errcode, 'BDT-05', 'proper error code');
2987              
2988             {
2989             my @select = $o->select_columns;
2990              
2991             $test->is($o->select_query, 'select ' . join(', ', map {"mytable.$_ as $_"} @select) . ' from mytable', "got default select query");
2992              
2993             }
2994              
2995             {
2996             my @select = $o->select_columns(['able']);
2997              
2998             $test->is($o->select_query, 'select ' . join(', ', map {"mytable.$_ as $_"} @select) . ' from mytable', "got able select query");
2999              
3000             $o->select_columns(undef);
3001             }
3002              
3003             {
3004             my @select = $o->select_columns(['able', 'baker']);
3005              
3006             $test->is($o->select_query, 'select ' . join(', ', map {"mytable.$_ as $_"} @select) . ' from mytable', "got able baker select query");
3007              
3008             $o->select_columns(undef);
3009             }
3010              
3011             {
3012             $test->is($o->select_query('able', 'baker'), 'select mytable.able as able, mytable.baker as baker from mytable', 'got able baker passed select query');
3013             }
3014              
3015             {
3016             $test->is($o->select_query('NOW()', '"const1"', "'const2'", 2004), 'select NOW(), "const1", \'const2\', 2004 from mytable', 'got function, constant select query');
3017             }
3018              
3019             {
3020             my $translator = {
3021             'able' => 'lc(able)',
3022             'baker' => 'uc(baker)',
3023             };
3024              
3025             my @select = $o->select_columns();
3026              
3027             $test->is($o->db_read_translation($translator), $translator, "Set translator");
3028              
3029             $test->is($o->select_query, 'select ' . join(', ', map{($_ eq 'able' ? 'lc(able)' : $_ eq 'baker' ? 'uc(baker)' : "mytable.$_") . " as $_"} @select) . ' from mytable', "got translated select query");
3030              
3031             $o->db_read_translation({});
3032             }
3033              
3034             {
3035             my $extra = {
3036             'current_time' => 'NOW()'
3037             };
3038              
3039             $test->is($o->extra_select($extra), $extra, "Set extra select");
3040              
3041             my @select = ((map {"mytable.$_ as $_"} $o->select_columns), (map {$extra->{$_} . ' as ' . $_} keys %$extra));
3042              
3043             $test->is($o->select_query, 'select ' . join(', ', @select) . ' from mytable', "got extra selecting select query");
3044             };
3045              
3046             =end btest
3047              
3048             =cut
3049              
3050             sub select_query {
3051 0     0 1 0 my $self = shift;
3052              
3053 0         0 my @cols = @_;
3054              
3055 0 0       0 if (@cols){
3056 0         0 foreach my $col (@cols){
3057 0 0       0 return $self->error("Cannot select column not in table : $col", "BDT-05")
3058             unless $self->is_selectable($col);
3059             #regex matches numbers, "foo", 'foo', or function(), also used below
3060             #in constructing the query
3061             };
3062             } else {
3063 0         0 @cols = ($self->select_columns, keys %{$self->extra_select});
  0         0  
3064             };
3065              
3066 0         0 my $querykey = join(',', 'select', @cols);
3067              
3068             my $query = $self->_cached_queries->{$querykey} || "select "
3069             . join(', ', map {
3070 0   0     0 $self->extra_select->{$_}
3071             ? $self->extra_select->{$_} . ' as ' . $_
3072             : $self->is_column($_)
3073             ? $self->db_translate_read($_) . ' as ' . $self->alias_column($_)
3074             : $_
3075             }
3076             @cols)
3077             . " from " . $self->name;
3078              
3079 0         0 $self->_cached_queries->{$querykey} = $query;
3080              
3081 0         0 return $query;
3082              
3083             };
3084              
3085             =pod
3086              
3087             =item multiselect_query
3088              
3089             Magic time. The multiselect_query allows you to auto-build and execute select queries across multiple tables. Expects up
3090             to two arguments, in a hash.
3091              
3092             =over
3093              
3094             =item tables
3095              
3096             The table objects that will be joined in this select statement. You need at least one table, but if you're only selecting one
3097             table, you should probably just use its select_query.
3098              
3099             =item cols
3100              
3101             The list of columns to select in the join. If this is not specified, then all columns in all tables will be used.
3102             NOTE THAT COLUMN ALIASES WILL NOT BE USED UNLESS YOU PASS THE use_aliases flag.
3103              
3104             $table->multiselect_query('tables' => $tables, 'use_aliases' => 1);
3105              
3106             This is by design, it is assumed that most of the time, you're using a multi select query when doing an arbitrary_sql call to get
3107             back massive amounts of data and you need to know the original column name, and the table it was from.
3108              
3109             =back
3110              
3111             Most of the time, hiding behind Basset's object persistence capabilities are more than sufficient. You can load up objects,
3112             manipulate them, write them back out. Everything's peachy. But some of the time, you just need data. Lots of data. And you need
3113             it fast. Real fast. Basset doesn't deal well with that.
3114              
3115             Let's say you have a table of users and a table (that serves as a log) of login information. Each time the user logs in, you
3116             insert an entry into the login table. You want to get a list of all users and the number of times they've logged in.
3117              
3118             You can do this with the standard methods.
3119              
3120             my $users = Some::User->load_all();
3121              
3122             foreach my $user (@$users) {
3123             print $user->name, " logged in : ", $user->logininformation, "\n"; #assuming logininformation wrappers what we want
3124             }
3125              
3126             But there's a lot of overhead involved in that and it's not necessarily the fastest way to do it. Sure, in this case,
3127             it makes sense. But it might not always. So, instead, you can do a multiselect_query. Let's define the tables for
3128             clarity, and we'll even assume they're in different packages.
3129              
3130             my $user_table = Basset::DB::Table->new(
3131             'name' => 'user',
3132             'primary_column' => 'id',
3133             'definition' => {
3134             'id' => 'SQL_INTEGER',
3135             'name' => 'SQL_VARCHAR'
3136             }
3137             );
3138              
3139             my $login_table = Basset::DB::Table->new(
3140             'name' => 'login',
3141             'primary_column' => 'id',
3142             'definition' => {
3143             'id' => 'SQL_INTEGER'
3144             'user_id' => 'SQL_INTEGER',
3145             'login_time'=> 'SQL_TIMESTAMP'
3146             },
3147             'references' => {
3148             'user_id' => 'user.id'
3149             }
3150             );
3151              
3152             my $q = Basset::DB::Table->multiselect_query(
3153             'tables' => [$user_table, $login_table],
3154             );
3155              
3156             print "$q\n";
3157              
3158             This prints out:
3159              
3160             select
3161             user.name,
3162             user.id,
3163             login.login_time,
3164             login.user_id,
3165             login.id,
3166             from
3167             user inner join login
3168             on user.id = login.user_id
3169              
3170             So now we have one query that will get us back all of our data. But we're still yanking back too much. We
3171             actually only care about the user and the total login info. We can fix that by specifying the columns we want. Please note that you
3172             need to qualify the column names.
3173              
3174             my $q = Basset::DB::Table->multiselect_query(
3175             'tables' => [$user_table, $login_table],
3176             'cols' => [qw[user.id user.name count(*)]]
3177             ) or die Basset::DB::Table->errstring;
3178              
3179             print "$q\n";
3180              
3181             This prints out:
3182              
3183             select
3184             user.id,
3185             user.name,
3186             count(*)
3187             from
3188             user inner join login
3189             on user.id = login.user_id
3190              
3191             Closer, but still not quite there. For one thing, this will ignore any users that have never logged in, since they don't have
3192             an entry in the login table. Easy to fix, specify the join type:
3193              
3194             my $q = Basset::DB::Table->multiselect_query(
3195             'tables' => [
3196             $user_table,
3197             ['left', $login_table]
3198             ],
3199             'cols' => [qw[user.id name], 'coalesce(count(*), 0) as count'],
3200             ) or die Basset::DB::Table->errstring;
3201              
3202             print "$q\n";
3203              
3204             This prints out:
3205              
3206             select
3207             user.id as id,
3208             user.name as name,
3209             coalesce(count(*), 0) as count
3210             from
3211             user left join login
3212             on user.id = login.user_id
3213              
3214             That's all of the data we want, but we're still missing something - the group by clause. So we attach one. We'll even tack
3215             on an order by clause for good measure so we don't need to sort later.
3216              
3217             my $q = Basset::DB::Table->attach_to_query(
3218             Basset::DB::Table->multiselect_query(
3219             'tables' => [
3220             $user_table,
3221             ['left', $login_table]
3222             ],
3223             'cols' => [qw[user.id name], 'coalesce(count(*), 0) as count'],
3224             ) ,
3225             {
3226             'group by' => 'user.id, name',
3227             'order by' => 'count',
3228             }
3229             );
3230              
3231             print "$q\n";
3232              
3233             This prints out:
3234              
3235             select
3236             user.id as id,
3237             user.name as name,
3238             coalesce(count(*), 0) as count
3239             from
3240             user left join login
3241             on user.id = login.user_id
3242             group by
3243             user.id, name
3244             order by
3245             count
3246              
3247             And voila! We're done. Hand that query off to whatever method it is you use to run sql queries (such as Basset::Object::Persistent's
3248             arbitrary_sql method), get back your data, and you're all set.
3249              
3250             =cut
3251              
3252             =pod
3253              
3254             =begin btest multiselect_query
3255              
3256             my $o = __PACKAGE__->new();
3257             $test->ok($o, "Created object");
3258              
3259             my $o2 = __PACKAGE__->new();
3260             $test->ok($o2, "Created object");
3261              
3262             my $o3 = __PACKAGE__->new();
3263             $test->ok($o3, "Created object");
3264              
3265             my $o4 = __PACKAGE__->new();
3266             $test->ok($o4, "Created object");
3267              
3268             my $def1 = {
3269             'able' => 'SQL_INTEGER',
3270             'baker' => 'SQL_INTEGER',
3271             'charlie' => 'SQL_INTEGER',
3272             'delta' => 'SQL_INTEGER'
3273             };
3274              
3275             my $ref1 = {
3276             'able' => 'table2.aid',
3277             'baker' => 'table4.b',
3278             'charlie' => 'table4.c',
3279             };
3280              
3281             $test->is($o->definition($def1), $def1, "Set definition");
3282             $test->is($o->references($ref1), $ref1, "Set references");
3283             $test->is($o->name("table1"), "table1", "set table name");
3284             $test->is($o->primary_column("able"), "able", "set table primary id");
3285              
3286             my $def2 = {
3287             'aid' => 'SQL_INTEGER',
3288             'bid' => 'SQL_INTEGER',
3289             'cid' => 'SQL_INTEGER',
3290             'did' => 'SQL_INTEGER'
3291             };
3292              
3293             my $ref2 = {
3294             'aid' => 'table3.ace'
3295             };
3296              
3297             my $aliases2 = {
3298             'aid' => 'ALIASED_aid',
3299             };
3300              
3301             $test->is($o2->definition($def2), $def2, "Set definition");
3302             $test->is($o2->references($ref2), $ref2, "Set references");
3303             $test->is($o2->column_aliases($aliases2), $aliases2, "Set aliases");
3304             $test->is($o2->name("table2"), "table2", "set table name");
3305             $test->is($o2->primary_column("aid"), "aid", "set table primary id");
3306              
3307             my $def3 = {
3308             'ace' => 'SQL_INTEGER',
3309             'bogey' => 'SQL_INTEGER',
3310             };
3311              
3312             $test->is($o3->definition($def3), $def3, "Set definition");
3313             $test->is($o3->name("table3"), "table3", "set table name");
3314             $test->is($o3->primary_column("ace"), "ace", "set table primary id");
3315              
3316             my $def4 = {
3317             'a' => 'SQL_INTEGER',
3318             'b' => 'SQL_INTEGER',
3319             'c' => 'SQL_INTEGER',
3320             'd' => 'SQL_INTEGER'
3321             };
3322              
3323             $test->is($o4->definition($def4), $def4, "Set definition");
3324             $test->is($o4->name("table4"), "table4", "set table name");
3325             $test->ok($o4->primary_column([qw(b c)]), "set table primary id");
3326              
3327             my @o1select = $o->select_columns();
3328             my @o2select = $o2->select_columns();
3329             my @o3select = $o3->select_columns();
3330             my @o4select = $o4->select_columns();
3331              
3332             $test->is(scalar(__PACKAGE__->multiselect_query()), undef, "Could not multiselect w/o tables");
3333             $test->is(__PACKAGE__->errcode, 'BDT-47', 'proper error code');
3334              
3335             $test->is(__PACKAGE__->multiselect_query('tables' => $o),
3336             "select " . (join(", ",map {"table1.$_ as $_"} @o1select)) . " from table1",
3337             'multi selected single table');
3338              
3339             $test->is(__PACKAGE__->multiselect_query('tables' => [$o]),
3340             "select " . (join(", ",map {"table1.$_ as $_"} @o1select)) . " from table1",
3341             'multi selected single table in arrayref');
3342              
3343              
3344             $test->is(__PACKAGE__->multiselect_query('cols' => 'able', 'tables' => $o),
3345             "select " . (join(", ",map {"table1.$_ as $_"} ('able'))) . " from table1",
3346             'multi selected single table, different cols');
3347              
3348             $test->is(__PACKAGE__->multiselect_query('cols' => ['able'], 'tables' => $o),
3349             "select " . (join(", ",map {"table1.$_ as $_"} ('able'))) . " from table1",
3350             'multi selected single table, different cols in arrayref');
3351              
3352             $test->is(__PACKAGE__->multiselect_query('cols' => ['able'], 'tables' => [$o]),
3353             "select " . (join(", ",map {"table1.$_ as $_"} ('able'))) . " from table1",
3354             'multi selected single table in arrayref, different cols');
3355              
3356             $test->is(__PACKAGE__->multiselect_query('tables' => [$o, $o2]),
3357             "select\n" . (join(",\n",map {"\ttable1.$_"} @o1select))
3358             . ",\n" . (join(",\n",map {"\ttable2.$_"} @o2select)) . "\nfrom\n" .
3359             "table1
3360             inner join
3361             table2
3362             on table1.able = table2.aid",
3363             'multi selected multi table in arrayref');
3364              
3365             $test->is(__PACKAGE__->multiselect_query('cols' => ['able', 'baker'], 'tables' => [$o, $o2]),
3366             "select\n" . (join(",\n",map {"\t$_"} ('able')))
3367             . ",\n" . (join(",\n",map {"\t$_"} ('baker'))) . "\nfrom\n" .
3368             "table1
3369             inner join
3370             table2
3371             on table1.able = table2.aid",
3372             'multi selected multi table in arrayref with differing columns');
3373              
3374             $test->is(__PACKAGE__->multiselect_query('use_aliases' => 1, 'tables' => [$o, $o2]),
3375             "select\n" . (join(",\n",map {"\ttable1.$_ as " . $o2->alias_column($_)} @o1select))
3376             . ",\n" . (join(",\n",map {"\ttable2.$_ as " . $o2->alias_column($_)} @o2select)) . "\nfrom\n" .
3377             "table1
3378             inner join
3379             table2
3380             on table1.able = table2.aid",
3381             'multi selected multi table in arrayref with aliases');
3382              
3383             =end btest
3384              
3385             =cut
3386              
3387             sub multiselect_query {
3388 0     0 1 0 my $class = shift;
3389              
3390 0         0 my %init = (
3391             'cols' => [],
3392             'use_aliases' => 0,
3393             @_
3394             );
3395              
3396 0 0       0 return $class->error("Cannot multi-select w/o tables", "BDT-47") unless defined $init{'tables'};
3397              
3398 0 0       0 $init{'tables'} = [$init{'tables'}] unless ref $init{'tables'} eq 'ARRAY';
3399 0 0       0 $init{'cols'} = [$init{'cols'}] unless ref $init{'cols'} eq 'ARRAY';
3400              
3401 0 0       0 if (@{$init{'tables'}} == 1) {
  0         0  
3402 0         0 return $init{'tables'}->[0]->select_query(@{$init{'cols'}});
  0         0  
3403             };
3404              
3405 0 0       0 my $joined_tables = $class->join_tables(@{$init{'tables'}}) or return;
  0         0  
3406              
3407 0         0 my %omit = ();
3408              
3409 0 0       0 if ($init{'omit_columns_from_tables'}) {
3410 0         0 %omit = map {$_->name, 1} @{$init{'omit_columns_from_tables'}};
  0         0  
  0         0  
3411             }
3412              
3413 0 0       0 unless (@{$init{'cols'}}) {
  0         0  
3414             #we duplicate the for loop to keep from doing the condition constantly in the loop. Lazy, I know.
3415 0 0       0 if ($init{'use_aliases'}) {
3416 0         0 foreach my $table (@{$init{'tables'}}) {
  0         0  
3417 0 0       0 next if $omit{$table->name};
3418 0         0 push @{$init{'cols'}}, map {$table->db_translate_read($_) . ' as ' . $table->alias_column($_)} $table->select_columns;
  0         0  
  0         0  
3419             }
3420             } else {
3421 0         0 foreach my $table (@{$init{'tables'}}) {
  0         0  
3422 0 0       0 next if $omit{$table->name};
3423 0         0 push @{$init{'cols'}}, map {$table->db_translate_read($_)} $table->select_columns;
  0         0  
  0         0  
3424             }
3425             }
3426             };
3427              
3428 0         0 return "select\n\t" . join(",\n\t", @{$init{'cols'}}) . "\nfrom\n" . $joined_tables;
  0         0  
3429             }
3430              
3431             =pod
3432              
3433             =item count_query
3434              
3435             Returns a count query ("select count(*) from $table").
3436              
3437             my $count_query = $table->count_query();
3438              
3439             Be warned that no where clause is attached.
3440              
3441             =cut
3442              
3443             =pod
3444              
3445             =begin btest count_query
3446              
3447             my $o = __PACKAGE__->new();
3448             $test->ok($o, "Got object");
3449              
3450             $test->is($o->name('count_query_table'), 'count_query_table', 'Set table name');
3451             $test->is($o->count_query, 'select count(1) as count from count_query_table', 'Got count query');
3452              
3453             =end btest
3454              
3455             =cut
3456              
3457             sub count_query {
3458 0     0 1 0 my $self = shift;
3459              
3460 0         0 return "select count(1) as count from " . $self->name;
3461             };
3462              
3463             =pod
3464              
3465             =item optimize_query
3466              
3467             Returns an optimize table query.
3468              
3469             my $optimize_query = $table->optimize_query();
3470              
3471             =cut
3472              
3473             =pod
3474              
3475             =begin btest optimize_query
3476              
3477             my $o = __PACKAGE__->new();
3478             $test->ok($o, "Got object");
3479             $test->is($o->name("test table"), "test table", "set table name");
3480             $test->is($o->optimize_query, 'optimize table test table', "got optimize query");
3481              
3482             =end btest
3483              
3484             =cut
3485              
3486             sub optimize_query {
3487 0     0 1 0 my $self = shift;
3488              
3489 0         0 return "optimize table " . $self->name;
3490             };
3491              
3492             =pod
3493              
3494             =item describe_query
3495              
3496             Returns an describe table query.
3497              
3498             my $describe_query = $table->describe_query();
3499              
3500             =cut
3501              
3502             =pod
3503              
3504             =begin btest describe_query
3505              
3506             my $o = __PACKAGE__->new();
3507             $test->ok($o, "Got object");
3508             $test->is($o->name("test table"), "test table", "set table name");
3509             $test->is($o->describe_query, 'desc test table', "got desc query");
3510              
3511             =end btest
3512              
3513             =cut
3514              
3515              
3516             sub describe_query {
3517 0     0 1 0 my $self = shift;
3518              
3519 0         0 return "desc " . $self->name;
3520             };
3521              
3522             =pod
3523              
3524             =item reference_query
3525              
3526             Given a column, returns a count query referencing the other table to determine whether the key is valid.
3527              
3528             $table->references(
3529             {
3530             'user_id' => 'user.id',
3531             'user_name' => 'user.name'
3532             }
3533             );
3534              
3535             print $table->reference_query('user_id'); #prints select count(1) from user where id = ?
3536              
3537             print $table->reference_query('login'); #prints nothing
3538              
3539             =cut
3540              
3541             =pod
3542              
3543             =begin btest reference_query
3544              
3545             my $def = {
3546             'user_id' => 'SQL_INTEGER',
3547             'user_name' => 'SQL_VARCHAR',
3548             };
3549              
3550             my $foreign = {
3551             'user_id' => 'user.id',
3552             'user_name' => 'user.name'
3553             };
3554              
3555             my $o = __PACKAGE__->new(
3556             'definition' => $def,
3557             'references' => $foreign,
3558             );
3559             $test->ok($o, "Got object");
3560             $test->is($o->definition, $def, "proper definition");
3561             $test->is($o->references, $foreign, "proper foreign references");
3562              
3563             my $f2 = {%$foreign};
3564              
3565             $test->is($o->references($f2), $f2, "properly reset foreign reference");
3566              
3567             $test->is($o->reference_query('user_id'), "select count(1) as count from user\n where id = ?", "successful reference query");
3568             $test->is($o->reference_query('user_name'), "select count(1) as count from user\n where name = ?", "successful reference query");
3569              
3570             $test->is(scalar($o->reference_query('foo')), undef, "got nothing for non-referenced column");
3571             $test->is($o->errcode, "BDT-14", "Proper error code");
3572              
3573             =end btest
3574              
3575             =cut
3576              
3577             sub reference_query {
3578 0     0 1 0 my $self = shift;
3579 0         0 my $column = shift;
3580              
3581 0 0       0 if (my $def = $self->referenced_column($column)) {
3582 0         0 my ($table, $col) = split(/\./, $def);
3583 0         0 my $tempTable = $self->pkg->new('name' => $table);
3584 0         0 return $tempTable->attach_to_query(
3585             $tempTable->count_query,
3586             {
3587             'where' => "$col = ?"
3588             }
3589             );
3590             } else {
3591 0         0 return $self->error("Cannot build query...$column is not a referenced column", "BDT-14");
3592             }
3593             };
3594              
3595             =pod
3596              
3597             =item is_column
3598              
3599             When passed a column name, returns a 1 if it is a column in this table, a 0 if it is not.
3600              
3601             print $table->is_column('foo');
3602              
3603             =cut
3604              
3605             =pod
3606              
3607             =begin btest is_column
3608              
3609             my $o = __PACKAGE__->new();
3610             $test->ok($o, "Created object");
3611             my $def = {
3612             'able' => 'SQL_INTEGER',
3613             'baker' => 'SQL_INTEGER',
3614             'charlie' => 'SQL_INTEGER',
3615             'delta' => 'SQL_INTEGER'
3616             };
3617              
3618             $test->is($o->definition($def), $def, "Set definition");
3619             $test->is($o->definition, $def, "Got definition");
3620              
3621             $test->ok($o->is_column('able'), 'able is column');
3622             $test->ok($o->is_column('baker'), 'baker is column');
3623             $test->ok($o->is_column('charlie'), 'charlie is column');
3624             $test->ok($o->is_column('delta'), 'delta is column');
3625             $test->is($o->is_column('edgar'), 0, 'edgar is not column');
3626             $test->is($o->is_column('foxtrot'), 0, 'foxtrot is not column');
3627              
3628             $test->is(scalar($o->is_column), undef, "Cannot call w/o column");
3629             $test->is($o->errcode, "BDT-04", "proper error code");
3630              
3631             =end btest
3632              
3633             =cut
3634              
3635             sub is_column {
3636 6     6 1 12 my $self = shift;
3637 6 50       18 my $col = shift or return $self->error("Cannot column-ness without column", "BDT-04");
3638              
3639 6         17 foreach my $column ($self->cols){
3640 14 100       67 return 1 if $column eq $col;
3641             }
3642 0         0 return 0;
3643             };
3644              
3645             =pod
3646              
3647             =item is_primary
3648              
3649             When passed a column name, returns a 1 if it is a primary column in this table, a 0 if it is not
3650              
3651             print $table->is_primary('foo');
3652              
3653             =cut
3654              
3655             =pod
3656              
3657             =begin btest is_primary
3658              
3659             my $o = __PACKAGE__->new();
3660             $test->ok($o, "Created object");
3661             my $def = {
3662             'able' => 'SQL_INTEGER',
3663             'baker' => 'SQL_INTEGER',
3664             'charlie' => 'SQL_INTEGER',
3665             'delta' => 'SQL_INTEGER'
3666             };
3667              
3668             $test->is($o->definition($def), $def, "Set definition");
3669             $test->is($o->primary_column('able'), 'able', 'Set primary column');;
3670              
3671             $test->is(scalar($o->is_primary), undef, 'Cannot determine primary-ness w/o a column');
3672             $test->is($o->errcode, 'BDT-01', 'proper error code');
3673              
3674             $test->ok($o->is_primary('able'), 'able is primary');
3675             $test->is($o->is_primary('baker'), 0, 'baker is not primary');
3676             $test->is($o->is_primary('charlie'), 0, 'charlie is not primary');
3677             $test->is($o->is_primary('delta'), 0, 'delta is not primary');
3678             $test->is($o->is_primary('edgar'), 0, 'edgar is not primary');
3679             $test->is($o->is_primary('foxtrot'), 0, 'foxtrot is not primary');
3680              
3681             my $primaries = [qw(baker delta)];
3682              
3683             $test->is($o->primary_column($primaries), $primaries, 'set primary column');
3684              
3685             $test->is($o->is_primary('able'), 0, 'able is not primary');
3686             $test->is($o->is_primary('baker'), 1, 'baker is primary');
3687             $test->is($o->is_primary('charlie'), 0, 'charlie is not primary');
3688             $test->is($o->is_primary('delta'), 1, 'delta is primary');
3689             $test->is($o->is_primary('edgar'), 0, 'edgar is not primary');
3690             $test->is($o->is_primary('foxtrot'), 0, 'foxtrot is not primary');
3691              
3692             $test->is(scalar($o->is_primary), undef, "Cannot call w/o column");
3693             $test->is($o->errcode, "BDT-01", "proper error code");
3694              
3695             =end btest
3696              
3697             =cut
3698              
3699             sub is_primary {
3700 0     0 1 0 my $self = shift;
3701 0 0       0 my $col = shift or return $self->error("Cannot determine primary-ness without column", "BDT-01");
3702              
3703 0         0 my %primaries = map {$_, 1} grep {defined} $self->primary_cols();
  0         0  
  0         0  
3704              
3705 0 0       0 return 1 if $primaries{$col};
3706 0         0 return 0;
3707             };
3708              
3709             =pod
3710              
3711             =item non_primary_cols
3712              
3713             Returns a list of all of the non primary columns in the table.
3714              
3715             my @nons = $table->non_primary_cols();
3716              
3717             =cut
3718              
3719             =pod
3720              
3721             =begin btest non_primary_cols
3722              
3723             my $o = __PACKAGE__->new();
3724             $test->ok($o, "Created object");
3725             my $def = {
3726             'able' => 'SQL_INTEGER',
3727             'baker' => 'SQL_INTEGER',
3728             'charlie' => 'SQL_INTEGER',
3729             'delta' => 'SQL_INTEGER'
3730             };
3731              
3732             $test->is($o->definition($def), $def, "Set definition");
3733              
3734             {
3735             my %primary = map {$_, 1} $o->non_primary_cols;
3736              
3737             $test->is($primary{'able'}, 1, 'able is not primary column');
3738             $test->is($primary{'baker'}, 1, 'baker is not primary column');
3739             $test->is($primary{'charlie'}, 1, 'charlie is not primary column');
3740             $test->is($primary{'delta'}, 1, 'delta is not primary column');
3741             }
3742              
3743             {
3744             $o->primary_column('able');
3745              
3746             my %primary = map {$_, 1} $o->non_primary_cols;
3747              
3748             $test->is($primary{'able'}, undef, 'able is primary column');
3749             $test->is($primary{'baker'}, 1, 'baker is not primary column');
3750             $test->is($primary{'charlie'}, 1, 'charlie is not primary column');
3751             $test->is($primary{'delta'}, 1, 'delta is not primary column');
3752             }
3753              
3754             {
3755             $o->primary_column(['charlie', 'delta']);
3756              
3757             my %primary = map {$_, 1} $o->non_primary_cols;
3758              
3759             $test->is($primary{'able'}, 1, 'able is not primary column');
3760             $test->is($primary{'baker'}, 1, 'baker is not primary column');
3761             $test->is($primary{'charlie'}, undef, 'charlie is primary column');
3762             $test->is($primary{'delta'}, undef, 'delta is primary column');
3763             }
3764              
3765             =end btest
3766              
3767             =cut
3768              
3769             sub non_primary_cols {
3770 0     0 1 0 my $self = shift;
3771              
3772 0         0 return grep {! $self->is_primary($_)} $self->cols;
  0         0  
3773             };
3774              
3775             =pod
3776              
3777             =item primary_cols
3778              
3779             Returns a list of all the primary columns in the table.
3780              
3781             my @primaries = $table->primary_cols();
3782              
3783             =cut
3784              
3785             =pod
3786              
3787             =begin btest primary_cols
3788              
3789             my $o = __PACKAGE__->new();
3790             $test->ok($o, "Created object");
3791             my $def = {
3792             'able' => 'SQL_INTEGER',
3793             'baker' => 'SQL_INTEGER',
3794             'charlie' => 'SQL_INTEGER',
3795             'delta' => 'SQL_INTEGER'
3796             };
3797              
3798             $test->is($o->definition($def), $def, "Set definition");
3799              
3800             {
3801             my %primary = map {$_, 1} grep {defined} $o->primary_cols;
3802              
3803             $test->is($primary{'able'}, undef, 'able is not primary column');
3804             $test->is($primary{'baker'}, undef, 'baker is not primary column');
3805             $test->is($primary{'charlie'}, undef, 'charlie is not primary column');
3806             $test->is($primary{'delta'}, undef, 'delta is not primary column');
3807             }
3808              
3809             {
3810             $o->primary_column('able');
3811              
3812             my %primary = map {$_, 1} $o->primary_cols;
3813              
3814             $test->is($primary{'able'}, 1, 'able is primary column');
3815             $test->is($primary{'baker'}, undef, 'baker is not primary column');
3816             $test->is($primary{'charlie'}, undef, 'charlie is not primary column');
3817             $test->is($primary{'delta'}, undef, 'delta is not primary column');
3818             }
3819              
3820             {
3821             $o->primary_column(['charlie', 'delta']);
3822              
3823             my %primary = map {$_, 1} $o->primary_cols;
3824              
3825             $test->is($primary{'able'}, undef, 'able is not primary column');
3826             $test->is($primary{'baker'}, undef, 'baker is not primary column');
3827             $test->is($primary{'charlie'}, 1, 'charlie is primary column');
3828             $test->is($primary{'delta'}, 1, 'delta is primary column');
3829             }
3830              
3831             =end btest
3832              
3833             =cut
3834              
3835             sub primary_cols {
3836 0     0 1 0 my $self = shift;
3837              
3838 0         0 my $primary = $self->primary_column;
3839              
3840 0 0       0 if (! ref $primary) {
    0          
3841 0         0 return ($primary);
3842             } elsif (ref $primary) {
3843 0         0 return @{$primary};
  0         0  
3844             } else {
3845 0         0 return ();
3846             };
3847             };
3848              
3849             =pod
3850              
3851             =item foreign_cols
3852              
3853             Given a table and an optional list of columns, returns all of the columns in the present table that reference
3854             the columns in the second table. If no columns are passed, then the second table's primary columns are assumed.
3855              
3856             $table->references(
3857             {
3858             'user_id' => 'user.id',
3859             'user_name' => 'user.name'
3860             }
3861             );
3862              
3863             $table->foreign_cols($user_table); #prints user_id
3864             $table->foreign_cols($user_table, 'id', 'name'); #prints user_id, user_name
3865             $table->foreign_cols($user_table, 'last_name', 'login'); #prints nothing - we have no references to those columns
3866              
3867             =cut
3868              
3869             =pod
3870              
3871             =begin btest foreign_cols
3872              
3873             my $o = __PACKAGE__->new();
3874             $test->ok($o, "Created object");
3875             my $def = {
3876             'able' => 'SQL_INTEGER',
3877             'baker' => 'SQL_INTEGER',
3878             'charlie' => 'SQL_INTEGER',
3879             'delta' => 'SQL_INTEGER'
3880             };
3881              
3882             $test->is($o->definition($def), $def, "Set definition");
3883             $test->is($o->name('tableone'), 'tableone', 'set object 1 name');
3884             $test->ok($o->primary_column(['able', 'baker']), 'set object 1 primary columns');
3885              
3886             my $o2 = __PACKAGE__->new();
3887             $test->ok($o2, "Created object 2");
3888             my $def2 = {
3889             'edgar' => 'SQL_VARCHAR',
3890             'foxtrot' => 'SQL_DATE',
3891             'goats' => 'SQL_TIMESTAMP',
3892             'henry' => 'SQL_FLOAT'
3893             };
3894              
3895             $test->is($o2->definition($def2), $def2, "set object 2 definition");
3896             $test->is($o2->name('tabletoo'), 'tabletoo', "set object 2 name");
3897             $test->ok($o2->primary_column(['edgar', 'foxtrot']), 'set object 2 primary columns');
3898              
3899             my $ref1 = {
3900             'able' => 'tabletoo.edgar',
3901             'baker' => 'tabletoo.foxtrot',
3902             'charlie' => 'tablethree.col'
3903             };
3904              
3905             $test->is($o->references($ref1), $ref1, "Set reference 1");
3906              
3907             my $o3 = __PACKAGE__->new();
3908             $test->ok($o3, "Created object 3");
3909             my $def3 = {
3910             'col' => 'SQL_VARCHAR',
3911             };
3912              
3913             $test->is($o3->definition($def3), $def3, "set object 3 definition");
3914             $test->is($o3->name('tablethree'), 'tablethree', "set object 3 name");
3915              
3916             my $o4 = __PACKAGE__->new();
3917             $test->ok($o4, "Created object 4");
3918             $test->is($o4->name('tablefour'), 'tablefour', "set object 4 name");
3919              
3920              
3921             $test->is(scalar($o->foreign_cols), undef, "Cannot get foreign cols w/o table");
3922             $test->is($o->errcode, 'BDT-45', "Proper error code");
3923              
3924             {
3925             my $i = 1;
3926             my %f1 = map {$_, $i++} $o->foreign_cols($o2);
3927             $test->is($f1{'able'}, 1, 'able is foreign column');
3928             $test->is($f1{'baker'}, 2, 'baker is foreign column');
3929             $test->is(scalar (keys %f1), 2, 'only 2 foreign columns');
3930             }
3931              
3932             {
3933             my %f2 = map {$_, 1} $o->foreign_cols($o3);
3934             $test->is(scalar (keys %f2), 0, 'object 1 references no primary columns in object 3');
3935             }
3936              
3937             {
3938             my %f2 = map {$_, 1} $o->foreign_cols($o3, 'col');
3939             $test->is($f2{'charlie'}, 1, 'charlie is foreign column');
3940             $test->is(scalar (keys %f2), 1, 'only 1 foreign column');
3941             }
3942              
3943             =end btest
3944              
3945             =cut
3946              
3947             sub foreign_cols {
3948 0     0 1 0 my $self = shift;
3949              
3950 0 0       0 my $foreign_table = shift or return $self->error("Cannot get foreign cols w/o table", "BDT-45");
3951              
3952 0 0       0 my @foreign_table_cols = map {$foreign_table->qualified_name($_)} grep {defined} (@_ ? @_ : $foreign_table->primary_cols);
  0         0  
  0         0  
3953              
3954 0         0 my $idx = 0;
3955 0         0 my %foreign_table_cols = map {$_, ++$idx} @foreign_table_cols;
  0         0  
3956              
3957             return
3958 0         0 sort {$foreign_table_cols{$self->references->{$a}} <=> $foreign_table_cols{$self->references->{$b}}}
  0         0  
3959 0         0 grep {$foreign_table_cols{$self->references->{$_}}}
3960 0         0 keys %{$self->references};
3961             }
3962              
3963             =pod
3964              
3965             =item referenced_column
3966              
3967             Given a column, returns the column it references in a foreign table or sets an error if references nothing.
3968              
3969             $table->references(
3970             {
3971             'user_id' => 'user.id',
3972             'user_name' => 'user.name'
3973             }
3974             );
3975              
3976             print $table->referenced_column('user_id'); #prints user.id
3977             print $table->referenced_column('password'); #prints nothing
3978              
3979             =cut
3980              
3981             =pod
3982              
3983             =begin btest referenced_column
3984              
3985             my $def = {
3986             'user_id' => 'SQL_INTEGER',
3987             'user_name' => 'SQL_VARCHAR',
3988             'user_extra' => 'SQL_VARCHAR',
3989             };
3990              
3991             my $foreign = {
3992             'user_id' => 'user.id',
3993             'user_name' => 'user.name'
3994             };
3995              
3996             my $o = __PACKAGE__->new(
3997             'definition' => $def,
3998             'references' => $foreign,
3999             );
4000             $test->ok($o, "Got object");
4001             $test->is($o->definition, $def, "proper definition");
4002             $test->is($o->references, $foreign, "proper foreign references");
4003              
4004             my $f2 = {%$foreign};
4005              
4006             $test->is($o->references($f2), $f2, "properly reset foreign reference");
4007              
4008             $test->is(scalar($o->referenced_column), undef, "Cannot get referenced column w/o column");
4009             $test->is($o->errcode, "BDT-15", "proper error code");
4010              
4011             $test->is($o->referenced_column('user_id'), 'user.id', 'user_id properly referenced');
4012             $test->is($o->referenced_column('user_name'), 'user.name', 'user_id properly referenced');
4013             $test->is(scalar($o->referenced_column('user_extra')), undef, 'user_id properly referenced');
4014             $test->is($o->errcode, "BDT-16", "proper error code");
4015              
4016             =end btest
4017              
4018             =cut
4019              
4020             sub referenced_column {
4021 0     0 1 0 my $self = shift;
4022 0 0       0 my $column = shift or return $self->error("Cannot determine reference w/o column", "BDT-15");
4023              
4024 0   0     0 return $self->references->{$column}
4025             || $self->error("Column does not reference any other table", "BDT-16");
4026              
4027             }
4028              
4029             =pod
4030              
4031             =item discover_columns
4032              
4033             Takes a table name as an argument. Returns a hashref of the columns in that table, suitable to be
4034             used in a definition call.
4035              
4036             my $definition = Basset::DB::Table->discover_columns('user_table');
4037              
4038             This should be typically be invoked via the discover flag to the constructor.
4039              
4040             my $table = Basset::DB::Table->new(
4041             'discover' => 1
4042             );
4043              
4044             =cut
4045              
4046             =pod
4047              
4048             =begin btest discover_columns
4049              
4050             =end btest
4051              
4052             =cut
4053              
4054             sub discover_columns {
4055 0     0 1 0 my $self = shift;
4056 0 0       0 my $table = shift or return $self->error("Cannot discover columns w/o table", "BDT-51");
4057              
4058 0 0       0 my $columns = join(', ', @_ ? @_ : ('*'));
4059              
4060             my $stmt = $self->arbitrary_sql(
4061             'query' => "select $columns from $table where 1 = 0",
4062             'iterator' => 1,
4063 0 0       0 ) or do {
4064 0 0       0 if ($columns) {
4065 0         0 return { map {$_, undef} @_};
  0         0  
4066             } else {
4067 0         0 return;
4068             }
4069             };
4070              
4071 0         0 my $definition = {};
4072 0         0 for (my $idx = 0; $idx < $stmt->{'NUM_OF_FIELDS'}; $idx++) {
4073 0         0 $definition->{$stmt->{'NAME_lc'}->[$idx]} = $stmt->{'TYPE'}->[$idx];
4074             }
4075              
4076 0 0       0 $stmt->finish or return $self->error($stmt->errstr, 'BDT-37');
4077              
4078 0         0 return $definition;
4079              
4080             }
4081              
4082             =pod
4083              
4084             =item attach_to_query
4085              
4086             Given a query string and a hashref of clauses, attaches the clauses to the query.
4087              
4088             my $update_query = $table->attach_to_query(
4089             $table->update_query,
4090             {
4091             'where' => 'id = ?'
4092             }
4093             );
4094              
4095             Valid clauses are "where", "group by", "having", "order by" and "limit", reflecting the
4096             SQL clauses of the same kind.
4097              
4098             =cut
4099              
4100             =pod
4101              
4102             =begin btest attach_to_query
4103              
4104             my $o = __PACKAGE__->new();
4105             $test->ok($o, "Created object");
4106             my $def = {
4107             'able' => 'SQL_INTEGER',
4108             };
4109              
4110             $test->is($o->definition($def), $def, "Set definition");
4111             $test->is($o->definition, $def, "Got definition");
4112              
4113             $test->is($o->name('mytable'), 'mytable', 'set table name');
4114              
4115             $test->is(scalar($o->attach_to_query), undef, "Cannot attach to query w/o query");
4116             $test->is($o->errcode, "BDT-02", "proper error code");
4117              
4118             $test->is($o->select_query, 'select mytable.able as able from mytable', 'proper select query');
4119             my $query = $o->select_query;
4120             $test->is(scalar($o->attach_to_query($query)), $query, "No clauses returns original query");
4121             $test->is(scalar($o->attach_to_query($query, {})), $query, "Empty clauses returns original query");
4122             $test->is(scalar($o->attach_to_query($query, {'having' => 'having clause'})), undef, "Cannot have having w/o group");
4123             $test->is($o->errcode, "BDT-09", "proper error code");
4124              
4125             $test->is($o->attach_to_query($query, {'where' => 'able = ?'}), $query . "\n where able = ?", "attached where clause");
4126             $test->is($o->attach_to_query($query, {'group by' => 'able'}), $query . "\n group by able", "attached group by clause");
4127             $test->is($o->attach_to_query($query, {'order by' => 'baker'}), $query . "\n order by baker", "attached order by clause");
4128             $test->is($o->attach_to_query($query, {'limit' => '5'}), $query . "\n limit 5", "attached limit clause");
4129              
4130             $test->is(
4131             $o->attach_to_query(
4132             $query,
4133             {
4134             'where' => 'able = ?',
4135             'group by' => 'baker',
4136             }
4137             ), $query . "\n where able = ?\n group by baker", "attached where and group by clause");
4138              
4139             $test->is(
4140             $o->attach_to_query(
4141             $query,
4142             {
4143             'where' => 'able = ?',
4144             'group by' => 'baker',
4145             'having' => 'count(*) > 1'
4146             }
4147             ), $query . "\n where able = ?\n group by baker\n having count(*) > 1", "attached where, group by, and having clause");
4148              
4149             =end btest
4150              
4151             =cut
4152              
4153             sub attach_to_query {
4154 0     0 1 0 my $class = shift;
4155              
4156 0 0       0 my $query = shift or return $class->error("Cannot attach to query w/o query", "BDT-02");
4157 0   0     0 my $clauses = shift || {};
4158              
4159 0 0       0 unless (keys %$clauses) {
4160 0         0 $class->notify("warnings", "No clauses to attach to query");
4161 0         0 return $query;
4162             };
4163              
4164 0 0 0     0 return $class->error("Cannot have having without group", "BDT-09")
4165             if defined $clauses->{'having'} && ! defined $clauses->{'group by'};
4166              
4167 0         0 foreach my $clause ('where', 'group by', 'having', 'order by', 'limit'){
4168 0 0       0 if (defined $clauses->{$clause}){
4169 0         0 my $value = $clauses->{$clause};
4170              
4171 0         0 $query .= "\n " . $clause . " " . $value;
4172             };
4173             };
4174              
4175 0         0 return $query;
4176             };
4177              
4178             =pod
4179              
4180             =item join_tables
4181              
4182             Magic time.
4183              
4184             join_tables is used internally by the multiselect_query, but you can use it yourself if you want.
4185              
4186             Takes an array of table objects or arrayrefs. arrayrefs must be of the following form:
4187              
4188             =over
4189              
4190             =item join type
4191              
4192             The type of join to be performed. Should be a string. "inner", "outer", "left outer", that sort of thing.
4193             Defaults to inner. This parameter is optional.
4194              
4195             =item table object
4196              
4197             The table object you're using.
4198              
4199             =item columns
4200              
4201             SQL clauses to override the auto-join. This parameter is optional.
4202              
4203             =back
4204              
4205             So, for example, if you have a usertable and a movietable, and movie.user references user.id, you could do:
4206              
4207             Basset::DB::Table->join_tables(
4208             $usertable,
4209             $movietable,
4210             ) || die Basset::DB::Table->errstring;
4211              
4212             which returns:
4213              
4214             user
4215             inner join
4216             movie
4217             on user.id = movie.user
4218              
4219             Say that user.movie was a foreign key to movie.id. Then you'd get back:
4220              
4221             user
4222             inner join
4223             movie
4224             on user.id = movie.user
4225             and user.movie = movie.id
4226              
4227             I can't say why you'd want to have two tables referencing each other, but it's important to know that it happens.
4228              
4229             3 tables is the same thing. Say that movie.genre references genre.id
4230              
4231             Basset::DB::Table->join_tables(
4232             $usertable,
4233             $movietable,
4234             $genretable,
4235             ) || die Basset::DB::Table->errstring;
4236              
4237             user
4238             inner join
4239             movie
4240             on movie.user = user.id
4241             inner join
4242             genre
4243             on movie.user = genre.id
4244              
4245             Okay, say that you want to use a left join between the user table and the movie table.
4246              
4247             Basset::DB::Table->join_tables(
4248             $usertable,
4249             ['left', $movietable],
4250             $genretable,
4251             ) || die Basset::DB::Table->errstring;
4252              
4253             user
4254             left join
4255             movie
4256             on movie.user = user.id
4257             inner join
4258             genre
4259             on movie.user = genre.id
4260              
4261             You can also join with earlier tables. Say that snack.user references user.id
4262              
4263             Basset::DB::Table->join_tables(
4264             $usertable,
4265             ['left', $movietable],
4266             $genretable,
4267             $snacktable,
4268             ) || die Basset::DB::Table->errstring;
4269              
4270             user
4271             left join
4272             movie
4273             on movie.user = user.id
4274             inner join
4275             genre
4276             on movie.user = genre.id
4277             inner join
4278             snack
4279             on user.id = snack.user
4280              
4281             Or, you can override the defaults specified in the table's references. For example, if the references don't
4282             exist for the table.
4283              
4284             Basset::DB::Table->join_tables(
4285             $usertable,
4286             ['left', $movietable],
4287             $genretable,
4288             [$snacktable, 'user.id = snack.user AND user.status = snack.status'],
4289             ) || die Basset::DB::Table->errstring;
4290              
4291             user
4292             left join
4293             movie
4294             on movie.user = user.id
4295             inner join
4296             genre
4297             on movie.user = genre.id
4298             inner join
4299             snack
4300             on user.id = snack.user
4301             and user.status = snack.status
4302              
4303             =cut
4304              
4305             =pod
4306              
4307             =begin btest join_tables
4308              
4309             my $o = __PACKAGE__->new();
4310             $test->ok($o, "Created object");
4311              
4312             my $o2 = __PACKAGE__->new();
4313             $test->ok($o2, "Created object");
4314              
4315             my $o3 = __PACKAGE__->new();
4316             $test->ok($o3, "Created object");
4317              
4318             my $o4 = __PACKAGE__->new();
4319             $test->ok($o4, "Created object");
4320              
4321             my $def1 = {
4322             'able' => 'SQL_INTEGER',
4323             'baker' => 'SQL_INTEGER',
4324             'charlie' => 'SQL_INTEGER',
4325             'delta' => 'SQL_INTEGER'
4326             };
4327              
4328             my $ref1 = {
4329             'able' => 'table2.aid',
4330             'baker' => 'table4.b',
4331             'charlie' => 'table4.c',
4332             };
4333              
4334             $test->is($o->definition($def1), $def1, "Set definition");
4335             $test->is($o->references($ref1), $ref1, "Set references");
4336             $test->is($o->name("table1"), "table1", "set table name");
4337             $test->is($o->primary_column("able"), "able", "set table primary id");
4338              
4339             my $def2 = {
4340             'aid' => 'SQL_INTEGER',
4341             'bid' => 'SQL_INTEGER',
4342             'cid' => 'SQL_INTEGER',
4343             'did' => 'SQL_INTEGER'
4344             };
4345              
4346             my $ref2 = {
4347             'aid' => 'table3.ace'
4348             };
4349              
4350             $test->is($o2->definition($def2), $def2, "Set definition");
4351             $test->is($o2->references($ref2), $ref2, "Set references");
4352             $test->is($o2->name("table2"), "table2", "set table name");
4353             $test->is($o2->primary_column("aid"), "aid", "set table primary id");
4354              
4355             my $def3 = {
4356             'ace' => 'SQL_INTEGER',
4357             'bogey' => 'SQL_INTEGER',
4358             };
4359              
4360             $test->is($o3->definition($def3), $def3, "Set definition");
4361             $test->is($o3->name("table3"), "table3", "set table name");
4362             $test->is($o3->primary_column("ace"), "ace", "set table primary id");
4363              
4364             my $def4 = {
4365             'a' => 'SQL_INTEGER',
4366             'b' => 'SQL_INTEGER',
4367             'c' => 'SQL_INTEGER',
4368             'd' => 'SQL_INTEGER'
4369             };
4370              
4371             $test->is($o4->definition($def4), $def4, "Set definition");
4372             $test->is($o4->name("table4"), "table4", "set table name");
4373             $test->ok($o4->primary_column([qw(b c)]), "set table primary id");
4374              
4375              
4376             $test->is(scalar(__PACKAGE__->join_tables), undef, "Could not join w/o tables");
4377             $test->is(__PACKAGE__->errcode, "BDT-28", "proper error code BDT-28");
4378              
4379             $test->is(__PACKAGE__->join_tables($o), "table1", "Join with one table is same table");
4380              
4381             $test->is(__PACKAGE__->join_tables($o, $o2),
4382             "table1
4383             inner join
4384             table2
4385             on table1.able = table2.aid",
4386             "Default joined two tables"
4387             );
4388              
4389             $test->is(__PACKAGE__->join_tables($o2, $o),
4390             "table2
4391             inner join
4392             table1
4393             on table1.able = table2.aid",
4394             "Reverse joined two tables"
4395             );
4396              
4397             $test->is(__PACKAGE__->join_tables($o, $o2, $o3),
4398             "table1
4399             inner join
4400             table2
4401             on table1.able = table2.aid
4402             inner join
4403             table3
4404             on table2.aid = table3.ace",
4405             "Default joined three tables"
4406             );
4407             $test->is(__PACKAGE__->join_tables($o, $o2, $o3, $o4),
4408             "table1
4409             inner join
4410             table2
4411             on table1.able = table2.aid
4412             inner join
4413             table3
4414             on table2.aid = table3.ace
4415             inner join
4416             table4
4417             on table1.baker = table4.b
4418             and table1.charlie = table4.c",
4419             "Default joined four tables"
4420             );
4421              
4422             $test->is(__PACKAGE__->join_tables($o, [$o2]),
4423             "table1
4424             inner join
4425             table2
4426             on table1.able = table2.aid",
4427             "Default joined two tables w/arrayref table only"
4428             );
4429              
4430             $test->is(__PACKAGE__->join_tables($o, ['inner',$o2]),
4431             "table1
4432             inner join
4433             table2
4434             on table1.able = table2.aid",
4435             "inner joined 2 tables");
4436              
4437             $test->is(__PACKAGE__->join_tables($o, ['outer',$o2]),
4438             "table1
4439             outer join
4440             table2
4441             on table1.able = table2.aid",
4442             "outer joined 2 tables");
4443              
4444             $test->is(__PACKAGE__->join_tables($o, ['natural',$o2]),
4445             "table1
4446             natural join
4447             table2",
4448             "natural joined 2 tables");
4449              
4450             $test->is(__PACKAGE__->join_tables($o, ['left',$o2]),
4451             "table1
4452             left join
4453             table2
4454             on table1.able = table2.aid",
4455             "left joined 2 tables");
4456              
4457             $test->is(__PACKAGE__->join_tables($o, ['right',$o2]),
4458             "table1
4459             right join
4460             table2
4461             on table1.able = table2.aid",
4462             "right joined 2 tables");
4463              
4464             $test->is(__PACKAGE__->join_tables($o, ['left outer',$o2]),
4465             "table1
4466             left outer join
4467             table2
4468             on table1.able = table2.aid",
4469             "left outer joined 2 tables");
4470              
4471             $test->is(__PACKAGE__->join_tables($o, ['right outer',$o2]),
4472             "table1
4473             right outer join
4474             table2
4475             on table1.able = table2.aid",
4476             "right outer joined 2 tables");
4477              
4478             $test->is(__PACKAGE__->join_tables($o, [$o4, 'table1.baker = table4.b']),
4479             "table1
4480             inner join
4481             table4
4482             on table1.baker = table4.b",
4483             "joined 2 tables with alternate clause");
4484              
4485             $test->is(__PACKAGE__->join_tables($o, ['outer', $o4, 'table1.baker = table4.b']),
4486             "table1
4487             outer join
4488             table4
4489             on table1.baker = table4.b",
4490             "outer joined 2 tables with 3 arg alternate clause");
4491              
4492             $test->is(__PACKAGE__->join_tables($o, [$o4, ['table1.baker = table4.b', 'table1.baker = table4.c']]),
4493             "table1
4494             inner join
4495             table4
4496             on table1.baker = table4.b
4497             and table1.baker = table4.c",
4498             "joined 2 tables with 2 alternate clauses");
4499              
4500             $test->is(__PACKAGE__->join_tables($o, ['outer', $o4, ['table1.baker = table4.b', 'table1.baker = table4.c']]),
4501             "table1
4502             outer join
4503             table4
4504             on table1.baker = table4.b
4505             and table1.baker = table4.c",
4506             "outer joined 2 tables with 2 alternate clauses");
4507              
4508             $test->is(__PACKAGE__->join_tables(['inner', $o], ['outer', $o4, ['table1.baker = table4.b', 'table1.baker = table4.c']]),
4509             "table1
4510             outer join
4511             table4
4512             on table1.baker = table4.b
4513             and table1.baker = table4.c",
4514             "outer joined 2 tables with 2 alternate clauses w/ first table array");
4515              
4516             $test->is(__PACKAGE__->join_tables(['inner', $o, 'foo = bar'], ['outer', $o4, ['table1.baker = table4.b', 'table1.baker = table4.c']]),
4517             "table1
4518             outer join
4519             table4
4520             on table1.baker = table4.b
4521             and table1.baker = table4.c",
4522             "outer joined 2 tables with 2 alternate clauses w/ first table array and columns");
4523              
4524             $test->is(__PACKAGE__->join_tables([$o, 'foo = bar'], ['outer', $o4, ['table1.baker = table4.b', 'table1.baker = table4.c']]),
4525             "table1
4526             outer join
4527             table4
4528             on table1.baker = table4.b
4529             and table1.baker = table4.c",
4530             "outer joined 2 tables with 2 alternate clauses w/ first table array and columns, non-inner");
4531              
4532             $test->is(scalar(__PACKAGE__->join_tables($o, $o3)), undef, "Cannot auto-join unreferenced tables");
4533             $test->is(__PACKAGE__->errcode, 'BDT-27', 'proper error code');
4534              
4535             =end btest
4536              
4537             =cut
4538              
4539              
4540             sub join_tables {
4541 0     0 1 0 my $self = shift;
4542              
4543 0         0 my @tables = @_;
4544              
4545 0         0 my @last_tables = ();
4546              
4547             {
4548 0 0       0 my $first_table = shift @tables or return $self->error("Cannot join tables w/o table", "BDT-28");
  0         0  
4549              
4550 0 0       0 if (ref $first_table eq 'ARRAY') {
4551 0 0       0 $first_table = ref $first_table->[0] ? $first_table->[0] : $first_table->[1];
4552             };
4553              
4554 0         0 unshift @last_tables, $first_table;
4555              
4556             }
4557              
4558 0         0 my $joined_tables = $last_tables[0]->name;
4559              
4560 0         0 while (@tables) {
4561 0         0 my $table = shift @tables;
4562 0         0 my ($join, $cols) = ('inner', []);
4563              
4564 0 0       0 if (ref $table eq 'ARRAY') {
4565 0 0       0 if (@$table == 3) {
    0          
4566 0         0 ($join, $table, $cols) = @$table;
4567 0 0       0 $cols = [$cols] unless ref $cols;
4568             } elsif (@$table == 2) {
4569 0 0       0 if (! ref $table->[0]) {
4570 0         0 ($join, $table) = @$table;
4571             } else {
4572 0         0 ($table, $cols) = @$table;
4573 0 0       0 $cols = [$cols] unless ref $cols;
4574             }
4575             }
4576             else {
4577 0         0 ($table) = @$table;
4578             };
4579              
4580             }
4581              
4582 0 0 0     0 if (@$cols == 0 && $join ne 'natural') {
4583 0         0 my $found = 0;
4584 0         0 my $idx = 0;
4585 0   0     0 while (! $found && $idx < @last_tables) {
4586              
4587 0         0 my $last_table = $last_tables[$idx++];
4588              
4589 0         0 my @foreign_cols = $table->foreign_cols($last_table);
4590 0 0       0 if (@foreign_cols) {
4591 0         0 $found++;
4592 0         0 foreach my $col (@foreign_cols) {
4593 0         0 push @$cols, $table->qualified_name($col) . ' = ' . $table->referenced_column($col);
4594             }
4595             }
4596 0         0 my @last_foreign_cols = $last_table->foreign_cols($table);
4597              
4598 0 0       0 if (@last_foreign_cols) {
4599 0         0 $found++;
4600 0         0 foreach my $col (@last_foreign_cols) {
4601 0         0 push @$cols, $last_table->qualified_name($col) . ' = ' . $last_table->referenced_column($col);
4602             }
4603             }
4604             }
4605 0 0       0 unless ($found) {
4606 0         0 return $self->error("Cannot auto-join table " . $table->name . " : not referenced by prior table", "BDT-27");
4607             }
4608             }
4609              
4610 0         0 $joined_tables .= "\n\t$join join\n\t\t" . $table->name;
4611 0 0       0 $joined_tables .= "\n\t\t\ton " . join("\n\t\t\tand ", @$cols) if @$cols;
4612 0         0 unshift @last_tables, $table;
4613             }
4614              
4615 0         0 return $joined_tables;
4616             }
4617              
4618             =pod
4619              
4620             =item many_clause
4621              
4622             Convenience method. Given a column and a list of values, returns a foo in (???) clause for use in queries.
4623              
4624             print $table->many_clause('id', qw(1 2 3 4)); #prints "id in (?, ?, ?, ?)"
4625              
4626             You may optionally pass your values in an arrayref, if it's more convenient.
4627              
4628             print $table->many_clause('id', [qw(1 2 3 4)]); #prints "id in (?, ?, ?, ?)"
4629              
4630             Finally, if you pass your values in an arrayref, you may specify the 'not' parameter to build a 'not in' clause
4631              
4632             print $table->many_clause('id', 'not', qw(1 2 3 4)); #prints "id not in (?, ?, ?, ?)"
4633              
4634             =cut
4635              
4636             sub many_clause {
4637 0     0 1 0 my $self = shift;
4638 0 0       0 my $column = shift or return $self->error("Cannot build many clause w/o column", "BDT-21");
4639 0         0 my $negative = 0;
4640              
4641 0 0       0 my @columns = @_ or return $self->error("Cannot build many clause w/o values", "BDT-22");
4642              
4643 0 0       0 if (ref $columns[-1] eq 'ARRAY') {
4644 0 0       0 $negative = shift @columns if @columns == 2;
4645 0 0       0 @columns = @{$columns[-1]} or return $self->error("Cannot build many clause w/o values", "BDT-22");
  0         0  
4646             }
4647              
4648 0         0 $column = $self->column_for_alias($column);
4649              
4650 0 0       0 $negative = $negative ? ' not' : '';
4651              
4652 0         0 return $self->qualified_name($column) . "$negative in (" . join(', ', ("?") x @columns) . ')';
4653             };
4654              
4655             =pod
4656              
4657             =begin btest many_clause
4658              
4659             my $o = __PACKAGE__->new();
4660             $test->ok($o, "Created object");
4661             my $def = {
4662             'able' => 'SQL_INTEGER',
4663             'baker' => 'SQL_INTEGER',
4664             'charlie' => 'SQL_INTEGER',
4665             'delta' => 'SQL_INTEGER'
4666             };
4667              
4668             $test->is($o->definition($def), $def, "Set definition");
4669             $test->is($o->definition, $def, "Got definition");
4670             $test->is($o->name('test'), 'test', 'set name');
4671              
4672             $test->is(scalar($o->many_clause), undef, "Cannot build many clause w/o column");
4673             $test->is($o->errcode, 'BDT-21', 'proper error code');
4674              
4675             $test->is(scalar($o->many_clause('able')), undef, "Cannot build many clause w/o values");
4676             $test->is($o->errcode, 'BDT-22', 'proper error code');
4677              
4678             $test->is(scalar($o->many_clause('able', [])), undef, "Cannot build many clause w/o values");
4679             $test->is($o->errcode, 'BDT-22', 'proper error code');
4680              
4681             $test->is($o->many_clause('able', 1), 'test.able in (?)', 'built single many clause');
4682             $test->is($o->many_clause('able', 1, 2), 'test.able in (?, ?)', 'built double many clause');
4683             $test->is($o->many_clause('able', 1, 2, 3), 'test.able in (?, ?, ?)', 'built triple many clause');
4684              
4685             $test->is($o->many_clause('able', [1]), 'test.able in (?)', 'built single many clause from arrayref');
4686             $test->is($o->many_clause('able', [1, 2]), 'test.able in (?, ?)', 'built double many clause from arrayref');
4687             $test->is($o->many_clause('able', [1, 2, 3]), 'test.able in (?, ?, ?)', 'built triple many clause from arrayref');
4688              
4689             $test->is($o->many_clause('able', 'not', [1]), 'test.able not in (?)', 'built single not many clause');
4690             $test->is($o->many_clause('able', 'not', [1, 2]), 'test.able not in (?, ?)', 'built double not many clause');
4691             $test->is($o->many_clause('able', 'not', [1, 2, 3]), 'test.able not in (?, ?, ?)', 'built triple not many clause');
4692             $test->is($o->many_clause('able', 1, [1, 2, 3]), 'test.able not in (?, ?, ?)', 'built triple not many clause w/arbitrary true value');
4693              
4694             =end btest
4695              
4696             =cut
4697              
4698              
4699              
4700              
4701             =pod
4702              
4703             =item qualified_name
4704              
4705             Given a column name, returns the column name with the table name prepended.
4706              
4707             print $user->qualified_name('id'); #prints user.id
4708              
4709             =cut
4710              
4711             =pod
4712              
4713             =begin btest qualified_name
4714              
4715             my $o = __PACKAGE__->new();
4716             $test->ok($o, "Got object");
4717              
4718             $test->is(scalar($o->qualified_name()), undef, 'could not get qualified name w/o column');
4719              
4720             $test->is($o->errcode, 'BDT-23', 'Proper error code');
4721             $test->is(scalar($o->qualified_name('foo')), undef, 'could not get qualified name w/o table name');
4722             $test->is($o->errcode, 'BDT-24', 'Proper error code');
4723             $test->is($o->name('test1'), 'test1', 'Set table name');
4724             $test->is($o->qualified_name('foo'), 'test1.foo', 'column foo properly qualified');
4725             $test->is($o->qualified_name('bar'), 'test1.bar', 'column bar properly qualified');
4726             $test->is($o->name('test2'), 'test2', 'changed column name to test2');
4727             $test->is($o->qualified_name('foo'), 'test2.foo', 'column foo properly qualified');
4728             $test->is($o->qualified_name('bar'), 'test2.bar', 'column bar properly qualified');
4729             $test->is($o->qualified_name('test2.foo'), 'test2.foo', 'previously column test2.foo properly qualified');
4730             $test->is($o->qualified_name('test2.bar'), 'test2.bar', 'previously column test2.bar properly qualified');
4731              
4732             =end btest
4733              
4734             =cut
4735              
4736             sub qualified_name {
4737 0     0 1 0 my $self = shift;
4738 0 0       0 my @cols = @_ or return $self->error("Cannot qualify name w/o column", "BDT-23");
4739 0 0       0 my $name = $self->name or return $self->error("Cannot qualify name w/o table name", "BDT-24");
4740              
4741 0         0 foreach my $column (@cols) {
4742 0 0       0 next if index($column, '.') != -1;
4743 0         0 $column = "$name.$column";
4744             }
4745            
4746 0 0       0 return wantarray ? @cols : $cols[0];
4747             };
4748              
4749             =pod
4750              
4751             =item nonqualified_name
4752              
4753             Given a column name, returns the column name without the table name prepended.
4754              
4755             print $user->qualified_name('id'); #prints id
4756             print $user->qualified_name('user.id'); #prints id
4757              
4758             =cut
4759              
4760             =pod
4761              
4762             =begin btest nonqualified_name
4763              
4764             $test->is(scalar(__PACKAGE__->nonqualified_name()), undef, "Could not get nonqualified name w/o column");
4765             $test->is(__PACKAGE__->nonqualified_name('foo.bar'), 'bar', 'stripped table name');
4766             $test->is(__PACKAGE__->nonqualified_name('bar'), 'bar', 'returned column w/o table name');
4767              
4768             =end btest
4769              
4770             =cut
4771              
4772             sub nonqualified_name {
4773 45     45 1 49 my $class = shift;
4774 45 50       83 my $column = shift or return $class->error("Cannot unqualify name w/o column", "BDT-46");
4775              
4776 45         126 return substr($column, index($column, '.') + 1);
4777             }
4778              
4779             =pod
4780              
4781             =item construct_where_clause
4782              
4783             The where clause constructor is a class method that takes an arrayref of tables as its first argument, and then
4784             an arbitrary set of clauses in a list.
4785              
4786             my ($clause, @bindvalues) = Basset::DB::Table->construct_where_clause($tables, @clauses);
4787              
4788             This is used to hide SQL from your application layer. You can specify arbitrarily complex statements here to build
4789             where clauses. The tables array is used to qualify the names of the columns passed. The array will be walked and the
4790             first table encounted that has the given column will be used to qualify the name. Hence, if a column exists in multiple
4791             tables, you should qualify it to ensure that you get it from the place you expect.
4792              
4793             Easily pass in key value pairs.
4794              
4795             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4796             $tables,
4797             'id' => 7
4798             ); #returns ('tablename.id = ?', 7)
4799              
4800             To specify an 'in' clause, pass in an array.
4801              
4802             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4803             $tables,
4804             'id' => [7, 8, 9]
4805             ); #returns ('tablename.id in (?, ?, ?)', 7, 8, 9)
4806              
4807             Additional values are joined by AND statements.
4808              
4809             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4810             $tables,
4811             'id' => [7, 8, 9],
4812             'status' => 1,
4813             ); #returns ('tablename.id in (?, ?, ?) AND tablename.status = ?', 7, 8, 9, 1)
4814              
4815             You may specify alternative values for columns in a hashref.
4816              
4817             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4818             $tables,
4819             'id' => {
4820             '>' => 7,
4821             '<' => 14,
4822             'status' => 1,
4823             ); #returns ('(tablename.id > ? OR tablename.id < ?) AND tablename.status = ?', 7, 14, 1)
4824              
4825             Groups of sets of values are joined with OR clauses.
4826              
4827             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4828             $tables,
4829             ['id' => 7,'status' => 1,],
4830             ['id' => {'>' => 18'}, 'status' => 3],
4831             ['status' => 5'],
4832             ); #returns ('(tablename.id = ? OR tablename.status = ?) OR (tablename.id > ? AND status = ?) OR (status = ?)', 7, 1, 18, 3, 5)
4833              
4834             groups may be nested
4835              
4836             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4837             $tables,
4838             'id' => 7,
4839             ['id' => {'>' => 20}, ['name' => 'test', status => 5]]
4840             ); #returns ('(tablename.id = ?) OR (tablename.id > ? OR (tablename.name = ? AND tablename.status = ?))', 7, 20, test, 5)
4841              
4842             Column order may not be preserved.
4843              
4844             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4845             $tables,
4846             'id' => 7,
4847             ['id' => 8],
4848             'name' => 'foo',
4849             ); #returns ('(tablename.id = ? AND tablename.name = ?) OR (tablename.id = ?)', 7, 'foo', 8)
4850              
4851             To group different columns with different and clauses, repeat the clause.
4852              
4853             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4854             $tables,
4855             'id' => {'>' => 8},
4856             'id' => {'<' => 25},
4857             ); #returns ('tablename.id > ? AND tablename.id < ?', 8, 25)
4858              
4859             Finally, sometimes you just need to have a literal value in there that you can't bind to a place
4860             holder. In that case, you want to pass in a reference.
4861              
4862             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4863             $tables,
4864             'id' => {'>' => \8},
4865             'id' => {'<' => \25},
4866             ); #returns ('tablename.id > 8 AND tablename.id < 25')
4867            
4868             This is most useful, obviously, for NULLs.
4869            
4870             my ($stmt, @values) = Basset::DB::Table->construct_where_clause(
4871             $tables,
4872             'id' => {'is' => \'NULL', '=' => 4},
4873             ); #returns ('tablename.id is NULL or tablename.id = ?', 4)
4874              
4875             =cut
4876              
4877             sub construct_where_clause {
4878 0     0 1   my $class = shift;
4879              
4880 0 0         my $tables = shift or return $class->error("Cannot construct_where_clause w/o tables", "BDT-48");
4881 0 0         my @clauses = @_ or return $class->error("Cannot construct_where_clause w/o clauses", "BDT-49");
4882              
4883 0           my @where = ();
4884 0           my @values = ();
4885 0           my @extra = ();
4886              
4887 0           while (@clauses) {
4888 0           my $clause = shift @clauses;
4889              
4890 0 0         if (ref $clause eq 'ARRAY') {
4891 0 0         my @subvalues = $class->construct_where_clause($tables, @$clause)
4892             or return;
4893 0           push @extra, \@subvalues;
4894 0           next;
4895             }
4896              
4897 0           my @relational = ();
4898 0           my @myvalues = ();
4899              
4900 0           my $value = shift @clauses;
4901 0 0         if (ref $value eq 'HASH') {
4902 0           push @relational, sort keys %$value;
4903 0           push @myvalues, map {$value->{$_}} sort keys %$value;
  0            
4904             } else {
4905 0           push @myvalues, $value;
4906             };
4907              
4908 0           my $table = undef;
4909 0           my ($name, $col);
4910 0 0         if ($clause =~ /^(\w+)\.(\w+)$/) {
4911 0           ($name, $col) = ($1, $2);
4912             };
4913              
4914 0           foreach my $t (@$tables) {
4915              
4916 0 0         if (defined $t->definition->{$t->column_for_alias($clause)}) {
4917 0 0 0       if (! defined $name || $name eq $t->name) {
4918 0           $table = $t;
4919 0           last;
4920             }
4921             }
4922             };
4923              
4924 0 0         return $class->error("Cannot construct_where_clause with clause $clause : not in any object table", "BDT-50")
4925             unless defined $table;
4926              
4927 0           my @mywhere = ();
4928              
4929 0           while (@myvalues) {
4930 0           my $value = shift @myvalues;
4931 0   0       my $relation = shift @relational || '=';
4932              
4933 0 0         if (ref $value eq 'ARRAY') {
4934 0           push @mywhere, $table->many_clause($clause, @$value);
4935 0 0         if (ref $value->[-1] eq 'ARRAY') {
4936 0           push @values, @{$value->[-1]};
  0            
4937             } else {
4938 0           push @values, @$value
4939             }
4940             } else {
4941 0 0         if (ref $value) {
4942 0           push @mywhere, $table->qualified_name($clause) . " $relation $$value";
4943             } else {
4944 0           push @mywhere, $table->qualified_name($clause) . " $relation ?";
4945 0           push @values, $value;
4946             }
4947             }
4948             }
4949              
4950 0           my $mywhere = join(' OR ', @mywhere);
4951 0 0         $mywhere = "($mywhere)" if @mywhere > 1;
4952 0           push @where, $mywhere;
4953              
4954             }
4955              
4956 0           my $where = join(' AND ', @where);
4957 0 0         if (@extra) {
4958 0           while (@extra) {
4959 0           my $extra = shift @extra;
4960 0           my $clause = shift @$extra;
4961 0 0         $where .= " OR " if $where;
4962 0           $where .= "($clause)";
4963 0           push @values, @$extra;
4964             }
4965             }
4966 0           return ($where, @values);
4967             }
4968              
4969             =pod
4970              
4971             =begin btest construct_where_clause
4972              
4973             $test->ok(! __PACKAGE__->construct_where_clause, "Cannot construct_where_clause w/o tables");
4974             $test->is(__PACKAGE__->errcode, "BDT-48", 'proper error code');
4975              
4976             my $t1 = __PACKAGE__->new(
4977             'name' => 't1',
4978             'primary_column' => 'id',
4979             'definition' => {
4980             'id' => 'SQL_INTEGER',
4981             'name' => 'SQL_VARCHAR',
4982             }
4983             );
4984              
4985             $test->ok($t1, 'built first table');
4986              
4987             my $t2 = __PACKAGE__->new(
4988             'name' => 't2',
4989             'primary_column' => 'id',
4990             'definition' => {
4991             'id' => 'SQL_INTEGER',
4992             'size' => 'SQL_VARCHAR',
4993             }
4994             );
4995              
4996             $test->ok($t2, 'built second table');
4997              
4998             my $one_table = [$t1];
4999             my $two_tables = [$t1, $t2];
5000              
5001             $test->ok(! __PACKAGE__->construct_where_clause($one_table), "Cannot construct_where_clause w/o clauses");
5002             $test->is(__PACKAGE__->errcode, "BDT-49", 'proper error code');
5003              
5004             {
5005             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => 1);
5006             $test->ok(scalar(@return), "got values from constructing where clause");
5007             $test->is($return[0], 't1.id = ?', 'proper clause');
5008             $test->is($return[1], '1', 'proper value');
5009             }
5010              
5011             {
5012             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => 1, 'name' => 'foo');
5013             $test->ok(scalar(@return), "got values from constructing where clause");
5014             $test->is($return[0], 't1.id = ? AND t1.name = ?', 'proper clause');
5015             $test->is($return[1], '1', 'proper value');
5016             $test->is($return[2], 'foo', 'proper value');
5017             }
5018              
5019             {
5020             $test->ok(!__PACKAGE__->construct_where_clause($one_table, 'id' => 1, 'name' => 'foo', 'bar' => 'baz'),
5021             'could not construct_where_clause w/non-existent column');
5022             $test->is(__PACKAGE__->errcode, 'BDT-50', 'proper error code');
5023             }
5024              
5025             {
5026             $test->ok(!__PACKAGE__->construct_where_clause($one_table, 'id' => 1, 'name' => 'foo', ['bar' => 'baz']),
5027             'could not construct_where_clause w/non-existent column');
5028             $test->is(__PACKAGE__->errcode, 'BDT-50', 'proper error code');
5029             }
5030              
5031             {
5032             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => [qw(a b c)]);
5033             $test->ok(scalar(@return), "got values from constructing where clause");
5034             $test->is($return[0], 't1.id in (?, ?, ?)', 'proper clause');
5035             $test->is($return[1], 'a', 'proper value');
5036             $test->is($return[2], 'b', 'proper value');
5037             $test->is($return[3], 'c', 'proper value');
5038             }
5039              
5040             {
5041             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => {'>' => 1});
5042             $test->ok(scalar(@return), "got values from constructing where clause");
5043             $test->is($return[0], 't1.id > ?', 'proper clause');
5044             $test->is($return[1], '1', 'proper value');
5045             }
5046              
5047             {
5048             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => {'>' => 1, '<' => 10});
5049             $test->ok(scalar(@return), "got values from constructing where clause");
5050             $test->is($return[0], '(t1.id < ? OR t1.id > ?)', 'proper clause');
5051             $test->is($return[1], '10', 'proper value');
5052             $test->is($return[2], '1', 'proper value');
5053             }
5054              
5055             {
5056             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => {'>' => 1, '<' => 10}, 'name' => 'you');
5057             $test->ok(scalar(@return), "got values from constructing where clause");
5058             $test->is($return[0], '(t1.id < ? OR t1.id > ?) AND t1.name = ?', 'proper clause');
5059             $test->is($return[1], '10', 'proper value');
5060             $test->is($return[2], '1', 'proper value');
5061             $test->is($return[3], 'you', 'proper value');
5062             }
5063              
5064             {
5065             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => {'>' => 1}, 'id' => {'<' => 10});
5066             $test->ok(scalar(@return), "got values from constructing where clause");
5067             $test->is($return[0], 't1.id > ? AND t1.id < ?', 'proper clause');
5068             $test->is($return[1], '1', 'proper value');
5069             $test->is($return[2], '10', 'proper value');
5070             }
5071              
5072             {
5073             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => 1, ['name' => 'me', 'id' => 3]);
5074             $test->ok(scalar(@return), "got values from constructing where clause");
5075             $test->is($return[0], 't1.id = ? OR (t1.name = ? AND t1.id = ?)', 'proper clause');
5076             $test->is($return[1], '1', 'proper value');
5077             $test->is($return[2], 'me', 'proper value');
5078             $test->is($return[3], '3', 'proper value');
5079             }
5080              
5081             {
5082             my @return = __PACKAGE__->construct_where_clause($one_table, 'id' => 1, ['name' => 'me', 'id' => 3], 'id' => 5);
5083             $test->ok(scalar(@return), "got values from constructing where clause");
5084             $test->is($return[0], 't1.id = ? AND t1.id = ? OR (t1.name = ? AND t1.id = ?)', 'proper clause');
5085             $test->is($return[1], '1', 'proper value');
5086             $test->is($return[2], '5', 'proper value');
5087             $test->is($return[3], 'me', 'proper value');
5088             $test->is($return[4], '3', 'proper value');
5089             }
5090              
5091             {
5092             my @return = __PACKAGE__->construct_where_clause($two_tables, 'id' => 1, ['name' => 'me', 'id' => 3], 'id' => 5);
5093             $test->ok(scalar(@return), "got values from constructing where clause");
5094             $test->is($return[0], 't1.id = ? AND t1.id = ? OR (t1.name = ? AND t1.id = ?)', 'proper clause');
5095             $test->is($return[1], '1', 'proper value');
5096             $test->is($return[2], '5', 'proper value');
5097             $test->is($return[3], 'me', 'proper value');
5098             $test->is($return[4], '3', 'proper value');
5099             }
5100              
5101             {
5102             my @return = __PACKAGE__->construct_where_clause($two_tables, 'id' => 1, ['name' => 'me', 'id' => 3], 't2.id' => 5);
5103             $test->ok(scalar(@return), "got values from constructing where clause");
5104             $test->is($return[0], 't1.id = ? AND t2.id = ? OR (t1.name = ? AND t1.id = ?)', 'proper clause');
5105             $test->is($return[1], '1', 'proper value');
5106             $test->is($return[2], '5', 'proper value');
5107             $test->is($return[3], 'me', 'proper value');
5108             $test->is($return[4], '3', 'proper value');
5109             }
5110              
5111             {
5112             my @return = __PACKAGE__->construct_where_clause($two_tables, 'id' => 1, 'size' => 7);
5113             $test->ok(scalar(@return), "got values from constructing where clause");
5114             $test->is($return[0], 't1.id = ? AND t2.size = ?', 'proper clause');
5115             $test->is($return[1], '1', 'proper value');
5116             $test->is($return[2], '7', 'proper value');
5117             }
5118              
5119             {
5120             my @return = __PACKAGE__->construct_where_clause($two_tables, 'id' => \1, 'size' => \7);
5121             $test->is(scalar(@return), 1, "got values from constructing where clause");
5122             $test->is($return[0], 't1.id = 1 AND t2.size = 7', 'proper clause');
5123             }
5124              
5125             {
5126             my @return = __PACKAGE__->construct_where_clause($two_tables, 'id' => {'is' => \'NULL'}, 'size' => 7);
5127             $test->ok(scalar(@return), "got values from constructing where clause");
5128             $test->is($return[0], 't1.id is NULL AND t2.size = ?', 'proper clause');
5129             $test->is($return[1], '7', 'proper value');
5130             }
5131              
5132             =end btest
5133              
5134             =cut
5135              
5136              
5137              
5138             =pod
5139              
5140             =item arbitrary_sql
5141              
5142             Wrappers Basset::Object::Persistent's arbitrary_sql method.
5143              
5144             =cut
5145              
5146             =pod
5147              
5148             =begin btest arbitrary_sql
5149              
5150             my $poclass = __PACKAGE__->pkg->pkg_for_type('persistentobject');
5151              
5152             $test->ok($poclass, "Got persistent object class");
5153             $test->ok($poclass->can('arbitrary_sql'), 'persistent class can arbitrary_sql');
5154              
5155             =end btest
5156              
5157             =cut
5158              
5159             sub arbitrary_sql {
5160 0     0 1   my $class = shift;
5161              
5162 0           my $persistent_class = $class->pkg_for_type('persistentobject');
5163 0   0       return $persistent_class->arbitrary_sql(@_) || $class->error($persistent_class->errvals);
5164             }
5165              
5166             1;
5167              
5168             =pod
5169              
5170             =back
5171              
5172             =cut