File Coverage

blib/lib/DBD/File.pm
Criterion Covered Total %
statement 365 470 77.6
branch 173 326 53.0
condition 57 171 33.3
subroutine 61 71 85.9
pod 0 1 0.0
total 656 1039 63.1


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # DBD::File - A base class for implementing DBI drivers that
4             # act on plain files
5             #
6             # This module is currently maintained by
7             #
8             # H.Merijn Brand & Jens Rehsack
9             #
10             # The original author is Jochen Wiedmann.
11             #
12             # Copyright (C) 2009-2013 by H.Merijn Brand & Jens Rehsack
13             # Copyright (C) 2004 by Jeff Zucker
14             # Copyright (C) 1998 by Jochen Wiedmann
15             #
16             # All rights reserved.
17             #
18             # You may distribute this module under the terms of either the GNU
19             # General Public License or the Artistic License, as specified in
20             # the Perl README file.
21              
22             require 5.008;
23              
24 52     52   19597 use strict;
  52         96  
  52         1374  
25 52     52   238 use warnings;
  52         89  
  52         1404  
26              
27 52     52   239 use DBI ();
  52         93  
  52         1070  
28              
29             package DBD::File;
30              
31 52     52   215 use strict;
  52         85  
  52         909  
32 52     52   220 use warnings;
  52         86  
  52         1330  
33              
34 52     52   224 use base qw( DBI::DBD::SqlEngine );
  52         106  
  52         19490  
35 52     52   295 use Carp;
  52         91  
  52         2472  
36 52     52   257 use vars qw( @ISA $VERSION $drh );
  52         93  
  52         4615  
37              
38             $VERSION = "0.44";
39              
40             $drh = undef; # holds driver handle(s) once initialized
41              
42             sub driver ($;$)
43             {
44 44     44 0 136 my ($class, $attr) = @_;
45              
46             # Drivers typically use a singleton object for the $drh
47             # We use a hash here to have one singleton per subclass.
48             # (Otherwise DBD::CSV and DBD::DBM, for example, would
49             # share the same driver object which would cause problems.)
50             # An alternative would be to not cache the $drh here at all
51             # and require that subclasses do that. Subclasses should do
52             # their own caching, so caching here just provides extra safety.
53 44 50       161 $drh->{$class} and return $drh->{$class};
54              
55 44   50     142 $attr ||= {};
56 52     52   306 { no strict "refs";
  52         87  
  52         8675  
  44         71  
57 44 100       144 unless ($attr->{Attribution}) {
58             $class eq "DBD::File" and
59 18 50       126 $attr->{Attribution} = "$class by Jeff Zucker";
60 18   0     65 $attr->{Attribution} ||= ${$class . "::ATTRIBUTION"} ||
      33        
61             "oops the author of $class forgot to define this";
62             }
63 44   33     200 $attr->{Version} ||= ${$class . "::VERSION"};
  44         208  
64 44 50       312 $attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://;
65             }
66              
67 44         364 $drh->{$class} = $class->SUPER::driver ($attr);
68              
69             # XXX inject DBD::XXX::Statement unless exists
70              
71 44         148 return $drh->{$class};
72             } # driver
73              
74             sub CLONE
75             {
76 0     0   0 undef $drh;
77             } # CLONE
78              
79             # ====== DRIVER ================================================================
80              
81             package DBD::File::dr;
82              
83 52     52   311 use strict;
  52         98  
  52         1037  
84 52     52   227 use warnings;
  52         89  
  52         1461  
85              
86 52     52   228 use vars qw( @ISA $imp_data_size );
  52         90  
  52         2027  
87              
88 52     52   256 use Carp;
  52         96  
  52         15334  
89              
90             @DBD::File::dr::ISA = qw( DBI::DBD::SqlEngine::dr );
91             $DBD::File::dr::imp_data_size = 0;
92              
93             sub dsn_quote
94             {
95 128     128   208 my $str = shift;
96 128 50       276 ref $str and return "";
97 128 100       326 defined $str or return "";
98 80         214 $str =~ s/([;:\\])/\\$1/g;
99 80         380 return $str;
100             } # dsn_quote
101              
102             # XXX rewrite using TableConfig ...
103 68     68   182 sub default_table_source { "DBD::File::TableSource::FileSystem" }
104              
105             sub connect
106             {
107 628     628   9447 my ($drh, $dbname, $user, $auth, $attr) = @_;
108              
109             # We do not (yet) care about conflicting attributes here
110             # my $dbh = DBI->connect ("dbi:CSV:f_dir=test", undef, undef, { f_dir => "text" });
111             # will test here that both test and text should exist
112 628 50       2625 if (my $attr_hash = (DBI->parse_dsn ($dbname))[3]) {
113 0 0 0     0 if (defined $attr_hash->{f_dir} && ! -d $attr_hash->{f_dir}) {
114 0         0 my $msg = "No such directory '$attr_hash->{f_dir}";
115 0         0 $drh->set_err (2, $msg);
116 0 0       0 $attr_hash->{RaiseError} and croak $msg;
117 0         0 return;
118             }
119             }
120 628 100 100     5491 if ($attr and defined $attr->{f_dir} && ! -d $attr->{f_dir}) {
      66        
121 48         137 my $msg = "No such directory '$attr->{f_dir}";
122 48         341 $drh->set_err (2, $msg);
123 48 100       5003 $attr->{RaiseError} and croak $msg;
124 12         62 return;
125             }
126              
127 580         2307 return $drh->SUPER::connect ($dbname, $user, $auth, $attr);
128             } # connect
129              
130             sub disconnect_all
131       44     {
132             } # disconnect_all
133              
134             sub DESTROY
135             {
136 0     0   0 undef;
137             } # DESTROY
138              
139             # ====== DATABASE ==============================================================
140              
141             package DBD::File::db;
142              
143 52     52   323 use strict;
  52         94  
  52         995  
