File Coverage

blib/lib/Jifty/DBI/Handle.pm
Criterion Covered Total %
statement 339 486 69.7
branch 82 164 50.0
condition 41 89 46.0
subroutine 41 57 71.9
pod 41 41 100.0
total 544 837 64.9


line stmt bran cond sub pod time code
1             package Jifty::DBI::Handle;
2 36     36   2493086 use strict;
  36         96  
  36         1559  
3 36     36   203 use Carp ();
  36         74  
  36         560  
4 36     36   370414 use DBI ();
  36         983406  
  36         2088  
5 36     36   37119 use Class::ReturnValue ();
  36         814489  
  36         918  
6 36     36   39227 use Encode ();
  36         492271  
  36         1087  
7              
8 36     36   326 use base qw/Jifty::DBI::HasFilters/;
  36         73  
  36         25157  
9              
10 36     36   326 use vars qw(%DBIHandle $PrevHandle $DEBUG $TRANSDEPTH);
  36         68  
  36         92829  
11              
12             $TRANSDEPTH = 0;
13              
14             our $VERSION = '0.01';
15              
16             if ( my $pattern = $ENV{JIFTY_DBQUERY_CALLER} ) {
17             require Hook::LexWrap;
18             Hook::LexWrap::wrap(
19             'Jifty::DBI::Handle::simple_query',
20             pre => sub {
21             return unless $_[1] =~ m/$pattern/;
22             Carp::cluck($_[1] . ' ' . CORE::join( ',', @_[ 2 .. $#_ ] ));
23             }
24             );
25             }
26              
27             =head1 NAME
28              
29             Jifty::DBI::Handle - Perl extension which is a generic DBI handle
30              
31             =head1 SYNOPSIS
32              
33             use Jifty::DBI::Handle;
34              
35             my $handle = Jifty::DBI::Handle->new();
36             $handle->connect( driver => 'mysql',
37             database => 'dbname',
38             host => 'hostname',
39             user => 'dbuser',
40             password => 'dbpassword');
41             # now $handle isa Jifty::DBI::Handle::mysql
42              
43             =head1 DESCRIPTION
44              
45             This class provides a wrapper for DBI handles that can also perform a
46             number of additional functions.
47              
48             =cut
49              
50             =head2 new
51              
52             Generic constructor
53              
54             =cut
55              
56             sub new {
57 32     32 1 2878 my $proto = shift;
58 32   33     497 my $class = ref($proto) || $proto;
59 32         98 my $self = {};
60 32         119 bless( $self, $class );
61              
62 32         264 @{ $self->{'StatementLog'} } = ();
  32         722  
63 32         134 return $self;
64             }
65              
66             =head2 connect PARAMHASH
67              
68             Takes a paramhash and connects to your DBI datasource, with the keys C,
69             C, C, C and C.
70              
71             If you created the handle with
72             Jifty::DBI::Handle->new
73             and there is a Jifty::DBI::Handle::(Driver) subclass for the driver you have chosen,
74             the handle will be automatically "upgraded" into that subclass.
75              
76             If there is an error, an exception will be thrown. If a connection has already
77             been established and is still active, C will be returned (which is not
78             an error). Otherwise, if a new connection is made, a true value will be returned.
79              
80             =cut
81              
82             sub connect {
83 32     32 1 506570 my $self = shift;
84              
85 32         439 my %args = (
86             driver => undef,
87             database => undef,
88             host => undef,
89             sid => undef,
90             port => undef,
91             user => undef,
92             password => undef,
93             requiressl => undef,
94             extra => {},
95             @_
96             );
97              
98 32 100 66     920 if ( $args{'driver'}
99             && !$self->isa( 'Jifty::DBI::Handle::' . $args{'driver'} ) )
100             {
101 1 50       6 if ( $self->_upgrade_handle( $args{'driver'} ) ) {
102 1         14 return ( $self->connect(%args) );
103             }
104             }
105              
106 31   50     878 my $dsn = $self->dsn || '';
107              
108             # Setting this actually breaks old RT versions in subtle ways. So we need to explicitly call it
109              
110 31         411 $self->build_dsn(%args);
111              
112             # Only connect if we're not connected to this source already
113 31 50 33     278 if ( ( !$self->dbh ) || ( !$self->dbh->ping ) || ( $self->dsn ne $dsn ) )
      33        
114             {
115 31   33     137 my $handle
116             = DBI->connect( $self->dsn, $args{'user'}, $args{'password'}, $args{'extra'} )
117             || Carp::croak "Connection failed: $DBI::errstr\n";
118              
119             #databases do case conversion on the name of columns returned.
120             #actually, some databases just ignore case. this smashes it to something consistent
121 31         64610 $handle->{FetchHashKeyName} = 'NAME_lc';
122              
123             #Set the handle
124 31         1027 $self->dbh($handle);
125              
126 31         234 return (1);
127             }
128              
129 0         0 return (undef);
130              
131             }
132              
133             =head2 _upgrade_handle DRIVER
134              
135             This private internal method turns a plain Jifty::DBI::Handle into one
136             of the standard driver-specific subclasses.
137              
138             =cut
139              
140             sub _upgrade_handle {
141 1     1   2 my $self = shift;
142              
143 1         2 my $driver = shift;
144 1         3 my $class = 'Jifty::DBI::Handle::' . $driver;
145              
146 1         2 local $@;
147 1         84 eval "require $class";
148 1 50       7 return if $@;
149              
150 1         4 bless $self, $class;
151 1         5 return 1;
152             }
153              
154             =head2 build_dsn PARAMHASH
155              
156             Builds a dsn suitable for handing to DBI->connect.
157              
158             Mandatory arguments:
159              
160             =over
161              
162             =item driver
163              
164             =item database
165              
166             =back
167              
168             Optional arguments:
169              
170             =over
171              
172             =item host
173              
174             =item port
175              
176             =item sid
177              
178             =item requiressl
179              
180             =item and anything else your DBD lets you pass in
181              
182             =back
183              
184             =cut
185              
186             sub build_dsn {
187 31     31 1 87 my $self = shift;
188 31         336 my %args = (
189             driver => undef,
190             database => undef,
191             host => undef,
192             port => undef,
193             sid => undef,
194             requiressl => undef,
195             @_
196             );
197              
198 31         106 my $driver = delete $args{'driver'};
199 31   33     290 $args{'dbname'} ||= delete $args{'database'};
200              
201 31         71 delete $args{'user'};
202 31         82 delete $args{'password'};
203 31         77 delete $args{'extra'};
204              
205 31         319 $self->{'dsn'} = "dbi:$driver:"
206             . CORE::join( ';',
207 31         172 map { $_ . "=" . $args{$_} } grep { defined $args{$_} } keys %args );
  155         360  
208             }
209              
210             =head2 dsn
211              
212             Returns the dsn for this database connection.
213              
214             =cut
215              
216             sub dsn {
217 97     97 1 176 my $self = shift;
218 97         966 return ( $self->{'dsn'} );
219             }
220              
221             =head2 raise_error [MODE]
222              
223             Turns on the Database Handle's RaiseError attribute.
224              
225             =cut
226              
227             sub raise_error {
228 0     0 1 0 my $self = shift;
229 0 0       0 $self->dbh->{RaiseError} = shift if (@_);
230 0         0 return $self->dbh->{RaiseError};
231             }
232              
233             =head2 print_error [MODE]
234              
235             Turns on the Database Handle's PrintError attribute.
236              
237             =cut
238              
239             sub print_error {
240 0     0 1 0 my $self = shift;
241 0 0       0 $self->dbh->{PrintError} = shift if (@_);
242 0         0 return $self->dbh->{PrintError};
243             }
244              
245             =head2 log MESSAGE
246              
247             Takes a single argument, a message to log.
248              
249             Currently prints that message to STDERR
250              
251             =cut
252              
253             sub log {
254 0     0 1 0 my $self = shift;
255 0         0 my $msg = shift;
256 0         0 warn $msg . "\n";
257              
258             }
259              
260             =head2 log_sql_statements BOOL
261              
262             Takes a boolean argument. If the boolean is true, it will log all SQL
263             statements, as well as their invocation times and execution times.
264              
265             Returns whether we're currently logging or not as a boolean
266              
267             =cut
268              
269             sub log_sql_statements {
270 997     997 1 3046 my $self = shift;
271 997 100       3514 if (@_) {
272 1         2117 require Time::HiRes;
273 1         3231 $self->{'_dologsql'} = shift;
274             }
275 997         4878 return ( $self->{'_dologsql'} );
276             }
277              
278             =head2 log_sql_hook NAME [, CODE]
279              
280             Used in instrumenting the SQL logging. You can use this to, for example, get a
281             stack trace for each query (so you can find out where the query is being made).
282             The name is required so that multiple hooks can be installed, and inspected, by
283             name.
284              
285             The coderef is run in scalar context and (currently) receives no arguments.
286              
287             If you don't pass CODE in, then the coderef currently assigned under
288             NAME is returned.
289              
290             =cut
291              
292             sub log_sql_hook {
293 0     0 1 0 my $self = shift;
294 0         0 my $name = shift;
295              
296 0 0       0 if (@_) {
297 0         0 $self->{'_logsqlhooks'}{$name} = shift;
298             }
299 0         0 return ( $self->{'_logsqlhooks'}{$name} );
300             }
301              
302             =head2 _log_sql_statement STATEMENT DURATION BINDINGS
303              
304             add an SQL statement to our query log
305              
306             =cut
307              
308             sub _log_sql_statement {
309 6     6   9 my $self = shift;
310 6         11 my $statement = shift;
311 6         12 my $duration = shift;
312 6         16 my @bind = @_;
313              
314 6         7 my %results;
315 6         41 my @log = (Time::HiRes::time(), $statement, [@bind], $duration, \%results);
316              
317 6 50       11 while (my ($name, $code) = each %{ $self->{'_logsqlhooks'} || {} }) {
  6         56  
318 0         0 $results{$name} = $code->(@log);
319             }
320              
321 6         14 push @{ $self->{'StatementLog'} }, \@log;
  6         28  
322             }
323              
324             =head2 clear_sql_statement_log
325              
326             Clears out the SQL statement log.
327              
328             =cut
329              
330             sub clear_sql_statement_log {
331 6     6 1 1809 my $self = shift;
332 6         13 @{ $self->{'StatementLog'} } = ();
  6         33  
333             }
334              
335             =head2 sql_statement_log
336              
337             Returns the current SQL statement log as an array of arrays. Each entry is a list of:
338              
339             (Time, Statement, [Bindings], Duration, {HookResults})
340              
341             Bindings is an arrayref of the values of any placeholders. HookResults is a
342             hashref keyed by hook name.
343              
344             =cut
345              
346             sub sql_statement_log {
347 6     6 1 2045 my $self = shift;
348 6         13 return ( @{ $self->{'StatementLog'} } );
  6         36  
349              
350             }
351              
352             =head2 auto_commit [MODE]
353              
354             Turns on the Database Handle's Autocommit attribute.
355              
356             =cut
357              
358             sub auto_commit {
359 0     0 1 0 my $self = shift;
360              
361 0         0 my $mode = 1;
362 0 0       0 $mode = shift if (@_);
363              
364 0         0 $self->dbh->{AutoCommit} = $mode;
365             }
366              
367             =head2 disconnect
368              
369             disconnect from your DBI datasource
370              
371             =cut
372              
373             sub disconnect {
374 57     57 1 14504 my $self = shift;
375 57 100       538 if ( $self->dbh ) {
376 56         1289 return ( $self->dbh->disconnect() );
377             } else {
378 1         3 return;
379             }
380             }
381              
382             =head2 dbh [HANDLE]
383              
384             Return the current DBI handle. If we're handed a parameter, make the database handle that.
385              
386             =cut
387              
388             sub dbh {
389 1253     1253 1 3726 my $self = shift;
390              
391             #If we are setting the database handle, set it.
392 1253 100       6412 $DBIHandle{$self} = $PrevHandle = shift if (@_);
393              
394 1253   66     38282 return ( $DBIHandle{$self} ||= $PrevHandle );
395             }
396              
397             =head2 delete $table_NAME @KEY_VALUE_PAIRS
398              
399             Takes a table name and a set of key-value pairs in an array. splits the key value pairs, constructs an DELETE statement and performs the delete. Returns the row_id of this row.
400              
401             =cut
402              
403             sub delete {
404 3     3 1 9 my ( $self, $table, @pairs ) = @_;
405              
406 3         7 my @bind = ();
407 3         18 my $where = 'WHERE ';
408 3         53 while ( my $key = shift @pairs ) {
409 3         11 $where .= $key . "=?" . " AND ";
410 3         13 push( @bind, shift(@pairs) );
411             }
412              
413 3         19 $where =~ s/AND $//;
414 3         11 my $query_string = "DELETE FROM " . $table . ' ' . $where;
415 3         14 $self->simple_query( $query_string, @bind );
416             }
417              
418             =head2 insert $table_NAME @KEY_VALUE_PAIRS
419              
420             Takes a table name and a set of key-value pairs in an array. splits the key value pairs, constructs an INSERT statement and performs the insert. Returns the row_id of this row.
421              
422             =cut
423              
424             sub insert {
425 104     104 1 819 my ( $self, $table, @pairs ) = @_;
426 104         199 my ( @cols, @vals, @bind );
427              
428             #my %seen; #only the *first* value is used - allows drivers to specify default
429 104         654 while ( my $key = shift @pairs ) {
430 345         528 my $value = shift @pairs;
431              
432             # next if $seen{$key}++;
433 345         570 push @cols, $key;
434 345         7737 push @vals, '?';
435 345         1375 push @bind, $value;
436             }
437              
438 104         937 my $query_string
439             = "INSERT INTO $table ("
440             . CORE::join( ", ", @cols )
441             . ") VALUES " . "("
442             . CORE::join( ", ", @vals ) . ")";
443              
444 104         624 my $sth = $self->simple_query( $query_string, @bind );
445 104         1479 return ($sth);
446             }
447              
448             =head2 update_record_value
449              
450             Takes a hash with columns: C, C, C, C, and
451             C. The first two should be obvious; C is where you
452             set the new value you want the column to have. The C column should
453             be the lvalue of Jifty::DBI::Record::PrimaryKeys(). Finally ,
454             C is set when the Value is a SQL function. For example, you
455             might have C<< value => 'PASSWORD(string)' >>, by setting C to true,
456             that string will be inserted into the query directly rather then as a binding.
457              
458             =cut
459              
460             sub update_record_value {
461 56     56 1 124 my $self = shift;
462 56         476 my %args = (
463             table => undef,
464             column => undef,
465             is_sql_function => undef,
466             primary_keys => undef,
467             @_
468             );
469              
470 56 50       246 return 1 unless grep {defined} values %{ $args{primary_keys} };
  56         260  
  56         230  
471              
472 56         144 my @bind = ();
473 56         226 my $query = 'UPDATE ' . $args{'table'} . ' ';
474 56         180 $query .= 'SET ' . $args{'column'} . '=';
475              
476             ## Look and see if the column is being updated via a SQL function.
477 56 50       186 if ( $args{'is_sql_function'} ) {
478 0         0 $query .= $args{'value'} . ' ';
479             } else {
480 56         123 $query .= '? ';
481 56         140 push( @bind, $args{'value'} );
482             }
483              
484             ## Constructs the where clause.
485 56         113 my $where = 'WHERE ';
486 56         113 foreach my $key ( keys %{ $args{'primary_keys'} } ) {
  56         197  
487 56         135 $where .= $key . "=?" . " AND ";
488 56         263 push( @bind, $args{'primary_keys'}{$key} );
489             }
490 56         381 $where =~ s/AND\s$//;
491              
492 56         933 my $query_str = $query . $where;
493 56         258 return ( $self->simple_query( $query_str, @bind ) );
494             }
495              
496             =head2 update_table_value table COLUMN NEW_value RECORD_ID IS_SQL
497              
498             Update column COLUMN of table table where the record id = RECORD_ID.
499              
500             If IS_SQL is set, don't quote the NEW_VALUE.
501              
502             =cut
503              
504             sub update_table_value {
505 0     0 1 0 my $self = shift;
506              
507             ## This is just a wrapper to update_record_value().
508 0         0 my %args = ();
509 0         0 $args{'table'} = shift;
510 0         0 $args{'column'} = shift;
511 0         0 $args{'value'} = shift;
512 0         0 $args{'primary_keys'} = shift;
513 0         0 $args{'is_sql_function'} = shift;
514              
515 0         0 return $self->update_record_value(%args);
516             }
517              
518             =head2 simple_query QUERY_STRING, [ BIND_VALUE, ... ]
519              
520             Execute the SQL string specified in QUERY_STRING
521              
522             =cut
523              
524             our $retry_simple_query = 1;
525             sub simple_query {
526 501     501 1 30763 my $self = shift;
527 501         1017 my $query_string = shift;
528 501         839 my @bind_values;
529 501 100       2364 @bind_values = (@_) if (@_);
530              
531 501         1798 my $sth = $self->dbh->prepare($query_string);
532 501 100       93309 unless ($sth) {
533 3         25 my $message = "$self couldn't prepare the query '$query_string': "
534             . $self->dbh->errstr;
535 3 50       19 if ($DEBUG) {
536 0         0 die "$message\n";
537             } else {
538 3         21 warn "$message\n";
539 3         47 my $ret = Class::ReturnValue->new();
540 3         36 $ret->as_error(
541             errno => '-1',
542             message => $message,
543             do_backtrace => undef
544             );
545 3         231 return ( $ret->return_value );
546             }
547             }
548              
549             # Check @bind_values for HASH refs
550 498         2154 for ( my $bind_idx = 0; $bind_idx < scalar @bind_values; $bind_idx++ ) {
551 592 100       2011 if ( ref( $bind_values[$bind_idx] ) eq "HASH" ) {
552 13         34 my $bhash = $bind_values[$bind_idx];
553 13         40 $bind_values[$bind_idx] = $bhash->{'value'};
554 13         110 delete $bhash->{'value'};
555 13         131 $sth->bind_param( $bind_idx + 1, undef, $bhash );
556             }
557              
558             # Some databases, such as Oracle fail to cope if it's a perl utf8
559             # string. they desperately want bytes.
560 592         2966 Encode::_utf8_off( $bind_values[$bind_idx] );
561             }
562              
563 498         1077 my $basetime;
564 498 100       2022 if ( $self->log_sql_statements ) {
565 6         161 $basetime = Time::HiRes::time();
566             }
567 498         880 my $executed;
568              
569 498         761 local $@;
570             {
571 36     36   344 no warnings 'uninitialized'; # undef in bind_values makes DBI sad
  36         91  
  36         771679  
  498         808  
572 498         998 eval { $executed = $sth->execute(@bind_values) };
  498         36164386  
573              
574             # try to ping and reconnect, if the DB connection failed
575 498 50 66     6650 if (($@ or not $executed) and !$self->dbh->ping) {
      66        
576 0         0 $self->dbh(undef); # don't try pinging again, just connect
577 0         0 $self->connect;
578              
579             # Need to call ourselves, to create a new sth from the new dbh
580 0 0       0 if ($retry_simple_query) {
581 0         0 local $retry_simple_query = 0;
582 0         0 return $self->simple_query($query_string, @_);
583             }
584             }
585             }
586 498 100       3463 if ( $self->log_sql_statements ) {
587 6         46 $self->_log_sql_statement( $query_string,
588             Time::HiRes::time() - $basetime, @bind_values );
589              
590             }
591              
592 498 100 66     6705 if ( $@ or !$executed ) {
593 1   33     8 my $message = "$self couldn't execute the query '$query_string': "
594             . ($self->dbh->errstr || $@);
595              
596 1 50       5 if ($DEBUG) {
597 0         0 die "$message\n";
598             } else {
599              
600             # XXX: This warn doesn't show up because we mask logging in Jifty::Test::END.
601             # and it usually fails because the test server is still running.
602 1         6 warn "$message\n";
603              
604 1         9 my $ret = Class::ReturnValue->new();
605 1         9 $ret->as_error(
606             errno => '-1',
607             message => $message,
608             do_backtrace => undef
609             );
610 1         18 return ( $ret->return_value );
611             }
612              
613             }
614 497         4515 return ($sth);
615              
616             }
617              
618             =head2 fetch_result QUERY, [ BIND_VALUE, ... ]
619              
620             Takes a SELECT query as a string, along with an array of BIND_VALUEs
621             If the select succeeds, returns the first row as an array.
622             Otherwise, returns a Class::ResturnValue object with the failure loaded
623             up.
624              
625             =cut
626              
627             sub fetch_result {
628 1     1 1 3 my $self = shift;
629 1         3 my $query = shift;
630 1         25 my @bind_values = @_;
631 1         5 my $sth = $self->simple_query( $query, @bind_values );
632 1 50       6 if ($sth) {
633 1         35 return ( $sth->fetchrow );
634             } else {
635 0         0 return ($sth);
636             }
637             }
638              
639             =head2 blob_params COLUMN_NAME COLUMN_TYPE
640              
641             Returns a hash ref for the bind_param call to identify BLOB types used
642             by the current database for a particular column type.
643              
644             =cut
645              
646             sub blob_params {
647 13     13 1 155 my $self = shift;
648              
649             # Don't assign to key 'value' as it is defined later.
650 13         51 return ( {} );
651             }
652              
653             =head2 database_version
654              
655             Returns the database's version.
656              
657             If argument C is true returns short variant, in other
658             case returns whatever database handle/driver returns. By default
659             returns short version, e.g. C<4.1.23> or C<8.0-rc4>.
660              
661             Returns empty string on error or if database couldn't return version.
662              
663             The base implementation uses a C
664              
665             =cut
666              
667             sub database_version {
668 0     0 1 0 my $self = shift;
669 0         0 my %args = ( short => 1, @_ );
670              
671 0 0       0 unless ( defined $self->{'database_version'} ) {
672              
673             # turn off error handling, store old values to restore later
674 0         0 my $re = $self->raise_error;
675 0         0 $self->raise_error(0);
676 0         0 my $pe = $self->print_error;
677 0         0 $self->print_error(0);
678              
679 0         0 my $statement = "SELECT VERSION()";
680 0         0 my $sth = $self->simple_query($statement);
681              
682 0         0 my $ver = '';
683 0 0 0     0 $ver = ( $sth->fetchrow_arrayref->[0] || '' ) if $sth;
684 0         0 $ver =~ /(\d+(?:\.\d+)*(?:-[a-z0-9]+)?)/i;
685 0         0 $self->{'database_version'} = $ver;
686 0   0     0 $self->{'database_version_short'} = $1 || $ver;
687              
688 0         0 $self->raise_error($re);
689 0         0 $self->print_error($pe);
690             }
691              
692 0 0       0 return $self->{'database_version_short'} if $args{'short'};
693 0         0 return $self->{'database_version'};
694             }
695              
696             =head2 case_sensitive
697              
698             Returns 1 if the current database's searches are case sensitive by default
699             Returns undef otherwise
700              
701             =cut
702              
703             sub case_sensitive {
704 0     0 1 0 my $self = shift;
705 0         0 return (1);
706             }
707              
708             =head2 _make_clause_case_insensitive column operator VALUE
709              
710             Takes a column, operator and value. performs the magic necessary to make
711             your database treat this clause as case insensitive.
712              
713             Returns a column operator value triple.
714              
715             =cut
716              
717             sub _case_insensitivity_valid {
718 88     88   160 my $self = shift;
719 88         137 my $column = shift;
720 88         136 my $operator = shift;
721 88         127 my $value = shift;
722              
723 88   100     1770 return $value ne ''
724             && $value ne "''"
725             && ( $operator =~ /^(?:(?:NOT )?LIKE|!?=|IN)$/i )
726              
727             # don't downcase integer values
728             && $value !~ /^['"]?\d+['"]?$/;
729             }
730              
731             sub _make_clause_case_insensitive {
732 0     0   0 my $self = shift;
733 0         0 my $column = shift;
734 0         0 my $operator = shift;
735 0         0 my $value = shift;
736              
737 0 0       0 if ( $self->_case_insensitivity_valid( $column, $operator, $value ) ) {
738 0         0 $column = "lower($column)";
739 0 0       0 if ( ref $value eq 'ARRAY' ) {
740 0         0 map { $_ = "lower($_)" } @{$value};
  0         0  
  0         0  
741             } else {
742 0         0 $value = "lower($value)";
743             }
744             }
745 0         0 return ( $column, $operator, $value );
746             }
747              
748             =head2 quote_value VALUE
749              
750             Calls the database's L method and returns the result.
751             Additionally, turns on perl's utf8 flag if the returned content is
752             UTF8.
753              
754             =cut
755              
756             sub quote_value {
757 260     260 1 2067 my $self = shift;
758 260         756 my ($value) = @_;
759 260         875 my $tmp = $self->dbh->quote($value);
760              
761             # Accomodate DBI drivers that don't understand UTF8
762 260 50       3344 if ( $] >= 5.007 ) {
763 260         2337 require Encode;
764 260 50       1468 if ( Encode::is_utf8($tmp) ) {
765 0         0 Encode::_utf8_on($tmp);
766             }
767             }
768 260         1554 return $tmp;
769             }
770              
771             =head2 begin_transaction
772              
773             Tells Jifty::DBI to begin a new SQL transaction. This will
774             temporarily suspend Autocommit mode.
775              
776             Emulates nested transactions, by keeping a transaction stack depth.
777              
778             =cut
779              
780             sub begin_transaction {
781 1     1 1 2 my $self = shift;
782              
783 1 50       5 if ( $TRANSDEPTH > 0 ) {
784             # We're inside a transaction.
785 0         0 $TRANSDEPTH++;
786 0         0 return $TRANSDEPTH;
787             }
788              
789 1         5 my $rv = $self->dbh->begin_work;
790 1 50       26 if ($rv) {
791 1         2 $TRANSDEPTH++;
792             }
793 1         2 return $rv;
794             }
795              
796             =head2 commit
797              
798             Tells Jifty::DBI to commit the current SQL transaction.
799             This will turn Autocommit mode back on.
800              
801             =cut
802              
803             sub commit {
804 1     1 1 2 my $self = shift;
805 1 50       3 unless ($TRANSDEPTH) {
806 0         0 Carp::confess(
807             "Attempted to commit a transaction with none in progress");
808             }
809              
810 1 50       4 if ($TRANSDEPTH > 1) {
811             # We're inside a nested transaction.
812 0         0 $TRANSDEPTH--;
813 0         0 return $TRANSDEPTH;
814             }
815              
816 1         3 my $rv = $self->dbh->commit;
817 1 50       19 if ($rv) {
818 1         8 $TRANSDEPTH--;
819             }
820 1         56 return $rv;
821             }
822              
823             =head2 rollback [FORCE]
824              
825             Tells Jifty::DBI to abort the current SQL transaction.
826             This will turn Autocommit mode back on.
827              
828             If this method is passed a true argument, stack depth is blown away and the outermost transaction is rolled back
829              
830             =cut
831              
832             sub rollback {
833 0     0 1 0 my $self = shift;
834 0         0 my $force = shift;
835              
836 0         0 my $dbh = $self->dbh;
837 0 0       0 unless ($dbh) {
838 0         0 $TRANSDEPTH = 0;
839 0         0 return;
840             }
841              
842             #unless ($TRANSDEPTH) {Carp::confess("Attempted to rollback a transaction with none in progress")};
843 0 0       0 if ($force) {
844 0         0 $TRANSDEPTH = 0;
845              
846 0         0 return ( $dbh->rollback );
847             }
848              
849 0 0       0 if ($TRANSDEPTH == 0) {
850             # We're not actually in a transaction.
851 0         0 return 1;
852             }
853              
854 0 0       0 if ($TRANSDEPTH > 1) {
855             # We're inside a nested transaction.
856 0         0 $TRANSDEPTH--;
857 0         0 return $TRANSDEPTH;
858             }
859              
860 0         0 my $rv = $dbh->rollback;
861 0 0       0 if ($rv) {
862 0         0 $TRANSDEPTH--;
863             }
864 0         0 return $rv;
865             }
866              
867             =head2 force_rollback
868              
869             Force the handle to rollback. Whether or not we're deep in nested transactions
870              
871             =cut
872              
873             sub force_rollback {
874 0     0 1 0 my $self = shift;
875 0         0 $self->rollback(1);
876             }
877              
878             =head2 transaction_depth
879              
880             Return the current depth of the faked nested transaction stack.
881              
882             =cut
883              
884             sub transaction_depth {
885 0     0 1 0 my $self = shift;
886 0         0 return ($TRANSDEPTH);
887             }
888              
889             =head2 apply_limits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
890              
891             takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW;
892              
893              
894             =cut
895              
896             sub apply_limits {
897 246     246 1 518 my $self = shift;
898 246         369 my $statementref = shift;
899 246         304 my $per_page = shift;
900 246         342 my $first = shift;
901              
902 246         306 my $limit_clause = '';
903              
904 246 50       546 if ($per_page) {
905 0         0 $limit_clause = " LIMIT ";
906 0 0       0 if ($first) {
907 0         0 $limit_clause .= $first . ", ";
908             }
909 0         0 $limit_clause .= $per_page;
910             }
911              
912 246         749 $$statementref .= $limit_clause;
913              
914             }
915              
916             =head2 join { Paramhash }
917              
918             Takes a paramhash of everything Jifty::DBI::Collection's C method
919             takes, plus a parameter called C that contains a ref to a
920             L object'.
921              
922             This performs the join.
923              
924             =cut
925              
926             sub join {
927              
928 12     12 1 318 my $self = shift;
929 12         120 my %args = (
930             collection => undef,
931             type => 'normal',
932             alias1 => 'main',
933             column1 => undef,
934             table2 => undef,
935             alias2 => undef,
936             column2 => undef,
937             expression => undef,
938             operator => '=',
939             is_distinct => 0,
940             @_
941             );
942              
943 12         21 my $alias;
944              
945             # If we're handed in a table2 as a Collection object, make notes
946             # about if the result of the join is still distinct for the
947             # calling collection
948 12 50 66     111 if ( $args{'table2'}
949             && UNIVERSAL::isa( $args{'table2'}, 'Jifty::DBI::Collection' ) )
950             {
951 0 0       0 my $c = ref $args{'table2'} ? $args{'table2'} : $args{'table2'}->new($args{collection}->_new_collection_args);
952 0 0       0 if ( $args{'operator'} eq '=' ) {
953 0         0 my $x = $c->new_item->column( $args{column2} );
954 0 0 0     0 if ( $x->type eq 'serial' || $x->distinct ) {
955 0         0 $args{'is_distinct'} = 1;
956             }
957             }
958 0         0 $args{'class2'} = ref $c;
959 0         0 $args{'table2'} = $c->table;
960             }
961              
962 12 100       31 if ( $args{'alias2'} ) {
963 3 50 33     39 if ( $args{'collection'}{'joins'}{ $args{alias2} } and lc $args{'collection'}{'joins'}{ $args{alias2} }{type} eq "cross" ) {
964 3         12 my $join = $args{'collection'}{'joins'}{ $args{alias2} };
965 3         9 $args{'table2'} = $join->{table};
966 3         8 $alias = $join->{alias};
967             } else {
968              
969             # if we can't do that, can we reverse the join and have it work?
970 0         0 @args{qw/alias1 alias2/} = @args{qw/alias2 alias1/};
971 0         0 @args{qw/column1 column2/} = @args{qw/column2 column1/};
972              
973 0 0 0     0 if ( $args{'collection'}{'joins'}{ $args{alias2} } and lc $args{'collection'}{'joins'}{ $args{alias2} }{type} eq "cross" ) {
974 0         0 my $join = $args{'collection'}{'joins'}{ $args{alias2} };
975 0         0 $args{'table2'} = $join->{table};
976 0         0 $alias = $join->{alias};
977             } else {
978              
979             # Swap back
980 0         0 @args{qw/alias1 alias2/} = @args{qw/alias2 alias1/};
981 0         0 @args{qw/column1 column2/} = @args{qw/column2 column1/};
982              
983 0         0 return $args{'collection'}->limit(
984             entry_aggregator => 'AND',
985             @_,
986             quote_value => 0,
987             alias => $args{'alias1'},
988             column => $args{'column1'},
989             value => $args{'alias2'} . "." . $args{'column2'},
990             );
991             }
992             }
993             } else {
994 9         43 $alias = $args{'collection'}->_get_alias( $args{'table2'} );
995             }
996              
997 12   100     84 my $meta = $args{'collection'}->{'joins'}{$alias} ||= {};
998 12         26 $meta->{alias} = $alias;
999 12 100       69 if ( $args{'type'} =~ /LEFT/i ) {
1000 8         29 $meta->{'alias_string'}
1001             = " LEFT JOIN " . $args{'table2'} . " $alias ";
1002 8         18 $meta->{'type'} = 'LEFT';
1003              
1004             } else {
1005 4         19 $meta->{'alias_string'} = " JOIN " . $args{'table2'} . " $alias ";
1006 4         11 $meta->{'type'} = 'NORMAL';
1007             }
1008 12         32 $meta->{'depends_on'} = $args{'alias1'};
1009 12         30 $meta->{'is_distinct'} = $args{'is_distinct'};
1010 12 50       43 $meta->{'class'} = $args{'class2'} if $args{'class2'};
1011 12 50       33 $meta->{'entry_aggregator'} = $args{'entry_aggregator'}
1012             if $args{'entry_aggregator'};
1013              
1014 12   33     59 my $criterion = $args{'expression'} || "$args{'alias1'}.$args{'column1'}";
1015 12         110 $meta->{'criteria'}{'base_criterion'} = [
1016             { column => $criterion,
1017             operator => $args{'operator'},
1018             value => "$alias.$args{'column2'}",
1019             }
1020             ];
1021              
1022 12         75 return ($alias);
1023             }
1024              
1025             # this code is all hacky and evil. but people desperately want _something_ and I'm
1026             # super tired. refactoring gratefully appreciated.
1027              
1028             sub _build_joins {
1029 328     328   2026 my $self = shift;
1030 328         404 my $collection = shift;
1031              
1032 328         983 $self->_optimize_joins( collection => $collection );
1033              
1034 21         83 my @cross = grep { lc $_->{type} eq "cross" }
  328         1030  
1035 328         482 values %{ $collection->{'joins'} };
1036 2         11 my $join_clause = ( $collection->table . " main" )
1037 328         1313 . CORE::join( " ", map { $_->{alias_string} } @cross );
1038 328         907 my %processed = map { $_->{alias} => 1 } @cross;
  2         9  
1039 328         3894 $processed{'main'} = 1;
1040              
1041             # get a @list of joins that have not been processed yet, but depend on processed join
1042 328         689 my $joins = $collection->{'joins'};
1043 328   100     2309 while ( my @list = grep !$processed{$_}
1044             && $processed{ $joins->{$_}{'depends_on'} }, keys %$joins )
1045             {
1046 19         46 foreach my $join (@list) {
1047 19         39 $processed{$join}++;
1048              
1049 19         34 my $meta = $joins->{$join};
1050 19   50     112 my $aggregator = $meta->{'entry_aggregator'} || 'AND';
1051              
1052 19         51 $join_clause .= $meta->{'alias_string'} . " ON ";
1053 76 100       410 my @tmp = map {
1054 19         54 ref($_)
1055             ? $_->{'column'} . ' '
1056             . $_->{'operator'} . ' '
1057             . $_->{'value'}
1058             : $_
1059             }
1060             map {
1061 19         63 ( '(', @$_, ')', $aggregator )
1062 19         29 } values %{ $meta->{'criteria'} };
1063              
1064             # delete last aggregator
1065 19         450 pop @tmp;
1066 19         457 $join_clause .= CORE::join ' ', @tmp;
1067             }
1068             }
1069              
1070             # here we could check if there is recursion in joins by checking that all joins
1071             # are processed
1072 328 50       1145 if ( my @not_processed = grep !$processed{$_}, keys %$joins ) {
1073 0         0 die "Unsatisfied dependency chain in joins @not_processed";
1074             }
1075 328         1563 return $join_clause;
1076             }
1077              
1078             sub _optimize_joins {
1079 328     328   437 my $self = shift;
1080 328         1154 my %args = ( collection => undef, @_ );
1081 328         703 my $joins = $args{'collection'}->{'joins'};
1082              
1083 328         482 my %processed;
1084 21         111 $processed{$_}++
1085 328         1351 foreach grep {lc $joins->{$_}{'type'} ne 'left'} keys %$joins;
1086 328         947 $processed{'main'}++;
1087              
1088 328         442 my @ordered;
1089              
1090             # get a @list of joins that have not been processed yet, but depend on processed join
1091             # if we are talking about forest then we'll get the second level of the forest,
1092             # but we should process nodes on this level at the end, so we build FILO ordered list.
1093             # finally we'll get ordered list with leafes in the beginning and top most nodes at
1094             # the end.
1095 328   100     1681 while ( my @list = grep !$processed{$_}
1096             && $processed{ $joins->{$_}{'depends_on'} }, keys %$joins )
1097             {
1098 14         29 unshift @ordered, @list;
1099 14         104 $processed{$_}++ foreach @list;
1100             }
1101              
1102 328         1405 foreach my $join (@ordered) {
1103             next
1104 14 100       61 if $self->may_be_null(
1105             collection => $args{'collection'},
1106             alias => $join
1107             );
1108              
1109 3         234 $joins->{$join}{'alias_string'} =~ s/^\s*LEFT\s+/ /i;
1110 3         15 $joins->{$join}{'type'} = 'NORMAL';
1111             }
1112              
1113             }
1114              
1115             =head2 may_be_null
1116              
1117             Takes a C and C in a hash and returns true if
1118             restrictions of the query allow NULLs in a table joined with the
1119             alias, otherwise returns false value which means that you can use
1120             normal join instead of left for the aliased table.
1121              
1122             Works only for queries have been built with
1123             L and L
1124             methods, for other cases return true value to avoid fault
1125             optimizations.
1126              
1127             =cut
1128              
1129             sub may_be_null {
1130 14     14 1 20 my $self = shift;
1131 14         53 my %args = ( collection => undef, alias => undef, @_ );
1132              
1133             # if we have at least one subclause that is not generic then we should get out
1134             # of here as we can't parse subclauses
1135 14         62 return 1
1136             if grep $_ ne 'generic_restrictions',
1137 14 50       22 keys %{ $args{'collection'}->{'subclauses'} };
1138              
1139             # build full list of generic conditions
1140 14         20 my @conditions;
1141 14         24 foreach ( grep @$_, values %{ $args{'collection'}->{'restrictions'} } ) {
  14         51  
1142 10 50       20 push @conditions, 'AND' if @conditions;
1143 10         29 push @conditions, '(', @$_, ')';
1144             }
1145              
1146             # find tables that depends on this alias and add their join conditions
1147 14         21 foreach my $join ( values %{ $args{'collection'}->{'joins'} } ) {
  14         63  
1148              
1149             # left joins on the left side so later we'll get 1 AND x expression
1150             # which equal to x, so we just skip it
1151 16 100       57 next if $join->{'type'} eq 'LEFT';
1152 1 50 33     8 next unless $join->{'depends_on'} && ($join->{'depends_on'} eq $args{'alias'});
1153              
1154 1         5 my @tmp = map { ( '(', @$_, ')', $join->{'entry_aggregator'} ) }
  1         3  
1155 1         3 values %{ $join->{'criteria'} };
1156 1         2 pop @tmp;
1157              
1158 1         6 @conditions = ( '(', @conditions, ')', 'AND', '(', @tmp, ')' );
1159              
1160             }
1161 14 100       57 return 1 unless @conditions;
1162              
1163             # replace conditions with boolean result: 1 - allow nulls, 0 - doesn't
1164 10         21 foreach ( splice @conditions ) {
1165 46 100 33     200 unless ( ref $_ ) {
    100          
    50          
1166 33         55 push @conditions, $_;
1167             } elsif ( $_->{'column'} =~ /^\Q$args{'alias'}./ ) {
1168              
1169             # only operator IS allows NULLs in the aliased table
1170 10         28 push @conditions, lc $_->{'operator'} eq 'is';
1171             } elsif ( $_->{'value'} && $_->{'value'} =~ /^\Q$args{'alias'}./ ) {
1172              
1173             # right operand is our alias, such condition don't allow NULLs
1174 0         0 push @conditions, 0;
1175             } else {
1176              
1177             # conditions on other aliases
1178 3         5 push @conditions, 1;
1179             }
1180             }
1181              
1182             # returns index of closing paren by index of openning paren
1183             my $closing_paren = sub {
1184 0     0   0 my $i = shift;
1185 0         0 my $count = 0;
1186 0         0 for ( ; $i < @conditions; $i++ ) {
1187 0 0 0     0 if ( $conditions[$i] && $conditions[$i] eq '(' ) {
    0 0        
1188 0         0 $count++;
1189             } elsif ( $conditions[$i] && $conditions[$i] eq ')' ) {
1190 0         0 $count--;
1191             }
1192 0 0       0 return $i unless $count;
1193             }
1194 0         0 die "lost in parens";
1195 10         48 };
1196              
1197             # solve boolean expression we have, an answer is our result
1198 10         19 my @tmp = ();
1199 10         53 while ( defined( my $e = shift @conditions ) ) {
1200              
1201             #warn "@tmp >>>$e<<< @conditions";
1202 48 100 66     202 return $e if !@conditions && !@tmp;
1203              
1204 38 100       110 unless ($e) {
    100          
    100          
    50          
1205 3 100       9 if ( $conditions[0] eq ')' ) {
1206 1         3 push @tmp, $e;
1207 1         2 next;
1208             }
1209              
1210 2         4 my $aggreg = uc shift @conditions;
1211 2 50       4 if ( $aggreg eq 'OR' ) {
    0          
1212              
1213             # 0 OR x == x
1214 2         6 next;
1215             } elsif ( $aggreg eq 'AND' ) {
1216              
1217             # 0 AND x == 0
1218 0         0 my $close_p = $closing_paren->(0);
1219 0         0 splice @conditions, 0, $close_p + 1, (0);
1220             } else {
1221 0         0 die "lost @tmp >>>$e $aggreg<<< @conditions";
1222             }
1223             } elsif ( $e eq '1' ) {
1224 6 100       12 if ( $conditions[0] eq ')' ) {
1225 5         9 push @tmp, $e;
1226 5         11 next;
1227             }
1228              
1229 1         4 my $aggreg = uc shift @conditions;
1230 1 50       5 if ( $aggreg eq 'OR' ) {
    50          
1231              
1232             # 1 OR x == 1
1233 0         0 my $close_p = $closing_paren->(0);
1234 0         0 splice @conditions, 0, $close_p + 1, (1);
1235             } elsif ( $aggreg eq 'AND' ) {
1236              
1237             # 1 AND x == x
1238 1         3 next;
1239             } else {
1240 0         0 die "lost @tmp >>>$e $aggreg<<< @conditions";
1241             }
1242             } elsif ( $e eq '(' ) {
1243 23 100       40 if ( $conditions[1] eq ')' ) {
1244 15         41 splice @conditions, 1, 1;
1245             } else {
1246 8         22 push @tmp, $e;
1247             }
1248             } elsif ( $e eq ')' ) {
1249 6         14 unshift @conditions, @tmp, $e;
1250 6         15 @tmp = ();
1251             } else {
1252 0         0 die "lost: @tmp >>>$e<<< @conditions";
1253             }
1254             }
1255 0         0 return 1;
1256             }
1257              
1258             =head2 distinct_query STATEMENTREF
1259              
1260             takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set.
1261              
1262             =cut
1263              
1264             sub distinct_query {
1265 5     5 1 42 my $self = shift;
1266 5         7 my $statementref = shift;
1267 5         8 my $collection = shift;
1268              
1269             # Prepend select query for DBs which allow DISTINCT on all column types.
1270 5         27 $$statementref
1271             = "SELECT DISTINCT "
1272             . $collection->query_columns
1273             . " FROM $$statementref";
1274              
1275 5         40 $$statementref .= $collection->_group_clause;
1276 5         137 $$statementref .= $collection->_order_clause;
1277             }
1278              
1279             =head2 distinct_count STATEMENTREF
1280              
1281             takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set.
1282              
1283             =cut
1284              
1285             sub distinct_count {
1286 0     0 1 0 my $self = shift;
1287 0         0 my $statementref = shift;
1288              
1289             # Prepend select query for DBs which allow DISTINCT on all column types.
1290 0         0 $$statementref = "SELECT COUNT(DISTINCT main.id) FROM $$statementref";
1291              
1292             }
1293              
1294             =head2 canonical_true
1295              
1296             This returns the canonical true value for this database. For example, in SQLite
1297             it is 1 but in Postgres it is 't'.
1298              
1299             The default is 1.
1300              
1301             =cut
1302              
1303 59     59 1 1030 sub canonical_true { 1 }
1304              
1305             =head2 canonical_false
1306              
1307             This returns the canonical false value for this database. For example, in SQLite
1308             it is 0 but in Postgres it is 'f'.
1309              
1310             The default is 0.
1311              
1312             =cut
1313              
1314 62     62 1 1111 sub canonical_false { 0 }
1315              
1316             =head2 Schema manipulation methods
1317              
1318             =head3 rename_column
1319              
1320             Rename a column in a table. Takes 'table', 'column' and new name in 'to'.
1321              
1322             =cut
1323              
1324             sub rename_column {
1325 0     0 1 0 my $self = shift;
1326 0         0 my %args = (table => undef, column => undef, to => undef, @_);
1327             # Oracle: since Oracle 9i R2
1328             # Pg: 7.4 can this and may be earlier
1329 0         0 return $self->simple_query(
1330             "ALTER TABLE $args{'table'} RENAME COLUMN $args{'column'} TO $args{'to'}"
1331             );
1332             }
1333              
1334              
1335             =head3 rename_table
1336              
1337             Renames a table in the DB. Takes 'table' and new name of it in 'to'.
1338              
1339             =cut
1340              
1341             sub rename_table {
1342 1     1 1 3 my $self = shift;
1343 1         8 my %args = (table => undef, to => undef, @_);
1344             # mysql has RENAME TABLE, but alter can rename temporary
1345             # Oracle, Pg, SQLite are ok with this
1346 1         8 return $self->simple_query("ALTER TABLE $args{'table'} RENAME TO $args{'to'}");
1347             }
1348              
1349             =head2 supported_drivers
1350              
1351             Returns a list of the drivers L supports.
1352              
1353             =cut
1354              
1355             sub supported_drivers {
1356 68     68 1 392855 return qw(
1357             SQLite
1358             Informix
1359             mysql
1360             mysqlPP
1361             ODBC
1362             Oracle
1363             Pg
1364             Sybase
1365             );
1366             }
1367              
1368             =head2 available_drivers
1369              
1370             Returns a list of the available drivers based on the presence of C
1371             modules.
1372              
1373             =cut
1374              
1375             sub available_drivers {
1376 34     34 1 204 my $self = shift;
1377              
1378 34         117 local $@;
1379 34         140 return grep { eval "require DBD::" . $_ } $self->supported_drivers;
  272         534449  
1380             }
1381              
1382             =head2 is_available_driver
1383              
1384             Returns a boolean indicating whether the provided driver is available.
1385              
1386             =cut
1387              
1388             do {
1389             # lazily memoize
1390             my $is_available_driver;
1391              
1392             sub is_available_driver {
1393 0     0 1 0 my $self = shift;
1394 0         0 my $driver = shift;
1395              
1396 0 0       0 if (!$is_available_driver) {
1397 0         0 %$is_available_driver = map { $_ => 1 } $self->available_drivers;
  0         0  
1398             }
1399              
1400 0         0 return $is_available_driver->{$driver};
1401             }
1402             };
1403              
1404             =head2 DESTROY
1405              
1406             When we get rid of the L, we need to disconnect
1407             from the database
1408              
1409             =cut
1410              
1411             sub DESTROY {
1412 31     31   10370 my $self = shift;
1413              
1414             # eval in DESTROY can cause $@ issues elsewhere
1415 31         85 local $@;
1416              
1417             $self->disconnect
1418             unless $self->dbh
1419             and $self->dbh
1420             # We use an eval {} because DESTROY order during
1421             # global destruction is not guaranteed -- the dbh may
1422             # no longer be tied, which throws an error.
1423 31 50 66     267 and eval { $self->dbh->{InactiveDestroy} };
  30   66     133  
1424 31         317 delete $DBIHandle{$self};
1425             }
1426              
1427             1;
1428             __END__