[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/site_perl/5.10.0/i586-linux-thread-multi/DBI/Gofer/ -> Request.pm (source)

   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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1