File Coverage

blib/lib/DBIx/SearchBuilder/Handle/Pg.pm
Criterion Covered Total %
statement 12 120 10.0
branch 0 40 0.0
condition 0 27 0.0
subroutine 4 17 23.5
pod 11 11 100.0
total 27 215 12.5


line stmt bran cond sub pod time code
1             package DBIx::SearchBuilder::Handle::Pg;
2              
3 1     1   1727 use strict;
  1         3  
  1         27  
4 1     1   5 use warnings;
  1         2  
  1         26  
5              
6 1     1   5 use base qw(DBIx::SearchBuilder::Handle);
  1         2  
  1         104  
7              
8 1     1   605 use Want qw(howmany);
  1         1823  
  1         1586  
9              
10             =head1 NAME
11              
12             DBIx::SearchBuilder::Handle::Pg - A Postgres specific Handle object
13              
14             =head1 SYNOPSIS
15              
16              
17             =head1 DESCRIPTION
18              
19             This module provides a subclass of DBIx::SearchBuilder::Handle that
20             compensates for some of the idiosyncrasies of Postgres.
21              
22             =head1 METHODS
23              
24             =cut
25              
26              
27             =head2 Connect
28              
29             Connect takes a hashref and passes it off to SUPER::Connect;
30             Forces the timezone to GMT
31             it returns a database handle.
32              
33             =cut
34              
35             sub Connect {
36 0     0 1   my $self = shift;
37              
38 0           my $rv = $self->SUPER::Connect(@_);
39 0           $self->SimpleQuery("SET TIME ZONE 'GMT'");
40 0           $self->SimpleQuery("SET DATESTYLE TO 'ISO'");
41 0           $self->AutoCommit(1);
42 0           return ($rv);
43             }
44              
45             =head2 BuildDSN
46              
47             Extend L to force
48             C to be UTF-8, so that character strings can be
49             safely passed to, and retrieved from, the database. See
50             L.
51              
52             =cut
53              
54             sub BuildDSN {
55 0     0 1   my $self = shift;
56 0           $self->SUPER::BuildDSN(@_);
57 0           $self->{'dsn'} .= ';client_encoding=UTF8';
58 0           return $self->{'dsn'};
59             }
60              
61             =head2 Insert
62              
63             Takes a table name as the first argument and assumes
64             that the rest of the arguments are an array of key-value
65             pairs to be inserted.
66              
67             In case of insert failure, returns a L
68             object preloaded with error info.
69              
70             =cut
71              
72              
73             sub Insert {
74 0     0 1   my $self = shift;
75 0           my $table = shift;
76 0           my %args = (@_);
77              
78 0           my $sth = $self->SUPER::Insert( $table, %args );
79 0 0         return $sth unless $sth;
80              
81 0 0 0       if ( $args{'id'} || $args{'Id'} ) {
82 0   0       $self->{'id'} = $args{'id'} || $args{'Id'};
83 0           return ( $self->{'id'} );
84             }
85              
86 0           my $sequence_name = $self->IdSequenceName($table);
87 0 0         unless ($sequence_name) { return ($sequence_name) } # Class::ReturnValue
  0            
88 0           my $seqsth = $self->dbh->prepare(
89             qq{SELECT CURRVAL('} . $sequence_name . qq{')} );
90 0           $seqsth->execute;
91 0           $self->{'id'} = $seqsth->fetchrow_array();
92              
93 0           return ( $self->{'id'} );
94             }
95              
96             =head2 InsertQueryString
97              
98             Postgres sepcific overriding method for
99             L.
100              
101             =cut
102              
103             sub InsertQueryString {
104 0     0 1   my $self = shift;
105 0           my ($query_string, @bind) = $self->SUPER::InsertQueryString( @_ );
106 0           $query_string =~ s/\(\s*\)\s+VALUES\s+\(\s*\)\s*$/DEFAULT VALUES/;
107 0           return ($query_string, @bind);
108             }
109              
110             =head2 IdSequenceName TABLE
111              
112             Takes a TABLE name and returns the name of the sequence of the primary key for that table.
113              
114             =cut
115              
116             sub IdSequenceName {
117 0     0 1   my $self = shift;
118 0           my $table = shift;
119              
120 0 0         return $self->{'_sequences'}{$table} if (exists $self->{'_sequences'}{$table});
121             # Let's get the id of that row we just inserted
122 0           my $seq;
123 0           my $colinfosth = $self->dbh->column_info( undef, undef, lc($table), '%' );
124 0           while ( my $foo = $colinfosth->fetchrow_hashref ) {
125              
126             # Regexp from DBIx::Class's Pg handle. Thanks to Marcus Ramberg
127 0 0 0       if ( defined $foo->{'COLUMN_DEF'}
128             && $foo->{'COLUMN_DEF'}
129             =~ m!^nextval\(+'"?([^"']+)"?'(::(?:text|regclass)\))+!i )
130              
131             {
132 0           return $self->{'_sequences'}{$table} = $1;
133             }
134              
135             }
136              
137 0           my $ret = Class::ReturnValue->new();
138 0           $ret->as_error(
139             errno => '-1',
140             message => "Found no sequence for $table",
141             do_backtrace => undef
142             );
143 0           return ( $ret->return_value );
144             }
145              
146              
147              
148             =head2 BinarySafeBLOBs
149              
150             Return undef, as no current version of postgres supports binary-safe blobs
151              
152             =cut
153              
154             sub BinarySafeBLOBs {
155 0     0 1   my $self = shift;
156 0           return(undef);
157             }
158              
159              
160             =head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
161              
162             takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW;
163              
164              
165             =cut
166              
167             sub ApplyLimits {
168 0     0 1   my $self = shift;
169 0           my $statementref = shift;
170 0           my $per_page = shift;
171 0           my $first = shift;
172 0           my $sb = shift;
173              
174 0           my $limit_clause = '';
175              
176 0 0         if ( $per_page) {
177 0           $limit_clause = " LIMIT ";
178              
179 0 0         if ( $sb->{_bind_values} ) {
180 0   0       push @{ $sb->{_bind_values} }, $per_page, $first || ();
  0            
181 0 0         $first = '?' if $first;
182 0           $per_page = '?';
183             }
184              
185 0           $limit_clause .= $per_page;
186 0 0         if ( $first ) {
187 0           $limit_clause .= " OFFSET $first";
188             }
189             }
190              
191 0           $$statementref .= $limit_clause;
192             }
193              
194              
195             =head2 _MakeClauseCaseInsensitive FIELD OPERATOR VALUE
196              
197             Takes a field, operator and value. performs the magic necessary to make
198             your database treat this clause as case insensitive.
199              
200             Returns a FIELD OPERATOR VALUE triple.
201              
202             =cut
203              
204             sub _MakeClauseCaseInsensitive {
205 0     0     my $self = shift;
206 0           my $field = shift;
207 0           my $operator = shift;
208 0           my $value = shift;
209              
210             # we don't need to downcase numeric values and dates
211 0 0         if ($value =~ /^$DBIx::SearchBuilder::Handle::RE_CASE_INSENSITIVE_CHARS+$/o) {
212 0           return ( $field, $operator, $value);
213             }
214              
215 0 0         if ( $operator =~ /LIKE/i ) {
    0          
216 0           $operator =~ s/LIKE/ILIKE/ig;
217 0           return ( $field, $operator, $value );
218             }
219             elsif ( $operator =~ /=/ ) {
220 0 0         if (howmany() >= 4) {
221 0           return ( "LOWER($field)", $operator, $value, "LOWER(?)");
222             }
223             # RT 3.0.x and earlier don't know how to cope with a "LOWER" function
224             # on the value. they only expect field, operator, value.
225             #
226             else {
227 0           return ( "LOWER($field)", $operator, lc($value));
228             }
229             }
230             else {
231 0           $self->SUPER::_MakeClauseCaseInsensitive( $field, $operator, $value );
232             }
233             }
234              
235              
236             =head2 DistinctQuery STATEMENTREF
237              
238             takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set.
239              
240             =cut
241              
242             sub DistinctQuery {
243 0     0 1   my $self = shift;
244 0           my $statementref = shift;
245 0           my $sb = shift;
246 0           my $table = $sb->Table;
247              
248 0 0         return $self->SUPER::DistinctQuery( $statementref, $sb, @_ )
249             if $sb->_OrderClause !~ /(?
250              
251             # "SELECT main.* FROM ( SELECT id FROM ... ORDER BY ... ) as dist,
252             # X main WHERE (main.id = dist.id);" doesn't work in some cases.
253             # It's hard to show with tests. Pg's optimizer can choose execution
254             # plan not guaranting order
255              
256 0           my $groups;
257 0 0 0       if ($self->DatabaseVersion =~ /^(\d+)\.(\d+)/ and ($1 > 9 or ($1 == 9 and $2 >= 1))) {
      0        
258             # Pg 9.1 supports "SELECT main.foo ... GROUP BY main.id" if id is the primary key
259 0           $groups = [ {FIELD => "id"} ];
260             } else {
261             # For earlier versions, we have to list out all of the columns
262 0           $groups = [ map {+{FIELD => $_}} $self->Fields($table) ];
  0            
263             }
264 0           local $sb->{group_by} = $groups;
265             local $sb->{'order_by'} = [
266             map {
267             ($_->{'ALIAS'}||'') ne "main"
268 0 0 0       ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" }
  0 0 0        
269             : $_
270             }
271 0           @{$sb->{'order_by'}}
  0            
272             ];
273 0           my $group = $sb->_GroupClause;
274 0           my $order = $sb->_OrderClause;
275 0           $$statementref = "SELECT main.* FROM $$statementref $group $order";
276             }
277              
278             =head2 SimpleDateTimeFunctions
279              
280             Returns hash reference with specific date time functions of this
281             database for L.
282              
283             =cut
284              
285             sub SimpleDateTimeFunctions {
286 0     0 1   my $self = shift;
287             return $self->{'_simple_date_time_functions'}
288 0 0         if $self->{'_simple_date_time_functions'};
289              
290 0           my %res = %{ $self->SUPER::SimpleDateTimeFunctions(@_) };
  0            
291 0           s/SUBSTR\s*\(\s*\?/SUBSTR( CAST(? AS text)/ig for values %res;
292              
293             # everything else we should implement through date_trunc that
294             # does SUBSTR(?, 1, X) on a date, but leaves trailing values
295             # when we don't need them
296              
297 0   0       return $self->{'_simple_date_time_functions'} ||= {
298             %res,
299             datetime => '?',
300             time => 'CAST(? AS time)',
301              
302             hour => 'EXTRACT(HOUR FROM ?)',
303              
304             date => 'CAST(? AS date)',
305             daily => 'CAST(? AS date)',
306              
307             day => 'EXTRACT(DAY FROM ?)',
308              
309             month => 'EXTRACT(MONTH FROM ?)',
310              
311             annually => 'EXTRACT(YEAR FROM ?)',
312             year => 'EXTRACT(YEAR FROM ?)',
313              
314             dayofweek => "EXTRACT(DOW FROM ?)", # 0-6, 0 - Sunday
315             dayofyear => "EXTRACT(DOY FROM ?)", # 1-366
316             # 1-53, 1st week January 4, week starts on Monay
317             weekofyear => "EXTRACT(WEEK FROM ?)",
318             };
319             }
320              
321             =head2 ConvertTimezoneFunction
322              
323             Custom implementation of L.
324              
325             In Pg time and timestamp data types may be "with time zone" or "without time zone".
326             So if Field argument is timestamp "with time zone" then From argument is not
327             required and is useless. Otherwise From argument identifies time zone of the Field
328             argument that is "without time zone".
329              
330             For consistency with other DBs use timestamp columns without time zones and provide
331             From argument.
332              
333             =cut
334              
335             sub ConvertTimezoneFunction {
336 0     0 1   my $self = shift;
337 0           my %args = (
338             From => 'UTC',
339             To => undef,
340             Field => '',
341             @_
342             );
343 0 0 0       return $args{'Field'} unless $args{From} && $args{'To'};
344 0 0         return $args{'Field'} if lc $args{From} eq lc $args{'To'};
345              
346 0           my $dbh = $self->dbh;
347 0           my $res = $args{'Field'};
348 0           $res = "TIMEZONE($_, $res)" foreach map $dbh->quote( $_ ), grep $_, @args{'From', 'To'};
349 0           return $res;
350             }
351              
352             sub _DateTimeIntervalFunction {
353 0     0     my $self = shift;
354 0           my %args = ( From => undef, To => undef, @_ );
355              
356 0           return "(EXTRACT(EPOCH FROM $args{'To'}) - EXTRACT(EPOCH FROM $args{'From'}))";
357             }
358              
359             sub HasSupportForNullsOrder {
360 0     0 1   return 1;
361             }
362              
363             1;