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