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

   1  {
   2      package DBD::Sponge;
   3  
   4      require DBI;
   5      require Carp;
   6  
   7      our @EXPORT = qw(); # Do NOT @EXPORT anything.
   8      our $VERSION = sprintf("12.%06d", q$Revision: 10002 $ =~ /(\d+)/o);
   9  
  10  
  11  #   $Id: Sponge.pm 10002 2007-09-26 21:03:25Z timbo $
  12  #
  13  #   Copyright (c) 1994-2003 Tim Bunce Ireland
  14  #
  15  #   You may distribute under the terms of either the GNU General Public
  16  #   License or the Artistic License, as specified in the Perl README file.
  17  
  18      $drh = undef;    # holds driver handle once initialised
  19      my $methods_already_installed;
  20  
  21      sub driver{
  22      return $drh if $drh;
  23  
  24      DBD::Sponge::db->install_method("sponge_test_installed_method")
  25          unless $methods_already_installed++;
  26  
  27      my($class, $attr) = @_;
  28      $class .= "::dr";
  29      ($drh) = DBI::_new_drh($class, {
  30          'Name' => 'Sponge',
  31          'Version' => $VERSION,
  32          'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce",
  33          });
  34      $drh;
  35      }
  36  
  37      sub CLONE {
  38          undef $drh;
  39      }
  40  }
  41  
  42  
  43  {   package DBD::Sponge::dr; # ====== DRIVER ======
  44      $imp_data_size = 0;
  45      # we use default (dummy) connect method
  46  }
  47  
  48  
  49  {   package DBD::Sponge::db; # ====== DATABASE ======
  50      $imp_data_size = 0;
  51      use strict;
  52  
  53      sub prepare {
  54      my($dbh, $statement, $attribs) = @_;
  55      my $rows = delete $attribs->{'rows'}
  56          or return $dbh->set_err($DBI::stderr,"No rows attribute supplied to prepare");
  57      my ($outer, $sth) = DBI::_new_sth($dbh, {
  58          'Statement'   => $statement,
  59          'rows'        => $rows,
  60          (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () }
  61          qw(execute_hook)
  62          ),
  63      });
  64      if (my $behave_like = $attribs->{behave_like}) {
  65          $outer->{$_} = $behave_like->{$_}
  66          foreach (qw(RaiseError PrintError HandleError ShowErrorStatement));
  67      }
  68  
  69      if ($statement =~ /^\s*insert\b/) {    # very basic, just for testing execute_array()
  70          $sth->{is_insert} = 1;
  71          my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS}
  72          or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement");
  73          $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} );
  74      }
  75      else {    #assume select
  76  
  77          # we need to set NUM_OF_FIELDS
  78          my $numFields;
  79          if ($attribs->{'NUM_OF_FIELDS'}) {
  80          $numFields = $attribs->{'NUM_OF_FIELDS'};
  81          } elsif ($attribs->{'NAME'}) {
  82          $numFields = @{$attribs->{NAME}};
  83          } elsif ($attribs->{'TYPE'}) {
  84          $numFields = @{$attribs->{TYPE}};
  85          } elsif (my $firstrow = $rows->[0]) {
  86          $numFields = scalar @$firstrow;
  87          } else {
  88          return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS');
  89          }
  90          $sth->STORE('NUM_OF_FIELDS' => $numFields);
  91          $sth->{NAME} = $attribs->{NAME}
  92              || [ map { "col$_" } 1..$numFields ];
  93          $sth->{TYPE} = $attribs->{TYPE}
  94              || [ (DBI::SQL_VARCHAR()) x $numFields ];
  95          $sth->{PRECISION} = $attribs->{PRECISION}
  96              || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ];
  97          $sth->{SCALE} = $attribs->{SCALE}
  98              || [ (0) x $numFields ];
  99          $sth->{NULLABLE} = $attribs->{NULLABLE}
 100              || [ (2) x $numFields ];
 101      }
 102  
 103      $outer;
 104      }
 105  
 106      sub type_info_all {
 107      my ($dbh) = @_;
 108      my $ti = [
 109          {    TYPE_NAME    => 0,
 110          DATA_TYPE    => 1,
 111          PRECISION    => 2,
 112          LITERAL_PREFIX    => 3,
 113          LITERAL_SUFFIX    => 4,
 114          CREATE_PARAMS    => 5,
 115          NULLABLE    => 6,
 116          CASE_SENSITIVE    => 7,
 117          SEARCHABLE    => 8,
 118          UNSIGNED_ATTRIBUTE=> 9,
 119          MONEY        => 10,
 120          AUTO_INCREMENT    => 11,
 121          LOCAL_TYPE_NAME    => 12,
 122          MINIMUM_SCALE    => 13,
 123          MAXIMUM_SCALE    => 14,
 124          },
 125          [ 'VARCHAR', DBI::SQL_VARCHAR(), undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ],
 126      ];
 127      return $ti;
 128      }
 129  
 130      sub FETCH {
 131          my ($dbh, $attrib) = @_;
 132          # In reality this would interrogate the database engine to
 133          # either return dynamic values that cannot be precomputed
 134          # or fetch and cache attribute values too expensive to prefetch.
 135          return 1 if $attrib eq 'AutoCommit';
 136          # else pass up to DBI to handle
 137          return $dbh->SUPER::FETCH($attrib);
 138      }
 139  
 140      sub STORE {
 141          my ($dbh, $attrib, $value) = @_;
 142          # would normally validate and only store known attributes
 143          # else pass up to DBI to handle
 144          if ($attrib eq 'AutoCommit') {
 145              return 1 if $value; # is already set
 146              Carp::croak("Can't disable AutoCommit");
 147          }
 148          return $dbh->SUPER::STORE($attrib, $value);
 149      }
 150  
 151      sub sponge_test_installed_method {
 152      my ($dbh, @args) = @_;
 153      return $dbh->set_err(42, "not enough parameters") unless @args >= 2;
 154      return \@args;
 155      }
 156  }
 157  
 158  
 159  {   package DBD::Sponge::st; # ====== STATEMENT ======
 160      $imp_data_size = 0;
 161      use strict;
 162  
 163      sub execute {
 164      my $sth = shift;
 165  
 166          # hack to support ParamValues (when not using bind_param)
 167          $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef;
 168  
 169      if (my $hook = $sth->{execute_hook}) {
 170          &$hook($sth, @_) or return;
 171      }
 172  
 173      if ($sth->{is_insert}) {
 174          my $row;
 175          $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ;
 176          my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS};
 177          return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected")
 178          if @$row != $NUM_OF_PARAMS;
 179          { local $^W; $sth->trace_msg("inserting (@$row)\n"); }
 180          push @{ $sth->{rows} }, $row;
 181      }
 182      else {    # mark select sth as Active
 183          $sth->STORE(Active => 1);
 184      }
 185      # else do nothing for select as data is already in $sth->{rows}
 186      return 1;
 187      }
 188  
 189      sub fetch {
 190      my ($sth) = @_;
 191      my $row = shift @{$sth->{'rows'}};
 192      unless ($row) {
 193          $sth->STORE(Active => 0);
 194          return undef;
 195      }
 196      return $sth->_set_fbav($row);
 197      }
 198      *fetchrow_arrayref = \&fetch;
 199  
 200      sub FETCH {
 201      my ($sth, $attrib) = @_;
 202      # would normally validate and only fetch known attributes
 203      # else pass up to DBI to handle
 204      return $sth->SUPER::FETCH($attrib);
 205      }
 206  
 207      sub STORE {
 208      my ($sth, $attrib, $value) = @_;
 209      # would normally validate and only store known attributes
 210      # else pass up to DBI to handle
 211      return $sth->SUPER::STORE($attrib, $value);
 212      }
 213  }
 214  
 215  1;
 216  
 217  __END__ 
 218  
 219  =pod
 220  
 221  =head1 NAME
 222  
 223  DBD::Sponge - Create a DBI statement handle from Perl data
 224  
 225  =head1 SYNOPSIS
 226  
 227    my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
 228    my $sth = $sponge->prepare($statement, {
 229            rows => $data,
 230            NAME => $names,
 231            %attr
 232        }
 233    );
 234  
 235  =head1 DESCRIPTION
 236  
 237  DBD::Sponge is useful for making a Perl data structure accessible through a
 238  standard DBI statement handle. This may be useful to DBD module authors who
 239  need to transform data in this way.
 240  
 241  =head1 METHODS
 242  
 243  =head2 connect()
 244  
 245    my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
 246  
 247  Here's a sample syntax for creating a database handle for the Sponge driver.
 248  No username and password are needed.
 249  
 250  =head2 prepare()
 251  
 252    my $sth = $sponge->prepare($statement, {
 253            rows => $data,
 254            NAME => $names,
 255            %attr
 256        }
 257    );
 258  
 259  =over 4
 260  
 261  =item *
 262  
 263  The C<$statement> here is an arbitrary statement or name you want
 264  to provide as identity of your data. If you're using DBI::Profile
 265  it will appear in the profile data.
 266  
 267  Generally it's expected that you are preparing a statement handle
 268  as if a C<select> statement happened.
 269  
 270  =item *
 271  
 272  C<$data> is a reference to the data you are providing, given as an array of arrays.
 273  
 274  =item *
 275  
 276  C<$names> is a reference an array of column names for the C<$data> you are providing.
 277  The number and order should match the number and ordering of the C<$data> columns. 
 278  
 279  =item *
 280  
 281  C<%attr> is a hash of other standard DBI attributes that you might pass to a prepare statement.
 282  
 283  Currently only NAME, TYPE, and PRECISION are supported.
 284  
 285  =back
 286  
 287  =head1 BUGS
 288  
 289  Using this module to prepare INSERT-like statements is not currently documented.
 290  
 291  =head1 AUTHOR AND COPYRIGHT
 292  
 293  This module is Copyright (c) 2003 Tim Bunce
 294  
 295  Documentation initially written by Mark Stosberg
 296  
 297  The DBD::Sponge module is free software; you can redistribute it and/or
 298  modify it under the same terms as Perl itself. In particular permission
 299  is granted to Tim Bunce for distributing this as a part of the DBI.
 300  
 301  =head1 SEE ALSO
 302  
 303  L<DBI>
 304  
 305  =cut


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