144 52     52   239 use warnings;
  52         110  
  52         1362  
145              
146 52     52   235 use vars qw( @ISA $imp_data_size );
  52         93  
  52         2004  
147              
148 52     52   250 use Carp;
  52         89  
  52         2938  
149             require File::Spec;
150             require Cwd;
151 52     52   285 use Scalar::Util qw( refaddr ); # in CORE since 5.7.3
  52         100  
  52         34894  
152              
153             @DBD::File::db::ISA = qw( DBI::DBD::SqlEngine::db );
154             $DBD::File::db::imp_data_size = 0;
155              
156             sub data_sources
157             {
158 24     24   424 my ($dbh, $attr, @other) = @_;
159 24 50       78 ref ($attr) eq "HASH" or $attr = {};
160 24 50       98 exists $attr->{f_dir} or $attr->{f_dir} = $dbh->{f_dir};
161 24 50       75 exists $attr->{f_dir_search} or $attr->{f_dir_search} = $dbh->{f_dir_search};
162 24         107 return $dbh->SUPER::data_sources ($attr, @other);
163             } # data_source
164              
165             sub set_versions
166             {
167 580     580   1958 my $dbh = shift;
168 580         1140 $dbh->{f_version} = $DBD::File::VERSION;
169              
170 580         2167 return $dbh->SUPER::set_versions ();
171             } # set_versions
172              
173             sub init_valid_attributes
174             {
175 580     580   1955 my $dbh = shift;
176              
177             $dbh->{f_valid_attrs} = {
178 580         3402 f_version => 1, # DBD::File version
179             f_dir => 1, # base directory
180             f_dir_search => 1, # extended search directories
181             f_ext => 1, # file extension
182             f_schema => 1, # schema name
183             f_lock => 1, # Table locking mode
184             f_lockfile => 1, # Table lockfile extension
185             f_encoding => 1, # Encoding of the file
186             f_valid_attrs => 1, # File valid attributes
187             f_readonly_attrs => 1, # File readonly attributes
188             };
189             $dbh->{f_readonly_attrs} = {
190 580         1751 f_version => 1, # DBD::File version
191             f_valid_attrs => 1, # File valid attributes
192             f_readonly_attrs => 1, # File readonly attributes
193             };
194              
195 580         1628 return $dbh->SUPER::init_valid_attributes ();
196             } # init_valid_attributes
197              
198             sub init_default_attributes
199             {
200 1160     1160   4503 my ($dbh, $phase) = @_;
201              
202             # must be done first, because setting flags implicitly calls $dbdname::db->STORE
203 1160         3369 $dbh->SUPER::init_default_attributes ($phase);
204              
205             # DBI::BD::SqlEngine::dr::connect will detect old-style drivers and
206             # don't call twice
207 1160 50       2231 unless (defined $phase) {
208             # we have an "old" driver here
209 0         0 $phase = defined $dbh->{sql_init_phase};
210 0 0       0 $phase and $phase = $dbh->{sql_init_phase};
211             }
212              
213 1160 100       2164 if (0 == $phase) {
214             # f_ext should not be initialized
215             # f_map is deprecated (but might return)
216 580         6768 $dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ());
217              
218 580         1037 push @{$dbh->{sql_init_order}{90}}, "f_meta";
  580         1541  
219              
220             # complete derived attributes, if required
221 580         2475 (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
222 580         1641 my $drv_prefix = DBI->driver_prefix ($drv_class);
223 580 100 66     2495 if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{sql_engine_in_gofer}) {
224 386         767 my $attr = $dbh->{$drv_prefix . "meta"};
225             defined $dbh->{f_valid_attrs}{f_meta}
226 386 50       850 and $dbh->{f_valid_attrs}{f_meta} = 1;
227              
228 386         818 $dbh->{f_meta} = $dbh->{$attr};
229             }
230             }
231              
232 1160         2098 return $dbh;
233             } # init_default_attributes
234              
235             sub validate_FETCH_attr
236             {
237 0     0   0 my ($dbh, $attrib) = @_;
238              
239 0 0 0     0 $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta";
240              
241 0         0 return $dbh->SUPER::validate_FETCH_attr ($attrib);
242             } # validate_FETCH_attr
243              
244             sub validate_STORE_attr
245             {
246 4088     4088   12654 my ($dbh, $attrib, $value) = @_;
247              
248 4088 100 66     8596 if ($attrib eq "f_dir" && defined $value) {
249 496 50       8242 -d $value or
250             return $dbh->set_err ($DBI::stderr, "No such directory '$value'");
251 496 100       3736 File::Spec->file_name_is_absolute ($value) or
252             $value = Cwd::abs_path ($value);
253             }
254              
255 4088 100       6763 if ($attrib eq "f_ext") {
256 108 50 33     680 $value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or
257             carp "'$value' doesn't look like a valid file extension attribute\n";
258             }
259              
260 4088 0 33     6380 $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta";
261              
262 4088         9448 return $dbh->SUPER::validate_STORE_attr ($attrib, $value);
263             } # validate_STORE_attr
264              
265             sub get_f_versions
266             {
267 16     16   43 my ($dbh, $table) = @_;
268              
269 16         34 my $class = $dbh->{ImplementorClass};
270 16         60 $class =~ s/::db$/::Table/;
271 16         30 my $dver;
272 16         28 my $dtype = "IO::File";
273 16         28 eval {
274 16         274 $dver = IO::File->VERSION ();
275              
276             # when we're still alive here, everything went ok - no need to check for $@
277 16         72 $dtype .= " ($dver)";
278             };
279              
280 16         28 my $f_encoding;
281 16 50       51 if ($table) {
282 0         0 my $meta;
283 0 0       0 $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
284 0 0 0     0 $meta and $meta->{f_encoding} and $f_encoding = $meta->{f_encoding};
285             } # if ($table)
286 16   33     85 $f_encoding ||= $dbh->{f_encoding};
287              
288 16 50       39 $f_encoding and $dtype .= " + " . $f_encoding . " encoding";
289              
290 16         90 return sprintf "%s using %s", $dbh->{f_version}, $dtype;
291             } # get_f_versions
292              
293             # ====== STATEMENT =============================================================
294              
295             package DBD::File::st;
296              
297 52     52   353 use strict;
  52         116  
  52         1053  
298 52     52   238 use warnings;
  52         123  
  52         1368  
299              
300 52     52   372 use vars qw( @ISA $imp_data_size );
  52         208  
  52         25833  
301              
302             @DBD::File::st::ISA = qw( DBI::DBD::SqlEngine::st );
303             $DBD::File::st::imp_data_size = 0;
304              
305             my %supported_attrs = (
306             TYPE => 1,
307             PRECISION => 1,
308             NULLABLE => 1,
309             );
310              
311             sub FETCH
312             {
313 2018     2018   7525 my ($sth, $attr) = @_;
314              
315 2018 100       3885 if ($supported_attrs{$attr}) {
316 748         1095 my $stmt = $sth->{sql_stmt};
317              
318 748 50 33     5280 if (exists $sth->{ImplementorClass} &&
      33        
319             exists $sth->{sql_stmt} &&
320             $sth->{sql_stmt}->isa ("SQL::Statement")) {
321              
322             # fill overall_defs unless we know
323 0 0 0     0 unless (exists $sth->{f_overall_defs} && ref $sth->{f_overall_defs}) {
324 0         0 my $types = $sth->{Database}{Types};
325 0 0       0 unless ($types) { # Fetch types only once per database
326 0 0       0 if (my $t = $sth->{Database}->type_info_all ()) {
327 0         0 foreach my $i (1 .. $#$t) {
328 0         0 $types->{uc $t->[$i][0]} = $t->[$i][1];
329 0   0     0 $types->{$t->[$i][1]} ||= uc $t->[$i][0];
330             }
331             }
332             # sane defaults
333 0         0 for ([ 0, "" ],
334             [ 1, "CHAR" ],
335             [ 4, "INTEGER" ],
336             [ 12, "VARCHAR" ],
337             ) {
338 0   0     0 $types->{$_->[0]} ||= $_->[1];
339 0   0     0 $types->{$_->[1]} ||= $_->[0];
340             }
341 0         0 $sth->{Database}{Types} = $types;
342             }
343             my $all_meta =
344 0         0 $sth->{Database}->func ("*", "table_defs", "get_sql_engine_meta");
345 0         0 foreach my $tbl (keys %$all_meta) {
346 0         0 my $meta = $all_meta->{$tbl};
347 0 0 0     0 exists $meta->{table_defs} && ref $meta->{table_defs} or next;
348 0         0 foreach (keys %{$meta->{table_defs}{columns}}) {
  0         0  
349 0         0 my $field_info = $meta->{table_defs}{columns}{$_};
350 0 0 0     0 if (defined $field_info->{data_type} &&
351             $field_info->{data_type} !~ m/^[0-9]+$/) {
352 0         0 $field_info->{type_name} = uc $field_info->{data_type};
353 0   0     0 $field_info->{data_type} = $types->{$field_info->{type_name}} || 0;
354             }
355 0   0     0 $field_info->{type_name} ||= $types->{$field_info->{data_type}} || "CHAR";
      0        
356 0         0 $sth->{f_overall_defs}{$_} = $field_info;
357             }
358             }
359             }
360              
361 0         0 my @colnames = $sth->sql_get_colnames ();
362              
363             $attr eq "TYPE" and
364 0 0       0 return [ map { $sth->{f_overall_defs}{$_}{data_type} || 12 }
  0 0       0  
365             @colnames ];
366              
367             $attr eq "TYPE_NAME" and
368 0 0       0 return [ map { $sth->{f_overall_defs}{$_}{type_name} || "VARCHAR" }
  0 0       0  
369             @colnames ];
370              
371             $attr eq "PRECISION" and
372 0 0       0 return [ map { $sth->{f_overall_defs}{$_}{data_length} || 0 }
  0 0       0  
373             @colnames ];
374              
375             $attr eq "NULLABLE" and
376 0 0       0 return [ map { ( grep { $_ eq "NOT NULL" }
  0         0  
377 0 0       0 @{ $sth->{f_overall_defs}{$_}{constraints} || [] })
  0 0       0  
378             ? 0 : 1 }
379             @colnames ];
380             }
381             }
382              
383 2018         4372 return $sth->SUPER::FETCH ($attr);
384             } # FETCH
385              
386             # ====== TableSource ===========================================================
387              
388             package DBD::File::TableSource::FileSystem;
389              
390 52     52   331 use strict;
  52         102  
  52         978  
