Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | { |
2 | package DBD::Sponge; | |
3 | ||
4 | require DBI; | |
5 | require Carp; | |
6 | ||
7 | @EXPORT = qw(); # Do NOT @EXPORT anything. | |
8 | $VERSION = substr(q$Revision: 10.6 $, 9,-1); | |
9 | ||
10 | # $Id: Sponge.pm,v 10.6 2001/03/30 14:35:41 timbo Exp $ | |
11 | # | |
12 | # Copyright (c) 1994, 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 | $err = 0; # The $DBI::err value | |
19 | ||
20 | sub driver{ | |
21 | return $drh if $drh; | |
22 | my($class, $attr) = @_; | |
23 | $class .= "::dr"; | |
24 | ($drh) = DBI::_new_drh($class, { | |
25 | 'Name' => 'Sponge', | |
26 | 'Version' => $VERSION, | |
27 | 'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce", | |
28 | }); | |
29 | $drh; | |
30 | } | |
31 | ||
32 | sub default_user { | |
33 | return ('',''); | |
34 | } | |
35 | } | |
36 | ||
37 | ||
38 | { package DBD::Sponge::dr; # ====== DRIVER ====== | |
39 | $imp_data_size = 0; | |
40 | # we use default (dummy) connect method | |
41 | sub disconnect_all { } | |
42 | sub DESTROY { } | |
43 | } | |
44 | ||
45 | ||
46 | { package DBD::Sponge::db; # ====== DATABASE ====== | |
47 | $imp_data_size = 0; | |
48 | use strict; | |
49 | ||
50 | sub prepare { | |
51 | my($dbh, $statement, $attribs) = @_; | |
52 | my $rows = $attribs->{'rows'} | |
53 | || Carp::croak("No rows attribute supplied to prepare"); | |
54 | delete $attribs->{'rows'}; | |
55 | my ($outer, $sth) = DBI::_new_sth($dbh, { | |
56 | 'Statement' => $statement, | |
57 | 'rows' => $rows, | |
58 | }); | |
59 | # we need to set NUM_OF_FIELDS | |
60 | my $numFields; | |
61 | if ($attribs->{'NUM_OF_FIELDS'}) { | |
62 | $numFields = $attribs->{'NUM_OF_FIELDS'}; | |
63 | } elsif ($attribs->{'NAME'}) { | |
64 | $numFields = @{$attribs->{NAME}}; | |
65 | } elsif ($attribs->{'TYPE'}) { | |
66 | $numFields = @{$attribs->{TYPE}}; | |
67 | } elsif (my $firstrow = $rows->[0]) { | |
68 | $numFields = scalar @$firstrow; | |
69 | } else { | |
70 | DBI::set_err($dbh, 1, 'Cannot determine NUM_OF_FIELDS'); | |
71 | return undef; | |
72 | } | |
73 | $sth->STORE('NUM_OF_FIELDS' => $numFields); | |
74 | $sth->{NAME} = $attribs->{NAME} | |
75 | || [ map { "col$_" } 1..$numFields ]; | |
76 | $sth->{TYPE} = $attribs->{TYPE} | |
77 | || [ (DBI::SQL_VARCHAR()) x $numFields ]; | |
78 | $sth->{PRECISION} = $attribs->{PRECISION} | |
79 | || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ]; | |
80 | ||
81 | $outer; | |
82 | } | |
83 | ||
84 | sub type_info_all { | |
85 | my ($dbh) = @_; | |
86 | my $ti = [ | |
87 | { TYPE_NAME => 0, | |
88 | DATA_TYPE => 1, | |
89 | PRECISION => 2, | |
90 | LITERAL_PREFIX => 3, | |
91 | LITERAL_SUFFIX => 4, | |
92 | CREATE_PARAMS => 5, | |
93 | NULLABLE => 6, | |
94 | CASE_SENSITIVE => 7, | |
95 | SEARCHABLE => 8, | |
96 | UNSIGNED_ATTRIBUTE=> 9, | |
97 | MONEY => 10, | |
98 | AUTO_INCREMENT => 11, | |
99 | LOCAL_TYPE_NAME => 12, | |
100 | MINIMUM_SCALE => 13, | |
101 | MAXIMUM_SCALE => 14, | |
102 | }, | |
103 | [ 'VARCHAR', DBI::SQL_VARCHAR, undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], | |
104 | ]; | |
105 | return $ti; | |
106 | } | |
107 | ||
108 | sub FETCH { | |
109 | my ($dbh, $attrib) = @_; | |
110 | # In reality this would interrogate the database engine to | |
111 | # either return dynamic values that cannot be precomputed | |
112 | # or fetch and cache attribute values too expensive to prefetch. | |
113 | return 1 if $attrib eq 'AutoCommit'; | |
114 | # else pass up to DBI to handle | |
115 | return $dbh->SUPER::FETCH($attrib); | |
116 | } | |
117 | ||
118 | sub STORE { | |
119 | my ($dbh, $attrib, $value) = @_; | |
120 | # would normally validate and only store known attributes | |
121 | # else pass up to DBI to handle | |
122 | if ($attrib eq 'AutoCommit') { | |
123 | return 1 if $value; # is already set | |
124 | croak("Can't disable AutoCommit"); | |
125 | } | |
126 | return $dbh->SUPER::STORE($attrib, $value); | |
127 | } | |
128 | ||
129 | sub DESTROY { } | |
130 | ||
131 | } | |
132 | ||
133 | ||
134 | { package DBD::Sponge::st; # ====== STATEMENT ====== | |
135 | $imp_data_size = 0; | |
136 | use strict; | |
137 | ||
138 | sub execute { | |
139 | my ($sth) = @_; | |
140 | 1; | |
141 | } | |
142 | ||
143 | sub fetch { | |
144 | my ($sth) = @_; | |
145 | my $row = shift @{$sth->{'rows'}}; | |
146 | unless ($row) { | |
147 | $sth->STORE(Active => 0); | |
148 | return undef; | |
149 | } | |
150 | return $sth->_set_fbav($row); | |
151 | } | |
152 | *fetchrow_arrayref = \&fetch; | |
153 | ||
154 | sub FETCH { | |
155 | my ($sth, $attrib) = @_; | |
156 | # would normally validate and only fetch known attributes | |
157 | # else pass up to DBI to handle | |
158 | return $sth->SUPER::FETCH($attrib); | |
159 | } | |
160 | ||
161 | sub STORE { | |
162 | my ($sth, $attrib, $value) = @_; | |
163 | # would normally validate and only store known attributes | |
164 | # else pass up to DBI to handle | |
165 | return $sth->SUPER::STORE($attrib, $value); | |
166 | } | |
167 | ||
168 | sub DESTROY { } | |
169 | } | |
170 | ||
171 | 1; |