home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Sponge.pm < prev    next >
Encoding:
Text File  |  2004-06-27  |  7.9 KB  |  302 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.     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(1,"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(1,"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(1, '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.     if (my $hook = $sth->{execute_hook}) {
  166.         &$hook($sth, @_) or return;
  167.     }
  168.  
  169.     if ($sth->{is_insert}) {
  170.         my $row;
  171.         $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ;
  172.         my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS};
  173.         return $sth->set_err(1, @$row." values bound (@$row) but $NUM_OF_PARAMS expected")
  174.         if @$row != $NUM_OF_PARAMS;
  175.         { local $^W; $sth->trace_msg("inserting (@$row)\n"); }
  176.         push @{ $sth->{rows} }, $row;
  177.     }
  178.     else {    # mark select sth as Active
  179.         $sth->STORE(Active => 1);
  180.     }
  181.     # else do nothing for select as data is already in $sth->{rows}
  182.     return 1;
  183.     }
  184.  
  185.     sub fetch {
  186.     my ($sth) = @_;
  187.     my $row = shift @{$sth->{'rows'}};
  188.     unless ($row) {
  189.         $sth->STORE(Active => 0);
  190.         return undef;
  191.     }
  192.     return $sth->_set_fbav($row);
  193.     }
  194.     *fetchrow_arrayref = \&fetch;
  195.  
  196.     sub FETCH {
  197.     my ($sth, $attrib) = @_;
  198.     # would normally validate and only fetch known attributes
  199.     # else pass up to DBI to handle
  200.     return $sth->SUPER::FETCH($attrib);
  201.     }
  202.  
  203.     sub STORE {
  204.     my ($sth, $attrib, $value) = @_;
  205.     # would normally validate and only store known attributes
  206.     # else pass up to DBI to handle
  207.     return $sth->SUPER::STORE($attrib, $value);
  208.     }
  209. }
  210.  
  211. 1;
  212.  
  213. __END__ 
  214.  
  215. =pod
  216.  
  217. =head1 NAME
  218.  
  219. DBD::Sponge - Create a DBI statement handle from Perl data
  220.  
  221. =head1 SYNOPSIS
  222.  
  223.   my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
  224.   my $sth = $sponge->prepare($statement, {
  225.           rows => $data,
  226.           NAME => $names,
  227.           %attr
  228.       }
  229.   );
  230.  
  231. =head1 DESCRIPTION
  232.  
  233. DBD::Sponge is useful for making a Perl data structure accessible through a
  234. standard DBI statement handle. This may be useful to DBD module authors who
  235. need to transform data in this way.
  236.  
  237. =head1 METHODS
  238.  
  239. =head2 connect()
  240.  
  241.   my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
  242.  
  243. Here's a sample syntax for creating a database handle for the Sponge driver.
  244. No username and password are needed.
  245.  
  246. =head2 prepare()
  247.  
  248.   my $sth = $sponge->prepare($statement, {
  249.           rows => $data,
  250.           NAME => $names,
  251.           %attr
  252.       }
  253.   );
  254.  
  255. =over 4
  256.  
  257. =item o
  258.  
  259. The C<$statement> here is an arbitrary statement or name you want
  260. to provide as identity of your data. If you're using DBI::Profile
  261. it will appear in the profile data.
  262.  
  263. Generally it's expected that you are preparing a statement handle
  264. as if a C<select> statement happened.
  265.  
  266. =item o
  267.  
  268. C<$data> is a reference to the data you are providing, given as an array of arrays.
  269.  
  270. =item o
  271.  
  272. C<$names> is a reference an array of column names for the C<$data> you are providing.
  273. The number and order should match the number and ordering of the C<$data> columns. 
  274.  
  275. =item o
  276.  
  277. C<%attr> is a hash of other standard DBI attributes that you might pass to a prepare statement.
  278.  
  279. Currently only NAME, TYPE, and PRECISION are supported.
  280.  
  281. =back
  282.  
  283. =head1 BUGS
  284.  
  285. Using this module to prepare INSERT-like statements is not currently documented.
  286.  
  287. =head1 AUTHOR AND COPYRIGHT
  288.  
  289. This module is Copyright (c) 2003 Tim Bunce
  290.  
  291. Documentation initially written by Mark Stosberg
  292.  
  293. The DBD::Sponge module is free software; you can redistribute it and/or
  294. modify it under the same terms as Perl itself. In particular permission
  295. is granted to Tim Bunce for distributing this as a part of the DBI.
  296.  
  297. =head1 SEE ALSO
  298.  
  299. L<DBI(3)>
  300.  
  301. =cut
  302.