File Coverage

blib/lib/DBI/Gofer/Request.pm
Criterion Covered Total %
statement 39 93 41.9
branch 14 44 31.8
condition 3 11 27.2
subroutine 11 13 84.6
pod 0 8 0.0
total 67 169 39.6


line stmt bran cond sub pod time code
1             package DBI::Gofer::Request;
2              
3             # $Id: Request.pm 12536 2009-02-24 22:37:09Z Tim $
4             #
5             # Copyright (c) 2007, Tim Bunce, Ireland
6             #
7             # You may distribute under the terms of either the GNU General Public
8             # License or the Artistic License, as specified in the Perl README file.
9              
10 56     56   400 use strict;
  56         128  
  56         1793  
11              
12 56     56   285 use DBI qw(neat neat_list);
  56         106  
  56         5569  
13              
14 56     56   382 use base qw(DBI::Util::_accessor);
  56         158  
  56         22737  
15              
16             our $VERSION = "0.012537";
17              
18 56     56   424 use constant GOf_REQUEST_IDEMPOTENT => 0x0001;
  56         107  
  56         4551  
19 56     56   336 use constant GOf_REQUEST_READONLY => 0x0002;
  56         109  
  56         61751  
20              
21             our @EXPORT = qw(GOf_REQUEST_IDEMPOTENT GOf_REQUEST_READONLY);
22              
23              
24             __PACKAGE__->mk_accessors(qw(
25             version
26             flags
27             dbh_connect_call
28             dbh_method_call
29             dbh_attributes
30             dbh_last_insert_id_args
31             sth_method_calls
32             sth_result_attr
33             ));
34             __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
35             meta
36             ));
37              
38              
39             sub new {
40 715     715 0 2328 my ($self, $args) = @_;
41 715   33     4968 $args->{version} ||= $VERSION;
42 715         3106 return $self->SUPER::new($args);
43             }
44              
45              
46             sub reset {
47 7138     7138 0 13939 my ($self, $flags) = @_;
48             # remove everything except connect and version
49             %$self = (
50             version => $self->{version},
51             dbh_connect_call => $self->{dbh_connect_call},
52 7138         45648 );
53 7138 100       20789 $self->{flags} = $flags if $flags;
54             }
55              
56              
57             sub init_request {
58 7138     7138 0 21286 my ($self, $method_and_args, $dbh) = @_;
59 7138 100       31496 $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 );
60 7138         26626 $self->dbh_method_call($method_and_args);
61             }
62              
63              
64             sub is_sth_request {
65 6454     6454 0 25381 return shift->{sth_result_attr};
66             }
67              
68              
69             sub statements {
70 328     328 0 505 my $self = shift;
71 328         465 my @statements;
72 328 50       747 if (my $dbh_method_call = $self->dbh_method_call) {
73 328         1316 my $statement_method_regex = qr/^(?:do|prepare)$/;
74 328         1037 my (undef, $method, $arg1) = @$dbh_method_call;
75 328 100 66     3553 push @statements, $arg1 if $method && $method =~ $statement_method_regex;
76             }
77 328         990 return @statements;
78             }
79              
80              
81             sub is_idempotent {
82 418     418 0 1047 my $self = shift;
83              
84 418 100       1053 if (my $flags = $self->flags) {
85 90 50       255 return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY);
86             }
87              
88             # else check if all statements are SELECT statement that don't include FOR UPDATE
89 328         760 my @statements = $self->statements;
90             # XXX this is very minimal for now, doesn't even allow comments before the select
91             # (and can't ever work for "exec stored_procedure_name" kinds of statements)
92             # XXX it also doesn't deal with multiple statements: prepare("select foo; update bar")
93             return 1 if @statements == grep {
94 328 100       925 m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi
  270 100       1953  
95             } @statements;
96              
97 226         582 return 0;
98             }
99              
100              
101             sub summary_as_text {
102 0     0 0   my $self = shift;
103 0           my ($context) = @_;
104 0           my @s = '';
105              
106 0 0 0       if ($context && %$context) {
107 0           my @keys = sort keys %$context;
108 0           push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
  0            
109             }
110              
111 0           my ($method, $dsn, $user, $pass, $attr) = @{ $self->dbh_connect_call };
  0            
112 0   0       $method ||= 'connect_cached';
113 0 0         $pass = '***' if defined $pass;
114 0           my $tmp = '';
115 0 0         if ($attr) {
116 0 0         $tmp = { %{$attr||{}} }; # copy so we can edit
  0            
117 0 0         $tmp->{Password} = '***' if exists $tmp->{Password};
118 0           $tmp = "{ ".neat_list([ %$tmp ])." }";
119             }
120 0           push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]), $tmp;
121              
122 0 0         if (my $flags = $self->flags) {
123 0           push @s, sprintf "flags: 0x%x", $flags;
124             }
125              
126 0 0         if (my $dbh_attr = $self->dbh_attributes) {
127 0 0         push @s, sprintf "dbh->FETCH: %s", @$dbh_attr
128             if @$dbh_attr;
129             }
130              
131 0           my ($wantarray, $meth, @args) = @{ $self->dbh_method_call };
  0            
132 0           my $args = neat_list(\@args);
133 0           $args =~ s/\n+/ /g;
134 0           push @s, sprintf "dbh->%s(%s)", $meth, $args;
135              
136 0 0         if (my $lii_args = $self->dbh_last_insert_id_args) {
137 0           push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args);
138             }
139              
140 0 0         for my $call (@{ $self->sth_method_calls || [] }) {
  0            
141 0           my ($meth, @args) = @$call;
142 0           ($args = neat_list(\@args)) =~ s/\n+/ /g;
143 0           push @s, sprintf "sth->%s(%s)", $meth, $args;
144             }
145              
146 0 0         if (my $sth_attr = $self->sth_result_attr) {
147 0 0         push @s, sprintf "sth->FETCH: %s", %$sth_attr
148             if %$sth_attr;
149             }
150              
151 0           return join("\n\t", @s) . "\n";
152             }
153              
154              
155             sub outline_as_text { # one-line version of summary_as_text
156 0     0 0   my $self = shift;
157 0           my @s = '';
158 0           my $neatlen = 80;
159              
160 0 0         if (my $flags = $self->flags) {
161 0           push @s, sprintf "flags=0x%x", $flags;
162             }
163              
164 0           my (undef, $meth, @args) = @{ $self->dbh_method_call };
  0            
165 0           push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen);
166              
167 0 0         for my $call (@{ $self->sth_method_calls || [] }) {
  0            
168 0           my ($meth, @args) = @$call;
169 0           push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen);
170             }
171              
172 0           my ($method, $dsn) = @{ $self->dbh_connect_call };
  0            
173 0           push @s, "$method($dsn,...)"; # dsn last as it's usually less interesting
174              
175 0           (my $outline = join("; ", @s)) =~ s/\s+/ /g; # squish whitespace, incl newlines
176 0           return $outline;
177             }
178              
179             1;
180              
181             =head1 NAME
182              
183             DBI::Gofer::Request - Encapsulate a request from DBD::Gofer to DBI::Gofer::Execute
184              
185             =head1 DESCRIPTION
186              
187             This is an internal class.
188              
189             =head1 AUTHOR
190              
191             Tim Bunce, L
192              
193             =head1 LICENCE AND COPYRIGHT
194              
195             Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
196              
197             This module is free software; you can redistribute it and/or
198             modify it under the same terms as Perl itself. See L.
199              
200             =cut