[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package DBI::Gofer::Request; 2 3 # $Id: Request.pm 11424 2008-06-16 14:52:03Z timbo $ 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 use strict; 11 12 use DBI qw(neat neat_list); 13 14 use base qw(DBI::Util::_accessor); 15 16 our $VERSION = sprintf("0.%06d", q$Revision: 11424 $ =~ /(\d+)/o); 17 18 use constant GOf_REQUEST_IDEMPOTENT => 0x0001; 19 use constant GOf_REQUEST_READONLY => 0x0002; 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 my ($self, $args) = @_; 41 $args->{version} ||= $VERSION; 42 return $self->SUPER::new($args); 43 } 44 45 46 sub reset { 47 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 ); 53 $self->{flags} = $flags if $flags; 54 } 55 56 57 sub init_request { 58 my ($self, $method_and_args, $dbh) = @_; 59 $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 ); 60 $self->dbh_method_call($method_and_args); 61 } 62 63 64 sub is_sth_request { 65 return shift->{sth_result_attr}; 66 } 67 68 69 sub statements { 70 my $self = shift; 71 my @statements; 72 my $statement_method_regex = qr/^(?:do|prepare)$/; 73 if (my $dbh_method_call = $self->dbh_method_call) { 74 my (undef, $method, $arg1) = @$dbh_method_call; 75 push @statements, $arg1 if $method =~ $statement_method_regex; 76 } 77 return @statements; 78 } 79 80 81 sub is_idempotent { 82 my $self = shift; 83 84 if (my $flags = $self->flags) { 85 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 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 m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi 95 } @statements; 96 97 return 0; 98 } 99 100 101 sub summary_as_text { 102 my $self = shift; 103 my ($context) = @_; 104 my @s = ''; 105 106 if ($context && %$context) { 107 my @keys = sort keys %$context; 108 push @s, join(", ", map { "$_=>".$context->{$_} } @keys); 109 } 110 111 my ($method, $dsn, $user, $pass, $attr) = @{ $self->dbh_connect_call }; 112 $method ||= 'connect_cached'; 113 $pass = '***' if defined $pass; 114 my $tmp = ''; 115 if ($attr) { 116 $tmp = { %{$attr||{}} }; # copy so we can edit 117 $tmp->{Password} = '***' if exists $tmp->{Password}; 118 $tmp = "{ ".neat_list([ %$tmp ])." }"; 119 } 120 push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]), $tmp; 121 122 if (my $flags = $self->flags) { 123 push @s, sprintf "flags: 0x%x", $flags; 124 } 125 126 if (my $dbh_attr = $self->dbh_attributes) { 127 push @s, sprintf "dbh->FETCH: %s", @$dbh_attr 128 if @$dbh_attr; 129 } 130 131 my ($wantarray, $meth, @args) = @{ $self->dbh_method_call }; 132 my $args = neat_list(\@args); 133 $args =~ s/\n+/ /g; 134 push @s, sprintf "dbh->%s(%s)", $meth, $args; 135 136 if (my $lii_args = $self->dbh_last_insert_id_args) { 137 push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args); 138 } 139 140 for my $call (@{ $self->sth_method_calls || [] }) { 141 my ($meth, @args) = @$call; 142 ($args = neat_list(\@args)) =~ s/\n+/ /g; 143 push @s, sprintf "sth->%s(%s)", $meth, $args; 144 } 145 146 if (my $sth_attr = $self->sth_result_attr) { 147 push @s, sprintf "sth->FETCH: %s", %$sth_attr 148 if %$sth_attr; 149 } 150 151 return join("\n\t", @s) . "\n"; 152 } 153 154 155 sub outline_as_text { # one-line version of summary_as_text 156 my $self = shift; 157 my @s = ''; 158 my $neatlen = 80; 159 160 if (my $flags = $self->flags) { 161 push @s, sprintf "flags=0x%x", $flags; 162 } 163 164 my (undef, $meth, @args) = @{ $self->dbh_method_call }; 165 push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); 166 167 for my $call (@{ $self->sth_method_calls || [] }) { 168 my ($meth, @args) = @$call; 169 push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); 170 } 171 172 my ($method, $dsn) = @{ $self->dbh_connect_call }; 173 push @s, "$method($dsn,...)"; # dsn last as it's usually less interesting 174 175 (my $outline = join("; ", @s)) =~ s/\s+/ /g; # squish whitespace, incl newlines 176 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<http://www.tim.bunce.name> 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<perlartistic>. 199 200 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |