File Coverage

blib/lib/DBD/ExampleP.pm
Criterion Covered Total %
statement 178 181 98.3
branch 79 88 89.7
condition 25 32 78.1
subroutine 28 30 93.3
pod 0 1 0.0
total 310 332 93.3


line stmt bran cond sub pod time code
1             {
2             package DBD::ExampleP;
3              
4 60     60   391 use strict;
  60         117  
  60         1880  
5 60     60   13314 use Symbol;
  60         24181  
  60         3932  
6              
7 60     60   390 use DBI qw(:sql_types);
  60         109  
  60         41039  
8              
9             require File::Spec;
10            
11             our (@EXPORT,$VERSION,@statnames,%statnames,@stattypes,%stattypes,
12             @statprec,%statprec,$drh,);
13              
14             @EXPORT = qw(); # Do NOT @EXPORT anything.
15             $VERSION = "12.014311";
16              
17             # $Id: ExampleP.pm 14310 2010-08-02 06:35:25Z Jens $
18             #
19             # Copyright (c) 1994,1997,1998 Tim Bunce
20             #
21             # You may distribute under the terms of either the GNU General Public
22             # License or the Artistic License, as specified in the Perl README file.
23              
24             @statnames = qw(dev ino mode nlink
25             uid gid rdev size
26             atime mtime ctime
27             blksize blocks name);
28             @statnames{@statnames} = (0 .. @statnames-1);
29              
30             @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
31             SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
32             SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
33             SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR);
34             @stattypes{@statnames} = @stattypes;
35             @statprec = ((10) x (@statnames-1), 1024);
36             @statprec{@statnames} = @statprec;
37             die unless @statnames == @stattypes;
38             die unless @statprec == @stattypes;
39              
40             $drh = undef; # holds driver handle once initialised
41             #$gensym = "SYM000"; # used by st::execute() for filehandles
42              
43             sub driver{
44 60 50   60 0 230 return $drh if $drh;
45 60         191 my($class, $attr) = @_;
46 60         160 $class .= "::dr";
47 60         478 ($drh) = DBI::_new_drh($class, {
48             'Name' => 'ExampleP',
49             'Version' => $VERSION,
50             'Attribution' => 'DBD Example Perl stub by Tim Bunce',
51             }, ['example implementors private data '.__PACKAGE__]);
52 60         269 $drh;
53             }
54              
55             sub CLONE {
56 0     0   0 undef $drh;
57             }
58             }
59              
60              
61             { package DBD::ExampleP::dr; # ====== DRIVER ======
62             $imp_data_size = 0;
63 60     60   484 use strict;
  60         143  
  60         9947  
64              
65             sub connect { # normally overridden, but a handy default
66 2409     2409   15773 my($drh, $dbname, $user, $auth)= @_;
67 2409         12841 my ($outer, $dbh) = DBI::_new_dbh($drh, {
68             Name => $dbname,
69             examplep_private_dbh_attrib => 42, # an example, for testing
70             });
71             $dbh->{examplep_get_info} = {
72 2409         12621 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR
73             41 => '.', # SQL_CATALOG_NAME_SEPARATOR
74             114 => 1, # SQL_CATALOG_LOCATION
75             };
76             #$dbh->{Name} = $dbname;
77 2409         14822 $dbh->STORE('Active', 1);
78 2409         13201 return $outer;
79             }
80              
81             sub data_sources {
82 0     0   0 return ("dbi:ExampleP:dir=."); # possibly usefully meaningless
83             }
84              
85             }
86              
87              
88             { package DBD::ExampleP::db; # ====== DATABASE ======
89             $imp_data_size = 0;
90 60     60   457 use strict;
  60         127  
  60         32856  
91              
92             sub prepare {
93 5756     5756   118085 my($dbh, $statement)= @_;
94 5756         8242 my @fields;
95 5756         35216 my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i;
96              
97 5756 100 66     23329 if (defined $fields and defined $dir) {
98 4295 100       24826 @fields = ($fields eq '*')
99             ? keys %DBD::ExampleP::statnames
100             : split(/\s*,\s*/, $fields);
101             }
102             else {
103 1461 50       7522 return $dbh->set_err($DBI::stderr, "Syntax error in select statement (\"$statement\")")
104             unless $statement =~ m/^\s*set\s+/;
105             # the SET syntax is just a hack so the ExampleP driver can
106             # be used to test non-select statements.
107             # Now we have DBI::DBM etc., ExampleP should be deprecated
108             }
109              
110 5756         31482 my ($outer, $sth) = DBI::_new_sth($dbh, {
111             'Statement' => $statement,
112             examplep_private_sth_attrib => 24, # an example, for testing
113             }, ['example implementors private data '.__PACKAGE__]);
114              
115             my @bad = map {
116 5756 100       15715 defined $DBD::ExampleP::statnames{$_} ? () : $_
  8569         24401  
117             } @fields;
118 5756 100       13380 return $dbh->set_err($DBI::stderr, "Unknown field names: @bad")
119             if @bad;
120              
121 5720         27334 $outer->STORE('NUM_OF_FIELDS' => scalar(@fields));
122              
123 5720 100 100     39079 $sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/;
124 5720 100       25062 $outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0);
125              
126 5720 100       24106 if (@fields) {
127 4259         13662 $outer->STORE('NAME' => \@fields);
128 4259         27296 $outer->STORE('NULLABLE' => [ (0) x @fields ]);
129 4259         23982 $outer->STORE('SCALE' => [ (0) x @fields ]);
130             }
131              
132 5720         35498 $outer;
133             }
134              
135              
136             sub table_info {
137 16     16   2969 my $dbh = shift;
138 16         49 my ($catalog, $schema, $table, $type) = @_;
139              
140 16   100     115 my @types = split(/["']*,["']/, $type || 'TABLE');
141 16         43 my %types = map { $_=>$_ } @types;
  16         75  
142              
143             # Return a list of all subdirectories
144 16         72 my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
145 16   66     380 my $dir = $catalog || File::Spec->curdir();
146 16         30 my @list;
147 16 100       56 if ($types{VIEW}) { # for use by test harness
148 4         20 push @list, [ undef, "schema", "table", 'VIEW', undef ];
149 4         20 push @list, [ undef, "sch-ema", "table", 'VIEW', undef ];
150 4         18 push @list, [ undef, "schema", "ta-ble", 'VIEW', undef ];
151 4         16 push @list, [ undef, "sch ema", "table", 'VIEW', undef ];
152 4         19 push @list, [ undef, "schema", "ta ble", 'VIEW', undef ];
153             }
154 16 100       48 if ($types{TABLE}) {
155 60     60   460 no strict 'refs';
  60         190  
  60         50340  
156 12 50       432 opendir($dh, $dir)
157             or return $dbh->set_err(int($!), "Failed to open directory $dir: $!");
158 12         443 while (defined(my $item = readdir($dh))) {
159 440 50       1014 if ($^O eq 'VMS') {
160             # if on VMS then avoid warnings from catdir if you use a file
161             # (not a dir) as the item below
162 0 0       0 next if $item !~ /\.dir$/oi;
163             }
164 440         1777 my $file = File::Spec->catdir($dir,$item);
165 440 100       4987 next unless -d $file;
166 92         913 my($dev, $ino, $mode, $nlink, $uid) = lstat($file);
167 92         211 my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid;
168 92         434 push @list, [ $dir, $pwnam, $item, 'TABLE', undef ];
169             }
170 12         44 close($dh);
171             }
172             # We would like to simply do a DBI->connect() here. However,
173             # this is wrong if we are in a subclass like DBI::ProxyServer.
174 16 50 66     140 $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','')
175             or return $dbh->set_err($DBI::err,
176             "Failed to connect to DBI::Sponge: $DBI::errstr");
177              
178 16         195 my $attr = {
179             'rows' => \@list,
180             'NUM_OF_FIELDS' => 5,
181             'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME',
182             'TABLE_TYPE', 'REMARKS'],
183             'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(),
184             DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ],
185             'NULLABLE' => [1, 1, 1, 1, 1]
186             };
187 16         36 my $sdbh = $dbh->{'dbd_sponge_dbh'};
188 16 50       125 my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr)
189             or return $dbh->set_err($sdbh->err(), $sdbh->errstr());
190 16         440 $sth;
191             }
192              
193              
194             sub type_info_all {
195 12     12   201 my ($dbh) = @_;
196 12         246 my $ti = [
197             { TYPE_NAME => 0,
198             DATA_TYPE => 1,
199             COLUMN_SIZE => 2,
200             LITERAL_PREFIX => 3,
201             LITERAL_SUFFIX => 4,
202             CREATE_PARAMS => 5,
203             NULLABLE => 6,
204             CASE_SENSITIVE => 7,
205             SEARCHABLE => 8,
206             UNSIGNED_ATTRIBUTE=> 9,
207             FIXED_PREC_SCALE=> 10,
208             AUTO_UNIQUE_VALUE => 11,
209             LOCAL_TYPE_NAME => 12,
210             MINIMUM_SCALE => 13,
211             MAXIMUM_SCALE => 14,
212             },
213             [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ],
214             [ 'INTEGER', DBI::SQL_INTEGER, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ],
215             ];
216 12         58 return $ti;
217             }
218              
219              
220             sub ping {
221 3033 100   3033   10580 (shift->FETCH('Active')) ? 2 : 0; # the value 2 is checked for by t/80proxy.t
222             }
223              
224              
225             sub disconnect {
226 2389     2389   83903 shift->STORE(Active => 0);
227 2389         7789 return 1;
228             }
229              
230              
231             sub get_info {
232 72     72   1107 my ($dbh, $info_type) = @_;
233 72         274 return $dbh->{examplep_get_info}->{$info_type};
234             }
235              
236              
237             sub FETCH {
238 34327     34327   107026 my ($dbh, $attrib) = @_;
239             # In reality this would interrogate the database engine to
240             # either return dynamic values that cannot be precomputed
241             # or fetch and cache attribute values too expensive to prefetch.
242             # else pass up to DBI to handle
243 34327 100       79024 return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path';
244 31988         173552 return $dbh->SUPER::FETCH($attrib);
245             }
246              
247              
248             sub STORE {
249 50503     50503   192983 my ($dbh, $attrib, $value) = @_;
250             # store only known attributes else pass up to DBI to handle
251 50503 100       89366 if ($attrib eq 'examplep_set_err') {
252             # a fake attribute to enable a test case where STORE issues a warning
253 4         21 $dbh->set_err($value, $value);
254 4         380 return;
255             }
256 50499 100       80089 if ($attrib eq 'AutoCommit') {
257             # convert AutoCommit values to magic ones to let DBI
258             # know that the driver has 'handled' the AutoCommit attribute
259 5332 100       10254 $value = ($value) ? -901 : -900;
260             }
261 50499 100       87501 return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/;
262 50495         269071 return $dbh->SUPER::STORE($attrib, $value);
263             }
264              
265             sub DESTROY {
266 2381     2381   23244 my $dbh = shift;
267 2381 100       8142 $dbh->disconnect if $dbh->FETCH('Active');
268             undef
269 2381         73523 }
270              
271              
272             # This is an example to demonstrate the use of driver-specific
273             # methods via $dbh->func().
274             # Use it as follows:
275             # my @tables = $dbh->func($re, 'examplep_tables');
276             #
277             # Returns all the tables that match the regular expression $re.
278             sub examplep_tables {
279 4     4   63 my $dbh = shift; my $re = shift;
  4         9  
280 4         17 grep { $_ =~ /$re/ } $dbh->tables();
  32         184  
281             }
282              
283             sub parse_trace_flag {
284 166     166   14311 my ($h, $name) = @_;
285 166 100       478 return 0x01000000 if $name eq 'foo';
286 152 100       379 return 0x02000000 if $name eq 'bar';
287 138 100       378 return 0x04000000 if $name eq 'baz';
288 124 100       363 return 0x08000000 if $name eq 'boo';
289 110 100       287 return 0x10000000 if $name eq 'bop';
290 96         347 return $h->SUPER::parse_trace_flag($name);
291             }
292              
293             sub private_attribute_info {
294 2317     2317   17102 return { example_driver_path => undef };
295             }
296             }
297              
298              
299             { package DBD::ExampleP::st; # ====== STATEMENT ======
300             $imp_data_size = 0;
301 60     60   500 use strict; no strict 'refs'; # cause problems with filehandles
  60     60   123  
  60         1668  
  60         341  
  60         152  
  60         52231  
302              
303             sub bind_param {
304 3896     3896   13521 my($sth, $param, $value, $attribs) = @_;
305 3896         11759 $sth->{'dbd_param'}->[$param-1] = $value;
306 3896         12424 return 1;
307             }
308              
309              
310             sub execute {
311 5369     5369   50099 my($sth, @dir) = @_;
312 5369         7091 my $dir;
313              
314 5369 100       11299 if (@dir) {
315             $sth->bind_param($_, $dir[$_-1]) or return
316 1898   50     8090 foreach (1..@dir);
317             }
318              
319 5369   100     14884 my $dbd_param = $sth->{'dbd_param'} || [];
320             return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected")
321 5369 100       12224 unless @$dbd_param == $sth->{NUM_OF_PARAMS};
322              
323 5357 100       26712 return 0 unless $sth->{NUM_OF_FIELDS}; # not a select
324              
325 3896   66     8986 $dir = $dbd_param->[0] || $sth->{examplep_ex_dir};
326 3896 50       7488 return $sth->set_err(2, "No bind parameter supplied")
327             unless defined $dir;
328              
329 3896         12960 $sth->finish;
330              
331             #
332             # If the users asks for directory "long_list_4532", then we fake a
333             # directory with files "file4351", "file4350", ..., "file0".
334             # This is a special case used for testing, especially DBD::Proxy.
335             #
336 3896 100       12742 if ($dir =~ /^long_list_(\d+)$/) {
337 12         49 $sth->{dbd_dir} = [ $1 ]; # array ref indicates special mode
338 12         33 $sth->{dbd_datahandle} = undef;
339             }
340             else {
341 3884         6860 $sth->{dbd_dir} = $dir;
342 3884         11259 my $sym = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
343 3884 100       155796 opendir($sym, $dir)
344             or return $sth->set_err(2, "opendir($dir): $!");
345 3872         15287 $sth->{dbd_datahandle} = $sym;
346             }
347 3884         21552 $sth->STORE(Active => 1);
348 3884         21806 return 1;
349             }
350              
351              
352             sub fetch {
353 102370     102370   293675 my $sth = shift;
354 102370         166637 my $dir = $sth->{dbd_dir};
355 102370         129084 my %s;
356              
357 102370 100       185240 if (ref $dir) { # special fake-data test mode
358 1212         5708 my $num = $dir->[0]--;
359 1212 100       2030 unless ($num > 0) {
360 12         57 $sth->finish();
361 12         113 return;
362             }
363 1200         1386 my $time = time;
364 1200         21313 @s{@DBD::ExampleP::statnames} =
365             ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024,
366             $time, $time, $time, 512, 2, "file$num")
367             }
368             else { # normal mode
369             my $dh = $sth->{dbd_datahandle}
370 101158 100       220038 or return $sth->set_err($DBI::stderr, "fetch without successful execute");
371 101003         416408 my $f = readdir($dh);
372 101003 100       213609 unless ($f) {
373 2021         10816 $sth->finish;
374 2021         16696 return;
375             }
376             # untaint $f so that we can use this for DBI taint tests
377 98982         419916 ($f) = ($f =~ m/^(.*)$/);
378 98982         760364 my $file = File::Spec->catfile($dir, $f);
379             # put in all the data fields
380 98982         1984107 @s{ @DBD::ExampleP::statnames } = (lstat($file), $f);
381             }
382              
383             # return just what fields the query asks for
384 100182         271854 my @new = @s{ @{$sth->{NAME}} };
  100182         336619  
385              
386 100182         1292056 return $sth->_set_fbav(\@new);
387             }
388             *fetchrow_arrayref = \&fetch;
389              
390              
391             sub finish {
392 9868     9868   41075 my $sth = shift;
393 9868 100       71661 closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle};
394 9868         29158 $sth->{dbd_datahandle} = undef;
395 9868         14589 $sth->{dbd_dir} = undef;
396 9868         27592 $sth->SUPER::finish();
397 9868         26346 return 1;
398             }
399              
400              
401             sub FETCH {
402 8615     8615   58269 my ($sth, $attrib) = @_;
403             # In reality this would interrogate the database engine to
404             # either return dynamic values that cannot be precomputed
405             # or fetch and cache attribute values too expensive to prefetch.
406 8615 100       25007 if ($attrib eq 'TYPE'){
    100          
    100          
407 2099         3336 return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ];
  2099         10852  
408             }
409             elsif ($attrib eq 'PRECISION'){
410 2099         3431 return [ @DBD::ExampleP::statprec{ @{ $sth->FETCH(q{NAME_lc}) } } ];
  2099         10208  
411             }
412             elsif ($attrib eq 'ParamValues') {
413 14   50     45 my $dbd_param = $sth->{dbd_param} || [];
414 14         38 my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param;
  96         192  
415 14         133 return \%pv;
416             }
417             # else pass up to DBI to handle
418 4403         54214 return $sth->SUPER::FETCH($attrib);
419             }
420              
421              
422             sub STORE {
423 28130     28130   153727 my ($sth, $attrib, $value) = @_;
424             # would normally validate and only store known attributes
425             # else pass up to DBI to handle
426 28130 100 100     148486 return $sth->{$attrib} = $value
      100        
      66        
427             if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION';
428 15351         66684 return $sth->SUPER::STORE($attrib, $value);
429             }
430              
431             *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag;
432             }
433              
434             1;
435             # vim: sw=4:ts=8