File Coverage

blib/lib/DBIx/OO.pm
Criterion Covered Total %
statement 50 602 8.3
branch 1 196 0.5
condition 0 20 0.0
subroutine 16 80 20.0
pod 34 34 100.0
total 101 932 10.8


line stmt bran cond sub pod time code
1             package DBIx::OO;
2              
3 2     2   61139 use base qw(Class::Data::Inheritable);
  2         6  
  2         2075  
4              
5 2     2   785 use warnings;
  2         4  
  2         68  
6 2     2   13 use strict;
  2         8  
  2         59  
7 2     2   12 use Carp ();
  2         4  
  2         39  
8 2     2   2283 use Encode ();
  2         25593  
  2         47  
9              
10 2     2   2223 use version; our $VERSION = qv('0.0.9');
  2         5254  
  2         11  
11              
12 2     2   4804 use DBI ();
  2         40324  
  2         74  
13 2     2   2614 use SQL::Abstract ();
  2         21717  
  2         163  
14              
15             __PACKAGE__->mk_classdata('__dboo_table');
16             __PACKAGE__->mk_classdata('__dboo_columns');
17             __PACKAGE__->mk_classdata('__dboo_colgroups');
18             __PACKAGE__->mk_classdata('__dboo_defaults');
19             ## __PACKAGE__->mk_classdata('__dboo_sql');
20             __PACKAGE__->mk_classdata('__dboo_sqlabstract');
21             ## __PACKAGE__->mk_classdata('__dboo_relations');
22              
23             my %INVALID_FIELD_NAMES = ( id => 1,
24             can => 1,
25             our => 1,
26             columns => 1,
27             table => 1,
28             set => 1,
29             get => 1,
30             count => 1,
31             );
32              
33 2     2   25 use vars qw( $HAS_WEAKEN );
  2         3  
  2         191  
34              
35             BEGIN {
36 2     2   5 $HAS_WEAKEN = 1;
37 2         4 eval {
38 2         11 require Scalar::Util;
39 2         172 import Scalar::Util qw(weaken);
40             };
41 2 50       925 if ($@) {
42 0         0 $HAS_WEAKEN = 0;
43             }
44             }
45              
46 0 0   0     sub __T { my $c = $_[0]; ref $c || $c; }
  0            
47              
48             =head1 NAME
49              
50             DBIx::OO - Database to Perl objects abstraction
51              
52             =head1 SYNOPSIS
53              
54             package MyDB;
55             use base 'DBIx::OO';
56              
57             # We need to overwrite get_dbh since it's an abstract function.
58             # The way you connect to the DB is really your job; this function
59             # should return the database handle. The default get_dbh() croaks.
60              
61             my $dbh;
62             sub get_dbh {
63             $dbh = DBI->connect_cached('dbi:mysql:test', 'user', 'passwd')
64             if !defined $dbh;
65             return $dbh;
66             }
67              
68             package MyDB::Users;
69             use base 'MyDB';
70              
71             __PACKAGE__->table('Users');
72             __PACKAGE__->columns(P => [ 'id' ],
73             E => [qw/ first_name last_name email /]);
74             __PACKAGE__->has_many(pages => 'MyDB::Pages', 'user');
75              
76             package MyDB::Pages;
77             use base 'MyDB';
78              
79             __PACKAGE__->table('Pages');
80             __PACKAGE__->columns(P => [ 'id' ],
81             E => [qw/ title content user /]);
82             __PACKAGE__->has_a(user => 'MyDB::Users');
83              
84             package main;
85              
86             my $u = MyDB::Users->create({ id => 'userid',
87             first_name => 'Q',
88             last_name => 'W' });
89              
90             my $foo = MyDB::Users->retrieve('userid');
91             my @p = @{ $foo->fk_pages };
92             print "User: ", $foo->first_name, " ", $foo->last_name, " pages:\n";
93             foreach (@p) {
94             print $_->title, "\n";
95             }
96              
97             $foo->first_name('John');
98             $foo->last_name('Doe');
99             # or
100             $foo->set(first_name => 'John', last_name => 'Doe');
101             $foo->update;
102              
103             =head1 IMPORTANT NOTE
104              
105             This code is tested only with MySQL. That's what I use. I don't have
106             too much time to test/fix it for other DBMS-es (it shouldn't be too
107             difficult though), but for now this is it... Volunteers are welcome.
108              
109             =head1 DESCRIPTION
110              
111             This module has been inspired by the wonderful Class::DBI. It is a
112             database-to-Perl-Objects abstraction layer, allowing you to interact
113             with a database using common Perl syntax.
114              
115             =head2 Why another Class::DBI "clone"?
116              
117             =over
118              
119             =item 1
120              
121             I had the feeling that Class::DBI is no longer maintained. This
122             doesn't seem to be the case, because:
123              
124             =item 2
125              
126             My code was broken multiple times by Class::DBI upgrades.
127              
128             =item 3
129              
130             Class::DBI doesn't quote table or field names, making it impossible to
131             use a column named, say, 'group' with MySQL.
132              
133             =item 4
134              
135             I wanted to know very well what happens "under the hood".
136              
137             =item 5
138              
139             I hoped my module would be faster than CDBI. I'm not sure this
140             is the case, but it certainly has less features. :-)
141              
142             =item 6
143              
144             There's more than one way to do it.
145              
146             =back
147              
148             All in all, I now use it in production code so this thing is here to
149             stay.
150              
151             =head2 Features
152              
153             =over
154              
155             =item B
156              
157             As Class::DBI, we have functions to retrieve an object by the primary
158             key, search a table and create multiple objects at once, create a new
159             object, update an existing object.
160              
161             =item B
162              
163             Same like Class::DBI, we provide accessors for each declared column in
164             a table. Usually accessors will have the same name as the column
165             name, but note that there are cases when we can't do that, such as
166             "can", "get", "set", etc. -- because DBIx::OO or parent objects
167             already define these functions and have a different meaning.
168              
169             When it is not possible to use the column name, it is prefixed with
170             "col_" -- so if you have a table with a column named "can", its
171             accessor will be named "col_can".
172              
173             =item B
174              
175             We support a few types of table relationships. They provide a few
176             nice features, though overally are not as flexible as Class::DBI's.
177             The syntax is quite different too, be sure to check the
178             L.
179              
180             =item B-s
181              
182             has_a also creates a search function that allows you to retrieve data
183             from both tables using a JOIN construct. This can drastically reduce
184             the number of SQL queries required to fetch a list of objects.
185              
186             =back
187              
188             =head2 Missing features:
189              
190             =over
191              
192             =item B
193              
194             DBIx::OO does not cache objects. This means that you can have the
195             same DB record in multiple Perl objects. Sometimes this can put you
196             in trouble (not if you're careful though).
197              
198             At some point I might want to implement object uniqueness like
199             Class::DBI, but not for now.
200              
201             =item B
202              
203             Triggers are nice, but can cause considerable performance problems
204             when misused.
205              
206             UPDATE: The only trigger that currently exists is before_set(), check
207             its documentation.
208              
209             =item B
210              
211             Constraints, integrity maintenance, etc. By contrast Class::DBI has a
212             lot of nice features, but I think the performance price we pay for
213             them is just too big. I hope this module to stay small and be fast.
214              
215             =back
216              
217             =head1 QUICK START
218              
219             You need to subclass DBIx::OO in order to provide an
220             implementation to the B() method. This function is pure
221             virtual and should retrieve the database handler, as returned by
222             Bconnect>, for the database that you want to use. You can
223             use an interim package for that, as we did in our example above
224             (B).
225              
226             Then, each derived package will handle exactly one table, should setup
227             columns and relationships.
228              
229             =head1 API DOCUMENTATION
230              
231             =head2 C
232              
233             Currently, B takes no arguments and constructs an empty object.
234             You normally shouldn't need to call this directly.
235              
236             =cut
237              
238             sub new {
239 0     0 1   my ($class) = @_;
240 0           bless { values => {},
241             modified => {},
242             ### foreign => {}
243             }, $class;
244             }
245              
246             =head2 C
247              
248             This method should return a database handler, as returned by
249             DBI->connect. The default implementation croaks, so you I to
250             overwrite it in your subclasses. To write it only once, you can use
251             an intermediate object.
252              
253             =cut
254              
255             sub get_dbh {
256 0     0 1   _croak("Pure virtual method not implemented: get_dbh.",
257             "See the documentation, if there is any.");
258             }
259              
260             =head2 C
261              
262             Call this method in each derived package to inform DBIx::OO of the
263             table that you wish that package to use.
264              
265             __PACKAGE__->table('Users')
266              
267             =cut
268              
269             sub table {
270 0     0 1   my $class = __T(shift);
271 0           my $table = shift;
272 0 0         $class->__dboo_table($table) if $table;
273 0           return $class->__dboo_table;
274             }
275              
276             =head2 C cols, ...])>
277              
278             Sets/retrieves the columns of the current package.
279              
280             Similarly to Class::DBI, DBIx::OO uses a sort of column grouping.
281             The 'P' group is always the primary key. The 'E' group is the
282             essential group--which will be fetched whenever the object is first
283             instantiated. You can specify any other groups names here, and they
284             will simply group retrieval of columns.
285              
286             Example:
287              
288             __PACKAGE__->columns(P => [ 'id' ],
289             E => [ 'name', 'description' ],
290             X => [ 'c1', 'big_content1', 'big_title1' ],
291             Y => [ 'c2', 'big_content2', 'big_title2' ]);
292              
293             The above code defines 4 groups. When an object is first
294             instantiated, it will fetch 'id', 'name' and 'description'. When you
295             say $obj->c1, it will fetch 'c1, 'big_content1' and 'big_title1',
296             because they are in the same group. When you say $obj->c2 it will
297             fetch 'c2', 'big_content2' and 'big_title2'. That's pretty much like
298             Class::DBI.
299              
300             To retrieve columns, you pass a group name.
301              
302             =head3 Notes
303              
304             =over
305              
306             =item *
307              
308             Class::DBI allows you to call columns() multiple times, passing one
309             group at a time. Our module should allow this too, but it's untested
310             and might be buggy. We suggest defining all groups in one shot, like
311             the example above.
312              
313             =item *
314              
315             Group 'P' is I. I mean that. We won't guess the primary
316             key column like Class::DBI does.
317              
318             =back
319              
320             =cut
321              
322             sub columns {
323 0     0 1   my $class = __T(shift);
324 0           my $h = $class->__dboo_columns;
325 0 0         if (@_) {
326 0 0         if (ref $_[0] eq 'HASH') {
    0          
327 0           $class->__dboo_columns($_[0]);
328             } elsif (@_ == 1) {
329 0           return $class->__dboo_columns->{$_[0]};
330             } else {
331 0 0         $class->__dboo_columns($h = {})
332             if !defined $h;
333 0           while (@_) {
334 0           my $k = shift;
335 0           my $v = shift;
336 0 0         $v = [ $v ]
337             if (!ref $v);
338 0           $h->{$k} = $v;
339             }
340             }
341             } else {
342 0           return [ keys %{$class->__dboo_colgroups} ];
  0            
343             }
344 0           my $all = $class->__dboo_columns;
345 0           my $hash = {};
346 0           while (my ($group, $v) = each %$all) {
347 0           foreach my $colname (@$v) {
348 0           my $wtf8;
349 0 0         if ($colname =~ /^!/) {
350 0           $colname = substr($colname, 1);
351 0           $wtf8 = 1;
352             }
353 0           my $closname = get_accessor_name($colname);
354 2     2   15 no strict 'refs';
  2         5  
  2         2026  
355 0           *{"$class\::$closname"} = __COL_CLOSURE($colname, $wtf8);
  0            
356 0           $hash->{$colname} = $group;
357             }
358             }
359 0           $class->__dboo_colgroups($hash);
360 0           return $h;
361             }
362              
363             =head2 C
364              
365             Though public, it's likely you won't need this function. It returns
366             a list of column names that would be cloned in a clone() operation.
367             By default it excludes any columns in the "B