391 52     52   232 use warnings;
  52         99  
  52         1228  
392              
393 52     52   14514 use IO::Dir;
  52         637861  
  52         34261  
394              
395             @DBD::File::TableSource::FileSystem::ISA = "DBI::DBD::SqlEngine::TableSource";
396              
397             sub data_sources
398             {
399 32     32   94 my ($class, $drh, $attr) = @_;
400             my $dir = $attr && exists $attr->{f_dir}
401             ? $attr->{f_dir}
402 32 50 33     172 : File::Spec->curdir ();
403 32 50       78 defined $dir or return; # Stream-based databases do not have f_dir
404 32 50 33     992 unless (-d $dir && -r $dir && -x $dir) {
      33        
405 0         0 $drh->set_err ($DBI::stderr, "Cannot use directory $dir from f_dir");
406 0         0 return;
407             }
408 32         75 my %attrs;
409 32 50       194 $attr and %attrs = %$attr;
410 32         94 delete $attrs{f_dir};
411 32         181 my $dsn_quote = $drh->{ImplementorClass}->can ("dsn_quote");
412 32         111 my $dsnextra = join ";", map { $_ . "=" . &{$dsn_quote} ($attrs{$_}) } keys %attrs;
  88         207  
  88         171  
413 32         93 my @dir = ($dir);
414             $attr->{f_dir_search} && ref $attr->{f_dir_search} eq "ARRAY" and
415 32 50 33     132 push @dir, grep { -d $_ } @{$attr->{f_dir_search}};
  0         0  
  0         0  
416 32         54 my @dsns;
417 32         71 foreach $dir (@dir) {
418 32         190 my $dirh = IO::Dir->new ($dir);
419 32 50       2255 unless (defined $dirh) {
420 0         0 $drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
421 0         0 return;
422             }
423              
424 32         68 my ($file, %names, $driver);
425 32 50       284 $driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File";
426              
427 32         317 while (defined ($file = $dirh->read ())) {
428 72         1813 my $d = File::Spec->catdir ($dir, $file);
429             # allow current dir ... it can be a data_source too
430             $file ne File::Spec->updir () && -d $d and
431 72 50 66     847 push @dsns, "DBI:$driver:f_dir=" . &{$dsn_quote} ($d) . ($dsnextra ? ";$dsnextra" : "");
  40 100       107  
432             }
433             }
434 32         1474 return @dsns;
435             } # data_sources
436              
437             sub avail_tables
438             {
439 36     36   87 my ($self, $dbh) = @_;
440              
441 36         82 my $dir = $dbh->{f_dir};
442 36 50       87 defined $dir or return; # Stream based db's cannot be queried for tables
443              
444 36         66 my %seen;
445             my @tables;
446 36         77 my @dir = ($dir);
447             $dbh->{f_dir_search} && ref $dbh->{f_dir_search} eq "ARRAY" and
448 36 100 66     130 push @dir, grep { -d $_ } @{$dbh->{f_dir_search}};
  4         56  
  4         14  
449 36         83 foreach $dir (@dir) {
450 40         289 my $dirh = IO::Dir->new ($dir);
451              
452 40 50       3996 unless (defined $dirh) {
453 0         0 $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
454 0         0 return;
455             }
456              
457 40         240 my $class = $dbh->FETCH ("ImplementorClass");
458 40         410 $class =~ s/::db$/::Table/;
459 40         78 my ($file, %names);
460             my $schema = exists $dbh->{f_schema}
461             ? defined $dbh->{f_schema} && $dbh->{f_schema} ne ""
462             ? $dbh->{f_schema} : undef
463 40 50 33     182 : eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent
  24 100       5848  
464 40         188 while (defined ($file = $dirh->read ())) {
465 176 100       2079 my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX
466             # $tbl && $meta && -f $meta->{f_fqfn} or next;
467 48 100       402 $seen{defined $schema ? $schema : "\0"}{$dir}{$tbl}++ or
    50          
468             push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ];
469             }
470 40 50       442 $dirh->close () or
471             $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
472             }
473              
474 36         1022 return @tables;
475             } # avail_tables
476              
477             # ====== DataSource ============================================================
478              
479             package DBD::File::DataSource::Stream;
480              
481 52     52   486 use strict;
  52         110  
  52         1086  
