| 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