" group (primary keys)

368             but you can pass a list of other names to exclude as well.
369              
370             =cut
371              
372             sub clone_columns {
373 0     0 1   my ($class) = __T(shift);
374 0           my %except;
375 0 0         if (@_) {
376 0           @except{@_} = @_;
377             }
378 0           my $all = $class->columns;
379 0 0         $all = [ grep { !exists($except{$_}) and $class->__dboo_colgroups->{$_} ne 'P' } @$all ];
  0            
380 0           return $all;
381             }
382              
383             =head2 C
384              
385             Using this function you can declare some default values for your
386             columns. They will be used unless alternative values are specified
387             when a record is inserted (e.g. with create()). Example:
388              
389             __PACKAGE__->defaults(created => ['now()'],
390             hidden => 1,
391             modified_by => \&get_current_user_id);
392              
393             You can specify any scalar supported by SQL::Abstract's insert
394             operation. For instance, an array reference specifies literal SQL
395             (won't be quoted). Additionally, you can pass code references, in
396             which case the subroutine will be called right when the data is
397             inserted and its return value will be used.
398              
399             =cut
400              
401             sub defaults {
402 0     0 1   my ($class, %args) = @_;
403 0           my $def = $class->__dboo_defaults;
404 0 0         if (!$def) {
405 0           $class->__dboo_defaults($def = {});
406             }
407 0           @{$def}{keys %args} = values %args;
  0            
408             }
409              
410             =head2 C
411              
412             Retrieves the value of one or more columns. If you pass more column
413             names, it will return an array of values, in the right order.
414              
415             =cut
416              
417             sub get {
418 0     0 1   my ($self, @field) = @_;
419 0 0         if (@field == 1) {
420 0           my $f = $field[0];
421 0 0         if (!exists $self->{values}{$f}) {
422 0           my $g = $self->__dboo_colgroups->{$f};
423 0           $self->_retrieve_columns($g, $self->{values});
424             }
425 0 0         return wantarray ? ( $self->{values}{$f} ) : $self->{values}{$f};
426             } else {
427 0           my %groups = ();
428 0           foreach my $f (@field) {
429 0 0         $groups{$self->__dboo_colgroups->{$f}} = 1
430             if !exists $self->{values}{$f};
431             }
432 0 0         $self->_retrieve_columns([ keys %groups ], $self->{values})
433             if %groups;
434 0           return @{$self->{values}}{@field};
  0            
435             }
436             }
437              
438             =head2 C value[, field =E value, ...])>
439              
440             Sets one or more columns to the specified value(s).
441              
442             This function calls C right before modifying the object
443             data, passing a hash reference to the new values.
444              
445             =cut
446              
447             sub set {
448 0     0 1   my $self = shift;
449 0 0         my %h = ref $_[0] eq 'HASH' ? %{$_[0]} : ( @_ );
  0            
450 0           $self->before_set(\%h, 0);
451 0           my @keys = keys %h;
452 0           @{$self->{modified}}{@keys} = @{$self->{values}}{@keys};
  0            
  0            
453 0           @{$self->{values}}{@keys} = values %h;
  0            
454 0           return $self;
455             }
456              
457             =head2 C
458              
459             By default this function does nothing. It will be called by the
460             framework right before setting column values. A hash reference with
461             columns to be set will be passed. You can modify this hash if you
462             wish. For example, assuming you have an Users table with a MD5
463             password and you want to create the MD5 right when the column is set,
464             you can do this:
465              
466             package Users;
467              
468             ...
469              
470             sub before_set {
471             my ($self, $h, $is_create) = @_;
472             if (exists $h->{password}) {
473             $h->{password} = make_md5_passwd($h->{password});
474             }
475             }
476              
477             my $u = Users->retrieve('foo');
478             $u->password('foobar');
479             print $u->password;
480             # be8cd58c70ad7dc935802fdb051869fe
481              
482             The $is_create argument will be true (1) if this function is called as
483             a result of a create() command.
484              
485             =cut
486              
487 0     0 1   sub before_set {}
488              
489             =head2 C
490              
491             Returns the value(s) of the primary key(s). If the primary key
492             consists of more columns, this method will return an array with the
493             values, in the order the PK column names were specified.
494              
495             Currently this is equivalent to $self->get(@{ $self->columns('P') }).
496              
497             =cut
498              
499             sub id {
500 0     0 1   my ($self) = @_;
501 0           return $self->get(@{$self->columns('P')});
  0            
502             }
503              
504             sub __COL_CLOSURE {
505 0     0     my ($col, $wtf8) = @_;
506 0 0         if (!$wtf8) {
507             return sub {
508 0     0     my $self = shift;
509 0 0         @_ > 0 ? $self->set($col, @_) : $self->get($col);
510 0           };
511             } else {
512             return sub {
513 0     0     my $self = shift;
514 0 0         if (@_ > 0) {
515 0           my @a = map { _to_utf8($_) } @_;
  0            
516 0           return $self->set($col, @a);
517             } else {
518 0           return $self->get($col);
519             }
520 0           };
521             }
522             }
523              
524             =head2 C, C, C
525              
526             Use these functions to start, commit or rollback a DB transaction.
527             These simply call begin_work, rollback and commit methods on the DB
528             handle returned by get_dbh().
529              
530             =cut
531              
532             sub transaction_start {
533 0     0 1   $_[0]->get_dbh->begin_work;
534             }
535              
536             sub transaction_rollback {
537 0     0 1   $_[0]->get_dbh->rollback;
538             }
539              
540             sub transaction_commit {
541 0     0 1   $_[0]->get_dbh->commit;
542             }
543              
544             =head2 C
545              
546             There are a few column names that we can't allow as accessor names.
547             This function receives a column name and returns the name of the
548             accessor for that field. By default it prefixes forbidden names with
549             'col_'. The forbidden names are:
550              
551             - id
552             - can
553             - our
554             - columns
555             - table
556             - get
557             - set
558             - count
559              
560             If you don't like this behavior you can override this function in your
561             classes to return something else. However, be very careful about
562             allowing any the above forbidden names as accessors--basically nothing
563             will work.
564              
565             =cut
566              
567             sub get_accessor_name {
568 0     0 1   my $name = shift;
569 0 0         return $name
570             if !$INVALID_FIELD_NAMES{$name};
571             return
572 0           "col_$name";
573             }
574              
575             =head2 C
576              
577             This function returns the name of a foreign key accessor, as defined
578             by L. The default returns
579             "fk_$name"--thus prepending "fk_".
580              
581             If you want the Class::DBI behavior, you can override this function in
582             your derived module:
583              
584             sub get_fk_name { return $_[1]; }
585              
586             (the first argument will be object ref. or package)
587              
588             I think the Class::DBI model is unwise. Many times I found my columns
589             inflated to objects when I was in fact expecting to get an ID. Having
590             the code do implicit work for you is nice, but you can spend hours
591             debugging when it gets it wrong--which is why, DBIx::OO will by
592             default prepend a "fk_" to foreign objects accessors. You'll get use
593             to it.
594              
595             =cut
596              
597             sub get_fk_name {
598 0     0 1   return "fk_$_[1]";
599             }
600              
601             =head2 C
602              
603             __PACKAGE__->has_a(name, type[, mapping[, order ]]);
604             __PACKAGE__->has_many(name, type[, mapping[, order[, limit[, offset ]]]]);
605              
606             Creates a relationship between two packages. In the simplest form,
607             you call:
608              
609             __PACKAGE__->has_a(user => Users);
610              
611             This declaration creates a relation between __PACKAGE__ (assuming it
612             has a column named 'user') and 'Users' package. It is assuming that
613             'user' from the current package points to the primary key of the Users
614             package.
615              
616             The declaration creates a method named 'fk_user', which you can call
617             in order to retrieve the pointed object. Example:
618              
619             package Pages;
620             use base 'MyDB';
621             __PACKAGE__->columns('P' => [ 'id' ],
622             'E' => [ 'user', ... ]);
623             __PACKAGE__->has_a(user => 'Users');
624              
625             my $p = Pages->retrieve(1);
626             my $u = $p->fk_user;
627             print $u->first_name;
628              
629             In more complex cases, you might need to point to a different field
630             than the primary key of the target package. You can call it like
631             this:
632              
633             Users->has_many(pages => Pages, 'user');
634             my $u = Users->retrieve('foo');
635             my @pages = @{ $u->fk_pages };
636              
637             The above specifies that an User has many pages, and that they are
638             determined by mapping the 'user' field of the Pages package to the
639             I of the C package.
640              
641             has_many() also defines an utility function that allows us to easily
642             count the number of rows in the referenced table, without retrieving
643             their data. Example:
644              
645             print $u->count_pages;
646              
647             You can specify an WHERE clause too, in SQL::Abstract syntax:
648              
649             print $u->count_pages(keywords => { -like => '%dhtml%' });
650              
651             The above returns the number of DHTML pages that belong to the user.
652              
653             In even more complex cases, you want to map one or more arbitrary
654             columns of one package to columns of another package, so you can pass
655             a hash reference that describes the column mapping:
656              
657             ## FIXME: find a good example
658              
659             has_many() is very similar to has_a, but the accessor it creates
660             simply returns multiple values (as an array ref). We can pass some
661             arguments too, either to has_a/has_many declarations, or to the
662             accessor.
663              
664             @pages = @{ $u->fk_pages('created', 10, 5) }
665              
666             The above will retrieve the user's pages ordered by 'created',
667             starting at OFFSET 5 and LIMIT-ing to 10 results.
668              
669             You can use has_a even if there's not a direct mapping. Example, a
670             page can have multiple revisions, but we can also easily access the
671             first/last revision:
672              
673             Pages->has_many(revisions => 'Revisions', 'page');
674             Pages->has_a(first_revision => 'Revisions', 'page', 'created');
675             Pages->has_a(last_revision => 'Revisions', 'page', '^created');
676              
677             has_a() will LIMIT the result to one. Ordering the results by
678             'created', we make sure that we actually retrieve what we need.
679             B that by prefixing the column name with a '^' character, we're
680             asking the module to do a DESC ordering.
681              
682             (Of course, it's a lot faster if we had first_revision and
683             last_revision as columns in the Pages table that link to Revision id,
684             but we just wanted to point out that the above is possible ;-)
685              
686             =head3 Join
687              
688             has_a() will additionally create a join function. It allows you to
689             select data from 2 tables using a single SQL query. Example:
690              
691             package MyDB::Users;
692             MyDB::Users->table('Users');
693             MyDB::Users->has_a(profile => 'Profiles');
694              
695             package MyDB::Profiles;
696             MyDB::Profiles->table('Profiles');
697              
698             @data = Users->search_join_profile;
699             foreach (@data) {
700             my $user = $_->{Users}; # the key is the SQL B name
701             my $profile = $_->{Profiles};
702             print $user->id, " has address: ", $profile->address;
703             }
704              
705             The above only does 1 SELECT. Note that the join search function
706             returns an array of hashes that map from the SQL table name to the
707             DBIx::OO instance.
708              
709             You can pass additional WHERE, ORDER, LIMIT and OFFSET clauses to the
710             join functions as well:
711              
712             @data = Users->search_join_profile({ 'Users.last_name' => 'Doe' },
713             'Users.nickname',
714             10);
715              
716             The above fetches the first 10 members of the Doe family ordered by
717             nickname.
718              
719             Due to lack of support from SQL::Abstract side, the JOIN is actually a
720             select like this:
721              
722             SELECT ... FROM table1, table2 WHERE table1.foreign = table2.id
723              
724             In the future I hope to add better support for this, that is, use
725             "INNER JOIN" and eventually support other JOIN types as well.
726              
727             =head3 Notes
728              
729             =over
730              
731             =item 1.
732              
733             The C accessors will actually retrieve data at each call.
734             Therefore:
735              
736             $p1 = $user->fk_pages;
737             $p2 = $user->fk_pages;
738              
739             will retrieve 2 different arrays, containing different sets of objects
740             (even if they point to the same records), hitting the database twice.
741             This is subject to change, but for now you have to be careful about
742             this. It's best to keep a reference to the returned object(s) rather
743             than calling fk_pages() all over the place.
744              
745             =item 2.
746              
747             has_many() creates accessors that select multiple objects. The
748             database will be hit once, though, and multiple objects are created
749             from the returned data. If this isn't desirable, feel free to LIMIT
750             your results.
751              
752             =back
753              
754             =cut
755              
756             ### TODO: this can be optimized: cache the where clause and generated SQL.
757             sub has_a {
758 0     0 1   my ($class, $name, $type, $arg, $order) = @_;
759 0           my $fk_name = $class->get_fk_name($name);
760 2     2   12 no strict 'refs';
  2         4  
  2         1771  
761 0           my $colmap;
762             my $mk_colmap = sub {
763 0 0   0     if (!defined $colmap) {
764 0           my ($class) = @_;
765 0           $colmap = {};
766 0 0         if (!$arg) {
    0          
    0          
    0          
767 0           $colmap->{$name} = $type->columns('P')->[0];
768             } elsif (!ref $arg) {
769 0           $colmap->{$class->columns('P')->[0]} = $arg;
770             } elsif (ref $arg eq 'HASH') {
771 0           $colmap = $arg;
772             } elsif (ref $arg eq 'ARRAY') {
773 0           @{$colmap}{@$arg} = @{$type->columns('P')};
  0            
  0            
774             }
775             }
776 0           };
777             ## declare the fk_colname function
778             {
779 0           *{"$class\::$fk_name"} = sub {
  0            
780 0     0     my ($self, $order2) = @_;
781 0 0         $order2 = $order
782             if !defined $order2;
783 0           &$mk_colmap($self);
784 0           my %where;
785 0           @where{values %$colmap} = @{$self->{values}}{keys %$colmap};
  0            
786 0           my $a = $type->search(\%where, $order, 1);
787 0           return $a->[0];
788 0           };
789             }
790             ## simple 2 tables JOIN facility
791             {
792 0           my %join_colmap;
  0            
793 0           my ($t1, $t2);
794 0           my ($c1, $c2);
795 0           my @cols;
796 0           *{"$class\::search_join_${name}"} = sub {
797 0     0     my ($class, $where2, $order2, $limit, $offset) = @_;
798 0 0         $order2 = $order
799             if !defined $order2;
800 0           my $sa = $class->get_sql_abstract;
801 0 0         if (!%join_colmap) {
802 0           &$mk_colmap($class);
803 0           ($t1, $t2) = ($class->table, $type->table);
804 0           $c1 = $class->_get_columns([ 'P', 'E' ]);
805 0           $c2 = $type->_get_columns([ 'P', 'E' ]);
806 0           @cols = map { "$t1.$_" } @$c1;
  0            
807 0           push(@cols,
808 0           map { "$t2.$_" } @$c2);
809 0           my @k = map { "$t1.$_" } keys %$colmap;
  0            
810 0           my @v = map { my $tmp = '= ' . $sa->_quote("$t2.$_");
  0            
811 0           \$tmp } values %$colmap;
812 0           @join_colmap{@k} = @v;
813             }
814 0           my %where = %join_colmap;
815 0 0         @where{keys %$where2} = values %$where2
816             if $where2;
817 0           my ($sql, @bind) = $sa->select([ $t1, $t2 ],
818             \@cols, \%where, $order2, $limit, $offset);
819 0           my $sth = $class->_run_sql($sql, \@bind);
820 0           my @ret;
821 0           my $slicepoint = scalar(@$c1) - 1;
822 0           my $end = $slicepoint + scalar(@$c2);
823 0           while (my $row = $sth->fetchrow_arrayref) {
824 0           my $obj = {};
825 0           my $o1 = $obj->{$t1} = $class->new;
826 0           my $o2 = $obj->{$t2} = $type->new;
827 0           @{$o1->{values}}{@$c1} = @{$row}[0..$slicepoint];
  0            
  0            
828 0           @{$o2->{values}}{@$c2} = @{$row}[$slicepoint+1..$end];
  0            
  0            
829 0           push @ret, $obj;
830             }
831 0           return @ret;
832 0           };
833             }
834 0           undef $class;
835             }
836              
837             =head2 C
838              
839             Alias to has_a().
840              
841             =cut
842              
843             *might_have = \&has_a;
844              
845             ### TODO: this can be optimized: cache the where clause and generated SQL.
846             sub has_many {
847 0     0 1   my ($class, $name, $type, $arg, $order, $limit, $offset) = @_;
848 0           my $colmap;
849 0           my $fk_name = $class->get_fk_name($name);
850 2     2   14 no strict 'refs';
  2         20  
  2         1278  
851             my $mk_colmap = sub {
852 0 0   0     if (!defined $colmap) {
853 0           my $self = shift;
854 0           $colmap = {};
855 0 0         if (!$arg) {
    0          
    0          
    0          
856 0           $colmap->{$name} = $type->columns('P')->[0];
857             } elsif (!ref $arg) {
858 0           $colmap->{$self->columns('P')->[0]} = $arg;
859             } elsif (ref $arg eq 'HASH') {
860 0           $colmap = $arg;
861             } elsif (ref $arg eq 'ARRAY') {
862 0           @{$colmap}{@$arg} = @{$type->columns('P')};
  0            
  0            
863             }
864             }
865 0           };
866 0           *{"$class\::$fk_name"} = sub {
867 0     0     my ($self, $where2, $order2, $limit2, $offset2) = @_;
868 0 0         $order2 = $order
869             if !defined $order2;
870 0 0         $limit2 = $limit
871             if !defined $limit2;
872 0 0         $offset2 = $offset
873             if !defined $offset2;
874 0           &$mk_colmap($self);
875 0           my %where;
876 0           @where{values %$colmap} = @{$self->{values}}{keys %$colmap};
  0            
877 0 0         @where{keys %$where2} = values %$where2
878             if $where2;
879 0           return $type->search(\%where, $order2, $limit2, $offset2);
880 0           };
881 0           *{"$class\::add_to_$name"} = sub {
882 0     0     my $self = shift;
883 0 0         my %val = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
  0            
884 0           &$mk_colmap($self);
885 0           @val{values %$colmap} = @{$self->{values}}{keys %$colmap};
  0            
886 0           return $type->create(\%val);
887 0           };
888 0           *{"$class\::count_$name"} = sub {
889 0     0     my $self = shift;
890 0 0         my %val = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
  0            
891 0           &$mk_colmap($self);
892 0           @val{values %$colmap} = @{$self->{values}}{keys %$colmap};
  0            
893 0           return $type->count(\%val);
894 0           };
895 0           undef $class;
896             }
897              
898             =head2 C
899              
900             You can use has_mapping to map one object to another using an
901             intermediate table. You can have these tables:
902              
903             Users: id, first_name, etc.
904             Groups: id, description, etc.
905             Users_To_Groups: user, group
906              
907             This is quite classical, I suppose, to declare many-to-many
908             relationships. The Users_To_Groups contains records that map one user
909             to one group. To get the ID-s of all groups that a certain user
910             belongs to, you would say:
911              
912             SELECT group FROM Users_To_Group where user = '$user'
913              
914             But since you usually need the Group objects directly, you could speed
915             things up with a join:
916              
917             SELECT Groups.id, Groups.description, ... FROM Groups, Users_To_Groups
918             WHERE Users_To_Groups.group = Groups.id
919             AND Users_To_Groups.user = '$user';
920              
921             The relationship declared with has_mapping() does exactly that. You
922             would call it like this:
923              
924             package Users;
925             __PACKAGE__->table('Users');
926             __PACKAGE__->columns(P => [ 'id' ], ...);
927              
928             __PACKAGE__->has_mapping(groups, 'Groups',
929             'Users_To_Groups', 'user', 'group');
930              
931             package Groups;
932             __PACKAGE__->table('Groups');
933             __PACKAGE__->columns(P => [ 'id' ], ...);
934              
935             # You can get the reverse mapping as well:
936             __PACKAGE__->has_mapping(users, 'Users',
937             'Users_To_Groups', 'group', 'user');
938              
939             package Users_To_Groups;
940             __PACKAGE__->table('Users_To_Groups');
941             __PACKAGE__->columns(P => [ 'user', 'group' ]);
942              
943             Note that Users_To_Groups has a multiple primary key. This isn't
944             required, but you should at least have an unique index for the (user,
945             group) pair.
946              
947             =head3 Arguments
948              
949             I started with an example because the function itself is quite
950             complicated. Here are arguments documentation:
951              
952             =over
953              
954             =item name
955              
956             This is used to name the accessors. By default we will prepend a
957             "fk_" (see L).
958              
959             =item type
960              
961             The type of the target objects.
962              
963             =item maptype
964              
965             The mapping object type. This is the name of the object that maps one
966             type to another. Even though you'll probably never need to
967             instantiate such an object, it still has to be declared.
968              
969             =item map1
970              
971             Specifies how we map from current package (__PACKAGE__) to the
972             C object. This can be a scalar or an hash ref. If it's a
973             scalar, we will assume that __PACKAGE__ has a simple primary key (not
974             multiple) and C is the name of the column from C that
975             we should map this key to. If it's a hash reference, it should
976             directly specify the mapping; the keys will be taken from __PACKAGE__
977             and the values from C. If that sounds horrible, check the
978             example below.
979              
980             =item map2
981              
982             Similar to C, but C specifies the mapping from C
983             to the target C. If a scalar, it will be the name of the column
984             from C that maps to the primary key of the target package
985             (assumed to be a simple primary key). If a hash reference, it
986             specifies the full mapping.
987              
988             =item order, limit, offset
989              
990             Similar to has_many, these can specify default ORDER BY and/or
991             LIMIT/OFFSET clauses for the resulted query.
992              
993             =back
994              
995             =head3 Example
996              
997             Here's the mapping overview:
998              
999             map1 map2
1000             __PACKAGE__ ===> C ===> C
1001             current package table that holds the target package
1002             the mapping
1003              
1004             =cut
1005              
1006             sub has_mapping {
1007 0     0 1   my ($class, $name, $type, $maptype, $arg1, $arg2, $order, $limit, $offset) = @_;
1008 0           my $fk_name = $class->get_fk_name($name);
1009 2     2   13 no strict 'refs';
  2         4  
  2         6729  
1010 0           my ($tcols, $select);
1011 0           my @keys;
1012 0           *{"$class\::$fk_name"} = sub {
1013 0     0     my ($self, $order2, $limit2, $offset2) = @_;
1014 0 0         $order2 = $order
1015             if !defined $order2;
1016 0 0         $limit2 = $limit
1017             if !defined $limit2;
1018 0 0         $offset2 = $offset
1019             if !defined $offset2;
1020              
1021 0           my $sa = $self->get_sql_abstract;
1022 0           my @bind;
1023 0 0         if (!$select) {
1024 0 0         if (!ref $arg1) {
    0          
1025 0           my %tmp;
1026 0           $tmp{$self->columns('P')->[0]} = $arg1;
1027 0           $arg1 = \%tmp;
1028             } elsif (ref $arg1 eq 'ARRAY') {
1029 0           my %tmp;
1030 0           @tmp{@{$self->columns('P')}} = @$arg1;
  0            
1031 0           $arg1 = \%tmp;
1032             }
1033 0 0         if (!ref $arg2) {
    0          
1034 0           my %tmp;
1035 0           $tmp{$arg2} = $type->columns('P')->[0];
1036 0           $arg2 = \%tmp;
1037             } elsif (ref $arg2 eq 'ARRAY') {
1038 0           my %tmp;
1039 0           @tmp{@$arg2} = @{$type->columns('P')};
  0            
1040 0           $arg2 = \%tmp;
1041             }
1042              
1043 0           my %where = ();
1044 0           my ($st, $tt, $mt) = ($self->table, $type->table, $maptype->table);
1045 0           while (my ($k, $v) = each %$arg1) {
1046 0           my $tmp = '= ' . $sa->_quote("$mt.$v");
1047 0           $where{"$st.$k"} = \$tmp; # SCALAR ref means literal SQL
1048 0           $where{"$mt.$v"} = $self->get($k);
1049 0           push @keys, $k; # remember these keys to reconstruct @bind later
1050             }
1051 0           while (my ($k, $v) = each %$arg2) {
1052 0           my $tmp = '= ' . $sa->_quote("$tt.$v");
1053 0           $where{"$mt.$k"} = \$tmp; # SCALAR ref means literal SQL
1054             }
1055 0           $tcols = $type->_get_columns([ 'P', 'E' ]);
1056 0           my @fields = map { "$tt.$_" } @$tcols;
  0            
1057              
1058 0           ($select, @bind) = $sa->select([ $st, $mt, $tt ], \@fields, \%where);
1059             } else {
1060 0           @bind = $self->get(@keys);
1061             }
1062 0           my $sql = $select . $sa->order_and_limit($order2, $limit2, $offset2);
1063 0           my $sth = $type->_run_sql($sql, \@bind);
1064 0           my @ret;
1065 0           while (my $row = $sth->fetchrow_arrayref) {
1066 0           my $obj = $type->new;
1067 0           @{$obj->{values}}{@$tcols} = @$row;
  0            
1068 0           push @ret, $obj;
1069             }
1070              
1071 0 0         return wantarray ? @ret : \@ret;
1072 0           };
1073             }
1074              
1075             =head2 C
1076              
1077             my $u = Users->create({ id => 'foo',
1078             first_name => 'John',
1079             last_name => 'Doe' });
1080              
1081             Creates a new record and stores it in the database. Returns the newly
1082             created object. We recommend passing a hash reference, but you can
1083             pass a hash by value as well.
1084              
1085             =cut
1086              
1087             sub create {
1088 0     0 1   my $self = shift;
1089 0 0         my %val = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
  0            
1090 0           my $class = __T($self);
1091              
1092 0           my $obj = $class->new;
1093 0           $obj->before_set(\%val, 1);
1094 0           $obj->{values} = \%val;
1095 0           $obj->_apply_defaults;
1096              
1097 0           my $sa = $self->get_sql_abstract;
1098 0           my ($sql, @bind) = $sa->insert($self->table, \%val);
1099 0           my $dbh = $self->get_dbh;
1100 0           $self->_run_sql($sql, \@bind);
1101              
1102 0           my $pk = $self->columns('P');
1103 0 0 0       $val{$pk->[0]} = $self->_get_last_id($dbh)
1104             if @$pk == 1 && !exists $val{$pk->[0]};
1105              
1106             # since users may specify SQL functions using an array ref, we
1107             # remove them in order to get full values later.
1108 0           while (my ($k, $v) = each %val) {
1109 0 0         delete $val{$k}
1110             if ref $v;
1111             }
1112              
1113 0           return $obj;
1114             }
1115              
1116             =head2 clone(@except)
1117              
1118             Clones an object, returning a hash (reference) suitable for create().
1119             Here's how you would call it:
1120              
1121             my $val = $page->clone;
1122             my $new_page = Pages->create($val);
1123              
1124             Or, supposing you don't want to copy the value of the "created" field:
1125              
1126             my $val = $page->clone('created');
1127             my $new_page = Pages->create($val);
1128              
1129             =cut
1130              
1131             sub clone {
1132 0     0 1   my ($self, @except) = @_;
1133 0           my %val;
1134 0           my $cols = $self->clone_columns(@except);
1135 0           @val{@$cols} = $self->get(@$cols);
1136 0           return \%val;
1137             }
1138              
1139             =head2 C
1140              
1141             Initializes one or more objects from the given data. $data can be a
1142             hashref (in which case a single object will be created and returned)
1143             or an arrayref (multiple objects will be created and returned as an
1144             array reference).
1145              
1146             The hashes simply contain the data, as retrieved from the database.
1147             That is, map column name to field value.
1148              
1149             This method is convenient in those cases where you already have the
1150             data (suppose you SELECT-ed it in a different way than using DBIx::OO)
1151             and want to initialize DBIx::OO objects without the penalty of going
1152             through the DB again.
1153              
1154             =cut
1155              
1156             sub init_from_data {
1157 0     0 1   my ($class, $data) = @_;
1158 0 0         if (ref $data eq 'ARRAY') {
1159 0           my @a = ();
1160 0           foreach my $h (@$data) {
1161 0           push @a, $class->init_from_data($h);
1162             }
1163 0           return \@a;
1164             } else {
1165 0           my $obj = $class->new;
1166 0           $obj->{values} = $data;
1167 0           return $obj;
1168             }
1169             }
1170              
1171             =head2 C
1172              
1173             my $u = Users->retrieve('foo');
1174              
1175             Retrieves an object from the database. You need to pass its ID (the
1176             value of the primary key). If the primary key consists on more
1177             columns, you can pass the values in order as an array, or you can pass
1178             a hash reference.
1179              
1180             Returns undef if no objects were found.
1181              
1182             =cut
1183              
1184             sub retrieve {
1185 0     0 1   my $class = __T($_[0]);
1186 0           my $self = shift;
1187 0           my $obj;
1188 0 0         if (ref $self) { # refresh existing object
1189 0           $obj = $self;
1190             # reset values
1191 0           $obj->{values} = $self->_get_pk_where;
1192 0           $obj->{modified} = {};
1193             } else { # create new object
1194 0           $obj = $class->new;
1195 0 0         if (!ref $_[0]) {
    0          
1196 0           my $pk = $class->columns('P');
1197 0           @{$obj->{values}}{@$pk} = @_;
  0            
1198             } elsif (ref $_[0] eq 'HASH') {
1199 0           my ($h) = @_;
1200 0           @{$obj->{values}}{keys %$h} = values %$h;
  0            
1201             }
1202             }
1203 0           eval {
1204 0           $obj->_retrieve_columns([ 'P', 'E' ]);
1205             };
1206 0 0         if ($@) {
1207             ### XXX: a warning should be in order here? We can't be sure
1208             ### why did the operation failed...
1209 0           undef $obj;
1210             }
1211 0           return $obj;
1212             }
1213              
1214             =head2 C
1215              
1216             $a = Users->search({ created => [ '>=', '2006-01-01 00:00:00' ]});
1217              
1218             Searches the database and returns an array of objects that match the
1219             search criteria. All arguments are optional. If you pass no
1220             arguments, it will return an array containing all objects in the DB.
1221             The syntax of C<$where> and C<$order> are described in
1222             L.
1223              
1224             In scalar context it will return a reference to the array.
1225              
1226             The C<$limit> and C<$offset> arguments are added by DBIx::OO and allow you
1227             to limit/paginate your query.
1228              
1229             UPDATE 0.0.7:
1230              
1231             Certain queries are difficult to express in SQL::Abstract syntax. The
1232             search accepts a literal WHERE clause too, but until version 0.0.7
1233             there was no way to specify bind variables. For example, now you can
1234             do this:
1235              
1236             @admins = Users->search("mode & ? <> 0 and created > ?",
1237             undef, undef, undef,
1238             MODE_FLAGS->{admin},
1239             strftime('%Y-%m-%d', localtime)).
1240              
1241             In order to pass bind variables, you must pass order, limit and offset
1242             (give undef if you don't care about them) and add your bind variables
1243             immediately after.
1244              
1245             =cut
1246              
1247             sub search {
1248 0     0 1   my $class = __T(shift);
1249 0           my ($where, $order, $limit, $offset) = @_;
1250 0           splice @_, 0, 4;
1251 0           my $sa = $class->get_sql_abstract;
1252 0           my $cols = $class->_get_columns([ 'P', 'E' ]);
1253 0           my ($sql, @bind) = $sa->select($class->table, $cols, $where, $order, $limit, $offset);
1254 0 0         if (@_) {
1255 0           push @bind, @_;
1256             }
1257 0           my $sth = $class->_run_sql($sql, \@bind);
1258 0           my @ret = ();
1259 0           while (my $row = $sth->fetchrow_arrayref) {
1260 0           my $obj = $class->new;
1261 0           @{$obj->{values}}{@$cols} = @$row;
  0            
1262 0           push @ret, $obj;
1263             }
1264 0 0         return wantarray ? @ret : \@ret;
1265             }
1266              
1267             =head2 C
1268              
1269             retrieve_all() is an alias to search() -- since with no arguments it
1270             fetches all objects.
1271              
1272             =cut
1273              
1274             *retrieve_all = *search;
1275              
1276             =head2 C
1277              
1278             $u->set(first_name => 'Foo',
1279             last_name => 'Bar');
1280             $u->update;
1281              
1282             Saves any modified columns to the database.
1283              
1284             =cut
1285              
1286             sub update {
1287 0     0 1   my $class = shift;
1288 0 0         if (ref $class) {
1289 0           $class->_do_update;
1290             } else {
1291 0           my ($fieldvals, $where) = @_;
1292 0           my $sa = $class->get_sql_abstract;
1293 0           my ($sql, @bind) = $sa->update($class->table, $fieldvals, $where);
1294 0           $class->_run_sql($sql, \@bind);
1295             }
1296             }
1297              
1298             =head2 C
1299              
1300             $u = Users->retrieve('foo');
1301             $u->delete;
1302              
1303             Removes the object's record from the database. Note that the Perl
1304             object remains intact and you can actually revive it (if you're not
1305             losing it) using undelete().
1306              
1307             =cut
1308              
1309             sub delete {
1310 0     0 1   my ($self, $where) = @_;
1311 0           my ($sql, @bind);
1312 0           my $sa = $self->get_sql_abstract;
1313 0 0         if (!defined $where) {
1314             # we're deleting one object
1315 0           ($sql, @bind) = $sa->delete($self->table, $self->_get_pk_where);
1316             } else {
1317             # deleting multiple objects at once
1318 0           ($sql, @bind) = $sa->delete($self->table, $where);
1319             }
1320 0           $self->_run_sql($sql, \@bind);
1321             }
1322              
1323             =head2 C
1324              
1325             $u = Users->retrieve('foo');
1326             $u->delete; # record's gone
1327             $u->undelete; # resurrected
1328              
1329             This function can "ressurect" an object that has been deleted (that
1330             is, it re-INSERT-s the record into the database), provided that you
1331             still have a reference to the object. I'm not sure how useful it is,
1332             but it helped me test the delete() function. :-)
1333              
1334             Other (unuseful) thing you can do with it is manually emulating the
1335             create() function:
1336              
1337             $u = new Users;
1338             $u->{values}{id} = 'foo';
1339             $u->first_name('Foo');
1340             $u->last_name('Bar');
1341             $u->undelete;
1342              
1343             Note we can't call the column accessors, nor use set/get, before we
1344             have a primary key.
1345              
1346             This method is not too useful in itself, but it helps understanding
1347             the internals of DBIx::OO. If you want to read more about this, see
1348             L.
1349              
1350             =cut
1351              
1352             sub undelete {
1353 0     0 1   my ($self) = @_;
1354 0           $self->_apply_defaults;
1355 0           my $sa = $self->get_sql_abstract;
1356 0           my ($sql, @bind) = $sa->insert($self->table, $self->{values});
1357 0           $self->_run_sql($sql, \@bind);
1358 0           $self->{modified} = {};
1359             }
1360              
1361             =head2 C, or C
1362              
1363             $u = Users->retrieve('foo');
1364             $u->first_name(undef);
1365             $u->revert;
1366              
1367             Discards any changes to the object, reverting to the state in the
1368             database. Note this doesn't SELECT new data, it just reverts to
1369             values saved in the C hash. See L for more
1370             info.
1371              
1372             C is an alias to C.
1373              
1374             =cut
1375              
1376             sub revert {
1377 0     0 1   my $self = shift;
1378             # delete @{$self->{values}}{keys %{$self->{modified}}};
1379 0           my $m = $self->{modified};
1380 0           @{$self->{values}}{keys %$m} = values %$m;
  0            
1381 0           $self->{modified} = {};
1382             }
1383              
1384             *discard_changes = \&revert;
1385              
1386             =head2 get_sql_abstract
1387              
1388             Returns the instance of SQL::Abstract::WithLimit (our custom
1389             derivative) suitable for generating SQL. This is cached (will be
1390             created only the first time get_sql_abstract is called).
1391              
1392             =cut
1393              
1394             sub get_sql_abstract {
1395 0     0 1   my $class = shift;
1396 0           my $sa = $class->__dboo_sqlabstract;
1397 0 0         if (!defined $sa) {
1398 0           $sa = SQL::Abstract::WithLimit->new(quote_char => '`', # NOTE: MySQL quote style
1399             name_sep => '.');
1400 0           $class->__dboo_sqlabstract($sa);
1401             }
1402 0           return $sa;
1403             }
1404              
1405             =head2 count
1406              
1407             Returns the result of an SQL COUNT(*) for the specified where clause.
1408             Call this as a package method, for example:
1409              
1410             $number_of_romanians = Users->count({ country => 'RO' });
1411              
1412             The argument is an SQL::Abstract where clause.
1413              
1414             =cut
1415              
1416             sub count {
1417 0     0 1   my $class = shift;
1418 0 0         my $where = ref $_[0] eq 'HASH' ? $_[0] : { @_ };
1419 0           my $sql = 'SELECT COUNT(*) FROM ' . $class->table;
1420 0           ($where, my @bind) = $class->get_sql_abstract->where($where);
1421 0           my $sth = $class->_run_sql($sql.$where, \@bind);
1422 0           return $sth->fetchrow_arrayref->[0];
1423             }
1424              
1425             sub _get_pk_where {
1426 0     0     my ($self) = @_;
1427 0           my $pc = $self->columns('P');
1428 0           my %where = ();
1429 0           @where{@$pc} = @{$self->{values}}{@$pc};
  0            
1430 0           return \%where;
1431             }
1432              
1433             sub _run_sql {
1434 0     0     my ($class, $sql, $bind) = @_;
1435             # {
1436             # ## DEBUG
1437             # no warnings 'uninitialized';
1438             # my @a = map { defined $_ ? $_ : 'NULL' } @$bind;
1439             # print STDERR "\033[1;33mSQL: $sql\nVAL: ", join(", ", @a), "\n\033[0m";
1440             # }
1441 0           my $dbh = $class->get_dbh;
1442 0           my $sth = $dbh->prepare($sql);
1443 0 0         if ($bind) {
1444 0           $sth->execute(@$bind);
1445             } else {
1446 0           $sth->execute();
1447             }
1448 0           return $sth;
1449             }
1450              
1451             sub _do_update {
1452 0     0     my ($self) = @_;
1453 0           my %set = ();
1454 0           my @k = keys %{$self->{modified}};
  0            
1455 0 0         if (@k) {
1456 0           @set{@k} = @{$self->{values}}{@k};
  0            
1457 0           my $where = $self->_get_pk_where;
1458 0           my $sa = $self->get_sql_abstract;
1459 0           my ($sql, @bind) = $sa->update($self->table, \%set, $where);
1460 0           $self->_run_sql($sql, \@bind);
1461 0           $self->{modified} = {};
1462 0           while (my ($k, $v) = each %set) {
1463 0 0         delete $self->{values}{$k}
1464             if ref $v;
1465             }
1466             }
1467             }
1468              
1469             sub _get_columns {
1470 0     0     my ($self, $groups, $exclude) = @_;
1471 0           my $ek;
1472 0 0 0       if (!$groups || @$groups == 0) {
    0          
1473 0           $ek = $self->columns;
1474             } elsif (@$groups == 1) {
1475 0           $ek = $self->columns($groups->[0]);
1476             } else {
1477 0           $ek = [];
1478 0           foreach my $g (@$groups) {
1479 0           my $a = $self->columns($g);
1480 0 0         push @$ek, @{$a}
  0            
1481             if $a;
1482             }
1483             }
1484 0 0 0       if (defined $exclude && %$exclude) {
1485 0           $ek = [ grep { !exists $exclude->{$_} } @$ek ];
  0            
1486             }
1487 0           return $ek;
1488             }
1489              
1490             sub _retrieve_columns {
1491 0     0     my ($self, $groups, $exclude) = @_;
1492 0 0         if (!ref $groups) {
1493 0           $groups = [ $groups ];
1494             }
1495 0   0       my $ek = $self->_get_columns($groups, $exclude || $self->{modified});
1496 0           my $where = $self->_get_pk_where;
1497 0           my $sa = $self->get_sql_abstract;
1498 0           my ($sql, @bind) = $sa->select($self->table, $ek, $where);
1499 0           my $sth = $self->_run_sql($sql, \@bind);
1500 0           my $data = $sth->fetchrow_arrayref;
1501 0           @{$self->{values}}{@$ek} = @$data;
  0            
1502             }
1503              
1504             sub _get_last_id {
1505 0     0     my ($self, $dbh) = @_;
1506             my $id = $dbh->last_insert_id(undef, undef, $self->table, undef)
1507             || $dbh->{mysql_insertid}
1508 0 0 0       || eval { $dbh->func('last_insert_rowid') }
1509             or $self->_croak("Can't get last insert id");
1510 0           return $id;
1511             }
1512              
1513             sub _col_in_group {
1514 0     0     my ($class, $col, $group) = @_;
1515 0           my $h = $class->__dboo_colgroups;
1516 0 0         return if !$h;
1517 0           return $h->{$col} eq $group;
1518             }
1519              
1520             sub _croak {
1521 0     0     Carp::croak(join("\n", @_));
1522             }
1523              
1524             sub _apply_defaults {
1525 0     0     my ($self) = @_;
1526 0           my $class = __T($self);
1527 0           my $def = $class->__dboo_defaults;
1528 0 0 0       if ($def && %$def) {
1529 0           my $val = $self->{values};
1530 0           while (my ($k, $v) = each %$def) {
1531 0 0         if (!exists $val->{$k}) {
1532 0 0         if (ref $v eq 'CODE') {
1533 0           $v = &$v();
1534             }
1535 0           $val->{$k} = $v;
1536             }
1537             }
1538             }
1539             }
1540              
1541             ## thanks Altblue!
1542             sub _to_utf8 {
1543 0     0     my ($str) = @_;
1544 0 0         return $str
1545             if Encode::is_utf8($str);
1546 0           eval {
1547 0           $str = Encode::decode_utf8($str);
1548             };
1549 0 0         if ($@) {
1550 0           $str = Encode::decode('Detect', $str);
1551             }
1552 0           return $str;
1553             }
1554              
1555             =head2 C, C
1556              
1557             Enable or disable foreign key checks in the backend DB server. These
1558             are hard-coded in MySQL syntax for now so be careful not to use them
1559             with other servers. ;-)
1560              
1561             =cut
1562              
1563             sub disable_fk_checks {
1564 0     0 1   my ($pak) = @_;
1565             # XXX: MySQL only for now
1566 0           $pak->get_dbh->do('set foreign_key_checks = 0');
1567             }
1568              
1569             sub enable_fk_checks {
1570 0     0 1   my ($pak) = @_;
1571             # XXX: MySQL only for now
1572 0           $pak->get_dbh->do('set foreign_key_checks = 1');
1573             }
1574              
1575             sub DESTROY {
1576 0     0     my $self = shift;
1577 0           my @a = keys %{$self->{modified}};
  0            
1578 0 0         if (@a) {
1579 0           my @id = $self->id;
1580 0           warn("Destroying ", ref $self, " with ID: ", join(':', @id), ' having uncomitted data: ', join(':', @a));
1581             }
1582             }
1583              
1584             ## database autocreate/update facility
1585              
1586             =head2 C
1587              
1588             You can use this facility to automatically create / upgrade your
1589             database. It takes a very simple (rudimentary even) approach, but we
1590             found it to be useful. Here's the "big" idea.
1591              
1592             package MyDB::Users;
1593             use base 'MyDB';
1594              
1595             __PACKAGE__->table('Users');
1596             __PACKAGE__->columns(P => [ 'id' ],
1597             E => [qw/ first_name last_name /]);
1598              
1599              
1600             sub get_autocreate_data {q{
1601             #### (users:0) ####
1602              
1603             CREATE TABLE Users ( id VARCHAR(32) NOT NULL PRIMARY KEY,
1604             first_name VARCHAR(64),
1605             last_name VARCHAR(64) );
1606              
1607             # you can put Perl comments too.
1608              
1609             CREATE INDEX idx_Users_first_name ON Users(first_name)
1610             }}
1611              
1612             OK, now you can write this make_database.pl script:
1613              
1614             /usr/bin/perl -w
1615              
1616             use MyDB;
1617             MyDB->autocreate(qw( MyDB::Users ));
1618              
1619             When you run this script the first time, it will create the Users
1620             table. (An internal _dbix_oo_versions table gets created as well;
1621             we're using it inside DBIx::OO in order to keep track of existing
1622             table versions). Note that if you run it again, it doesn't do
1623             anything--the database is up to date.
1624              
1625             Later. You sold a billion copies of your software, customers are
1626             happy but they are crying loud for an "email" field in their user
1627             profiles, also wondering what was your idea to index on first_name and
1628             not on last_name! In order to make it easy for them to upgrade their
1629             databases, you need to modify MyDB::Users. Besides declaring the
1630             'email' column using __PACKAGE__->columns, B the following to
1631             your get_autocreate_data section:
1632              
1633             #### (users:1) ####
1634              
1635             # (note that we incremented the version number)
1636              
1637             # add the 'email' field
1638             ALTER TABLE Users ADD (email VARCHAR(128));
1639              
1640             # index it
1641             CREATE UNIQUE INDEX idx_Users_email ON Users(email);
1642              
1643             # and add that last_name index
1644             CREATE INDEX idx_Users_last_name ON Users(last_name);
1645              
1646             Now you can just tell your users to run make_database.pl again and
1647             everything gets updated.
1648              
1649             The #### (foo:N) #### syntax is meant simply to declare an ID and a
1650             version number. "foo" can be anything you want -- it doesn't have to
1651             be the table name. You can actually create multiple tables, if you
1652             need to.
1653              
1654             =cut
1655              
1656             sub autocreate {
1657 0     0 1   my ($class, @packages) = @_;
1658 0           $class->disable_fk_checks;
1659 0           $class->transaction_start;
1660 0           eval {
1661 2     2   230262 use Module::Load qw( load );
  2         2904  
  2         12  
1662              
1663             # make sure _dbix_oo_versions gets created first
1664 0           my @sql_lines = split(/^/m, get_autocreate_data());
1665 0           $class->__do_autocreate(@sql_lines);
1666              
1667             # autocreate other packages that were passed
1668 0           foreach my $pak (@packages) {
1669 0           load $pak;
1670 0           @sql_lines = split(/^/m, $pak->get_autocreate_data());
1671 0           $class->__do_autocreate(@sql_lines);
1672             }
1673             };
1674 0 0         if ($@) {
1675 0           $class->transaction_rollback;
1676 0           print STDERR "\033[1;31m- There was a problem auto-creating or upgrading tables, can't continue -\033[0m\n";
1677 0           die $@;
1678             } else {
1679 0           $class->transaction_commit;
1680             }
1681 0           foreach my $pak (@packages) {
1682 0           $pak->autopopulate;
1683             }
1684 0           $class->enable_fk_checks;
1685             }
1686              
1687             =head2 autopopulate
1688              
1689             This is supposed to initialize tables. Untested and may not work --
1690             don't use it.
1691              
1692             =cut
1693              
1694 0     0 1   sub autopopulate {}
1695              
1696             =head2 get_autocreate_data
1697              
1698             See the documentation of L.
1699              
1700             =cut
1701              
1702 0     0 1   sub get_autocreate_data {q{
1703             #### (_dbix_oo_versions:0) ####
1704              
1705             CREATE TABLE _dbix_oo_versions ( TB_name VARCHAR(255) PRIMARY KEY,
1706             TB_version INTEGER );
1707             }}
1708              
1709             my $AUTOCREATE_LINE_RE = qr/^\s*####\s*\(([a-z0-9_-]+):([0-9]+)\)\s*####\s*$/i;
1710             # my $AUTOCREATE_SPLIT_SQLS = qr/^\s*##\s*$/m;
1711             my $AUTOCREATE_SPLIT_SQLS = qr/;\s*$/m;
1712             my $AUTOCREATE_TABLES_TABLE = '_dbix_oo_versions';
1713              
1714             sub __do_autocreate {
1715 0     0     my ($class, @lines) = @_;
1716              
1717 0           my $tables = $class->__autocreate_parse_lines(\@lines);
1718              
1719 0           my $dbh = $class->get_dbh;
1720 0           my $sth = $dbh->table_info('', '', $AUTOCREATE_TABLES_TABLE);
1721 0           my $existing_tables = $sth->fetchall_hashref('TABLE_NAME');
1722 0           my $has_version = exists $existing_tables->{$AUTOCREATE_TABLES_TABLE};
1723 0           $sth->finish;
1724              
1725 0           while (my ($t, $versions) = each %$tables) {
1726 0           $class->__autocreate_one_table($t, $versions, $has_version);
1727             }
1728             }
1729              
1730             sub __autocreate_one_table {
1731 0     0     my ($class, $t, $versions, $has_version) = @_;
1732 0           my $dbh = $class->get_dbh;
1733 0           my $cv = -1;
1734 0 0         if ($has_version) {
1735 0           my $sql = $dbh->prepare("SELECT TB_version FROM $AUTOCREATE_TABLES_TABLE WHERE TB_name = ?");
1736 0           $sql->execute($t);
1737 0           ($cv) = $sql->fetchrow_array;
1738 0           $sql->finish;
1739 0 0         if (!defined $cv) {
1740 0           $cv = -1;
1741 0           $sql = $dbh->prepare("INSERT INTO $AUTOCREATE_TABLES_TABLE (TB_name, TB_version) VALUES (?, ?)");
1742 0           $sql->execute($t, $cv);
1743 0           $sql->finish;
1744             }
1745             }
1746 0           my $sql_insert = $dbh->prepare("INSERT INTO $AUTOCREATE_TABLES_TABLE (TB_name, TB_version) VALUES (?, ?)");
1747 0           my $sql_delete = $dbh->prepare("DELETE FROM $AUTOCREATE_TABLES_TABLE WHERE TB_name = ?");
1748 0           foreach my $v (sort keys %$versions) {
1749 0 0         if ($v > $cv) {
1750             # print STDERR "$versions->{$v}\n";
1751 0           my @statements = split($AUTOCREATE_SPLIT_SQLS, $versions->{$v});
1752 0           foreach my $sql (@statements) {
1753 0           $sql =~ s/#.*$//mg;
1754 0           $sql =~ s/^\s+//;
1755 0           $sql =~ s/\s+$//;
1756 0           $sql =~ s/,\s*\)/)/g;
1757 0 0         if ($sql) {
1758             # print STDERR " $sql\n";
1759 0           my $n = index($sql, "\n");
1760 0           print STDERR "... $t: " . substr($sql, 0, $n) . "\n";
1761 0           $dbh->do($sql);
1762             }
1763             }
1764 0           $sql_delete->execute($t);
1765 0           $sql_insert->execute($t, $v);
1766             }
1767             }
1768 0           $sql_insert->finish;
1769 0           $sql_delete->finish;
1770             }
1771              
1772             sub __autocreate_parse_lines {
1773 0     0     my ($class, $lines) = @_;
1774 0           my ($h, $ct, $cv, $cs) = ({}, undef, undef, undef);
1775             my $doit = sub {
1776 0 0   0     if (defined $ct) {
1777 0   0       $h->{$ct} ||= {};
1778 0           $cs =~ s/^\s+//;
1779 0           $cs =~ s/\s+$//;
1780 0           $h->{$ct}{$cv} = $cs;
1781             }
1782 0           };
1783 0           foreach my $i (@$lines) {
1784 0 0         if ($i =~ $AUTOCREATE_LINE_RE) {
    0          
1785 0           &$doit;
1786 0           $ct = $1;
1787 0           $cv = $2;
1788 0           $cs = '';
1789             } elsif (defined $ct) {
1790 0           $cs .= $i;
1791             }
1792             }
1793 0           &$doit;
1794             # print STDERR Data::Dumper::Dumper($h);
1795 0           return $h;
1796             }
1797              
1798             =head1 CAVEATS
1799              
1800             There are a number of problems you might encounter, mostly related to
1801             the fact that we don't cache objects.
1802              
1803             =head2 Concurrent objects
1804              
1805             $u1 = Users->retrieve('foo');
1806             $u2 = Users->retrieve('foo');
1807              
1808             C<$u1> and C<$u2> now point to different objects, but both point to
1809             the same record in the database. Now the problem:
1810              
1811             $u1->first_name('Foo');
1812             $u2->first_name('Bar');
1813             $u1->update;
1814              
1815             Which one gets set? 'Foo', but $u2 has uncommitted changes. When you
1816             further say $u2->update, it will set the name to 'Bar'. If you say
1817             $u2->revert, it will revert to whatever was there I 'Foo'.
1818             This can lead to potential problems.
1819              
1820             Class::DBI (almost) doesn't have this problem (it can appear when you
1821             have multiple processes accessing the database concurrently, such as
1822             httpd processes).
1823              
1824             =head1 UNDER THE HOOD
1825              
1826             A DBIx::OO object is a hash blessed into the DBIx::OO package.
1827             The hash currently contains 2 keys:
1828              
1829             =over
1830              
1831             =item B
1832              
1833             A hash containing the field => value pairs that are currently
1834             retrieved from the database.
1835              
1836             =item B
1837              
1838             Another hash that maps field_name => 'original value' for the fields
1839             that were modified and not yet committed of the current object.
1840              
1841             =back
1842              
1843             If a field is not present in B and is requested with get(),
1844             then the database will be queried for it and for all other fields that
1845             aren't present in "values" but are listed in the Bssential group.
1846              
1847             If a field is present in B, then it will be saved in the DB
1848             on the next update() call. An object can discard these operations
1849             with the discard() method. Discard restores the values using those
1850             stored in the C hash.
1851              
1852             Each operation plays around these hashes. For instance, when you call
1853             search(), a single SQL will run and then we'll iterate over the
1854             results, create objects and assign the SELECT-ed values to the
1855             B hash.
1856              
1857             A retrieve() operation creates a new object and assign the passed
1858             value to its primary key, then it will call the internal
1859             _retrieve_columns([ 'P', 'E' ]) function in order to fetch essential
1860             object data from the DB. Note that a call to _retrieve_columns is not
1861             actually necessary, since it will happen anyway the first time you
1862             want to retrieve a field that doesn't exist in B -- but it's
1863             good to call it because retrieve() should return B if the
1864             object can't be found in the DB.
1865              
1866             =head1 BUGS
1867              
1868             Yeah, the documentation sucks. Other bugs?
1869              
1870             =head1 SEE ALSO
1871              
1872             L, L, L
1873              
1874             =head1 AUTHOR
1875              
1876             Mihai Bazon,
1877             http://www.dynarch.com/
1878             http://www.bazon.net/mishoo/
1879              
1880             =head1 COPYRIGHT
1881              
1882             Copyright (c) Mihai Bazon 2006. All rights reserved.
1883              
1884             This module is free software; you can redistribute it and/or modify it
1885             under the same terms as Perl itself.
1886              
1887             =head1 THANKS
1888              
1889             I'd like to thank irc.n0i.net -- our small but wonderful community
1890             that's always there when you need it.
1891              
1892             =head1 DISCLAIMER OF WARRANTY
1893              
1894             BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
1895             FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT
1896             WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER
1897             PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND,
1898             EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
1899             IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
1900             PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
1901             SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME
1902             THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
1903              
1904             IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
1905             WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
1906             REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE
1907             TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR
1908             CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
1909             SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
1910             RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
1911             FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
1912             SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
1913             DAMAGES.
1914              
1915             =cut
1916              
1917              
1918              
1919              
1920              
1921              
1922              
1923             package SQL::Abstract::WithLimit;
1924 2     2   2564 use base 'SQL::Abstract';
  2         5  
  2         1066  