482 52     52   250 use warnings;
  52         104  
  52         1332  
483              
484 52     52   253 use Carp;
  52         102  
  52         27330  
485              
486             @DBD::File::DataSource::Stream::ISA = "DBI::DBD::SqlEngine::DataSource";
487              
488             # We may have a working flock () built-in but that doesn't mean that locking
489             # will work on NFS (flock () may hang hard)
490             my $locking = eval {
491             my $fh;
492             my $nulldevice = File::Spec->devnull ();
493             open $fh, ">", $nulldevice or croak "Can't open $nulldevice: $!";
494             flock $fh, 0;
495             close $fh;
496             1;
497             };
498              
499             sub complete_table_name
500             {
501 0     0   0 my ($self, $meta, $file, $respect_case) = @_;
502              
503 0         0 my $tbl = $file;
504 0 0 0     0 if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER
    0 0        
505 0         0 $tbl = uc $tbl;
506             }
507             elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
508 0         0 $tbl = lc $tbl;
509             }
510              
511 0         0 $meta->{f_fqfn} = undef;
512 0         0 $meta->{f_fqbn} = undef;
513 0         0 $meta->{f_fqln} = undef;
514              
515 0         0 $meta->{table_name} = $tbl;
516              
517 0         0 return $tbl;
518             } # complete_table_name
519              
520             sub apply_encoding
521             {
522 44     44   141 my ($self, $meta, $fn) = @_;
523 44 50       192 defined $fn or $fn = "file handle " . fileno ($meta->{fh});
524 44 50       135 if (my $enc = $meta->{f_encoding}) {
525 44 50   8   736 binmode $meta->{fh}, ":encoding($enc)" or
  8         64  
  8         14  
  8         47  
526             croak "Failed to set encoding layer '$enc' on $fn: $!";
527             }
528             else {
529 0 0       0 binmode $meta->{fh} or croak "Failed to set binary mode on $fn: $!";
530             }
531             } # apply_encoding
532              
533             sub open_data
534             {
535 0     0   0 my ($self, $meta, $attrs, $flags) = @_;
536              
537 0 0       0 $flags->{dropMode} and croak "Can't drop a table in stream";
538 0         0 my $fn = "file handle " . fileno ($meta->{f_file});
539              
540 0 0 0     0 if ($flags->{createMode} || $flags->{lockMode}) {
541 0 0       0 $meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "w+") or
542             croak "Cannot open $fn for writing: $! (" . ($!+0) . ")";
543             }
544             else {
545 0 0       0 $meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "r") or
546             croak "Cannot open $fn for reading: $! (" . ($!+0) . ")";
547             }
548              
549 0 0       0 if ($meta->{fh}) {
550 0         0 $self->apply_encoding ($meta, $fn);
551             } # have $meta->{$fh}
552              
553 0 0 0     0 if ($self->can_flock && $meta->{fh}) {
554             my $lm = defined $flags->{f_lock}
555             && $flags->{f_lock} =~ m/^[012]$/
556             ? $flags->{f_lock}
557 0 0 0     0 : $flags->{lockMode} ? 2 : 1;
    0          
558 0 0       0 if ($lm == 2) {
    0          
559 0 0       0 flock $meta->{fh}, 2 or croak "Cannot obtain exclusive lock on $fn: $!";
560             }
561             elsif ($lm == 1) {
562 0 0       0 flock $meta->{fh}, 1 or croak "Cannot obtain shared lock on $fn: $!";
563             }
564             # $lm = 0 is forced no locking at all
565             }
566             } # open_data
567              
568 412     412   1867 sub can_flock { $locking }
569              
570             package DBD::File::DataSource::File;
571              
572 52     52   367 use strict;
  52         102  
  52         1016  
573 52     52   232 use warnings;
  52         100  
  52         1793  
574              
575             @DBD::File::DataSource::File::ISA = "DBD::File::DataSource::Stream";
576              
577 52     52   272 use Carp;
  52         98  
  52         59420  
