File Coverage

blib/lib/DBIx/PgLink/Local.pm
Criterion Covered Total %
statement 56 333 16.8
branch 4 158 2.5
condition 0 47 0.0
subroutine 17 49 34.6
pod 18 20 90.0
total 95 607 15.6


line stmt bran cond sub pod time code
1             package DBIx::PgLink::Local;
2              
3             # NOTE: this is general-purpose light-weight non-Moose class
4             # NOTE: at compile time PL/Perl subroutines are not functional
5             # NOTE: all non-critical messages logged with INFO severity
6              
7 2     2   104639 use strict;
  2         7  
  2         87  
8 2     2   10 use warnings;
  2         4  
  2         66  
9 2     2   11 use Exporter;
  2         4  
  2         1570  
10 2     2   14 use Carp;
  2         4  
  2         315  
11 2     2   2061 use Tie::Cache::LRU;
  2         40271  
  2         64  
12 2     2   507 use DBIx::PgLink::Logger;
  2         5  
  2         226  
13              
14             our $VERSION = '0.01';
15              
16             our @ISA = qw(Exporter);
17             our @EXPORT = qw(pg_dbh);
18              
19 2     2   15 use constant 'pg_dbh' => bless \(my $anon_scalar), __PACKAGE__; # singleton
  2         3  
  2         117  
20              
21 2     2   11 use constant 'default_plan_cache_size' => 100;
  2         4  
  2         4939  
