[ 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/ -> Response.pm (source)

   1  package DBI::Gofer::Response;
   2  
   3  #   $Id: Response.pm 11565 2008-07-22 20:17:33Z 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 Carp;
  13  use DBI qw(neat neat_list);
  14  
  15  use base qw(DBI::Util::_accessor Exporter);
  16  
  17  our $VERSION = sprintf("0.%06d", q$Revision: 11565 $ =~ /(\d+)/o);
  18  
  19  use constant GOf_RESPONSE_EXECUTED => 0x0001;
  20  
  21  our @EXPORT = qw(GOf_RESPONSE_EXECUTED);
  22  
  23  
  24  __PACKAGE__->mk_accessors(qw(
  25      version
  26      rv
  27      err
  28      errstr
  29      state
  30      flags
  31      last_insert_id
  32      dbh_attributes
  33      sth_resultsets
  34      warnings
  35  ));
  36  __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
  37      meta
  38  ));
  39  
  40  
  41  sub new {
  42      my ($self, $args) = @_;
  43      $args->{version} ||= $VERSION;
  44      chomp $args->{errstr} if $args->{errstr};
  45      return $self->SUPER::new($args);
  46  }   
  47  
  48  
  49  sub err_errstr_state {
  50      my $self = shift;
  51      return @{$self}{qw(err errstr state)};
  52  }
  53  
  54  sub executed_flag_set {
  55      my $flags = shift->flags
  56          or return 0;
  57      return $flags & GOf_RESPONSE_EXECUTED;
  58  }
  59  
  60  
  61  sub add_err {
  62      my ($self, $err, $errstr, $state, $trace) = @_;
  63  
  64      # acts like the DBI's set_err method.
  65      # this code copied from DBI::PurePerl's set_err method.
  66  
  67      chomp $errstr if $errstr;
  68      $state ||= '';
  69      carp ref($self)."->add_err($err, $errstr, $state)"
  70          if $trace and defined($err) || $errstr;
  71  
  72      my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr}, $self->{state});
  73  
  74      if ($r_errstr) {
  75          $r_errstr .= sprintf " [err was %s now %s]", $r_err, $err
  76                  if $r_err && $err && $r_err ne $err;
  77          $r_errstr .= sprintf " [state was %s now %s]", $r_state, $state
  78                  if $r_state and $r_state ne "S1000" && $state && $r_state ne $state;
  79          $r_errstr .= "\n$errstr" if $r_errstr ne $errstr;
  80      }   
  81      else { 
  82          $r_errstr = $errstr;
  83      }
  84  
  85      # assign if higher priority: err > "0" > "" > undef
  86      my $err_changed;
  87      if ($err                 # new error: so assign
  88          or !defined $r_err   # no existing warn/info: so assign
  89             # new warn ("0" len 1) > info ("" len 0): so assign
  90          or defined $err && length($err) > length($r_err)
  91      ) {
  92          $r_err = $err;
  93          ++$err_changed;
  94      }
  95  
  96      $r_state = ($state eq "00000") ? "" : $state
  97          if $state && $err_changed;
  98  
  99      ($self->{err}, $self->{errstr}, $self->{state}) = ($r_err, $r_errstr, $r_state);
 100  
 101      return undef;
 102  }
 103  
 104  
 105  sub summary_as_text {
 106      my $self = shift;
 107      my ($context) = @_;
 108  
 109      my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state});
 110  
 111      my @s = sprintf("\trv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
 112      $s[-1] .= sprintf(", err=%s, errstr=%s", $err, neat($errstr))
 113          if defined $err;
 114      $s[-1] .= sprintf(",  flags=0x%x", $self->{flags})
 115          if defined $self->{flags};
 116  
 117      push @s, "last_insert_id=%s", $self->last_insert_id
 118          if defined $self->last_insert_id;
 119  
 120      if (my $dbh_attr = $self->dbh_attributes) {
 121          my @keys = sort keys %$dbh_attr;
 122          push @s, sprintf "dbh= { %s }", join(", ", map { "$_=>".neat($dbh_attr->{$_},100) } @keys)
 123              if @keys;
 124      }   
 125  
 126      for my $rs (@{$self->sth_resultsets || []}) {
 127          my ($rowset, $err, $errstr, $state)
 128              = @{$rs}{qw(rowset err errstr state)};
 129          my $summary = "rowset: ";
 130          my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0;
 131          my $rows = $rowset ? @$rowset : 0;
 132          if ($rowset || $NUM_OF_FIELDS > 0) {
 133              $summary .= sprintf "%d rows, %d columns", $rows, $NUM_OF_FIELDS;
 134          }
 135          $summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if defined $err;
 136          if ($rows) {
 137              my $NAME = $rs->{NAME};
 138              # generate 
 139              my @colinfo = map { "$NAME->[$_]=".neat($rowset->[0][$_], 30) } 0..@{$NAME}-1;
 140              $summary .= sprintf " [%s]", join ", ", @colinfo;
 141              $summary .= ",..." if $rows > 1;
 142              # we can be a little more helpful for Sybase/MSSQL user
 143              $summary .= " syb_result_type=$rs->{syb_result_type}"
 144                  if $rs->{syb_result_type} and $rs->{syb_result_type} != 4040;
 145          }
 146          push @s, $summary;
 147      }
 148      for my $w (@{$self->warnings || []}) {
 149          chomp $w;
 150          push @s, "warning: $w";
 151      }
 152      if ($context && %$context) { 
 153          my @keys = sort keys %$context;
 154          push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
 155      }       
 156      return join("\n\t", @s). "\n";
 157  }
 158  
 159  
 160  sub outline_as_text { # one-line version of summary_as_text
 161      my $self = shift;
 162      my ($context) = @_;
 163  
 164      my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state});
 165  
 166      my $s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
 167      $s .= sprintf(", err=%s %s", $err, neat($errstr))
 168          if defined $err;
 169      $s .= sprintf(", flags=0x%x", $self->{flags})
 170          if $self->{flags};
 171  
 172      if (my $sth_resultsets = $self->sth_resultsets) {
 173          $s .= sprintf(", %d resultsets ", scalar @$sth_resultsets);
 174  
 175          my @rs;
 176          for my $rs (@{$self->sth_resultsets || []}) {
 177              my $summary = "";
 178              my ($rowset, $err, $errstr)
 179                  = @{$rs}{qw(rowset err errstr)};
 180              my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0;
 181              my $rows = $rowset ? @$rowset : 0;
 182              if ($rowset || $NUM_OF_FIELDS > 0) {
 183                  $summary .= sprintf "%dr x %dc", $rows, $NUM_OF_FIELDS;
 184              }
 185              $summary .= sprintf "%serr %s %s", ($summary?", ":""), $err, neat($errstr)
 186                  if defined $err;
 187              push @rs, $summary;
 188          }
 189          $s .= join "; ", map { "[$_]" } @rs;
 190      }
 191  
 192      return $s;
 193  }
 194  
 195  
 196  1;
 197  
 198  =head1 NAME
 199  
 200  DBI::Gofer::Response - Encapsulate a response from DBI::Gofer::Execute to DBD::Gofer
 201  
 202  =head1 DESCRIPTION
 203  
 204  This is an internal class.
 205  
 206  =head1 AUTHOR
 207  
 208  Tim Bunce, L<http://www.tim.bunce.name>
 209  
 210  =head1 LICENCE AND COPYRIGHT
 211  
 212  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
 213  
 214  This module is free software; you can redistribute it and/or
 215  modify it under the same terms as Perl itself. See L<perlartistic>.
 216  
 217  =cut
 218  


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