578              
579             my $fn_any_ext_regex = qr/\.[^.]*/;
580              
581             sub complete_table_name
582             {
583 514     514   1140 my ($self, $meta, $file, $respect_case, $file_is_table) = @_;
584              
585 514 100 100     2169 $file eq "." || $file eq ".." and return; # XXX would break a possible DBD::Dir
586              
587             # XXX now called without proving f_fqfn first ...
588 434         828 my ($ext, $req) = ("", 0);
589 434 100       909 if ($meta->{f_ext}) {
590 432         1425 ($ext, my $opt) = split m{/}, $meta->{f_ext};
591 432 100 66     1504 if ($ext && $opt) {
592 296 50       1239 $opt =~ m/r/i and $req = 1;
593             }
594             }
595              
596             # (my $tbl = $file) =~ s/\Q$ext\E$//i;
597 434         748 my ($tbl, $basename, $dir, $fn_ext, $user_spec_file, $searchdir);
598 434 100 100     1414 if ($file_is_table and defined $meta->{f_file}) {
599 4         6 $tbl = $file;
600 4         76 ($basename, $dir, $fn_ext) = File::Basename::fileparse ($meta->{f_file}, $fn_any_ext_regex);
601 4         17 $file = $basename . $fn_ext;
602 4         7 $user_spec_file = 1;
603             }
604             else {
605 430         18559 ($basename, $dir, undef) = File::Basename::fileparse ($file, qr{\Q$ext\E});
606             # $dir is returned with trailing (back)slash. We just need to check
607             # if it is ".", "./", or ".\" or "[]" (VMS)
608 430 100 66     3944 if ($dir =~ m{^(?:[.][/\\]?|\[\])$} && ref $meta->{f_dir_search} eq "ARRAY") {
609 32         60 foreach my $d ($meta->{f_dir}, @{$meta->{f_dir_search}}) {
  32         84  
610 52         342 my $f = File::Spec->catdir ($d, $file);
611 52 100       654 -f $f or next;
612 24         395 $searchdir = Cwd::abs_path ($d);
613 24         40 $dir = "";
614 24         40 last;
615             }
616             }
617 430         854 $file = $tbl = $basename;
618 430         657 $user_spec_file = 0;
619             }
620              
621 434 100 66     2571 if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER
    50 33        
622 16         34 $basename = uc $basename;
623 16         26 $tbl = uc $tbl;
624             }
625             elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
626 418         793 $basename = lc $basename;
627 418         708 $tbl = lc $tbl;
628             }
629              
630 434 100       876 unless (defined $searchdir) {
631             $searchdir = File::Spec->file_name_is_absolute ($dir)
632             ? ($dir =~ s{/$}{}, $dir)
633 410 100       14096 : Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
634             }
635 434 50       3122 -d $searchdir or
636             croak "-d $searchdir: $!";
637              
638             $searchdir eq $meta->{f_dir} and
639 434 100       1366 $dir = "";
640              
641 434 100       900 unless ($user_spec_file) {
642 430 100       1002 $file_is_table and $file = "$basename$ext";
643              
644             # Fully Qualified File Name
645 430         599 my $cmpsub;
646 430 50       799 if ($respect_case) {
647             $cmpsub = sub {
648 0     0   0 my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex);
649 0 0 0     0 $^O eq "VMS" && $sfx eq "." and
650             $sfx = ""; # no extension turns up as a dot
651 0 0 0     0 $fn eq $basename and
652             return (lc $sfx eq lc $ext or !$req && !$sfx);
653 0         0 return 0;
654             }
655 0         0 }
656             else {
657             $cmpsub = sub {
658 1926     1926   38306 my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex);
659 1926 50 33     5991 $^O eq "VMS" && $sfx eq "." and
660             $sfx = ""; # no extension turns up as a dot
661 1926 100 100     6143 lc $fn eq lc $basename and
662             return (lc $sfx eq lc $ext or !$req && !$sfx);
663 1314         2720 return 0;
664             }
665 430         2260 }
666              
667 430         730 my @f;
668 430 50       573 { my $dh = IO::Dir->new ($searchdir) or croak "Can't open '$searchdir': $!";
  430         2359  
669 8         39 @f = sort { length $b <=> length $a }
670 430         28082 grep { &$cmpsub ($_) }
  1926         11010  
671             $dh->read ();
672 430 50       1667 $dh->close () or croak "Can't close '$searchdir': $!";
673             }
674 430 100 66     16534 @f > 0 && @f <= 2 and $file = $f[0];
675 430 50 33     2027 !$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED
676             ($tbl = $file) =~ s/\Q$ext\E$//i;
677              
678 430         757 my $tmpfn = $file;
679 430 100 100     2007 if ($ext && $req) {
680             # File extension required
681 292 100       3204 $tmpfn =~ s/\Q$ext\E$//i or return;
682             }
683             }
684              
685 386         4612 my $fqfn = File::Spec->catfile ($searchdir, $file);
686 386         2277 my $fqbn = File::Spec->catfile ($searchdir, $basename);
687              
688 386         1047 $meta->{f_fqfn} = $fqfn;
689 386         688 $meta->{f_fqbn} = $fqbn;
690             defined $meta->{f_lockfile} && $meta->{f_lockfile} and
691 386 50 66     1683 $meta->{f_fqln} = $meta->{f_fqbn} . $meta->{f_lockfile};
692              
693 386 50 33     1211 $dir && !$user_spec_file and $tbl = File::Spec->catfile ($dir, $tbl);
694 386         1073 $meta->{table_name} = $tbl;
695              
696 386         1397 return $tbl;
697             } # complete_table_name
698              
699             sub open_data
700             {
701 460     460   940 my ($self, $meta, $attrs, $flags) = @_;
702              
703 460 50 33     1904 defined $meta->{f_fqfn} && $meta->{f_fqfn} ne "" or croak "No filename given";
704              
705 460         727 my ($fh, $fn);
706 460 100       1015 unless ($meta->{f_dontopen}) {
707 52         99 $fn = $meta->{f_fqfn};
708 52 100       125 if ($flags->{createMode}) {
709             -f $meta->{f_fqfn} and
710 8 50       165 croak "Cannot create table $attrs->{table}: Already exists";
711 8 50       62 $fh = IO::File->new ($fn, "a+") or
712             croak "Cannot open $fn for writing: $! (" . ($!+0) . ")";
713             }
714             else {
715 44 100       314 unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) {
    100          
716 8         2898 croak "Cannot open $fn: $! (" . ($!+0) . ")";
717             }
718             }
719              
720 44         4338 $meta->{fh} = $fh;
721              
722 44 50       111 if ($fh) {
723 44 50       255 $fh->seek (0, 0) or
724             croak "Error while seeking back: $!";
725              
726 44         600 $self->apply_encoding ($meta);
727             }
728             }
729 452 100       71014 if ($meta->{f_fqln}) {
730 406         642 $fn = $meta->{f_fqln};
731 406 100       779 if ($flags->{createMode}) {
732 54 50       808 -f $fn and
733             croak "Cannot create table lock at '$fn' for $attrs->{table}: Already exists";
734 54 50       405 $fh = IO::File->new ($fn, "a+") or
735             croak "Cannot open $fn for writing: $! (" . ($!+0) . ")";
736             }
737             else {
738 352 100       2223 unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) {
    100          
739 40         12051 croak "Cannot open $fn: $! (" . ($!+0) . ")";
740             }
741             }
742              
743 366         35776 $meta->{lockfh} = $fh;
744             }
745              
746 412 100 66     2192 if ($self->can_flock && $fh) {
747             my $lm = defined $flags->{f_lock}
748             && $flags->{f_lock} =~ m/^[012]$/
749             ? $flags->{f_lock}
750 410 100 33     1683 : $flags->{lockMode} ? 2 : 1;
    50          
751 410 100       1015 if ($lm == 2) {
    50          
752 318 50       3152 flock $fh, 2 or croak "Cannot obtain exclusive lock on $fn: $!";
753             }
754             elsif ($lm == 1) {
755 92 50       861 flock $fh, 1 or croak "Cannot obtain shared lock on $fn: $!";
756             }
757             # $lm = 0 is forced no locking at all
758             }
759             } # open_data
760              
761             # ====== SQL::STATEMENT ========================================================
762              
763             package DBD::File::Statement;
764              
765 52     52   394 use strict;
  52         123  
  52         1069  