1925              
1926             ### MySQL and Postgres syntax; Buzz off for others. :-p
1927             sub select {
1928 0     0     my ($self, $table, $cols, $where, $order, $limit, $offset) = @_;
1929 0           my ($sql, @bind) = $self->SUPER::select($table, $cols, $where, $order);
1930 0           $sql .= $self->order_and_limit(undef, $limit, $offset);
1931 0 0         return wantarray ? ($sql, @bind) : $sql;
1932             }
1933              
1934             sub _order_by {
1935 0     0     my $self = shift;
1936 0           my $ref = ref $_[0];
1937              
1938 0           my @vals = $ref eq 'ARRAY' ? @{$_[0]} :
  0            
1939 0 0         $ref eq 'SCALAR' ? ${$_[0]} :
    0          
    0          
1940             $ref eq '' ? $_[0] :
1941             SQL::Abstract::puke("Unsupported data struct $ref for ORDER BY");
1942              
1943 0 0         my $val = join ', ', map {
1944 0           s/^\^// ?
1945             $self->_quote($_) . $self->_sqlcase(' desc')
1946             : $self->_quote($_)
1947             } @vals;
1948 0 0         return $val ? $self->_sqlcase(' order by')." $val" : '';
1949             }
1950              
1951             sub order_and_limit {
1952 0     0     my ($self, $order, $limit, $offset) = @_;
1953 0 0         my $q = $order ? $self->_order_by($order) : '';
1954 0 0         $q .= " LIMIT $limit"
1955             if defined $limit;
1956 0 0         $q .= " OFFSET $offset"
1957             if defined $offset;
1958 0           return $q;
1959             }
1960              
1961             *quote_field = \&SQL::Abstract::_quote;