22             our %cached_plans;
23              
24             our $quote_ident_only_if_necessary = 1; # little slower, but no excessive quoting ("foo","bar",etc.)
25              
26             sub prepare {
27 0     0 1 0 my $self = shift;
28 0         0 return DBIx::PgLink::Local::st->prepare(@_);
29             }
30              
31              
32             sub _attr_types {
33             # in : $attr
34             # out : list of types
35 0     0   0 my $self = shift;
36 0         0 my $attr = shift;
37 0 0       0 my $t = ref $attr eq 'HASH' ? $attr->{types} : undef;
38 0         0 my $r = ref $t;
39 0         0 return map { uc } (
  0         0  
40             $r eq '' && $t ? ($t) # { types => 'INT4' }
41             : $r eq 'SCALAR' ? ($$t) # { types => \$type }
42 0         0 : $r eq 'ARRAY' ? @{$t} # { types => ['TEXT', 'INT4'] }
43             : $r eq 'HASH' ? # { types => {1=>'TEXT', 2=>'INT4'} }
44 0 0 0     0 map { $t->{$_} } sort { $a<=>$b } keys %{$t}
  0 0       0  
  0 0       0  
    0          
45             : ()
46             );
47             }
48              
49              
50             sub _query_key {
51 0     0   0 my $self = shift;
52 0         0 my $query = shift;
53 0         0 my $attr = shift;
54 0         0 my @types = $self->_attr_types($attr);
55 0 0       0 $query .= "\nparams(" . join(",", @types) . ")" if @types;
56 0         0 return $query;
57             }
58              
59              
60             sub prepare_cached {
61 0     0 1 0 my $self = shift;
62 0         0 my $query = shift;
63 0         0 my $attr = shift;
64              
65 0 0       0 if ($attr->{no_cache}) {
66 0         0 return DBIx::PgLink::Local::st->prepare($query, $attr);
67             }
68              
69 0 0       0 unless (tied %cached_plans) {
70             my $cache_size =
71 0   0     0 eval {
72             my $rv = main::spi_exec_query(q/SELECT current_setting('plperl.plan_cache_size')/);
73             $rv->{rows}->[0]->{current_setting};
74             } # fails if custom_variable_classes not include 'plperl'
75             || default_plan_cache_size;
76 0         0 tie %cached_plans, 'Tie::Cache::LRU', $cache_size;
77             }
78              
79 0         0 my $key = $self->_query_key($query, $attr);
80              
81 0 0       0 if (exists $cached_plans{$key}) {
82 0 0       0 trace_msg("INFO", "Reuse plan for '$key'") if trace_level >= 3;
83 0         0 return $cached_plans{$key};
84             } else {
85 0         0 return $cached_plans{$key} = DBIx::PgLink::Local::st->prepare($query, $attr);
86             }
87             }
88              
89              
90             sub do {
91 0     0 1 0 my $self = shift;
92 0         0 my $query = shift;
93 0         0 my $attr = shift;
94 0 0       0 $attr->{no_cursor} = 1 unless exists $attr->{no_cursor}; # don't create cursor
95 0 0       0 $attr->{no_parse} = 1 unless @_; # skip parsing if no parameter values
96              
97 0 0       0 if ($query !~ /^\s*(SELECT|INSERT|UPDATE|DELETE)/) {
98 0 0       0 $attr->{no_cache} = 1 unless exists $attr->{no_cache}; # don't cache plan for DDL
99             }
100              
101 0         0 my $sth = $self->prepare_cached($query, $attr);
102 0         0 return $sth->execute(@_);
103             }
104              
105              
106             sub selectall_arrayref {
107 0     0 1 0 my $self = shift;
108 0         0 my $query = shift;
109 0         0 my $attr = shift;
110 0 0 0     0 carp "selectall_arrayref() can return only array of hashes, use Slice=>{} attribute"
111             unless defined $attr->{Slice} && ref $attr->{Slice} eq 'HASH';
112             # @_ = parameters
113 0         0 $attr->{no_cursor} = 1;
114 0         0 my $sth = $self->prepare_cached($query, $attr);
115 0         0 $sth->execute(@_);
116 0         0 return $sth->fetchall_arrayref({});
117             }
118              
119              
120             sub selectrow_array {
121 0 0   0 1 0 confess "list context of selectrow_array() does not implemented" if wantarray;
122 0         0 my $self = shift;
123 0         0 my $query = shift;
124 0         0 my $attr = shift;
125             # @_ = parameters
126 0         0 $attr->{no_cursor} = 1;
127 0         0 my $sth = $self->prepare_cached($query, $attr);
128 0         0 $sth->execute(@_);
129 0         0 return $sth->fetchrow_array;
130             }
131              
132              
133             sub selectrow_hashref {
134 0     0 1 0 my $self = shift;
135 0         0 my $query = shift;
136 0         0 my $attr = shift;
137 0         0 $attr->{no_cursor} = 1;
138             # @_ = parameters
139 0         0 my $sth = $self->prepare_cached($query, $attr);
140 0         0 $sth->execute(@_);
141 0         0 return $sth->fetchrow_hashref;
142             }
143              
144              
145             sub selectall_hashref {
146 0     0 1 0 my $self = shift;
147 0         0 my $query = shift;
148 0         0 my $key_field = shift;
149 0         0 my $attr = shift;
150 0         0 $attr->{Slice} = {};
151 0         0 my $data = $self->selectall_arrayref($query, $attr, @_);
152 0         0 my $result;
153 0         0 for my $row (@{$data}) {
  0         0  
154 0         0 $result->{$row->{$key_field}} = $row;
155             }
156 0         0 return $result;
157             }
158              
159              
160             sub quote {
161 0     0 1 0 my $self = shift;
162 0         0 my $q = shift;
163 0 0       0 return 'NULL' unless defined $q;
164 0         0 $q =~ s/'/''/g;
165 0         0 $q = "'$q'";
166 0 0       0 if ($q =~ s/\\/\\\\/g) {
167             # work with any 'standard_conforming_strings' value
168 0         0 $q = 'E' . $q; #if pg_server_version() >= 80100;
169             }
170 0         0 return $q;
171             };
172              
173              
174             my $quote_ident_sth;
175              
176             sub quote_identifier {
177 0     0 1 0 my $self = shift;
178 0         0 my @id = @_;
179              
180             # no catalog/attr
181 0         0 for (@id) { # quote the elements
182 0 0       0 next unless defined;
183 0 0       0 if ($quote_ident_only_if_necessary) {
184 0 0       0 $quote_ident_sth = $self->prepare_cached('SELECT quote_ident($1)', {no_cursor=>1})
185             unless $quote_ident_sth;
186 0         0 $quote_ident_sth->execute($_);
187 0         0 $_ = $quote_ident_sth->fetchrow_array;
188             } else {# quote all
189 0         0 s/"/""/g; # escape embedded quotes
190 0         0 $_ = qq{"$_"};
191             }
192             }
193             # join the dots, ignoring any null/undef elements (ie schema)
194 0         0 my $quoted_id = join '.', grep { defined } @id;
  0         0  
195 0         0 return $quoted_id;
196             }
197              
198              
199             #------------------------------ utils
200              
201             sub pg_flush_plan_cache {
202 0     0 1 0 my $self = shift;
203 0   0     0 my $key_regex = shift || qr//;
204 0         0 delete @cached_plans{ grep /$key_regex/, keys %cached_plans };
205             }
206              
207              
208             sub pg_to_perl_array {
209 0     0 1 0 my $self = shift;
210 0         0 my $pg_array = shift; # as string
211 0 0 0     0 return () unless defined $pg_array && $pg_array ne '' && $pg_array ne '{}';
      0        
212              
213 0 0       0 if ($pg_array =~ /^\{([^{"]*)\}$/) {
214              
215             # simple, one-dimensional array
216 0 0       0 return map { $_ eq 'NULL' ? undef : $_ } split ',', $1;
  0         0  
217              
218             } else {
219              
220             # quoted or multidimensional array
221             # not fast, but reliable SQL conversion
222             # WARNING: treats any array as TEXT[]
223              
224             # get dimensions of array
225 0         0 my $dim = $self->selectrow_array('SELECT array_dims($1)', {types=>'_TEXT'}, $pg_array);
226              
227 0 0       0 if ($dim =~ /^\[\d+:\d+\]$/) {
228              
229             # single dimension, get set of scalars
230 0         0 my $a = $self->selectall_arrayref(<<'END_OF_SQL', {Slice=>{}, types=>'_TEXT'}, $pg_array);
231             SELECT $1[i] as i
232             FROM pg_catalog.generate_series(1, array_upper($1, 1)) as a(i)
233             END_OF_SQL
234              
235 0         0 return map { $_->{i} } @{$a};
  0         0  
  0         0  
236              
237             } else {
238              
239             # nested array, get set of array slices
240 0         0 my $a = $self->selectall_arrayref(<<'END_OF_SQL', {Slice=>{}, types=>'_TEXT'}, $pg_array);
241             SELECT $1[i:i] as i
242             FROM pg_catalog.generate_series(1, array_upper($1, 1)) as a(i)
243             END_OF_SQL
244              
245 0         0 return map {
246 0         0 my $i = $_->{i};
247 0         0 $i =~ /^\{(.*)\}$/; # chop extra {}
248 0         0 my @b = $self->pg_to_perl_array($1);
249 0         0 \@b;
250 0         0 } @{$a};
251              
252             }
253             }
254             }
255              
256              
257             sub pg_from_perl_array {
258 0     0 1 0 my $self = shift;
259             return
260 0         0 '{'
261             . join(',',
262             map {
263 0         0 (ref $_ eq 'ARRAY') # nested array
264             ? $self->pg_from_perl_array(@{$_})
265             : defined $_
266 0 0       0 ? do { # quote all values
    0          
267 0         0 my $a = $_;
268 0         0 $a =~ s/"/\\"/g;
269 0         0 '"' . $a . '"'
270             }
271             : 'NULL'
272             } @_
273             )
274             . '}';
275             }
276              
277              
278             # HASH pseudotype, store hash as TEXT[] as 'key','value' pairs
279             sub pg_to_perl_hash {
280 0     0 1 0 my ($self, $pg_array) = @_;
281 0         0 my %result = pg_dbh->pg_to_perl_array($pg_array);
282 0         0 return \%result;
283             }
284              
285             sub pg_from_perl_hash {
286 0     0 1 0 my ($self, $hashref) = @_;
287 0         0 return $self->pg_from_perl_array(%{$hashref});
  0         0  
288             }
289              
290              
291             sub pg_to_perl_encoding {
292 0     0 1 0 my $self = shift;
293 0         0 my $enc = shift;
294 0         0 $enc =~ s/^WIN(\d+)$/cp$1/;
295 0   0     0 $enc = {
296             #pg #perl
297             SQL_ASCII => 'ascii',
298             UNICODE => 'utf8',
299             KOI8 => 'koi8-r',
300             ALT => 'cp866',
301             WIN => 'cp1251',
302             #TODO
303             }->{$enc} || $enc;
304 0         0 return $enc;
305             }
306              
307             sub pg_from_perl_boolean {
308 0     0 0 0 my $self = shift;
309 0         0 my $b = shift;
310 0 0       0 return defined $b ? $b ? 't' : 'f' : undef;
    0          
311             }
312              
313             sub pg_to_perl_boolean {
314 0     0 0 0 my $self = shift;
315 0         0 my $b = shift;
316 0 0       0 return defined $b ? $b eq 't' ? '1' : '0' : undef;
    0          
317             }
318              
319              
320             my $pg_server_version; # cached
321             sub pg_server_version {
322 0     0 1 0 my $self = shift;
323 0 0       0 return $pg_server_version if $pg_server_version;
324 0         0 my $ver = pg_dbh->selectrow_array("SELECT version()");
325 0         0 my ($major, $minor, $release) = $ver =~ /^PostgreSQL (\d+)\.(\d+)\.(\d+)/;
326 0         0 return $pg_server_version = $major*10000+$minor*100+$release;
327             }
328              
329              
330             my $pg_current_database; # cached
331             sub pg_current_database {
332 0     0 1 0 my $self = shift;
333 0   0     0 return $pg_current_database
334             || ( $pg_current_database = pg_dbh->selectrow_array("SELECT current_database()"));
335             }
336              
337             # session_user, not cached because can be changed by SET SESSION AUTHORIZATION
338             sub pg_session_user {
339 0     0 1 0 my $self = shift;
340 0         0 return scalar(pg_dbh->selectrow_array("SELECT session_user"));
341             }
342              
343              
344             1;
345              
346              
347              
348              
349             package DBIx::PgLink::Local::st;
350              
351 2     2   19 use strict;
  2         3  
  2         75  
352 2     2   12 use warnings;
  2         4  
  2         80  
353 2     2   12 use Carp;
  2         4  
  2         418  
354 2     2   2776 use Data::Dumper;
  2         16875  
  2         160  
355 2     2   19 use DBIx::PgLink::Logger;
  2         4  
  2         104  
356              
357             BEGIN {
358             # alias pg_dbh constant
359 2     2   11 no strict 'refs';
  2         4  
  2         121  
360 2     2   2453 *pg_dbh = \&DBIx::PgLink::Local::pg_dbh;
361             }
362              
363              
364             sub _find_placeholders {
365             # in : $_[0] = query text
366             # out : array of placeholder numbers, changed query
367              
368             # WARNING: false placeholders in literals and comments are detected
369              
370             # $1, $2, ... placeholders, PostgreSQL default
371 8 100   8   11284 if ($_[0] =~ /\$\d/) {
    100          
372 2         4 my %uniq;
373 2         14 @uniq{ $_[0] =~ m/\$(\d+)/g } = ();
374 2         17 return sort { $a <=> $b } keys %uniq;
  1         6  
375             }
376             # ? placeholders
377             elsif ($_[0] =~ /[?]/) {
378 5         12 my $cnt=0;
379             # replace ? to $n in-place
380 5         23 $_[0] =~ s/[?]/'$' . ++$cnt/eg;
  6         20  
381 5         24 return (1..$cnt);
382             }
383 1         4 return ();
384             }
385              
386             our %TYPE_ALIAS = (
387             'int' => 'INT4',
388             'integer' => 'INT4',
389             'real' => 'FLOAT4',
390             'float' => 'FLOAT8',
391             'double' => 'FLOAT8',
392             'double precision' => 'FLOAT8',
393             'boolean' => 'BOOL',
394             );
395             $TYPE_ALIAS{uc $_} = $TYPE_ALIAS{$_} for keys %TYPE_ALIAS;
396             # standard type aliases also allowed in Pg-8.3
397              
398             # constructor
399             sub prepare {
400 0     0     my ($proto, $query, $attr) = @_;
401 0   0       $proto = ref $proto || $proto;
402 0 0         $attr = ref $attr eq 'HASH' ? $attr : {};
403              
404 0           my @types = pg_dbh->_attr_types($attr);
405              
406 0           my $data = {
407             Attr => $attr,
408             Statement => $query,
409             Types => \@types,
410             };
411              
412 0           my @mapped_types = ();
413 0 0         if (@types) {
    0          
414 0           for my $t (@types) {
415             # spi_prepare do not understand TYPE[] syntax for array
416 0           my ($array, $base) = (0, $t);
417 0 0 0       if ($t =~ /^_(.*)$/ || $t =~ /^(.*)\[\]$/) {
418 0           ($array, $base) = (1, $1);
419             }
420 0 0         $base = $TYPE_ALIAS{$base} if exists $TYPE_ALIAS{$base};
421 0 0         $t = $array ? '_' . $base : $base;
422              
423             # special hash pseudotype
424 0 0         push @mapped_types, $t eq 'HASH' ? '_TEXT' : $t;
425             }
426             } elsif (!$attr->{no_parse}) {
427             # no types specified, defaults all parameters to TEXT
428             # also replace '?' to '$1' in-place
429 0           @mapped_types = map { 'TEXT' } _find_placeholders($query);
  0            
430             }
431              
432 0 0         if (trace_level >= 3) {
433 0 0         trace_msg("INFO", "spi_prepare: $query"
434             . (@types ? "\nBind types: " . join(",", @mapped_types) : "") )
435             }
436              
437 0           eval {
438 0           $data->{Plan} = main::spi_prepare($query, @mapped_types);
439             };
440 0 0 0       confess "spi_prepare failed for $query: $@" if $@ || !$data->{Plan};
441 0 0         trace_msg("INFO", " plan=$data->{Plan}") if trace_level >= 3;
442              
443 0           $data->{Boolean} = _attr_arrayref($attr->{boolean});
444 0           $data->{Array} = _attr_arrayref($attr->{array});
445 0           $data->{Hash} = _attr_arrayref($attr->{hash});
446              
447 0           return bless $data, $proto;
448             }
449              
450              
451             sub _attr_arrayref {
452 0     0     my $r = shift;
453 0 0         return [] unless defined $r;
454 0 0         if (ref $r eq 'ARRAY') {
    0          
455 0           return $r;
456             } elsif (ref $r eq 'HASH') {
457 0           my @keys = keys %{$r};
  0            
458 0           return \@keys;
459             }
460 0           return [];
461             }
462              
463              
464             sub DESTROY {
465 0     0     my $self = shift;
466 0           $self->finish;
467             }
468              
469              
470             sub finish {
471 0     0     my $self = shift;
472 0 0         if (defined $self->{Cursor}) {
473 0 0         trace_msg("INFO", "spi_close_cursor ($self->{Cursor})")
474             if trace_level >= 3;
475 0           main::spi_cursor_close($self->{Cursor});
476             }
477 0           delete @{$self}{qw/Cursor Result Pos/};
  0            
478             }
479              
480              
481             sub _convert_params {
482 0     0     my $self = shift;
483 0 0         return unless @{$self->{Types}};
  0            
484 0           my $i = 0;
485 0           for my $param (@_) {
486 0           my $type = $self->{Types}->[$i++];
487 0 0 0       if ($type eq 'BOOL') {
    0 0        
    0          
488 0           $param = pg_dbh->pg_from_perl_boolean($param);
489             } elsif ($type =~ '^_' && ref $param eq 'ARRAY') {
490 0           $param = pg_dbh->pg_from_perl_array(@{$param});
  0            
491             } elsif ($type eq 'HASH' && ref $param eq 'HASH') {
492 0           $param = pg_dbh->pg_from_perl_hash($param);
493             }
494             }
495             }
496              
497              
498             sub _convert_row {
499 0     0     my $self = shift;
500 0           my $row = shift;
501 0 0         return unless $row;
502 0           for my $field (@{$self->{Boolean}}) {
  0            
503 0 0         next unless exists $row->{$field};
504 0           $row->{$field} = pg_dbh->pg_to_perl_boolean($row->{$field});
505             }
506 0           for my $field (@{$self->{Array}}) {
  0            
507 0 0         next unless exists $row->{$field};
508 0           my @arr= pg_dbh->pg_to_perl_array($row->{$field});
509 0           $row->{$field} = \@arr;
510             }
511 0           for my $field (@{$self->{Hash}}) {
  0            
512 0 0         next unless exists $row->{$field};
513 0           $row->{$field} = pg_dbh->pg_to_perl_hash($row->{$field});
514             }
515             }
516              
517              
518             sub execute {
519 0     0     my $self = shift;
520            
521 0           $self->finish;
522              
523 0 0         if ($self->{Attr}->{no_cursor}) {
524              
525             # does not use cursor, fetch all rows at once
526              
527 0 0         if (trace_level >= 4) {
528 0           local $" = ',';
529 2     2   13 no warnings;
  2         6  
  2         1799  
530 0           trace_msg("INFO", "spi_execute_prepared ($self->{Plan} Bind: @_)")
531             }
532              
533 0           my @param_values = @_;
534 0           $self->_convert_params(@param_values);
535              
536 0           my $rv = eval {
537 0           main::spi_exec_prepared($self->{Plan}, @param_values);
538             };
539 0 0         if ($@) {
540 0 0         confess "spi_exec_prepared failed: $@\nStatement: $self->{Statement} with "
541 0           . join(",", map { defined $_ ? $_ : '<NULL>' } @param_values);
542             }
543              
544 0 0         return unless ref $rv eq 'HASH';
545              
546 0           $self->{Result} = $rv;
547 0 0         trace_msg("INFO", "spi_execute_prepared results:\n" . Dumper($rv))
548             if trace_level >= 4;
549 0           my $result = $rv->{processed};
550 0 0 0       $result = '0E0' if defined $result && $result eq '0';
551              
552 0           return $result;
553              
554             } else {
555            
556             # open cursor
557              
558 0 0         if (trace_level >= 4) {
559 0           local $" = ',';
560 0           trace_msg("INFO", "spi_query_prepared ($self->{Plan}, Bind: @_)")
561             }
562              
563 0           undef $self->{Cursor};
564              
565 0           my @param_values = @_;
566 0           $self->_convert_params(@param_values);
567              
568 0           $self->{Cursor} = eval {
569 0           main::spi_query_prepared($self->{Plan}, @param_values)
570             };
571 0 0 0       confess "spi_query_prepared failed: $@\nStatement: $self->{Statement} with " . join(",", @param_values)
572             if $@ || !defined $self->{Cursor};
573              
574 0           return -1; # cannot get row count before fetching all rows
575             }
576              
577             }
578              
579              
580             sub fetchall_arrayref {
581 0     0     my $self = shift;
582 0           my $attr = shift;
583 0 0 0       carp "fetchall_arrayref() can return only array of hashes, use {} attribute"
584             unless defined $attr && ref $attr eq 'HASH';
585 0 0         if (defined (my $rv = $self->{Result})) {
    0          
586 0           $self->_convert_row($_) for @{$self->{Result}->{rows}};
  0            
587 0           return $rv->{rows};
588             }
589             elsif (defined $self->{Cursor}) {
590 0           my @result = ();
591 0 0         trace_msg("INFO", "fetch all rows by spi_fetchrow($self->{Plan})")
592             if trace_level >= 3;
593 0           while (defined (my $row = main::spi_fetchrow($self->{Cursor}))) {
594 0           $self->_convert_row($row);
595 0           push @result, $row;
596             }
597 0           return \@result;
598             }
599             else {
600 0 0         trace_msg("INFO", "fetch failed: no statement executing for $self->{Statement}")
601             if trace_level >= 3;
602             }
603             }
604              
605              
606             sub fetchrow_hashref {
607 0     0     my $self = shift;
608 0           my $result;
609 0 0         if (defined (my $rv = $self->{Result})) {
    0          
610 0           $result = $rv->{rows}->[ $self->{Pos}++ ];
611             }
612             elsif (defined $self->{Cursor}) {
613 0 0         trace_msg("INFO", " spi_fetchrow($self->{Cursor})")
614             if trace_level >= 4;
615 0           $result = main::spi_fetchrow($self->{Cursor});
616             }
617             else { # not error
618 0 0         trace_msg("WARNING", "fetch failed: no statement executing for $self->{Statement}")
619             if trace_level >= 4;
620             }
621 0 0         trace_msg("INFO", "fetchrow_hashref result:\n" . Dumper($result))
622             if trace_level >= 4;
623 0           $self->_convert_row($result);
624 0           return $result;
625             }
626              
627              
628             sub fetchrow_array {
629 0 0   0     confess "list context of fetchrow_array() does not implemented" if wantarray;
630 0           my $self = shift;
631 0           my $row = $self->fetchrow_hashref;
632 0 0         return defined $row ? (each %{$row})[1] : undef;
  0            
633             }
634              
635             1;
636              
637             __END__
638              
639             =head1 NAME
640              
641             DBIx::PgLink::Local - DBI emulation for local data access in PostgreSQL PL/Perl function
642              
643             =head1 SYNOPSIS
644              
645             I<PostgreSQL script>
646              
647             CREATE FUNCTION fn() RETURNS ... LANGUAGE plperlu AS $$
648              
649             ...
650              
651             use DBIx::PgLink::Local;
652              
653             $q = pg_dbh->prepare( q<SELECT 'Hello, ' || ? as foo> );
654             $q->execute("world");
655             while (my $row = $q->fetchrow_hashref) {
656             elog 'INFO', $row->{foo}; # prints 'Hello, world'
657             }
658              
659             ...
660              
661             $v = pg_dbh->selectrow_array(
662             'SELECT $1 * $1 as bar', # query string
663             { types=>['INT4'] } ), # attributes
664             3 # parameter values
665             );
666             elog 'INFO', $v; # prints '9'
667              
668             ...
669              
670             $$
671              
672             =head1 DESCRIPTION
673              
674             B<WARNING: this module works only in PostgreSQL functions written in I<PL/PerlU> language
675             in PostgreSQL server version 8.2 or higher.>
676              
677             DBIx::PgLink::Local is a wrapper around PL/Perl Server Programming Interface (SPI) functions.
678             Module provides only basic functions of L<DBI>.
679             For full DBI-compatible driver look at L<DBD::PgSPI>.
680              
681             Module manage prepared statements and cache query plans.
682             It is not depend on other L<DBIx::PgLink> code (except L<DBIx::PgLink::Logger>)
683             and can be used in any PL/Perl function.
684              
685             =head1 SUBROUTINES
686              
687             =over
688              
689             =item C<pg_dbh>
690              
691             Returns singleton instance of class DBIx::PgLink::Local. Exported by default.
692              
693             =back
694              
695              
696             =head1 METHODS
697              
698             =over
699              
700             =item C<quote>
701              
702             $sql = pg_dbh->quote($value);
703              
704             Quote a string literal for use as a literal value in an SQL statement,
705             by escaping single quote and backslash characters and adding the single quotes.
706              
707             =item C<quote_identifier>
708              
709             $sql = pg_dbh->quote_identifier( $name );
710             $sql = pg_dbh->quote_identifier( $schema, $object );
711              
712             Quote an identifier (table name etc.) for use in an SQL statement,
713             by escaping double quote and adding double quotes.
714              
715             =item C<prepare>
716              
717             $sth = pg_dbh->prepare($statement);
718             $sth = pg_dbh->prepare($statement, \%attr);
719              
720             Prepares a statement for later execution by the database
721             engine and returns a reference to a statement handle.
722             Statement handle is object containing query plan.
723              
724             Supports $n ("dollar sign numbers") and ? (question mark) placeholder styles.
725             $n-style is PostgreSQL default and preferred over quotation marks.
726              
727             Wrapped C<spi_prepare()> function cannot infer parameter data type from the context,
728             although SQL command C<PREPARE> can.
729             If no parameter types specified, C<prepare> implicitly detect placeholders
730             and assign 'TEXT' type to all of them.
731              
732             C<prepare> attributes:
733              
734             =over
735              
736             =item C<types>
737              
738             Supply explicit data type names for parameters in C<types> attribute as array-ref:
739              
740             $sth = pg_dbh->prepare(
741             'SELECT * FROM foo WHERE bar=$1 and baz=$2',
742             { types => [qw/TEXT INT4/] }
743             );
744              
745             Type names are case insensitive.
746             Examples: 'TEXT', 'INT4', 'INT8', 'FLOAT4', 'FLOAT8'.
747             In addition 'int', 'integer' are aliased to 'INT4', 'double' to 'FLOAT8'.
748              
749             B<Only "dollar sign number" placeholders can be used with explicit types.>
750              
751             See alse "Placeholders" in L<DBD::Pg>.
752              
753             =item C<boolean>
754              
755             Array-ref containing field names in result set with boolean type.
756             Converts PostgreSQL boolean values to Perl ('f' -> 0, 't' -> 1).
757              
758             Also accepted hashref with field name as key.
759              
760             =item C<array>
761              
762             Array-ref containing field names in result set with array type.
763             Converts PostgreSQL array values to Perl array.
764              
765             Also accepted hashref with field name as key.
766              
767             =item C<no_cursor>
768              
769             Boolean: do not create cursor and fetch all data at once.
770             Automatically set for any not SELECT/INSERT/UPDATE/DELETE query.
771              
772             =item C<no_cache>
773              
774             Boolean: do not save query plan.
775             Automatically set for any not SELECT/INSERT/UPDATE/DELETE query.
776              
777             =item C<no_parse>
778              
779             Boolean: make no attempt to find placeholders in query and replace '?' marks.
780             Automatically set for C<do> method with no parameter values.
781              
782             =back
783              
784             =item C<prepare_cached>
785              
786             $sth = pg_dbh->prepare_cached($statement);
787             $sth = pg_dbh->prepare_cached($statement, \%attr);
788              
789             Like L</prepare> except that the plan for statement will be
790             stored in a global (session) hash. If another call is made to
791             C<prepare_cached> with the same C<$query> value,
792             then the corresponding cached plan will be used.
793             B<Statement handles are not cached>, it is safe to mix
794             different C<prepare_cached> and C<execute> with the same query string.
795              
796             Cache is managed by LRU algorithm. Default cache size is 100.
797             Cache size can be configured via PostgreSQL run-time parameter B<plperl.plan_cache_size>.
798             See I<Customized Options> in PostgreSQL Manual for example how to enable I<plperl> custom variable class.
799              
800             =item C<do>
801              
802             $rows = pg_dbh->do($statement)
803             $rows = pg_dbh->do($statement, \%attr)
804             $rows = pg_dbh->do($statement, \%attr, @bind_values)
805              
806             Prepare and execute a single statement.
807             Returns the number of rows affected. Plan is cached.
808              
809             =item C<selectrow_array>
810              
811             $scalar = pg_dbh->selectall_arrayref($statement)
812             $scalar = pg_dbh->selectall_arrayref($statement, \%attr)
813             $scalar = pg_dbh->selectall_arrayref($statement, \%attr, @bind_values)
814              
815             This utility method combines C<prepare_cached>, C<execute> and C<fetchrow_hashref> into a single call.
816             In scalar context returns single value from first row of resultset.
817             If called for a statement handle that has more than one column, it is undefined whether column will be return.
818              
819             NOTE: in list context always dies, because of internal limitation.
820              
821              
822             =item C<selectrow_hashref>
823              
824             $hash_ref = $dbh->selectrow_hashref($statement);
825             $hash_ref = $dbh->selectrow_hashref($statement, \%attr);
826             $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values);
827              
828             This utility method combines C<prepare_cached>, C<execute> and C<fetchrow_hashref> into a single call.
829             It returns the first row of data from the statement.
830              
831             =item C<selectall_arrayref>
832              
833             $ary_ref = pg_dbh->selectall_arrayref($statement)
834             $ary_ref = pg_dbh->selectall_arrayref($statement, \%attr)
835             $ary_ref = pg_dbh->selectall_arrayref($statement, \%attr, @bind_values)
836              
837             This utility method combines C<prepare_cached>, C<execute> and C<fetchall_arrayref> into a single call.
838             It returns a reference to an array containing a reference to a hash for each row of data fetched.
839              
840             Note that unlike DBI C<selectall_arrayref> returns arrayref of B<hashes>.
841              
842             =item C<selectall_hashref>
843              
844             $hash_ref = pg_dbh->selectall_hashref($statement, $key_field)
845             $hash_ref = pg_dbh->selectall_hashref($statement, $key_field, \%attr)
846             $hash_ref = pg_dbh->selectall_hashref($statement, $key_field, \%attr, @bind_values)
847              
848             This utility method combines C<prepare_cached>, C<execute> and C<fetchrow_hashref> into a single call.
849             It returns a reference to a hash containing one entry, at most, for each row, as returned by fetchall_hashref().
850              
851             =back
852              
853             =head2 PostgreSQL-only methods
854              
855             =over
856              
857             =item C<pg_flush_plan_cache>
858              
859             pg_dbh->pg_flush_plan_cache;
860             pg_dbh->pg_flush_plan_cache($regex);
861              
862             Free all or selected prepared query plans from cache. Use after changing of database schema.
863              
864             =item C<pg_to_perl_array>
865              
866             @arr = pg_dbh->pg_to_perl_array('{1,2,3}');
867              
868             Convert text representation of PostgreSQL array to Perl array.
869              
870             =item C<pg_from_perl_array>
871              
872             $string = pg_dbh->pg_from_perl_array(1,2,3,undef,'hello');
873             # returns '{"1","2","3",NULL,"hello"}'
874              
875             Convert Perl array to PostgreSQL array literal.
876              
877             =item C<pg_to_perl_hash>
878              
879             $hashref = pg_dbh->pg_to_perl_hash('{foo,1,bar,2}');
880              
881             Convert text representation of PostgreSQL array to Perl hash.
882              
883             This method is particularly useful for PL/Perl array argument conversion,
884             for PL/Perl stringify it.
885              
886             =item C<pg_from_perl_hash>
887              
888             $string = pg_dbh->pg_from_perl_hash({foo=>1,bar=>2});
889             # returns '{foo,1,bar,2}'
890              
891             Convert Perl hash reference to PostgreSQL array literal.
892              
893             =item C<pg_to_perl_encoding>
894              
895             Convert name of PostgreSQL encoding to Perl encoding name. See L<Encode>.
896              
897             =item C<pg_server_version>
898              
899             Indicates which version of local PostgreSQL that hosts PL/Perl function.
900             Returns a number with major, minor, and revision together; version 8.2.5 would be 80205
901              
902             =item C<pg_current_database>
903              
904             Returns name of local database PostgreSQL that hosts PL/Perl function.
905              
906             =item C<pg_session_user>
907              
908             Returns PostgreSQL session user name.
909             See I<System Information Functions> chapter of PostgreSQL Manual.
910              
911             =back
912              
913              
914             =head1 STATEMENT METHODS
915              
916             =over
917              
918             =item C<execute>
919              
920             $q->execute;
921             $q->execute(@values);
922              
923             Execute prepared statement.
924              
925             When statement prepared with true value of C<no_cursor> attribute, all rows are fetched at once
926             (if it is data retrieving operation) and C<execute> returns number of proceeded rows.
927              
928             When attribute C<no_cursor> is not set, C<execute> open cursor and fetch row-by-row.
929             In this mode method always returns -1 because number of affected rows can not be known.
930              
931             Wrapper of C<spi_exec_prepared> / C<spi_query_prepared>.
932              
933             =item C<fetchrow_hashref>
934              
935             $hash_ref = $q->fetchrow_hashref;
936              
937             Fetches the next row of data and returns a reference to an hash
938             holding the field values.
939             If there are no more rows or if an error occurs, then C<fetchrow_hashref>
940             returns an C<undef>.
941              
942             =item C<fetchrow_array>
943              
944             $scalar = $q->fetchrow_array;
945              
946             Fetches the next row of data and return one field value.
947              
948             NOTE: in list context always dies, because of internal limitation.
949              
950             =item C<fetchall_arrayref>
951              
952             $row_aref = $q->fetchall_arrayref;
953              
954             The method can be used to fetch all the data to be returned
955             from a prepared and executed statement handle.
956             It returns a reference to an array that contains one reference per row.
957             Note that unlike DBI C<fetchall_arrayref> returns arrayref of B<hashes>.
958              
959             =item C<finish>
960              
961             $q->finish;
962              
963             Indicate that no more data will be fetched from this statement handle
964             before it is either executed again or destroyed.
965              
966             Wrapper of C<spi_cursor_close>.
967              
968             =back
969              
970              
971             =head1 CAVEATS
972              
973             =over
974              
975             =item *
976              
977             SQL parsing for parameters in C<prepare> is dumb.
978              
979             Use explicit types if query contains string like '$1' or '?'
980             in literal, identifier or comment.
981              
982             =item *
983              
984             Full set of selectI<XXX> and fetchI<XXX> methods is not implemented.
985              
986             In PL/Perl data access layer every data row (tuple) converted to hash,
987             and there is no easy way to restore original column order.
988              
989             =item *
990              
991             C<selectall_arrayref> and C<fetchall_arrayref> always returns reference to array of hashes
992              
993             =item *
994              
995             C<selectrow_array> and C<fetchrow_array> works in scalar context only.
996              
997             =item *
998              
999             Data fetching slower than PL/PGSQL.
1000              
1001             The tuple->hash conversion take extra time and memory.
1002              
1003             =item *
1004              
1005             No automatic plan invalidation.
1006              
1007             Use C<pg_flush_plan_cache> (or reconnect) after database schema changes.
1008              
1009             =item *
1010              
1011             Array conversion suppose that C<array_nulls> variable is ON.
1012              
1013             =item *
1014              
1015             Lot ot this module code will be obsolete when (and if) L<DBD::PgSPI>
1016             starts support real prepared statements.
1017              
1018             =back
1019              
1020              
1021             =head1 SEE ALSO
1022              
1023             L<DBI>, L<DBD::Pg>, L<Tie::Cache::LRU>, PostgreSQL Manual
1024              
1025              
1026             =head1 AUTHOR
1027              
1028             Alexey Sharafutdinov E<lt>alexey.s.v.br@gmail.comE<gt>
1029              
1030             =head1 LICENSE
1031              
1032             This library is free software; you can redistribute it and/or modify it under
1033             the same terms as Perl itself.
1034              
1035             =cut