| 1 |
joko |
1.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 |
|
|
# Jeff Zucker |
| 9 |
|
|
# <jeff@vpservices.com> |
| 10 |
|
|
# |
| 11 |
|
|
# The original author is Jochen Wiedmann. |
| 12 |
|
|
# |
| 13 |
|
|
# Copyright (C) 1998 by Jochen Wiedmann |
| 14 |
|
|
# |
| 15 |
|
|
# All rights reserved. |
| 16 |
|
|
# |
| 17 |
|
|
# You may distribute this module under the terms of either the GNU |
| 18 |
|
|
# General Public License or the Artistic License, as specified in |
| 19 |
|
|
# the Perl README file. |
| 20 |
|
|
# |
| 21 |
|
|
|
| 22 |
|
|
require 5.004; |
| 23 |
|
|
use strict; |
| 24 |
|
|
|
| 25 |
|
|
|
| 26 |
|
|
require DynaLoader; |
| 27 |
|
|
require DBI; |
| 28 |
|
|
require SQL::Statement; |
| 29 |
|
|
require SQL::Eval; |
| 30 |
|
|
my $haveFileSpec = eval { require File::Spec }; |
| 31 |
|
|
|
| 32 |
|
|
package DBD::File; |
| 33 |
|
|
|
| 34 |
|
|
use vars qw(@ISA $VERSION $drh $err $errstr $sqlstate); |
| 35 |
|
|
|
| 36 |
|
|
@ISA = qw(DynaLoader); |
| 37 |
|
|
|
| 38 |
|
|
$VERSION = '0.2001'; # FIRST JZ CHANGES (cached parser) |
| 39 |
|
|
|
| 40 |
|
|
$err = 0; # holds error code for DBI::err |
| 41 |
|
|
$errstr = ""; # holds error string for DBI::errstr |
| 42 |
|
|
$sqlstate = ""; # holds error state for DBI::state |
| 43 |
|
|
$drh = undef; # holds driver handle once initialised |
| 44 |
|
|
|
| 45 |
|
|
|
| 46 |
|
|
sub driver ($;$) { |
| 47 |
|
|
my($class, $attr) = @_; |
| 48 |
|
|
my $drh = eval '$' . $class . "::drh"; |
| 49 |
|
|
if (!$drh) { |
| 50 |
|
|
if (!$attr) { $attr = {} }; |
| 51 |
|
|
if (!exists($attr->{Attribution})) { |
| 52 |
|
|
$attr->{Attribution} = "$class by Jochen Wiedmann"; |
| 53 |
|
|
} |
| 54 |
|
|
if (!exists($attr->{Version})) { |
| 55 |
|
|
$attr->{Version} = eval '$' . $class . '::VERSION'; |
| 56 |
|
|
} |
| 57 |
|
|
if (!exists($attr->{Err})) { |
| 58 |
|
|
$attr->{Err} = eval '\$' . $class . '::err'; |
| 59 |
|
|
} |
| 60 |
|
|
if (!exists($attr->{Errstr})) { |
| 61 |
|
|
$attr->{Errstr} = eval '\$' . $class . '::errstr'; |
| 62 |
|
|
} |
| 63 |
|
|
if (!exists($attr->{State})) { |
| 64 |
|
|
$attr->{State} = eval '\$' . $class . '::state'; |
| 65 |
|
|
} |
| 66 |
|
|
if (!exists($attr->{Name})) { |
| 67 |
|
|
my $c = $class; |
| 68 |
|
|
$c =~ s/^DBD\:\://; |
| 69 |
|
|
$attr->{Name} = $c; |
| 70 |
|
|
} |
| 71 |
|
|
|
| 72 |
|
|
$drh = DBI::_new_drh($class . "::dr", $attr); |
| 73 |
|
|
} |
| 74 |
|
|
$drh; |
| 75 |
|
|
} |
| 76 |
|
|
|
| 77 |
|
|
|
| 78 |
|
|
package DBD::File::dr; # ====== DRIVER ====== |
| 79 |
|
|
|
| 80 |
|
|
$DBD::File::dr::imp_data_size = 0; |
| 81 |
|
|
|
| 82 |
|
|
sub connect ($$;$$$) { |
| 83 |
|
|
my($drh, $dbname, $user, $auth, $attr)= @_; |
| 84 |
|
|
|
| 85 |
|
|
# create a 'blank' dbh |
| 86 |
|
|
my $this = DBI::_new_dbh($drh, { |
| 87 |
|
|
'Name' => $dbname, |
| 88 |
|
|
'USER' => $user, |
| 89 |
|
|
'CURRENT_USER' => $user, |
| 90 |
|
|
}); |
| 91 |
|
|
|
| 92 |
|
|
if ($this) { |
| 93 |
|
|
my($var, $val); |
| 94 |
|
|
$this->{f_dir} = $haveFileSpec ? File::Spec->curdir() : '.'; |
| 95 |
|
|
while (length($dbname)) { |
| 96 |
|
|
if ($dbname =~ s/^((?:[^\\;]|\\.)*?);//s) { |
| 97 |
|
|
$var = $1; |
| 98 |
|
|
} else { |
| 99 |
|
|
$var = $dbname; |
| 100 |
|
|
$dbname = ''; |
| 101 |
|
|
} |
| 102 |
|
|
if ($var =~ /^(.+?)=(.*)/s) { |
| 103 |
|
|
$var = $1; |
| 104 |
|
|
($val = $2) =~ s/\\(.)/$1/g; |
| 105 |
|
|
$this->{$var} = $val; |
| 106 |
|
|
} |
| 107 |
|
|
} |
| 108 |
|
|
} |
| 109 |
|
|
|
| 110 |
|
|
$this; |
| 111 |
|
|
} |
| 112 |
|
|
|
| 113 |
|
|
sub data_sources ($;$) { |
| 114 |
|
|
my($drh, $attr) = @_; |
| 115 |
|
|
my($dir) = ($attr and exists($attr->{'f_dir'})) ? |
| 116 |
|
|
$attr->{'f_dir'} : $haveFileSpec ? File::Spec->curdir() : '.'; |
| 117 |
|
|
my($dirh) = Symbol::gensym(); |
| 118 |
|
|
if (!opendir($dirh, $dir)) { |
| 119 |
|
|
DBI::set_err($drh, 1, "Cannot open directory $dir"); |
| 120 |
|
|
return undef; |
| 121 |
|
|
} |
| 122 |
|
|
my($file, @dsns, %names, $driver); |
| 123 |
|
|
if ($drh->{'ImplementorClass'} =~ /^dbd\:\:([^\:]+)\:\:/i) { |
| 124 |
|
|
$driver = $1; |
| 125 |
|
|
} else { |
| 126 |
|
|
$driver = 'File'; |
| 127 |
|
|
} |
| 128 |
|
|
while (defined($file = readdir($dirh))) { |
| 129 |
|
|
my $d = $haveFileSpec ? |
| 130 |
|
|
File::Spec->catdir($dir, $file) : "$dir/$file"; |
| 131 |
|
|
if ($file ne ($haveFileSpec ? File::Spec->curdir() : '.') |
| 132 |
|
|
and $file ne ($haveFileSpec ? File::Spec->updir() : '..') |
| 133 |
|
|
and -d $d) { |
| 134 |
|
|
push(@dsns, "DBI:$driver:f_dir=$d"); |
| 135 |
|
|
} |
| 136 |
|
|
} |
| 137 |
|
|
@dsns; |
| 138 |
|
|
} |
| 139 |
|
|
|
| 140 |
|
|
sub disconnect_all { |
| 141 |
|
|
} |
| 142 |
|
|
|
| 143 |
|
|
sub DESTROY { |
| 144 |
|
|
undef; |
| 145 |
|
|
} |
| 146 |
|
|
|
| 147 |
|
|
|
| 148 |
|
|
package DBD::File::db; # ====== DATABASE ====== |
| 149 |
|
|
|
| 150 |
|
|
$DBD::File::db::imp_data_size = 0; |
| 151 |
|
|
|
| 152 |
|
|
|
| 153 |
|
|
sub prepare ($$;@) { |
| 154 |
|
|
my($dbh, $statement, @attribs)= @_; |
| 155 |
|
|
|
| 156 |
|
|
# create a 'blank' dbh |
| 157 |
|
|
my $sth = DBI::_new_sth($dbh, {'Statement' => $statement}); |
| 158 |
|
|
|
| 159 |
|
|
if ($sth) { |
| 160 |
|
|
$@ = ''; |
| 161 |
|
|
my $class = $sth->FETCH('ImplementorClass'); |
| 162 |
|
|
$class =~ s/::st$/::Statement/; |
| 163 |
|
|
###jz |
| 164 |
|
|
# my($stmt) = eval { $class->new($statement) }; |
| 165 |
|
|
#=pod |
| 166 |
|
|
my($stmt); |
| 167 |
|
|
my $sversion = $SQL::Statement::VERSION; |
| 168 |
|
|
if ($SQL::Statement::VERSION > 1) { |
| 169 |
|
|
my $parser = $dbh->{csv_sql_parser_object}; |
| 170 |
|
|
$parser ||= $dbh->func('csv_cache_sql_parser_object'); |
| 171 |
|
|
$stmt = eval { $class->new($statement,$parser) }; |
| 172 |
|
|
} |
| 173 |
|
|
else { |
| 174 |
|
|
$stmt = eval { $class->new($statement) }; |
| 175 |
|
|
} |
| 176 |
|
|
#=cut |
| 177 |
|
|
###jzend |
| 178 |
|
|
if ($@) { |
| 179 |
|
|
DBI::set_err($dbh, 1, $@); |
| 180 |
|
|
undef $sth; |
| 181 |
|
|
} else { |
| 182 |
|
|
$sth->STORE('f_stmt', $stmt); |
| 183 |
|
|
$sth->STORE('f_params', []); |
| 184 |
|
|
$sth->STORE('NUM_OF_PARAMS', scalar($stmt->params())); |
| 185 |
|
|
} |
| 186 |
|
|
} |
| 187 |
|
|
|
| 188 |
|
|
$sth; |
| 189 |
|
|
} |
| 190 |
|
|
|
| 191 |
|
|
sub disconnect ($) { |
| 192 |
|
|
1; |
| 193 |
|
|
} |
| 194 |
|
|
|
| 195 |
|
|
sub FETCH ($$) { |
| 196 |
|
|
my ($dbh, $attrib) = @_; |
| 197 |
|
|
if ($attrib eq 'AutoCommit') { |
| 198 |
|
|
return 1; |
| 199 |
|
|
} elsif ($attrib eq (lc $attrib)) { |
| 200 |
|
|
# Driver private attributes are lower cased |
| 201 |
|
|
return $dbh->{$attrib}; |
| 202 |
|
|
} |
| 203 |
|
|
# else pass up to DBI to handle |
| 204 |
|
|
return $dbh->DBD::_::db::FETCH($attrib); |
| 205 |
|
|
} |
| 206 |
|
|
|
| 207 |
|
|
sub STORE ($$$) { |
| 208 |
|
|
my ($dbh, $attrib, $value) = @_; |
| 209 |
|
|
if ($attrib eq 'AutoCommit') { |
| 210 |
|
|
return 1 if $value; # is already set |
| 211 |
|
|
die("Can't disable AutoCommit"); |
| 212 |
|
|
} elsif ($attrib eq (lc $attrib)) { |
| 213 |
|
|
# Driver private attributes are lower cased |
| 214 |
|
|
$dbh->{$attrib} = $value; |
| 215 |
|
|
return 1; |
| 216 |
|
|
} |
| 217 |
|
|
return $dbh->DBD::_::db::STORE($attrib, $value); |
| 218 |
|
|
} |
| 219 |
|
|
|
| 220 |
|
|
sub DESTROY ($) { |
| 221 |
|
|
undef; |
| 222 |
|
|
} |
| 223 |
|
|
|
| 224 |
|
|
sub type_info_all ($) { |
| 225 |
|
|
[ |
| 226 |
|
|
{ TYPE_NAME => 0, |
| 227 |
|
|
DATA_TYPE => 1, |
| 228 |
|
|
PRECISION => 2, |
| 229 |
|
|
LITERAL_PREFIX => 3, |
| 230 |
|
|
LITERAL_SUFFIX => 4, |
| 231 |
|
|
CREATE_PARAMS => 5, |
| 232 |
|
|
NULLABLE => 6, |
| 233 |
|
|
CASE_SENSITIVE => 7, |
| 234 |
|
|
SEARCHABLE => 8, |
| 235 |
|
|
UNSIGNED_ATTRIBUTE=> 9, |
| 236 |
|
|
MONEY => 10, |
| 237 |
|
|
AUTO_INCREMENT => 11, |
| 238 |
|
|
LOCAL_TYPE_NAME => 12, |
| 239 |
|
|
MINIMUM_SCALE => 13, |
| 240 |
|
|
MAXIMUM_SCALE => 14, |
| 241 |
|
|
}, |
| 242 |
|
|
[ 'VARCHAR', DBI::SQL_VARCHAR(), |
| 243 |
|
|
undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999 |
| 244 |
|
|
], |
| 245 |
|
|
[ 'CHAR', DBI::SQL_CHAR(), |
| 246 |
|
|
undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999 |
| 247 |
|
|
], |
| 248 |
|
|
[ 'INTEGER', DBI::SQL_INTEGER(), |
| 249 |
|
|
undef, "", "", undef,0, 0,1,0,0,0,undef,0, 0 |
| 250 |
|
|
], |
| 251 |
|
|
[ 'REAL', DBI::SQL_REAL(), |
| 252 |
|
|
undef, "", "", undef,0, 0,1,0,0,0,undef,0, 0 |
| 253 |
|
|
], |
| 254 |
|
|
[ 'BLOB', DBI::SQL_LONGVARBINARY(), |
| 255 |
|
|
undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999 |
| 256 |
|
|
], |
| 257 |
|
|
[ 'BLOB', DBI::SQL_LONGVARBINARY(), |
| 258 |
|
|
undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999 |
| 259 |
|
|
], |
| 260 |
|
|
[ 'TEXT', DBI::SQL_LONGVARCHAR(), |
| 261 |
|
|
undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999 |
| 262 |
|
|
] |
| 263 |
|
|
] |
| 264 |
|
|
} |
| 265 |
|
|
|
| 266 |
|
|
|
| 267 |
|
|
{ |
| 268 |
|
|
my $names = ['TABLE_QUALIFIER', 'TABLE_OWNER', 'TABLE_NAME', |
| 269 |
|
|
'TABLE_TYPE', 'REMARKS']; |
| 270 |
|
|
|
| 271 |
|
|
sub table_info ($) { |
| 272 |
|
|
my($dbh) = @_; |
| 273 |
|
|
my($dir) = $dbh->{f_dir}; |
| 274 |
|
|
my($dirh) = Symbol::gensym(); |
| 275 |
|
|
if (!opendir($dirh, $dir)) { |
| 276 |
|
|
DBI::set_err($dbh, 1, "Cannot open directory $dir"); |
| 277 |
|
|
return undef; |
| 278 |
|
|
} |
| 279 |
|
|
my($file, @tables, %names); |
| 280 |
|
|
while (defined($file = readdir($dirh))) { |
| 281 |
|
|
if ($file ne '.' && $file ne '..' && -f "$dir/$file") { |
| 282 |
|
|
my $user = eval { getpwuid((stat(_))[4]) }; |
| 283 |
|
|
push(@tables, [undef, $user, $file, "TABLE", undef]); |
| 284 |
|
|
} |
| 285 |
|
|
} |
| 286 |
|
|
if (!closedir($dirh)) { |
| 287 |
|
|
DBI::set_err($dbh, 1, "Cannot close directory $dir"); |
| 288 |
|
|
return undef; |
| 289 |
|
|
} |
| 290 |
|
|
|
| 291 |
|
|
my $dbh2 = $dbh->{'csv_sponge_driver'}; |
| 292 |
|
|
if (!$dbh2) { |
| 293 |
|
|
$dbh2 = $dbh->{'csv_sponge_driver'} = DBI->connect("DBI:Sponge:"); |
| 294 |
|
|
if (!$dbh2) { |
| 295 |
|
|
DBI::set_err($dbh, 1, $DBI::errstr); |
| 296 |
|
|
return undef; |
| 297 |
|
|
} |
| 298 |
|
|
} |
| 299 |
|
|
|
| 300 |
|
|
# Temporary kludge: DBD::Sponge dies if @tables is empty. :-( |
| 301 |
|
|
return undef if !@tables; |
| 302 |
|
|
|
| 303 |
|
|
my $sth = $dbh2->prepare("TABLE_INFO", { 'rows' => \@tables, |
| 304 |
|
|
'NAMES' => $names }); |
| 305 |
|
|
if (!$sth) { |
| 306 |
|
|
DBI::set_err($dbh, 1, $dbh2->errstr()); |
| 307 |
|
|
} |
| 308 |
|
|
$sth; |
| 309 |
|
|
} |
| 310 |
|
|
} |
| 311 |
|
|
sub list_tables ($) { |
| 312 |
|
|
my $dbh = shift; |
| 313 |
|
|
my($sth, @tables); |
| 314 |
|
|
if (!($sth = $dbh->table_info())) { |
| 315 |
|
|
return (); |
| 316 |
|
|
} |
| 317 |
|
|
while (my $ref = $sth->fetchrow_arrayref()) { |
| 318 |
|
|
push(@tables, $ref->[2]); |
| 319 |
|
|
} |
| 320 |
|
|
@tables; |
| 321 |
|
|
} |
| 322 |
|
|
|
| 323 |
|
|
sub quote ($$;$) { |
| 324 |
|
|
my($self, $str, $type) = @_; |
| 325 |
|
|
if (defined($type) && |
| 326 |
|
|
($type == DBI::SQL_NUMERIC() || |
| 327 |
|
|
$type == DBI::SQL_DECIMAL() || |
| 328 |
|
|
$type == DBI::SQL_INTEGER() || |
| 329 |
|
|
$type == DBI::SQL_SMALLINT() || |
| 330 |
|
|
$type == DBI::SQL_FLOAT() || |
| 331 |
|
|
$type == DBI::SQL_REAL() || |
| 332 |
|
|
$type == DBI::SQL_DOUBLE() || |
| 333 |
|
|
$type == DBI::TINYINT())) { |
| 334 |
|
|
return $str; |
| 335 |
|
|
} |
| 336 |
|
|
if (!defined($str)) { return "NULL" } |
| 337 |
|
|
$str =~ s/\\/\\\\/sg; |
| 338 |
|
|
$str =~ s/\0/\\0/sg; |
| 339 |
|
|
$str =~ s/\'/\\\'/sg; |
| 340 |
|
|
$str =~ s/\n/\\n/sg; |
| 341 |
|
|
$str =~ s/\r/\\r/sg; |
| 342 |
|
|
"'$str'"; |
| 343 |
|
|
} |
| 344 |
|
|
|
| 345 |
|
|
sub commit ($) { |
| 346 |
|
|
my($dbh) = shift; |
| 347 |
|
|
if ($dbh->FETCH('Warn')) { |
| 348 |
|
|
warn("Commit ineffective while AutoCommit is on", -1); |
| 349 |
|
|
} |
| 350 |
|
|
1; |
| 351 |
|
|
} |
| 352 |
|
|
|
| 353 |
|
|
sub rollback ($) { |
| 354 |
|
|
my($dbh) = shift; |
| 355 |
|
|
if ($dbh->FETCH('Warn')) { |
| 356 |
|
|
warn("Rollback ineffective while AutoCommit is on", -1); |
| 357 |
|
|
} |
| 358 |
|
|
0; |
| 359 |
|
|
} |
| 360 |
|
|
|
| 361 |
|
|
|
| 362 |
|
|
package DBD::File::st; # ====== STATEMENT ====== |
| 363 |
|
|
|
| 364 |
|
|
$DBD::File::st::imp_data_size = 0; |
| 365 |
|
|
|
| 366 |
|
|
sub bind_param ($$$;$) { |
| 367 |
|
|
my($sth, $pNum, $val, $attr) = @_; |
| 368 |
|
|
$sth->{f_params}->[$pNum-1] = $val; |
| 369 |
|
|
1; |
| 370 |
|
|
} |
| 371 |
|
|
|
| 372 |
|
|
sub execute { |
| 373 |
|
|
my $sth = shift; |
| 374 |
|
|
my $params; |
| 375 |
|
|
if (@_) { |
| 376 |
|
|
$sth->{'f_params'} = ($params = [@_]); |
| 377 |
|
|
} else { |
| 378 |
|
|
$params = $sth->{'f_params'}; |
| 379 |
|
|
} |
| 380 |
|
|
my $stmt = $sth->{'f_stmt'}; |
| 381 |
|
|
my $result = eval { $stmt->execute($sth, $params); }; |
| 382 |
|
|
if ($@) { |
| 383 |
|
|
DBI::set_err($sth, 1, $@); |
| 384 |
|
|
return undef; |
| 385 |
|
|
} |
| 386 |
|
|
if ($stmt->{'NUM_OF_FIELDS'} && !$sth->FETCH('NUM_OF_FIELDS')) { |
| 387 |
|
|
$sth->STORE('NUM_OF_FIELDS', $stmt->{'NUM_OF_FIELDS'}); |
| 388 |
|
|
} |
| 389 |
|
|
return $result; |
| 390 |
|
|
} |
| 391 |
|
|
|
| 392 |
|
|
sub fetch ($) { |
| 393 |
|
|
my $sth = shift; |
| 394 |
|
|
my $data = $sth->{f_stmt}->{data}; |
| 395 |
|
|
if (!$data || ref($data) ne 'ARRAY') { |
| 396 |
|
|
DBI::set_err($sth, 1, |
| 397 |
|
|
"Attempt to fetch row from a Non-SELECT statement"); |
| 398 |
|
|
return undef; |
| 399 |
|
|
} |
| 400 |
|
|
my $dav = shift @$data; |
| 401 |
|
|
if (!$dav) { |
| 402 |
|
|
return undef; |
| 403 |
|
|
} |
| 404 |
|
|
if ($sth->FETCH('ChopBlanks')) { |
| 405 |
|
|
map { $_ =~ s/\s+$//; } @$dav; |
| 406 |
|
|
} |
| 407 |
|
|
$sth->_set_fbav($dav); |
| 408 |
|
|
} |
| 409 |
|
|
*fetchrow_arrayref = \&fetch; |
| 410 |
|
|
|
| 411 |
|
|
sub FETCH ($$) { |
| 412 |
|
|
my ($sth, $attrib) = @_; |
| 413 |
|
|
return undef if ($attrib eq 'TYPE'); # Workaround for a bug in DBI 0.93 |
| 414 |
|
|
return $sth->FETCH('f_stmt')->{'NAME'} if ($attrib eq 'NAME'); |
| 415 |
|
|
if ($attrib eq 'NULLABLE') { |
| 416 |
|
|
my($meta) = $sth->FETCH('f_stmt')->{'NAME'}; # Intentional ! |
| 417 |
|
|
if (!$meta) { |
| 418 |
|
|
return undef; |
| 419 |
|
|
} |
| 420 |
|
|
my($names) = []; |
| 421 |
|
|
my($col); |
| 422 |
|
|
foreach $col (@$meta) { |
| 423 |
|
|
push(@$names, 1); |
| 424 |
|
|
} |
| 425 |
|
|
return $names; |
| 426 |
|
|
} |
| 427 |
|
|
if ($attrib eq (lc $attrib)) { |
| 428 |
|
|
# Private driver attributes are lower cased |
| 429 |
|
|
return $sth->{$attrib}; |
| 430 |
|
|
} |
| 431 |
|
|
# else pass up to DBI to handle |
| 432 |
|
|
return $sth->DBD::_::st::FETCH($attrib); |
| 433 |
|
|
} |
| 434 |
|
|
|
| 435 |
|
|
sub STORE ($$$) { |
| 436 |
|
|
my ($sth, $attrib, $value) = @_; |
| 437 |
|
|
if ($attrib eq (lc $attrib)) { |
| 438 |
|
|
# Private driver attributes are lower cased |
| 439 |
|
|
$sth->{$attrib} = $value; |
| 440 |
|
|
return 1; |
| 441 |
|
|
} |
| 442 |
|
|
return $sth->DBD::_::st::STORE($attrib, $value); |
| 443 |
|
|
} |
| 444 |
|
|
|
| 445 |
|
|
sub DESTROY ($) { |
| 446 |
|
|
undef; |
| 447 |
|
|
} |
| 448 |
|
|
|
| 449 |
|
|
sub rows ($) { shift->{'f_stmt'}->{'NUM_OF_ROWS'} }; |
| 450 |
|
|
|
| 451 |
|
|
sub finish ($) { 1; } |
| 452 |
|
|
|
| 453 |
|
|
|
| 454 |
|
|
package DBD::File::Statement; |
| 455 |
|
|
|
| 456 |
|
|
my $locking = $^O ne 'MacOS' && |
| 457 |
|
|
($^O ne 'MSWin32' || !Win32::IsWin95()) && |
| 458 |
|
|
$^O ne 'VMS'; |
| 459 |
|
|
|
| 460 |
|
|
@DBD::File::Statement::ISA = qw(SQL::Statement); |
| 461 |
|
|
|
| 462 |
|
|
my $open_table_re = |
| 463 |
|
|
$haveFileSpec ? |
| 464 |
|
|
sprintf('(?:%s|%s¦%s)', |
| 465 |
|
|
quotemeta(File::Spec->curdir()), |
| 466 |
|
|
quotemeta(File::Spec->updir()), |
| 467 |
|
|
quotemeta(File::Spec->rootdir())) |
| 468 |
|
|
: '(?:\.?\.)?\/'; |
| 469 |
|
|
sub open_table ($$$$$) { |
| 470 |
|
|
my($self, $data, $table, $createMode, $lockMode) = @_; |
| 471 |
|
|
my $file = $table; |
| 472 |
|
|
if ($file !~ /^$open_table_re/o) { |
| 473 |
|
|
$file = $haveFileSpec ? |
| 474 |
|
|
File::Spec->catfile($data->{Database}->{'f_dir'}, $table) |
| 475 |
|
|
: $data->{Database}->{'f_dir'} . "/$table"; |
| 476 |
|
|
} |
| 477 |
|
|
my $fh; |
| 478 |
|
|
if ($createMode) { |
| 479 |
|
|
if (-f $file) { |
| 480 |
|
|
die "Cannot create table $table: Already exists"; |
| 481 |
|
|
} |
| 482 |
|
|
if (!($fh = IO::File->new($file, "a+"))) { |
| 483 |
|
|
die "Cannot open $file for writing: $!"; |
| 484 |
|
|
} |
| 485 |
|
|
if (!$fh->seek(0, 0)) { |
| 486 |
|
|
die " Error while seeking back: $!"; |
| 487 |
|
|
} |
| 488 |
|
|
} else { |
| 489 |
|
|
if (!($fh = IO::File->new($file, ($lockMode ? "r+" : "r")))) { |
| 490 |
|
|
die " Cannot open $file: $!"; |
| 491 |
|
|
} |
| 492 |
|
|
} |
| 493 |
|
|
binmode($fh); |
| 494 |
|
|
if ($locking) { |
| 495 |
|
|
if ($lockMode) { |
| 496 |
|
|
if (!flock($fh, 2)) { |
| 497 |
|
|
die " Cannot obtain exclusive lock on $file: $!"; |
| 498 |
|
|
} |
| 499 |
|
|
} else { |
| 500 |
|
|
if (!flock($fh, 1)) { |
| 501 |
|
|
die "Cannot obtain shared lock on $file: $!"; |
| 502 |
|
|
} |
| 503 |
|
|
} |
| 504 |
|
|
} |
| 505 |
|
|
my $columns = {}; |
| 506 |
|
|
my $array = []; |
| 507 |
|
|
my $tbl = { |
| 508 |
|
|
file => $file, |
| 509 |
|
|
fh => $fh, |
| 510 |
|
|
col_nums => $columns, |
| 511 |
|
|
col_names => $array, |
| 512 |
|
|
first_row_pos => $fh->tell() |
| 513 |
|
|
}; |
| 514 |
|
|
my $class = ref($self); |
| 515 |
|
|
$class =~ s/::Statement/::Table/; |
| 516 |
|
|
bless($tbl, $class); |
| 517 |
|
|
$tbl; |
| 518 |
|
|
} |
| 519 |
|
|
|
| 520 |
|
|
|
| 521 |
|
|
package DBD::File::Table; |
| 522 |
|
|
|
| 523 |
|
|
@DBD::File::Table::ISA = qw(SQL::Eval::Table); |
| 524 |
|
|
|
| 525 |
|
|
sub drop ($) { |
| 526 |
|
|
my($self) = @_; |
| 527 |
|
|
# We have to close the file before unlinking it: Some OS'es will |
| 528 |
|
|
# refuse the unlink otherwise. |
| 529 |
|
|
$self->{'fh'}->close(); |
| 530 |
|
|
unlink($self->{'file'}); |
| 531 |
|
|
return 1; |
| 532 |
|
|
} |
| 533 |
|
|
|
| 534 |
|
|
sub seek ($$$$) { |
| 535 |
|
|
my($self, $data, $pos, $whence) = @_; |
| 536 |
|
|
if ($whence == 0 && $pos == 0) { |
| 537 |
|
|
$pos = $self->{'first_row_pos'}; |
| 538 |
|
|
} elsif ($whence != 2 || $pos != 0) { |
| 539 |
|
|
die "Illegal seek position: pos = $pos, whence = $whence"; |
| 540 |
|
|
} |
| 541 |
|
|
if (!$self->{'fh'}->seek($pos, $whence)) { |
| 542 |
|
|
die "Error while seeking in " . $self->{'file'} . ": $!"; |
| 543 |
|
|
} |
| 544 |
|
|
} |
| 545 |
|
|
|
| 546 |
|
|
sub truncate ($$) { |
| 547 |
|
|
my($self, $data) = @_; |
| 548 |
|
|
if (!$self->{'fh'}->truncate($self->{'fh'}->tell())) { |
| 549 |
|
|
die "Error while truncating " . $self->{'file'} . ": $!"; |
| 550 |
|
|
} |
| 551 |
|
|
1; |
| 552 |
|
|
} |
| 553 |
|
|
|
| 554 |
|
|
1; |
| 555 |
|
|
|
| 556 |
|
|
|
| 557 |
|
|
__END__ |
| 558 |
|
|
|
| 559 |
|
|
=head1 NAME |
| 560 |
|
|
|
| 561 |
|
|
DBD::File - Base class for writing DBI drivers for plain files |
| 562 |
|
|
|
| 563 |
|
|
=head1 SYNOPSIS |
| 564 |
|
|
|
| 565 |
|
|
use DBI; |
| 566 |
|
|
$dbh = DBI->connect("DBI:File:f_dir=/home/joe/csvdb") |
| 567 |
|
|
or die "Cannot connect: " . $DBI::errstr; |
| 568 |
|
|
$sth = $dbh->prepare("CREATE TABLE a (id INTEGER, name CHAR(10))") |
| 569 |
|
|
or die "Cannot prepare: " . $dbh->errstr(); |
| 570 |
|
|
$sth->execute() or die "Cannot execute: " . $sth->errstr(); |
| 571 |
|
|
$sth->finish(); |
| 572 |
|
|
$dbh->disconnect(); |
| 573 |
|
|
|
| 574 |
|
|
=head1 DESCRIPTION |
| 575 |
|
|
|
| 576 |
|
|
The DBD::File module is not a true DBI driver, but an abstract |
| 577 |
|
|
base class for deriving concrete DBI drivers from it. The implication is, |
| 578 |
|
|
that these drivers work with plain files, for example CSV files or |
| 579 |
|
|
INI files. The module is based on the SQL::Statement module, a simple |
| 580 |
|
|
SQL engine. |
| 581 |
|
|
|
| 582 |
|
|
See L<DBI(3)> for details on DBI, L<SQL::Statement(3)> for details on |
| 583 |
|
|
SQL::Statement and L<DBD::CSV(3)> or L<DBD::IniFile(3)> for example |
| 584 |
|
|
drivers. |
| 585 |
|
|
|
| 586 |
|
|
|
| 587 |
|
|
=head2 Metadata |
| 588 |
|
|
|
| 589 |
|
|
The following attributes are handled by DBI itself and not by DBD::File, |
| 590 |
|
|
thus they all work like expected: |
| 591 |
|
|
|
| 592 |
|
|
Active |
| 593 |
|
|
ActiveKids |
| 594 |
|
|
CachedKids |
| 595 |
|
|
CompatMode (Not used) |
| 596 |
|
|
InactiveDestroy |
| 597 |
|
|
Kids |
| 598 |
|
|
PrintError |
| 599 |
|
|
RaiseError |
| 600 |
|
|
Warn (Not used) |
| 601 |
|
|
|
| 602 |
|
|
The following DBI attributes are handled by DBD::File: |
| 603 |
|
|
|
| 604 |
|
|
=over 4 |
| 605 |
|
|
|
| 606 |
|
|
=item AutoCommit |
| 607 |
|
|
|
| 608 |
|
|
Always on |
| 609 |
|
|
|
| 610 |
|
|
=item ChopBlanks |
| 611 |
|
|
|
| 612 |
|
|
Works |
| 613 |
|
|
|
| 614 |
|
|
=item NUM_OF_FIELDS |
| 615 |
|
|
|
| 616 |
|
|
Valid after C<$sth->execute> |
| 617 |
|
|
|
| 618 |
|
|
=item NUM_OF_PARAMS |
| 619 |
|
|
|
| 620 |
|
|
Valid after C<$sth->prepare> |
| 621 |
|
|
|
| 622 |
|
|
=item NAME |
| 623 |
|
|
|
| 624 |
|
|
Valid after C<$sth->execute>; undef for Non-Select statements. |
| 625 |
|
|
|
| 626 |
|
|
=item NULLABLE |
| 627 |
|
|
|
| 628 |
|
|
Not really working, always returns an array ref of one's, as DBD::CSV |
| 629 |
|
|
doesn't verify input data. Valid after C<$sth->execute>; undef for |
| 630 |
|
|
Non-Select statements. |
| 631 |
|
|
|
| 632 |
|
|
=back |
| 633 |
|
|
|
| 634 |
|
|
These attributes and methods are not supported: |
| 635 |
|
|
|
| 636 |
|
|
bind_param_inout |
| 637 |
|
|
CursorName |
| 638 |
|
|
LongReadLen |
| 639 |
|
|
LongTruncOk |
| 640 |
|
|
|
| 641 |
|
|
Additional to the DBI attributes, you can use the following dbh |
| 642 |
|
|
attribute: |
| 643 |
|
|
|
| 644 |
|
|
=over 4 |
| 645 |
|
|
|
| 646 |
|
|
=item f_dir |
| 647 |
|
|
|
| 648 |
|
|
This attribute is used for setting the directory where CSV files are |
| 649 |
|
|
opened. Usually you set it in the dbh, it defaults to the current |
| 650 |
|
|
directory ("."). However, it is overwritable in the statement handles. |
| 651 |
|
|
|
| 652 |
|
|
=back |
| 653 |
|
|
|
| 654 |
|
|
|
| 655 |
|
|
=head2 Driver private methods |
| 656 |
|
|
|
| 657 |
|
|
=over 4 |
| 658 |
|
|
|
| 659 |
|
|
=item data_sources |
| 660 |
|
|
|
| 661 |
|
|
The C<data_sources> method returns a list of subdirectories of the current |
| 662 |
|
|
directory in the form "DBI:CSV:f_dir=$dirname". |
| 663 |
|
|
|
| 664 |
|
|
If you want to read the subdirectories of another directory, use |
| 665 |
|
|
|
| 666 |
|
|
my($drh) = DBI->install_driver("CSV"); |
| 667 |
|
|
my(@list) = $drh->data_sources('f_dir' => '/usr/local/csv_data' ); |
| 668 |
|
|
|
| 669 |
|
|
=item list_tables |
| 670 |
|
|
|
| 671 |
|
|
This method returns a list of file names inside $dbh->{'f_dir'}. |
| 672 |
|
|
Example: |
| 673 |
|
|
|
| 674 |
|
|
my($dbh) = DBI->connect("DBI:CSV:f_dir=/usr/local/csv_data"); |
| 675 |
|
|
my(@list) = $dbh->func('list_tables'); |
| 676 |
|
|
|
| 677 |
|
|
Note that the list includes all files contained in the directory, even |
| 678 |
|
|
those that have non-valid table names, from the view of SQL. See |
| 679 |
|
|
L<Creating and dropping tables> above. |
| 680 |
|
|
|
| 681 |
|
|
=back |
| 682 |
|
|
|
| 683 |
|
|
|
| 684 |
|
|
=head1 TODO |
| 685 |
|
|
|
| 686 |
|
|
=over 4 |
| 687 |
|
|
|
| 688 |
|
|
=item Joins |
| 689 |
|
|
|
| 690 |
|
|
The current version of the module works with single table SELECT's |
| 691 |
|
|
only, although the basic design of the SQL::Statement module allows |
| 692 |
|
|
joins and the likes. |
| 693 |
|
|
|
| 694 |
|
|
=item Table name mapping |
| 695 |
|
|
|
| 696 |
|
|
Currently it is not possible to use files with names like C<names.csv>. |
| 697 |
|
|
Instead you have to use soft links or rename files. As an alternative |
| 698 |
|
|
one might use, for example a dbh attribute 'table_map'. It might be a |
| 699 |
|
|
hash ref, the keys being the table names and the values being the file |
| 700 |
|
|
names. |
| 701 |
|
|
|
| 702 |
|
|
=back |
| 703 |
|
|
|
| 704 |
|
|
|
| 705 |
|
|
=head1 KNOWN BUGS |
| 706 |
|
|
|
| 707 |
|
|
=over 8 |
| 708 |
|
|
|
| 709 |
|
|
=item * |
| 710 |
|
|
|
| 711 |
|
|
The module is using flock() internally. However, this function is not |
| 712 |
|
|
available on all platforms. Using flock() is disabled on MacOS and |
| 713 |
|
|
Windows 95: There's no locking at all (perhaps not so important on |
| 714 |
|
|
MacOS and Windows 95, as there's a single user anyways). |
| 715 |
|
|
|
| 716 |
|
|
=back |
| 717 |
|
|
|
| 718 |
|
|
|
| 719 |
|
|
=head1 AUTHOR AND COPYRIGHT |
| 720 |
|
|
|
| 721 |
|
|
This module is currently maintained by |
| 722 |
|
|
|
| 723 |
|
|
Jeff Zucker |
| 724 |
|
|
<jeff@vpservices.com> |
| 725 |
|
|
|
| 726 |
|
|
The original author is Jochen Wiedmann. |
| 727 |
|
|
|
| 728 |
|
|
Copyright (C) 1998 by Jochen Wiedmann |
| 729 |
|
|
|
| 730 |
|
|
All rights reserved. |
| 731 |
|
|
|
| 732 |
|
|
You may distribute this module under the terms of either the GNU |
| 733 |
|
|
General Public License or the Artistic License, as specified in |
| 734 |
|
|
the Perl README file. |
| 735 |
|
|
|
| 736 |
|
|
=head1 SEE ALSO |
| 737 |
|
|
|
| 738 |
|
|
L<DBI(3)>, L<Text::CSV_XS(3)>, L<SQL::Statement(3)> |
| 739 |
|
|
|
| 740 |
|
|
|
| 741 |
|
|
=cut |
Parent Directory
| 
Revision Log
