#
# This handles DBD::SQLite 1.x which uses SQLite 3.x
#
package OOPS::sqlite_v3;
@ISA = qw(OOPS::DBO Exporter);
@EXPORT = qw(
tabledefs
table_list
db_initial_values
initial_query_set
$big_blob_size
$retry_count
);
use strict;
use warnings;
use Carp qw(confess);
our $big_blob_size = 900*1024;
our $enable_fd_leak_workaround = 500;
our $invocations = 0;
sub tmode {}
sub lock_object {}
sub deadlock_rx
{
return (
qr/database is locked(?:\(\d+\) at dbdimp\.c line )?/,
qr/unable to open database file\(\d+\) at dbdimp\.c line/,
);
}
sub nodata_rx
{
return qr/no such table: \S+object(?:\(1\) at dbdimp\.c)?/;
}
sub initialize
{
my $dbo = shift;
my $dbh = $dbo->{dbh};
$dbh->{sqlite_handle_binary_nulls} = 1;
#
# SQLite will sometimes error out with a locked database
# error when it should have just waited instead. Oh well.
#
# http://rt.cpan.org/Ticket/Display.html?id=11680
#
$dbh->func(10_000, 'busy_timeout');
my $sync = $dbo->{default_synchronous} || $ENV{OOPS_SYNC};
if ($sync) {
my $sm = $dbh->prepare("PRAGMA default_synchronous = $sync;") || confess $dbh->errstr;
$sm->execute || confess $sm->errstr;
}
$dbo->{sqlite_version} = 3;
return unless $invocations++ >= $enable_fd_leak_workaround;
return unless $enable_fd_leak_workaround;
return undef unless -d "/proc/$$/fd";
return undef unless $dbo->{database} =~ /dbname=(\S+)/;
my $dbfile = $1;
my ($dev, $ino) = (stat($dbfile))[0,1];
my @r;
local(*D);
opendir(D, "/proc/$$/fd") || return undef;
@r = sort { $a <=> $b } grep($_ ne "." && $_ ne "..", readdir(D));
closedir(D);
require POSIX;
pop(@r); pop(@r); pop(@r); pop(@r);
#
# The very-recently created sqlite open file is a
# pipe rather than a link so this won't accidently
# close it.
#
for my $r (@r) {
next unless $r > $enable_fd_leak_workaround;
my $f = readlink("/proc/$$/fd/$r");
next unless $f;
unless ($f eq $dbfile) {
my ($fddev, $fdino) = (stat($f))[0,1];
next unless $fddev == $dev;
next unless $fdino == $ino;
}
warn "Closing fd probably leaked by SQLite ($r);";
POSIX::close($r);
}
}
# subroutine
sub tabledefs
{
my $x = <<'END';
CREATE TABLE TP_object (
id INTEGER PRIMARY KEY,
loadgroup BIGINT,
class VARCHAR(255), # ref($object)
otype CHAR(1), # 'S'calar/ref, 'A'rray, 'H'ash
virtual CHAR(1), # load virutal ('V' or '0')
reftarg CHAR(1), # reference target ('T' or '0')
rfe CHAR(1), # reserved for future expansion
alen INT, # array length
refs INT, # references
counter INT,
gcgeneration INT DEFAULT 1
);
CREATE INDEX TP_group_index ON TP_object (loadgroup);
CREATE TABLE TP_attribute (
id BIGINT NOT NULL,
pkey VARCHAR(128) NOT NULL,
pval VARCHAR(255),
ptype VARCHAR(1), # type '0'-normal or 'R'eference 'B'ig
PRIMARY KEY (id, pkey));
CREATE INDEX TP_value_index ON TP_attribute (pval);
CREATE TABLE TP_big (
id BIGINT NOT NULL,
pkey VARCHAR(128) NOT NULL,
fragno INT,
pval TEXT,
PRIMARY KEY (id, pkey, fragno));
END
$x =~ s/#.*//mg;
return $x;
}
sub lock
{
return 1;
}
# subroutine
sub table_list
{
return (qw(TP_object TP_attribute TP_big));
}
# subroutine
sub db_initial_values
{
require OOPS::Setup;
return <<END;
INSERT INTO TP_object values(100, 100, 'HASH', 'H', 'V', '0', '0', 0, 1, 1, $OOPS::gcgenstart);
INSERT INTO TP_attribute values(2, 'last reserved object id', $OOPS::last_reserved_oid, 'R');
END
}
sub allocate_id
{
my $dbo = shift;
return undef;
}
sub post_new_object
{
my $dbo = shift;
return $dbo->{dbh}->func('last_insert_rowid');
}
our $retry_count = 0;
# subroutine
sub initial_query_set
{
return <<END;
bigload: 2
SELECT pval, fragno FROM TP_big
WHERE id = ? AND pkey = ?
ORDER BY fragno
savebig: 2 3
INSERT INTO TP_big
VALUES (?, ?, ?, ?)
updatebig: 1 3
UPDATE TP_big
SET pval = ?
WHERE id = ? AND pkey = ?
END
}
sub rebless
{
my ($dbo, $oops) = @_;
bless $oops, 'OOPS::sqlite2::subclass';
}
package OOPS::sqlite2::subclass;
use strict;
use warnings;
use Carp;
our @ISA = qw(OOPS Exporter);
sub load_big
{
my ($oops, $id, $pkey) = @_;
my $bigloadQ = $oops->query('bigload');
$bigloadQ->execute($id, $pkey) || confess $bigloadQ->errstr()." ";
my $val;
my ($frag, $fragno);
while (($frag, $fragno) = $bigloadQ->fetchrow_array()) {
$val .= $frag;
}
$bigloadQ->finish();
confess "null big *$id/'$pkey'" if ! defined($val) || $val eq '';
return $val;
}
sub save_big
{
my $oops = shift;
my $id = shift;
my $pkey = shift;
my $savebigQ = $oops->query('savebig');
for (my $fragno = 0; $fragno * $big_blob_size < length($_[0]); $fragno++) {
$savebigQ->execute($id, $pkey, $fragno, substr($_[0], $fragno * $big_blob_size, $big_blob_size)) || confess;
}
}
sub update_big
{
my $oops = shift;
my $id = shift;
my $pkey = shift;
$oops->query('deletebig', execute => [ $id, $pkey ]);
$oops->save_big($id, $pkey, $_[0]);
}
1;