[Summary view] [Print] [Text view]

   1  {
   2      package DBD::NullP;
   3  
   4      require DBI;
   5      require Carp;
   6  
   7      @EXPORT = qw(); # Do NOT @EXPORT anything.
   8      $VERSION = sprintf("12.%06d", q$Revision: 9215 $ =~ /(\d+)/o);
   9  
  10  #   $Id: NullP.pm 9215 2007-03-08 17:03:58Z timbo $
  11  #
  12  #   Copyright (c) 1994-2007 Tim Bunce
  13  #
  14  #   You may distribute under the terms of either the GNU General Public
  15  #   License or the Artistic License, as specified in the Perl README file.
  16  
  17      $drh = undef;    # holds driver handle once initialised
  18  
  19      sub driver{
  20      return $drh if $drh;
  21      my($class, $attr) = @_;
  22      $class .= "::dr";
  23      ($drh) = DBI::_new_drh($class, {
  24          'Name' => 'NullP',
  25          'Version' => $VERSION,
  26          'Attribution' => 'DBD Example Null Perl stub by Tim Bunce',
  27          }, [ qw'example implementors private data']);
  28      $drh;
  29      }
  30  
  31      sub CLONE {
  32          undef $drh;
  33      }
  34  }
  35  
  36  
  37  {   package DBD::NullP::dr; # ====== DRIVER ======
  38      $imp_data_size = 0;
  39      use strict;
  40  
  41      sub connect { # normally overridden, but a handy default
  42          my $dbh = shift->SUPER::connect(@_)
  43              or return;
  44          $dbh->STORE(Active => 1); 
  45          $dbh;
  46      }
  47  
  48  
  49      sub DESTROY { undef }
  50  }
  51  
  52  
  53  {   package DBD::NullP::db; # ====== DATABASE ======
  54      $imp_data_size = 0;
  55      use strict;
  56      use Carp qw(croak);
  57  
  58      sub prepare {
  59      my ($dbh, $statement)= @_;
  60  
  61      my ($outer, $sth) = DBI::_new_sth($dbh, {
  62          'Statement'     => $statement,
  63          });
  64  
  65      return $outer;
  66      }
  67  
  68      sub FETCH {
  69      my ($dbh, $attrib) = @_;
  70      # In reality this would interrogate the database engine to
  71      # either return dynamic values that cannot be precomputed
  72      # or fetch and cache attribute values too expensive to prefetch.
  73      return $dbh->SUPER::FETCH($attrib);
  74      }
  75  
  76      sub STORE {
  77      my ($dbh, $attrib, $value) = @_;
  78      # would normally validate and only store known attributes
  79      # else pass up to DBI to handle
  80      if ($attrib eq 'AutoCommit') {
  81          Carp::croak("Can't disable AutoCommit") unless $value;
  82              # convert AutoCommit values to magic ones to let DBI
  83              # know that the driver has 'handled' the AutoCommit attribute
  84              $value = ($value) ? -901 : -900;
  85      }
  86      return $dbh->SUPER::STORE($attrib, $value);
  87      }
  88  
  89      sub ping { 1 }
  90  
  91      sub disconnect {
  92      shift->STORE(Active => 0);
  93      }
  94  
  95  }
  96  
  97  
  98  {   package DBD::NullP::st; # ====== STATEMENT ======
  99      $imp_data_size = 0;
 100      use strict;
 101  
 102      sub bind_param {
 103          my ($sth, $param, $value, $attr) = @_;
 104          $sth->{ParamValues}{$param} = $value;
 105          $sth->{ParamAttr}{$param}   = $attr
 106              if defined $attr; # attr is sticky if not explicitly set
 107          return 1;
 108      }       
 109  
 110      sub execute {
 111      my $sth = shift;
 112          $sth->bind_param($_, $_[$_-1]) for (1..@_);
 113          if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) {
 114              $sth->STORE(NUM_OF_FIELDS => 1); 
 115              $sth->{NAME} = [ "fieldname" ];
 116              # just for the sake of returning something, we return the params
 117              my $params = $sth->{ParamValues} || {};
 118              $sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ];
 119              $sth->STORE(Active => 1); 
 120          }
 121      1;
 122      }
 123  
 124      sub fetchrow_arrayref {
 125      my $sth = shift;
 126      my $data = $sth->{dbd_nullp_data};
 127          if (!$data || !@$data) {
 128              $sth->finish;     # no more data so finish
 129              return undef;
 130      }
 131          return $sth->_set_fbav(shift @$data);
 132      }
 133      *fetch = \&fetchrow_arrayref; # alias
 134  
 135      sub FETCH {
 136      my ($sth, $attrib) = @_;
 137      # would normally validate and only fetch known attributes
 138      # else pass up to DBI to handle
 139      return $sth->SUPER::FETCH($attrib);
 140      }
 141  
 142      sub STORE {
 143      my ($sth, $attrib, $value) = @_;
 144      # would normally validate and only store known attributes
 145      # else pass up to DBI to handle
 146      return $sth->SUPER::STORE($attrib, $value);
 147      }
 148  
 149  }
 150  
 151  1;