766 52     52   242 use warnings;
  52         106  
  52         2319  
767              
768             @DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement );
769              
770             # ====== SQL::TABLE ============================================================
771              
772             package DBD::File::Table;
773              
774 52     52   265 use strict;
  52         96  
  52         951  
775 52     52   210 use warnings;
  52         113  
  52         1163  
776              
777 52     52   235 use Carp;
  52         100  
  52         46745  
778             require IO::File;
779             require File::Basename;
780             require File::Spec;
781             require Cwd;
782             require Scalar::Util;
783              
784             @DBD::File::Table::ISA = qw( DBI::DBD::SqlEngine::Table );
785              
786             # ====== UTILITIES ============================================================
787              
788             if (eval { require Params::Util; }) {
789             Params::Util->import ("_HANDLE");
790             }
791             else {
792             # taken but modified from Params::Util ...
793             *_HANDLE = sub {
794             # It has to be defined, of course
795 488 100   488   2303 defined $_[0] or return;
796              
797             # Normal globs are considered to be file handles
798 4 50       16 ref $_[0] eq "GLOB" and return $_[0];
799              
800             # Check for a normal tied filehandle
801             # Side Note: 5.5.4's tied () and can () doesn't like getting undef
802 4 50 33     14 tied ($_[0]) and tied ($_[0])->can ("TIEHANDLE") and return $_[0];
803              
804             # There are no other non-object handles that we support
805 4 50       26 Scalar::Util::blessed ($_[0]) or return;
806              
807             # Check for a common base classes for conventional IO::Handle object
808 0 0       0 $_[0]->isa ("IO::Handle") and return $_[0];
809              
810             # Check for tied file handles using Tie::Handle
811 0 0       0 $_[0]->isa ("Tie::Handle") and return $_[0];
812              
813             # IO::Scalar is not a proper seekable, but it is valid is a
814             # regular file handle
815 0 0       0 $_[0]->isa ("IO::Scalar") and return $_[0];
816              
817             # Yet another special case for IO::String, which refuses (for now
818             # anyway) to become a subclass of IO::Handle.
819 0 0       0 $_[0]->isa ("IO::String") and return $_[0];
820              
821             # This is not any sort of object we know about
822 0         0 return;
823             };
824             }
825              
826             # ====== FLYWEIGHT SUPPORT =====================================================
827              
828             # Flyweight support for table_info
829             # The functions file2table, init_table_meta, default_table_meta and
830             # get_table_meta are using $self arguments for polymorphism only. The
831             # must not rely on an instantiated DBD::File::Table
832             sub file2table
833             {
834 0     0   0 my ($self, $meta, $file, $file_is_table, $respect_case) = @_;
835              
836 0         0 return $meta->{sql_data_source}->complete_table_name ($meta, $file, $respect_case, $file_is_table);
837             } # file2table
838              
839             sub bootstrap_table_meta
840             {
841 522     522   1142 my ($self, $dbh, $meta, $table, @other) = @_;
842              
843 522         1684 $self->SUPER::bootstrap_table_meta ($dbh, $meta, $table, @other);
844              
845 522 100       1355 exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir};
846 522 100       1225 exists $meta->{f_dir_search} or $meta->{f_dir_search} = $dbh->{f_dir_search};
847 522 100       1089 defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext};
848 522 100       1557 defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding};
849 522 100       1272 exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock};
850 522 100       1378 exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile};
851 522 50       1267 defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema};
852              
853             defined $meta->{f_open_file_needed} or
854 522 100       4086 $meta->{f_open_file_needed} = $self->can ("open_file") != DBD::File::Table->can ("open_file");
855              
856             defined ($meta->{sql_data_source}) or
857             $meta->{sql_data_source} = _HANDLE ($meta->{f_file})
858 522 50       2562 ? "DBD::File::DataSource::Stream"
    100          
859             : "DBD::File::DataSource::File";
860             } # bootstrap_table_meta
861              
862             sub get_table_meta ($$$$;$)
863             {
864 1224     1224   2557 my ($self, $dbh, $table, $file_is_table, $respect_case) = @_;
865              
866 1224         3475 my $meta = $self->SUPER::get_table_meta ($dbh, $table, $respect_case, $file_is_table);
867 1224         1969 $table = $meta->{table_name};
868 1224 100       2409 return unless $table;
869              
870 1096         3396 return ($table, $meta);
871             } # get_table_meta
872              
873             my %reset_on_modify = (
874             f_file => [ "f_fqfn", "sql_data_source" ],
875             f_dir => "f_fqfn",
876             f_dir_search => [],
877             f_ext => "f_fqfn",
878             f_lockfile => "f_fqfn", # forces new file2table call
879             );
880              
881             __PACKAGE__->register_reset_on_modify (\%reset_on_modify);
882              
883             my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile );
884              
885             __PACKAGE__->register_compat_map (\%compat_map);
886              
887             # ====== DBD::File <= 0.40 compat stuff ========================================
888              
889             # compat to 0.38 .. 0.40 API
890             sub open_file
891             {
892 0     0   0 my ($className, $meta, $attrs, $flags) = @_;
893              
894 0         0 return $className->SUPER::open_data ($meta, $attrs, $flags);
895             } # open_file
896              
897             sub open_data
898             {
899 460     460   946 my ($className, $meta, $attrs, $flags) = @_;
900              
901             # compat to 0.38 .. 0.40 API
902             $meta->{f_open_file_needed}
903 460 50       1878 ? $className->open_file ($meta, $attrs, $flags)
904             : $className->SUPER::open_data ($meta, $attrs, $flags);
905              
906 412         785 return;
907             } # open_data
908              
909             # ====== SQL::Eval API =========================================================
910              
911             sub drop ($)
912             {
913 72     72   174 my ($self, $data) = @_;
914 72         681 my $meta = $self->{meta};
915             # We have to close the file before unlinking it: Some OS'es will
916             # refuse the unlink otherwise.
917 72 100       321 $meta->{fh} and $meta->{fh}->close ();
918 72 100       639 $meta->{lockfh} and $meta->{lockfh}->close ();
919 72         743 undef $meta->{fh};
920 72         246 undef $meta->{lockfh};
921 72 50       5633 $meta->{f_fqfn} and unlink $meta->{f_fqfn}; # XXX ==> sql_data_source
922 72 100       1199 $meta->{f_fqln} and unlink $meta->{f_fqln}; # XXX ==> sql_data_source
923 72         303 delete $data->{Database}{sql_meta}{$self->{table}};
924 72         208 return 1;
925             } # drop
926              
927             sub seek ($$$$)
928             {
929 0     0   0 my ($self, $data, $pos, $whence) = @_;
930 0         0 my $meta = $self->{meta};
931 0 0 0     0 if ($whence == 0 && $pos == 0) {
    0 0        
932 0 0       0 $pos = defined $meta->{first_row_pos} ? $meta->{first_row_pos} : 0;
933             }
934             elsif ($whence != 2 || $pos != 0) {
935 0         0 croak "Illegal seek position: pos = $pos, whence = $whence";
936             }
937              
938             $meta->{fh}->seek ($pos, $whence) or
939 0 0       0 croak "Error while seeking in " . $meta->{f_fqfn} . ": $!";
940             } # seek
941              
942             sub truncate ($$)
943             {
944 0     0   0 my ($self, $data) = @_;
945 0         0 my $meta = $self->{meta};
946             $meta->{fh}->truncate ($meta->{fh}->tell ()) or
947 0 0       0 croak "Error while truncating " . $meta->{f_fqfn} . ": $!";
948 0         0 return 1;
949             } # truncate
950              
951             sub DESTROY
952             {
953 412     412   677 my $self = shift;
954 412         775 my $meta = $self->{meta};
955 412 100       982 $meta->{fh} and $meta->{fh}->close ();
956 412 100       2031 $meta->{lockfh} and $meta->{lockfh}->close ();
957 412         3805 undef $meta->{fh};
958 412         1053 undef $meta->{lockfh};
959              
960 412         1285 $self->SUPER::DESTROY();
961             } # DESTROY
962              
963             1;
964              
965             __END__