# DBD::SQLite for pperl - pure-Perl SQLite driver over Peta::FFI/libsqlite3. # # pperl-authored (docs/internal/design/dbi.md Track 3, driver 1). # API-parity reference: DBD-SQLite-1.78 (lib/DBD/SQLite.pm + dbdimp.c) in # perl5-modules; this is NOT a transliteration - the substrate is # libsqlite3 via Peta::FFI instead of XS - but DSN grammar, placeholder # rules, transaction semantics and error conventions follow the reference. # # SQLite is an embedded engine with no wire protocol, so FFI is the only # pure-Perl-adjacent route; there is no PgPP-style alternative here. # # VERSION SKEW, deliberate: the reference dist vendors its own # amalgamation (sqlite3.c) and is built against exactly that, while we # bind whatever libsqlite3.so.0 the host provides - which differs between # machines and moves under us as the host is updated. That is the # intended behaviour, not a limitation to be pinned down: the SQL # features, PRAGMA surface and error *text* a program sees are the host # library's, so a pperl program behaves like every other program on that # machine. Same trade-off already recorded for Peta::FFI::Cairo. # # BIND AND FETCH ARE LENGTH-DELIMITED THROUGHOUT, and that is parity, not # an improvement. dbdimp.c passes SvPV's (data, len) pair to # sqlite3_bind_text and reads columns back with sv_setpvn(val, # sqlite3_column_bytes(...)); values containing a NUL therefore survive # intact in both directions. Peta::FFI's `p` marshalling is # NUL-terminated, so every data path here goes through an allocated # buffer plus an explicit byte count instead. Getting this wrong is # silent: a first draft bound NUL-bearing strings as BLOB and read TEXT # back through `p`, which changed the storage class typeof() reports AND # truncated the value on the way out. # # The storage class SQLite settles on is observable, so the bind decision # is upstream's, verbatim: with no explicit TYPE everything binds as # text - even a Perl IV or NV - because the value reaches SQLite through # SvPV and sqlite_see_if_its_a_number defaults off. Guessing INTEGER for # a digit string is a divergence. # # Phase 1 scope: connect/prepare/execute/fetch/finish/disconnect, all five # placeholder syntaxes SQLite accepts, transactions (AutoCommit, # begin/commit/rollback), quote/quote_identifier, last_insert_id, rows, # err/errstr/state, ping, type-aware column fetch including BLOBs with # embedded NULs. Known gaps vs the reference: custom collations and # functions (install_collation/create_function), virtual tables and # tokenizers, the backup API, incremental BLOB I/O, and the catalogue # methods (table_info/column_info/primary_key_info/foreign_key_info/ # statistics_info) - those last are pure Perl over sqlite_master and # PRAGMAs in the reference and port straight across when wanted. use strict; use warnings; { package DBD::SQLite; use DBI (); use Peta::FFI (); # blessed() gates create_aggregate's instances. DBI happens to pull # this in today, so omitting it works by accident until it does not. use Scalar::Util (); # _utf8_on for the NAIVE string mode: an unconditional flag flip, # which utf8::decode deliberately will not do for invalid input. use Encode (); our $VERSION = '1.78_01'; our $drh; # sqlite3.h result codes. use constant { SQLITE_OK => 0, SQLITE_ERROR => 1, SQLITE_BUSY => 5, SQLITE_LOCKED => 6, SQLITE_READONLY => 8, SQLITE_CONSTRAINT => 19, SQLITE_MISUSE => 21, SQLITE_NOTADB => 26, SQLITE_ROW => 100, SQLITE_DONE => 101, }; # sqlite3.h fundamental datatypes (sqlite3_column_type). use constant { SQLITE_INTEGER => 1, SQLITE_FLOAT => 2, SQLITE_TEXT => 3, SQLITE_BLOB => 4, SQLITE_NULL => 5, }; # sqlite3.h flags for sqlite3_open_v2(). Exported by the reference as # DBD::SQLite::OPEN_*, and connect() honours sqlite_open_flags. use constant { OPEN_READONLY => 0x00000001, OPEN_READWRITE => 0x00000002, OPEN_CREATE => 0x00000004, OPEN_URI => 0x00000040, OPEN_MEMORY => 0x00000080, OPEN_NOMUTEX => 0x00008000, OPEN_FULLMUTEX => 0x00010000, OPEN_SHAREDCACHE => 0x00020000, OPEN_PRIVATECACHE => 0x00040000, }; # sqlite3.h: SQLITE_TRANSIENT is ((sqlite3_destructor_type)-1) and tells # SQLite to COPY the bound bytes before returning. Without it we would # be promising that a Perl scalar's buffer outlives the statement, # which it does not. use constant SQLITE_TRANSIENT => -1; # dbdimp.c keeps MY_CXT.last_dbh_string_mode for the tokenizer, # which fts3 reaches with no handle in hand. our $last_string_mode = 0; # SQLite.xs BOOT constants: the action codes an update hook is # handed. Values verified against the 5.44 baseline DBD::SQLite. use constant { DELETE => 9, INSERT => 18, UPDATE => 23, # sqlite3 authorizer verdicts. OK => 0, DENY => 1, IGNORE => 2, }; # DBI SQL_* type codes, keyed by SQLite's storage class. SQLite is # dynamically typed - the class is per VALUE, not per column - so this # is what the reference reports for TYPE as well. my %sql_type = ( SQLITE_INTEGER() => 4, # SQL_INTEGER SQLITE_FLOAT() => 8, # SQL_DOUBLE SQLITE_TEXT() => 12, # SQL_VARCHAR SQLITE_BLOB() => -3, # SQL_VARBINARY SQLITE_NULL() => 0, # SQL_UNKNOWN_TYPE ); sub _sql_type { defined $_[0] ? ($sql_type{ $_[0] } // 12) : 12 } # dbdimp.c sqlite_type_from_odbc_type(): which SQLite storage class a # DBI SQL_* type code asks for. SQL_UNKNOWN_TYPE maps to SQLITE_NULL, # which is upstream's marker for "caller gave no type", NOT a request # to bind SQL NULL. my %odbc2sqlite = ( 16 => SQLITE_INTEGER(), # SQL_BOOLEAN 4 => SQLITE_INTEGER(), # SQL_INTEGER 5 => SQLITE_INTEGER(), # SQL_SMALLINT -6 => SQLITE_INTEGER(), # SQL_TINYINT -5 => SQLITE_INTEGER(), # SQL_BIGINT 6 => SQLITE_FLOAT(), # SQL_FLOAT 7 => SQLITE_FLOAT(), # SQL_REAL 8 => SQLITE_FLOAT(), # SQL_DOUBLE -7 => SQLITE_BLOB(), # SQL_BIT 30 => SQLITE_BLOB(), # SQL_BLOB -2 => SQLITE_BLOB(), # SQL_BINARY -3 => SQLITE_BLOB(), # SQL_VARBINARY -4 => SQLITE_BLOB(), # SQL_LONGVARBINARY ); sub _sqlite_type_from_odbc_type { my $t = shift; return SQLITE_NULL() unless defined $t && $t != 0; # SQL_UNKNOWN_TYPE return $odbc2sqlite{$t} // SQLITE_TEXT(); } # dbdimp.c sqlite_is_number(), which it adopted from sqlite3.c. # 1 = fits in an i64, 2 = a double, 0 = NOT a number, and 0 means # "bind this as text". # # The float answer is decided by a ROUND TRIP, not by the syntax: the # value is formatted back with %.f and must come out byte # for byte identical to the string we were given. A regex that merely # recognises float syntax says yes to "2e1000", which parses to Inf - # binding that silently replaces the caller's string with infinity, # and t/rt_73787 stores exactly such a value and reads it back. # # $sql_type is the type the caller named; SQLITE_NULL means "no type # given, we are only guessing", and that is the one case where # leading blanks are NOT skipped - " 4" stays a string. sub _is_number { my ($v, $sql_type) = @_; return 0 unless defined $v; $sql_type = SQLITE_NULL() unless defined $sql_type; $v =~ s/\A +// if $sql_type != SQLITE_NULL(); my $z = $v; my ($neg, $has_plus) = (0, 0); if ($z =~ s/\A-//) { $neg = 1 } elsif ($z =~ s/\A\+//) { $has_plus = 1 } return 0 unless $z =~ s/\A([0-9]+)//; my $digits = $1; my $digit = length $digits; my $maybe_int = 1; $maybe_int = 0 if $digit > 19; # too large for i64 if ($digit == 19) { my $c = substr($digits, 0, 18) cmp '922337203685477580'; $c = ord(substr $digits, 18, 1) - ord('7') - $neg if $c == 0; $maybe_int = 0 if $c > 0; } my $precision = 0; if ($z =~ s/\A\.//) { $maybe_int = 0; return 0 unless $z =~ s/\A([0-9]+)//; $precision = length $1; } if ($z =~ s/\A[eE]//) { $maybe_int = 0; $z =~ s/\A[+-]//; return 0 unless $z =~ s/\A[0-9]+//; } return 0 if length $z; # trailing junk return 1 if $maybe_int && $digit; if ($sql_type != SQLITE_INTEGER()) { my $format = ($has_plus ? '+%.' : '%.') . $precision . 'f'; return 2 if sprintf($format, $v) eq $v; } return 0; } # dbdimp.c: imp_dbh->see_if_its_a_number = FALSE at connect. Exposed # as the sqlite_see_if_its_a_number handle attribute. our $see_if_its_a_number = 0; # Warn as if from the caller's line, the way upstream's XS warn() does. # # XS has no COP of its own, so a warn() inside dbdimp.c is attributed to # the Perl statement that called execute. Neither `warn` (blames this # file) nor Carp::carp (blames whichever dispatch frame is directly # above) reproduces that here, because DBI::PurePerl interposes a Perl # frame where DBI's XS dispatch has none. Walk out to the first frame # that is neither ours nor DBI's and report there, which gives the same # answer under either dispatch. sub _warn_at_caller { my $msg = shift; my $i = 0; while (my ($pkg, $file, $line) = caller($i++)) { next if $pkg =~ /^DBD::SQLite\b/ || $pkg =~ /^DBI\b/; warn "$msg at $file line $line.\n"; return; } warn "$msg\n"; } my $lib; # dlopen handle, process-wide sub _lib { $lib ||= Peta::FFI::dlopen("libsqlite3.so.0") } sub _c { my $sig = splice @_, 1, 1; Peta::FFI::call(_lib(), $_[0], $sig, @_[1..$#_]) } sub sqlite_version { _c("sqlite3_libversion", "()p") } # $DBD::SQLite::sqlite_version_number, as the XS half sets it. # NOT cosmetic: t/lib/SQLiteTest.pm's has_sqlite() gates on this # package variable, so while it was undef every requires_sqlite() # call in the reference suite compared undef >= N, failed, and # skipped the whole file with `1..0 # SKIP this test requires SQLite # X and newer` - 24 of 103 files silently disabled, and a skip reads # as success. Read from the LIBRARY at runtime rather than baked at # authoring time: we bind whatever libsqlite3 the host has, which is # not necessarily the one these sources were written against. our $sqlite_version_number = _c("sqlite3_libversion_number", "()i"); our $sqlite_version = sqlite_version(); # SQLite.xs strglob()/strlike(): the LIKE and GLOB matchers exposed # as plain functions, so a caller can apply SQLite's own matching # rules without a round trip through a statement. Both return 0 on a # match, like the C functions they wrap. The escape character is # passed as its first BYTE - a whole string is what the XS prototype # accepts, but only *esc is read. sub strglob { _c("sqlite3_strglob", "(pp)i", $_[0], $_[1]) } sub strlike { my ($zglob, $zstr, $esc) = @_; return _c("sqlite3_strlike", "(ppi)i", $zglob, $zstr, defined $esc && length $esc ? ord(substr $esc, 0, 1) : 0); } # constants.inc PACKAGE = DBD::SQLite::Constants, BOOT block. Upstream # splits this two ways and so do we: the vendored Constants.pm holds # the NAMES, the export tags and the POD but no values, and the # compiled half installs the values into that package with # newCONSTSUB. This is our stand-in for the newCONSTSUB loop. # # Regenerate with perl-src/DBD-SQLite/regen-constants.pl; the values # come from the host sqlite3.h and the dist dbdimp.h, and were # verified 215/217 identical against the system perl s real # DBD::SQLite. The two that differed are version skew and ours are # the right ones for our binding: that build was compiled against # sqlite 3.51.1 while this host header is 3.53.4, which moved # SQLITE_DBCONFIG_MAX from 1022 to 1023. # --- BEGIN generated constants (regen-constants.pl) --- # Values resolved from /usr/include/sqlite3.h (sqlite 3053004) and the dist's dbdimp.h. # 217 constants. my %CONSTANTS = ( DBD_SQLITE_STRING_MODE_BYTES => 1, DBD_SQLITE_STRING_MODE_PV => 0, DBD_SQLITE_STRING_MODE_UNICODE_FALLBACK => 5, DBD_SQLITE_STRING_MODE_UNICODE_NAIVE => 4, DBD_SQLITE_STRING_MODE_UNICODE_STRICT => 6, SQLITE_ABORT => 4, SQLITE_ABORT_ROLLBACK => 516, SQLITE_ALTER_TABLE => 26, SQLITE_ANALYZE => 28, SQLITE_ATTACH => 24, SQLITE_AUTH => 23, SQLITE_AUTH_USER => 279, SQLITE_BLOB => 4, SQLITE_BUSY => 5, SQLITE_BUSY_RECOVERY => 261, SQLITE_BUSY_SNAPSHOT => 517, SQLITE_BUSY_TIMEOUT => 773, SQLITE_CANTOPEN => 14, SQLITE_CANTOPEN_CONVPATH => 1038, SQLITE_CANTOPEN_DIRTYWAL => 1294, SQLITE_CANTOPEN_FULLPATH => 782, SQLITE_CANTOPEN_ISDIR => 526, SQLITE_CANTOPEN_NOTEMPDIR => 270, SQLITE_CANTOPEN_SYMLINK => 1550, SQLITE_CONSTRAINT => 19, SQLITE_CONSTRAINT_CHECK => 275, SQLITE_CONSTRAINT_COMMITHOOK => 531, SQLITE_CONSTRAINT_DATATYPE => 3091, SQLITE_CONSTRAINT_FOREIGNKEY => 787, SQLITE_CONSTRAINT_FUNCTION => 1043, SQLITE_CONSTRAINT_NOTNULL => 1299, SQLITE_CONSTRAINT_PINNED => 2835, SQLITE_CONSTRAINT_PRIMARYKEY => 1555, SQLITE_CONSTRAINT_ROWID => 2579, SQLITE_CONSTRAINT_TRIGGER => 1811, SQLITE_CONSTRAINT_UNIQUE => 2067, SQLITE_CONSTRAINT_VTAB => 2323, SQLITE_COPY => 0, SQLITE_CORRUPT => 11, SQLITE_CORRUPT_INDEX => 779, SQLITE_CORRUPT_SEQUENCE => 523, SQLITE_CORRUPT_VTAB => 267, SQLITE_CREATE_INDEX => 1, SQLITE_CREATE_TABLE => 2, SQLITE_CREATE_TEMP_INDEX => 3, SQLITE_CREATE_TEMP_TABLE => 4, SQLITE_CREATE_TEMP_TRIGGER => 5, SQLITE_CREATE_TEMP_VIEW => 6, SQLITE_CREATE_TRIGGER => 7, SQLITE_CREATE_VIEW => 8, SQLITE_CREATE_VTABLE => 29, SQLITE_DBCONFIG_DEFENSIVE => 1010, SQLITE_DBCONFIG_DQS_DDL => 1014, SQLITE_DBCONFIG_DQS_DML => 1013, SQLITE_DBCONFIG_ENABLE_ATTACH_CREATE => 1020, SQLITE_DBCONFIG_ENABLE_ATTACH_WRITE => 1021, SQLITE_DBCONFIG_ENABLE_COMMENTS => 1022, SQLITE_DBCONFIG_ENABLE_FKEY => 1002, SQLITE_DBCONFIG_ENABLE_FTS3_TOKENIZER => 1004, SQLITE_DBCONFIG_ENABLE_LOAD_EXTENSION => 1005, SQLITE_DBCONFIG_ENABLE_QPSG => 1007, SQLITE_DBCONFIG_ENABLE_TRIGGER => 1003, SQLITE_DBCONFIG_ENABLE_VIEW => 1015, SQLITE_DBCONFIG_LEGACY_ALTER_TABLE => 1012, SQLITE_DBCONFIG_LEGACY_FILE_FORMAT => 1016, SQLITE_DBCONFIG_LOOKASIDE => 1001, SQLITE_DBCONFIG_MAINDBNAME => 1000, SQLITE_DBCONFIG_MAX => 1023, SQLITE_DBCONFIG_NO_CKPT_ON_CLOSE => 1006, SQLITE_DBCONFIG_RESET_DATABASE => 1009, SQLITE_DBCONFIG_REVERSE_SCANORDER => 1019, SQLITE_DBCONFIG_STMT_SCANSTATUS => 1018, SQLITE_DBCONFIG_TRIGGER_EQP => 1008, SQLITE_DBCONFIG_TRUSTED_SCHEMA => 1017, SQLITE_DBCONFIG_WRITABLE_SCHEMA => 1011, SQLITE_DELETE => 9, SQLITE_DENY => 1, SQLITE_DETACH => 25, SQLITE_DETERMINISTIC => 2048, SQLITE_DIRECTONLY => 524288, SQLITE_DONE => 101, SQLITE_DROP_INDEX => 10, SQLITE_DROP_TABLE => 11, SQLITE_DROP_TEMP_INDEX => 12, SQLITE_DROP_TEMP_TABLE => 13, SQLITE_DROP_TEMP_TRIGGER => 14, SQLITE_DROP_TEMP_VIEW => 15, SQLITE_DROP_TRIGGER => 16, SQLITE_DROP_VIEW => 17, SQLITE_DROP_VTABLE => 30, SQLITE_EMPTY => 16, SQLITE_ERROR => 1, SQLITE_ERROR_KEY => 1281, SQLITE_ERROR_MISSING_COLLSEQ => 257, SQLITE_ERROR_RESERVESIZE => 1025, SQLITE_ERROR_RETRY => 513, SQLITE_ERROR_SNAPSHOT => 769, SQLITE_ERROR_UNABLE => 1537, SQLITE_FLOAT => 2, SQLITE_FORMAT => 24, SQLITE_FULL => 13, SQLITE_FUNCTION => 31, SQLITE_IGNORE => 2, SQLITE_INNOCUOUS => 2097152, SQLITE_INSERT => 18, SQLITE_INTEGER => 1, SQLITE_INTERNAL => 2, SQLITE_INTERRUPT => 9, SQLITE_IOERR => 10, SQLITE_IOERR_ACCESS => 3338, SQLITE_IOERR_AUTH => 7178, SQLITE_IOERR_BADKEY => 8970, SQLITE_IOERR_BEGIN_ATOMIC => 7434, SQLITE_IOERR_BLOCKED => 2826, SQLITE_IOERR_CHECKRESERVEDLOCK => 3594, SQLITE_IOERR_CLOSE => 4106, SQLITE_IOERR_CODEC => 9226, SQLITE_IOERR_COMMIT_ATOMIC => 7690, SQLITE_IOERR_CONVPATH => 6666, SQLITE_IOERR_CORRUPTFS => 8458, SQLITE_IOERR_DATA => 8202, SQLITE_IOERR_DELETE => 2570, SQLITE_IOERR_DELETE_NOENT => 5898, SQLITE_IOERR_DIR_CLOSE => 4362, SQLITE_IOERR_DIR_FSYNC => 1290, SQLITE_IOERR_FSTAT => 1802, SQLITE_IOERR_FSYNC => 1034, SQLITE_IOERR_GETTEMPPATH => 6410, SQLITE_IOERR_IN_PAGE => 8714, SQLITE_IOERR_LOCK => 3850, SQLITE_IOERR_MMAP => 6154, SQLITE_IOERR_NOMEM => 3082, SQLITE_IOERR_RDLOCK => 2314, SQLITE_IOERR_READ => 266, SQLITE_IOERR_ROLLBACK_ATOMIC => 7946, SQLITE_IOERR_SEEK => 5642, SQLITE_IOERR_SHMLOCK => 5130, SQLITE_IOERR_SHMMAP => 5386, SQLITE_IOERR_SHMOPEN => 4618, SQLITE_IOERR_SHMSIZE => 4874, SQLITE_IOERR_SHORT_READ => 522, SQLITE_IOERR_TRUNCATE => 1546, SQLITE_IOERR_UNLOCK => 2058, SQLITE_IOERR_VNODE => 6922, SQLITE_IOERR_WRITE => 778, SQLITE_LIMIT_ATTACHED => 7, SQLITE_LIMIT_COLUMN => 2, SQLITE_LIMIT_COMPOUND_SELECT => 4, SQLITE_LIMIT_EXPR_DEPTH => 3, SQLITE_LIMIT_FUNCTION_ARG => 6, SQLITE_LIMIT_LENGTH => 0, SQLITE_LIMIT_LIKE_PATTERN_LENGTH => 8, SQLITE_LIMIT_SQL_LENGTH => 1, SQLITE_LIMIT_TRIGGER_DEPTH => 10, SQLITE_LIMIT_VARIABLE_NUMBER => 9, SQLITE_LIMIT_VDBE_OP => 5, SQLITE_LIMIT_WORKER_THREADS => 11, SQLITE_LOCKED => 6, SQLITE_LOCKED_SHAREDCACHE => 262, SQLITE_LOCKED_VTAB => 518, SQLITE_MISMATCH => 20, SQLITE_MISUSE => 21, SQLITE_NOLFS => 22, SQLITE_NOMEM => 7, SQLITE_NOTADB => 26, SQLITE_NOTFOUND => 12, SQLITE_NOTICE => 27, SQLITE_NOTICE_RBU => 795, SQLITE_NOTICE_RECOVER_ROLLBACK => 539, SQLITE_NOTICE_RECOVER_WAL => 283, SQLITE_NULL => 5, SQLITE_OK => 0, SQLITE_OK_SYMLINK => 512, SQLITE_OPEN_CREATE => 4, SQLITE_OPEN_EXRESCODE => 33554432, SQLITE_OPEN_FULLMUTEX => 65536, SQLITE_OPEN_MEMORY => 128, SQLITE_OPEN_NOFOLLOW => 16777216, SQLITE_OPEN_NOMUTEX => 32768, SQLITE_OPEN_PRIVATECACHE => 262144, SQLITE_OPEN_READONLY => 1, SQLITE_OPEN_READWRITE => 2, SQLITE_OPEN_SHAREDCACHE => 131072, SQLITE_OPEN_SUPER_JOURNAL => 16384, SQLITE_OPEN_URI => 64, SQLITE_PERM => 3, SQLITE_PRAGMA => 19, SQLITE_PROTOCOL => 15, SQLITE_RANGE => 25, SQLITE_READ => 20, SQLITE_READONLY => 8, SQLITE_READONLY_CANTINIT => 1288, SQLITE_READONLY_CANTLOCK => 520, SQLITE_READONLY_DBMOVED => 1032, SQLITE_READONLY_DIRECTORY => 1544, SQLITE_READONLY_RECOVERY => 264, SQLITE_READONLY_ROLLBACK => 776, SQLITE_RECURSIVE => 33, SQLITE_REINDEX => 27, SQLITE_RESULT_SUBTYPE => 16777216, SQLITE_ROW => 100, SQLITE_SAVEPOINT => 32, SQLITE_SCHEMA => 17, SQLITE_SELECT => 21, SQLITE_SELFORDER1 => 33554432, SQLITE_SETLK_BLOCK_ON_CONNECT => 1, SQLITE_SUBTYPE => 1048576, SQLITE_TEXT => 3, SQLITE_TOOBIG => 18, SQLITE_TRANSACTION => 22, SQLITE_TXN_NONE => 0, SQLITE_TXN_READ => 1, SQLITE_TXN_WRITE => 2, SQLITE_UPDATE => 23, SQLITE_VERSION_NUMBER => 3053004, SQLITE_WARNING => 28, SQLITE_WARNING_AUTOINDEX => 284, ); # --- END generated constants --- # The two version constants are NOT baked: they must describe the # library actually loaded, which differs per host. $CONSTANTS{SQLITE_VERSION_NUMBER} = $sqlite_version_number; $CONSTANTS{SQLITE_VERSION} = $sqlite_version; { no strict "refs"; for my $name (keys %CONSTANTS) { my $v = $CONSTANTS{$name}; # A constant sub with an empty prototype, which is what # newCONSTSUB creates and what lets these inline. *{"DBD::SQLite::Constants::$name"} = sub () { $v }; } } # SQLite.xs PACKAGE = DBD::SQLite: compile_options() and # sqlite_status() sit beside the constants, not in Constants.pm. sub compile_options { my @opt; for (my $i = 0; ; $i++) { my $o = _c("sqlite3_compileoption_get", "(i)p", $i); last unless defined $o && length $o; push @opt, $o; } return @opt; } # ---- String modes ------------------------------------------------ # # dbdimp.h dbd_sqlite_string_mode_t. The gap between BYTES and # UNICODE_NAIVE is deliberate upstream: the unicode modes share bit # 4, so `$mode & UNICODE_ANY` tests "is this any unicode mode" in # one comparison. Keep the numbering. use constant { STRING_MODE_PV => 0, STRING_MODE_BYTES => 1, STRING_MODE_UNICODE_NAIVE => 4, STRING_MODE_UNICODE_FALLBACK => 5, STRING_MODE_UNICODE_STRICT => 6, }; use constant STRING_MODE_UNICODE_ANY => STRING_MODE_UNICODE_NAIVE; # DBD_SQLITE_UTF8_DECODE_IF_NEEDED. Applied to TEXT coming OUT of # SQLite, which is always UTF-8 on the wire; the mode decides how # much we trust it. # NAIVE - flag it and ask no questions (SvUTF8_on) # FALLBACK - validate, warn and leave it as bytes if it is invalid # STRICT - validate, croak if it is invalid # PV and BYTES do nothing at all. # SvPV semantics for a value we hand to C with an explicit length. # The bytes C sees are the scalar's INTERNAL bytes, so the count that # goes with them is the BYTE length - never length(), which counts # characters. Getting this wrong truncates every non-ASCII value by # exactly the number of multi-byte characters in it, which is how # "BERGERE" came back as "BERGER" from a user-defined function. sub _pv_bytes { my $s = $_[0]; utf8::encode($s) if utf8::is_utf8($s); return $s; } # SvPVbyte: the scalar's BYTES, downgrading a flagged scalar back to # them rather than reading its UTF-8 encoding. The difference is not # academic - "K\x{f6}nig" upgraded is five characters but six # internal bytes, and a blob must store the five the caller meant. # Dies on a genuinely wide character, exactly as SvPVbyte does. sub _pvbyte { my $s = $_[0]; utf8::downgrade($s); return $s; } sub _decode_text { my ($mode) = $_[1]; return if !defined $mode || !($mode & STRING_MODE_UNICODE_ANY()); if ($mode == STRING_MODE_UNICODE_NAIVE()) { # No validation, by definition: this is SvUTF8_on, not a # decode. utf8::decode would REFUSE invalid input, which is # the fallback mode's job, not this one's. Encode::_utf8_on($_[0]); return; } if (utf8::decode($_[0])) { # dbdimp.h DBD_SQLITE_UTF8_DECODE_CHECKED is # `is_utf8_string(...) ? SvUTF8_on(sv) : onfail(...)` - it # VALIDATES and then flags unconditionally. utf8::decode # leaves an all-ASCII string unflagged, because for perl the # flag is redundant there; for this driver it is not, since # the caller asked a unicode mode for text and checks # utf8::is_utf8 on what comes back (t/rt_71311). Encode::_utf8_on($_[0]) unless utf8::is_utf8($_[0]); return; } my $msg = 'Received invalid UTF-8 from SQLite; cannot decode!'; die "$msg\n" if $mode == STRING_MODE_UNICODE_STRICT(); warn "$msg\n"; return; } # DBD_SQLITE_PREP_SV_FOR_SQLITE. Applied to anything handed TO # SQLite - and upstream applies it to the STATEMENT TEXT (dbdimp.c # 606, 966), not only to bound values. That matters: a test that # interpolates Latin-1 words straight into SQL relies on this to # store them as UTF-8, and without it the bytes go in raw and a # later strict read correctly rejects them. # # unicode modes -> sv_utf8_upgrade: hand SQLite UTF-8 bytes. # utf8::encode does this for BOTH flagged and # unflagged scalars, because an unflagged one's # bytes ARE its characters (Latin-1). Guarding on # is_utf8 skips exactly the case that needs it. # BYTES -> sv_utf8_downgrade(sv, 0): characters back to # bytes, fatal above U+00FF. # # The caller's scalar is never modified - it may well be a literal. sub _encode_text { my ($val, $mode) = @_; return $val unless defined $mode; my $copy = $val; if ($mode & STRING_MODE_UNICODE_ANY()) { utf8::encode($copy); } elsif ($mode == STRING_MODE_BYTES()) { utf8::downgrade($copy); } return $copy; } # ---- Collations and the REGEXP operator -------------------------- # # Collations are installed ON DEMAND: SQLite calls back through # sqlite3_collation_needed the first time a statement names one it # does not know, and install_collation looks it up in %COLLATION. # That is why registering nothing here still lets `ORDER BY x # COLLATE perl` work. our %COLLATION; tie %COLLATION, 'DBD::SQLite::_WriteOnceHash'; $COLLATION{perl} = sub { $_[0] cmp $_[1] }; $COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] }; sub install_collation { my $dbh = shift; my $name = shift; my $collation = $DBD::SQLite::COLLATION{$name}; unless ($collation) { warn "Can't install unknown collation: $name" if $dbh->{PrintWarn}; return; } $dbh->sqlite_create_collation($name => $collation); } # Default implementation of SQLite's infix REGEXP operator. The # arguments are REVERSED - `a REGEXP b` calls REGEXP(b, a) - because # that is how SQLite's xFindFunction passes an infix operator's # operands. sub regexp { use locale; return if !defined $_[0] || !defined $_[1]; return scalar($_[1] =~ $_[0]); } # dbdimp.c _sqlite_status(). The op list and the key NAMES are # upstream's, including the SCRATCH_* ones sqlite3 no longer uses: # they still answer, and dropping them would change the key set the # caller sees. # # The two out-parameters are int*, so they get real 4-byte buffers. # They must not be passed as \$scalar under the 'P' code: that code # sizes its buffer FROM the argument, and a reference numifies to its # address, so it asked for a 94-terabyte allocation and aborted the # process before any of this ran. my @STATUS_OPS = ( [ 0, 'memory_used' ], [ 1, 'pagecache_used' ], [ 2, 'pagecache_overflow' ], [ 3, 'scratch_used' ], [ 4, 'scratch_overflow' ], [ 5, 'malloc_size' ], [ 6, 'parser_stack' ], [ 7, 'pagecache_size' ], [ 8, 'scratch_size' ], [ 9, 'malloc_count' ], ); sub sqlite_status { my ($reset) = @_; $reset = $reset ? 1 : 0; my $pcur = Peta::FFI::alloc(4); my $phi = Peta::FFI::alloc(4); my %status; for my $op (@STATUS_OPS) { next if _c("sqlite3_status", "(iooi)i", $op->[0], $pcur, $phi, $reset); $status{ $op->[1] } = { current => unpack('l', Peta::FFI::peek($pcur, 4)), highwater => unpack('l', Peta::FFI::peek($phi, 4)), }; } Peta::FFI::free($pcur); Peta::FFI::free($phi); return \%status; } sub driver { return $drh if $drh; my ($class, $attr) = @_; # SQLite.pm driver(): the private methods are installed here, # once. Defining the sub is not enough - DBI dispatches through # DBI::db, so an uninstalled method is "Can't locate DBI object # method ... via package DBD::SQLite::db" however well it is # defined. Both spellings of each ALIAS pair are installed. # Only the sqlite_-prefixed spelling may be installed: DBI's # install_method rejects a name whose prefix is not a registered # driver prefix ("method name prefix 'busy_' is not associated # with a registered driver"). The BARE names need no # installation - func() looks the sub up in this package # directly, which is how upstream's suite reaches them. if (!$DBD::SQLite::methods_are_installed) { DBD::SQLite::db->install_method($_) for qw(sqlite_trace sqlite_profile); DBD::SQLite::st->install_method('sqlite_st_status'); DBD::SQLite::db->install_method("sqlite_$_") for qw( busy_timeout get_autocommit db_filename db_status error_offset limit txn_state last_insert_rowid create_function create_aggregate progress_handler commit_hook rollback_hook update_hook set_authorizer create_collation collation_needed table_column_metadata db_config register_fts3_perl_tokenizer backup_to_file backup_from_file backup_to_dbh backup_from_dbh ); $DBD::SQLite::methods_are_installed = 1; } ($drh) = DBI::_new_drh("${class}::dr", { Name => 'SQLite', Version => $VERSION, Attribution => 'DBD::SQLite over Peta::FFI/libsqlite3 (peta-perl)', }); $drh; } sub CLONE { undef $drh } } { package DBD::SQLite::dr; our $imp_data_size = 0; sub connect { my ($drh, $dsn, $user, $pass, $attr) = @_; # SQLite.pm connect(): a DSN containing '=' is a ';'-separated # attribute list, and db/dbname/database all name the file. 'uri' # additionally forces OPEN_URI. Anything else becomes an attribute, # which is how sqlite_open_flags etc. arrive through the DSN. my $real = $dsn; if ($dsn =~ /=/) { for my $pair (split /;/, $dsn) { my ($key, $value) = split /=/, $pair, 2; next unless defined $key; if ($key =~ /^(?:db(?:name)?|database)$/) { $real = $value; } elsif ($key eq 'uri') { $real = $value; $attr->{sqlite_open_flags} |= DBD::SQLite::OPEN_URI(); } else { $attr->{$key} = $value; } } } $real = '' unless defined $real; # SQLite.pm: an explicit flag set that names neither access mode # gets READWRITE|CREATE added, so sqlite_open_flags => OPEN_URI # alone still opens a writable database. my $flags = $attr->{sqlite_open_flags} || 0; # dbdimp.c sqlite_db_login6_sv(): ReadOnly is the portable DBI # spelling of SQLITE_OPEN_READONLY, so it has to reach the open # call - storing it on the handle afterwards would leave a # writable database claiming to be read-only. $flags |= DBD::SQLite::OPEN_READONLY() if $attr->{ReadOnly}; if ($flags) { unless ($flags & (DBD::SQLite::OPEN_READONLY() | DBD::SQLite::OPEN_READWRITE())) { $flags |= DBD::SQLite::OPEN_READWRITE() | DBD::SQLite::OPEN_CREATE(); } } else { $flags = DBD::SQLite::OPEN_READWRITE() | DBD::SQLite::OPEN_CREATE(); } my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dsn, }); # sqlite3_open_v2(filename, OUT sqlite3**, flags, zVfs) my $out = Peta::FFI::alloc(8); my $rc = DBD::SQLite::_c("sqlite3_open_v2", "(poio)i", $real, $out, $flags, 0); my $db = Peta::FFI::unpack_ptr(Peta::FFI::peek($out, 8)); Peta::FFI::free($out); if ($rc != DBD::SQLite::SQLITE_OK() || !$db) { # sqlite3_open_v2 hands back a handle even on failure precisely # so the message can be read off it; close it either way. my $msg = $db ? DBD::SQLite::_c("sqlite3_errmsg", "(o)p", $db) : "cannot open '$real' (rc=$rc)"; DBD::SQLite::_c("sqlite3_close_v2", "(o)i", $db) if $db; return $drh->set_err($rc || DBD::SQLite::SQLITE_ERROR(), $msg); } $dbh->{sqlite_db} = $db; $dbh->{sqlite_dbname} = $real; $dbh->{sqlite_version} = DBD::SQLite::sqlite_version(); $dbh->{sqlite_open_flags} = $flags; # ...and the reverse: opening READONLY through sqlite_open_flags # makes the handle read-only whether or not DBI was told. $dbh->{ReadOnly} = 1 if $flags & DBD::SQLite::OPEN_READONLY(); # dbdimp.h SQL_TIMEOUT: imp_dbh->timeout starts at 30000, so # busy_timeout() reports a value before anyone sets one. $dbh->{sqlite_timeout} = 30000; # dbdimp.c: use_immediate_transaction starts TRUE, so an implicit # transaction takes its write lock up front instead of risking # SQLITE_BUSY on upgrade. Only an explicit attribute turns it off. $dbh->{sqlite_use_immediate_transaction} = exists $attr->{sqlite_use_immediate_transaction} ? ($attr->{sqlite_use_immediate_transaction} ? 1 : 0) : 1; $dbh->{sqlite_allow_multiple_statements} = $attr->{sqlite_allow_multiple_statements} ? 1 : 0; # dbdimp.c sqlite_db_login6_sv(): the ONLY db_config knob applied # at connect, and only when the caller gave an integer - so # SQLITE_DBCONFIG_DEFENSIVE is in effect before the first # statement rather than one PRAGMA too late. # The DBCONFIG ids live in DBD::SQLite::Constants, NOT in # DBD::SQLite - only the handful of codes above are defined here. DBD::SQLite::_c("sqlite3_db_config", "(oiio)i", $db, DBD::SQLite::Constants::SQLITE_DBCONFIG_DEFENSIVE(), int($attr->{sqlite_defensive}), 0) if defined $attr->{sqlite_defensive} && $attr->{sqlite_defensive} =~ /\A[+-]?[0-9]+\z/; # dbdimp.c: string_mode starts at DBD_SQLITE_STRING_MODE_PV. # sqlite_unicode is the legacy spelling and means NAIVE - it # predates the mode enum, so it cannot select the checked ones. $DBD::SQLite::last_string_mode = $dbh->{sqlite_string_mode} = defined $attr->{sqlite_string_mode} ? $attr->{sqlite_string_mode} : ($attr->{sqlite_unicode} || $attr->{unicode}) ? DBD::SQLite::STRING_MODE_UNICODE_NAIVE() : DBD::SQLite::STRING_MODE_PV(); $dbh->STORE(Active => 1); # SQLite.pm connect(): the on-demand collation installer and the # REGEXP implementation are registered on EVERY connection, which # is what makes `COLLATE perl` and the infix REGEXP operator work # without the caller registering anything. # Through the OUTER handle and the sqlite_-prefixed spelling: # only the prefixed names are install_method'd, and DBI # dispatches driver-private methods on the outer handle. $outer->sqlite_collation_needed(\&DBD::SQLite::install_collation); $outer->sqlite_create_function("REGEXP", 2, \&DBD::SQLite::regexp); $outer->sqlite_register_fts3_perl_tokenizer(); return $outer; } sub data_sources { () } } { package DBD::SQLite::db; our $imp_data_size = 0; sub _db { $_[0]->{sqlite_db} } # Raise the last libsqlite3 error on $h. SQLite has no SQLSTATE, so # the reference leaves state unset and reports code + message. sub _err { my ($h, $db, $fallback) = @_; my $code = $db ? DBD::SQLite::_c("sqlite3_errcode", "(o)i", $db) : DBD::SQLite::SQLITE_ERROR(); my $msg = $db ? DBD::SQLite::_c("sqlite3_errmsg", "(o)p", $db) : $fallback; $msg = $fallback if !defined($msg) || $msg eq '' || $msg eq 'not an error'; return $h->set_err($code || DBD::SQLite::SQLITE_ERROR(), $msg); } # Run SQL with no result set and no placeholders. sub _exec { my ($dbh, $sql) = @_; my $db = _db($dbh) or return undef; my $rc = DBD::SQLite::_c("sqlite3_exec", "(opooo)i", $db, $sql, 0, 0, 0); return $rc == DBD::SQLite::SQLITE_OK() ? 1 : _err($dbh, $db, "exec failed: $sql"); } # sqlite3_get_autocommit() is FALSE exactly while an explicit # transaction is open, which is the honest test for "already begun" - # tracking it in a Perl flag would drift the moment user SQL issues # its own BEGIN or a statement triggers an implicit rollback. sub _in_txn { my $db = _db($_[0]) or return 0; return DBD::SQLite::_c("sqlite3_get_autocommit", "(o)i", $db) ? 0 : 1; } # dbdimp.c _skip_whitespaces(): leading whitespace AND "--" line # comments both have to go before the BEGIN sniff below, or a DDL # file that opens with a comment stops looking like a transaction. sub _skip_whitespaces { my $sql = shift; $sql =~ s/\A(?:\s+|--[^\n]*)+//; return $sql; } # dbdimp.c _starts_with_begin(): BEGIN or SAVEPOINT, either case. sub _starts_with_begin { $_[0] =~ /\A(?:BEGIN|SAVEPOINT)/i ? 1 : 0 } # dbdimp.c sqlite_st_execute()'s pre-step block, which sqlite_db_do() # repeats verbatim in C. # # The BEGIN branch is the one that is easy to leave out, and leaving # it out is not harmless: SQL that says BEGIN itself must NOT get a # second BEGIN wrapped around it ("cannot start a transaction within # a transaction"). Instead the handle goes into BegunWork so # $dbh->{AutoCommit} reads '' for as long as the caller's own # transaction is open, and the matching COMMIT hands AutoCommit back. # # $sql is the statement about to run; undef means "no statement to # sniff", which is only the case on paths that cannot carry a BEGIN. sub _maybe_begin { my ($dbh, $sql) = @_; return 1 if _in_txn($dbh); # sqlite3_get_autocommit() == 0 if (defined $sql && _starts_with_begin(_skip_whitespaces($sql))) { if ($dbh->{AutoCommit}) { # imp_dbh->began_transaction: remembers that WE flipped # AutoCommit off, so only we may flip it back on. $dbh->{_began_transaction} = 1 if !$dbh->{BegunWork}; $dbh->{BegunWork} = 1; $dbh->{AutoCommit} = !!0; } return 1; } return 1 if $dbh->{AutoCommit}; return _exec($dbh, $dbh->{sqlite_use_immediate_transaction} ? 'BEGIN IMMEDIATE TRANSACTION' : 'BEGIN TRANSACTION'); } # dbdimp.c sqlite_st_execute(), the SQLITE_ROW/SQLITE_DONE-with-columns # arm: a statement can leave a transaction open without ever saying # BEGIN, so if sqlite reports a transaction while DBI still thinks # AutoCommit is on, DBI is corrected. began_transaction is NOT set # here - upstream commented that out for rt_52573 - so this flip is # deliberately one that _maybe_end() will never undo. sub _note_implicit_txn { my $dbh = shift; return unless $dbh->{AutoCommit} && _in_txn($dbh); $dbh->{BegunWork} = 1; $dbh->{AutoCommit} = !!0; return; } # dbdimp.c: the tail of sqlite_db_do() and of sqlite_st_execute()'s # no-columns branch. A COMMIT/ROLLBACK/RELEASE inside the statement # ends the transaction behind our back, and only then does the # BegunWork we set above get handed back as AutoCommit. sub _maybe_end { my $dbh = shift; return unless $dbh->{BegunWork} && !_in_txn($dbh); return unless $dbh->{_began_transaction}; $dbh->{BegunWork} = 0; $dbh->{AutoCommit} = 1; return; } sub prepare { my ($dbh, $sql, $attr) = @_; my $db = _db($dbh) or return $dbh->set_err(DBD::SQLite::SQLITE_MISUSE(), 'attempt to prepare on inactive database handle'); # dbdimp.c:966 preps the STATEMENT for the string mode, so SQL # carrying literal non-ASCII reaches SQLite correctly encoded. $sql = DBD::SQLite::_encode_text($sql, $dbh->{sqlite_string_mode}); my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $sql }); # sqlite3_prepare_v2(db, zSql, nByte, OUT sqlite3_stmt**, OUT tail) my $pstmt = Peta::FFI::alloc(8); my $ptail = Peta::FFI::alloc(8); my $rc = DBD::SQLite::_c("sqlite3_prepare_v2", "(opioo)i", $db, $sql, -1, $pstmt, $ptail); my $stmt = Peta::FFI::unpack_ptr(Peta::FFI::peek($pstmt, 8)); my $tail = Peta::FFI::unpack_ptr(Peta::FFI::peek($ptail, 8)); Peta::FFI::free($pstmt); Peta::FFI::free($ptail); if ($rc != DBD::SQLite::SQLITE_OK()) { DBD::SQLite::_c("sqlite3_finalize", "(o)i", $stmt) if $stmt; return _err($sth, $db, "prepare failed"); } # An empty statement (comment or whitespace only) compiles to a # NULL stmt rather than an error; the reference treats it as a # no-op statement, not a failure. $sth->{sqlite_stmt} = $stmt; # Anything left over means the string held more than one # statement. dbdimp.c keeps that tail only when the handle allows # multiple statements - do() walks it - and otherwise drops it, so # SQL the caller may not have meant to run is never executed. $sth->{sqlite_unprepared_statements} = $dbh->FETCH('sqlite_allow_multiple_statements') ? ($tail ? Peta::FFI::peek_cstr($tail) : '') : undef; my $nparams = $stmt ? DBD::SQLite::_c("sqlite3_bind_parameter_count", "(o)i", $stmt) : 0; my $nfields = $stmt ? DBD::SQLite::_c("sqlite3_column_count", "(o)i", $stmt) : 0; # NUM_OF_PARAMS and NAME are answered live by our FETCH - see the # note there on quick_FETCH. NUM_OF_FIELDS must still be STOREd: # DBI::PurePerl sizes the row buffer (dbih_setup_fbav) from that # store, and fetch() hands rows back through it. $sth->STORE('NUM_OF_FIELDS', $nfields); $sth->{sqlite_params} = []; return $outer; } # dbdimp.c sqlite_db_do(): one sqlite3_exec, skipping the # prepare/step/finalize round trip, plus the transaction bookkeeping # that goes with it. sub _do { my ($dbh, $sql) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to do on inactive database handle'); # dbdimp.c:606 - same prep on the do() path. $sql = DBD::SQLite::_encode_text($sql, $dbh->{sqlite_string_mode}); _maybe_begin($dbh, $sql) or return undef; _exec($dbh, $sql) or return undef; _maybe_end($dbh); # Driver.xst do(): a row count of 0 is "true but zero", because a # CREATE TABLE affects no rows and still succeeded. my $rows = DBD::SQLite::_c("sqlite3_changes", "(o)i", $db); return $rows == 0 ? '0E0' : $rows; } # lib/DBD/SQLite.pm sub do(). sqlite3_exec runs semicolon-separated # statements, which is handy but insecure, so that shortcut is taken # only when the string cannot hold a second statement - or when the # caller explicitly allowed several. sub do { my ($dbh, $statement, $attr, @bind_values) = @_; my $allow_multiple_statements = $dbh->FETCH('sqlite_allow_multiple_statements'); if (defined $statement && !defined $attr && !@bind_values) { if (index($statement, ';') == -1 or $allow_multiple_statements) { return _do($dbh, $statement); } } my @copy = @bind_values; my $rows = 0; # An undef statement never enters the loop - that is how # $dbh->do(undef) stays a silent no-op rather than a warning. while ($statement) { my $sth = $dbh->prepare($statement, $attr) or return undef; $sth->execute(splice @copy, 0, $sth->{NUM_OF_PARAMS}) or return undef; $rows += $sth->rows; last unless $allow_multiple_statements; $statement = $sth->{sqlite_unprepared_statements}; } # always return true if no error return $rows == 0 ? '0E0' : $rows; } # Driver.xst commit()/rollback() emit the "ineffective" warning # before calling into the driver, so a pure-Perl driver has to do it # here - there is no generated glue to do it for us. sub commit { my $dbh = shift; return $dbh->set_err(-2, 'attempt to commit on inactive database handle') unless _db($dbh); warn "commit ineffective with AutoCommit enabled" if $dbh->{AutoCommit} && $dbh->FETCH('Warn'); # dbdimp.c sqlite_db_commit(): DBI has already warned, so a # commit under AutoCommit is a no-op rather than an error. return 1 if $dbh->{AutoCommit}; if ($dbh->{BegunWork}) { $dbh->{BegunWork} = 0; $dbh->{AutoCommit} = 1; } return 1 unless _in_txn($dbh); return _exec($dbh, 'COMMIT TRANSACTION'); } sub rollback { my $dbh = shift; return $dbh->set_err(-2, 'attempt to rollback on inactive database handle') unless _db($dbh); warn "rollback ineffective with AutoCommit enabled" if $dbh->{AutoCommit} && $dbh->FETCH('Warn'); # sqlite_db_rollback() has no AutoCommit early-out: a rollback # still discards whatever transaction is actually open. if ($dbh->{BegunWork}) { $dbh->{BegunWork} = 0; $dbh->{AutoCommit} = 1; } return 1 unless _in_txn($dbh); return _exec($dbh, 'ROLLBACK TRANSACTION'); } sub ping { my $dbh = shift; my $db = _db($dbh) or return 0; # Cheapest statement that proves the handle still compiles SQL. return _exec($dbh, 'SELECT 1') ? 1 : 0; } sub last_insert_id { my $dbh = shift; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to get last inserted id on inactive database handle'); return DBD::SQLite::_c("sqlite3_last_insert_rowid", "(o)l", $db); } # ---- Driver-private methods -------------------------------------- # # SQLite.xs declares each of these once and gives it an ALIAS, so the # same XSUB answers to both the bare name and an sqlite_-prefixed # one. Both spellings are load-bearing: DBI's func() dispatches on # the BARE name ($dbh->func(5000, 'busy_timeout')), which is how # upstream's suite calls them, while the documented API is the # prefixed form. The aliases below are declared after the subs. # sqlite_db_busy_timeout: the timeout is remembered on the handle and # returned whether or not it was just set, so a getter call needs no # argument. Setting it on a closed handle is an error, not a silent # no-op. sub busy_timeout { my ($dbh, $ms) = @_; if (defined $ms && $ms =~ /\A-?\d+\z/) { my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to set busy timeout on inactive database handle'); $dbh->{sqlite_timeout} = $ms; DBD::SQLite::_c("sqlite3_busy_timeout", "(oi)i", $db, $ms); } return $dbh->{sqlite_timeout}; } sub get_autocommit { my $dbh = shift; my $db = _db($dbh) or return undef; return DBD::SQLite::_c("sqlite3_get_autocommit", "(o)i", $db); } # sqlite_db_filename always asks about "main"; undef when the handle # has no database rather than an empty string, because an in-memory # or temporary database legitimately reports "". sub db_filename { my $dbh = shift; my $db = _db($dbh) or return undef; return DBD::SQLite::_c("sqlite3_db_filename", "(op)p", $db, 'main'); } sub error_offset { my $dbh = shift; my $db = _db($dbh) or return undef; return DBD::SQLite::_c("sqlite3_error_offset", "(o)i", $db); } # sqlite3_limit: a NEGATIVE new value queries without changing, which # is how the no-argument getter form works. sub limit { my ($dbh, $id, $new) = @_; my $db = _db($dbh) or return undef; $new = -1 unless defined $new; return DBD::SQLite::_c("sqlite3_limit", "(oii)i", $db, $id, $new); } sub txn_state { my ($dbh, $schema) = @_; my $db = _db($dbh) or return undef; return defined $schema && length $schema ? DBD::SQLite::_c("sqlite3_txn_state", "(op)i", $db, $schema) : DBD::SQLite::_c("sqlite3_txn_state", "(oo)i", $db, undef); } # dbdimp.c _sqlite_db_status(). Upstream stops at cache_write; the # DBSTATUS ops sqlite3 added after that are deliberately absent, so # the key set is the reference's and not this libsqlite3's. my @DBSTATUS_OPS = ( [ 0, 'lookaside_used' ], [ 1, 'cache_used' ], [ 2, 'schema_used' ], [ 3, 'stmt_used' ], [ 4, 'lookaside_hit' ], [ 5, 'lookaside_miss_size' ], [ 6, 'lookaside_miss_full' ], [ 7, 'cache_hit' ], [ 8, 'cache_miss' ], [ 9, 'cache_write' ], ); sub db_status { my ($dbh, $reset) = @_; my $db = _db($dbh) or return {}; $reset = $reset ? 1 : 0; my $pcur = Peta::FFI::alloc(4); my $phi = Peta::FFI::alloc(4); my %status; for my $op (@DBSTATUS_OPS) { next if DBD::SQLite::_c("sqlite3_db_status", "(oiooi)i", $db, $op->[0], $pcur, $phi, $reset); $status{ $op->[1] } = { current => unpack('l', Peta::FFI::peek($pcur, 4)), highwater => unpack('l', Peta::FFI::peek($phi, 4)), }; } Peta::FFI::free($pcur); Peta::FFI::free($phi); return \%status; } # The sqlite_-prefixed half of each ALIAS pair. { no strict 'refs'; for my $m (qw( busy_timeout get_autocommit db_filename db_status error_offset limit txn_state last_insert_rowid create_function create_aggregate progress_handler commit_hook rollback_hook update_hook set_authorizer create_collation collation_needed table_column_metadata db_config register_fts3_perl_tokenizer backup_to_file backup_from_file backup_to_dbh backup_from_dbh )) { *{"DBD::SQLite::db::sqlite_$m"} = \&{"DBD::SQLite::db::$m"} if defined &{"DBD::SQLite::db::$m"}; } } # SQLite.pm names this one differently from DBI's standard # last_insert_id, and both are documented. *last_insert_rowid = \&last_insert_id; { no strict 'refs'; *{"DBD::SQLite::db::sqlite_last_insert_rowid"} = \&last_insert_id; } # SQLite quoting is SQL-standard: double the embedded quote. Binary # values become blob literals, which is what the reference emits and # the only form that survives an embedded NUL. sub quote { my ($dbh, $value, $type) = @_; return 'NULL' unless defined $value; if (defined $type && ($type == -3 || $type == -2 || $type == -4)) { return "X'" . unpack('H*', $value) . "'"; } if ($value =~ /\0/) { return "X'" . unpack('H*', $value) . "'"; } $value =~ s/'/''/g; return "'$value'"; } sub quote_identifier { my ($dbh, @parts) = @_; my $attr = ref $parts[-1] ? pop @parts : undef; return join '.', map { my $p = $_; $p =~ s/"/""/g; qq{"$p"}; } grep { defined && length } @parts; } # lib/DBD/SQLite.pm sub get_info(). The table lives in # DBD::SQLite::GetInfo, vendored beside this file: it is upstream's # own pure Perl, ~150 ODBC keys, and a hand-picked subset here would # answer undef for everything the caller did not happen to be lucky # about (t/11_get_info.t checks 17 of them). sub get_info { my ($dbh, $info_type) = @_; require DBD::SQLite::GetInfo; my $v = $DBD::SQLite::GetInfo::info{int($info_type)}; $v = $v->($dbh) if ref $v eq 'CODE'; return $v; } # ---- Catalogue methods ------------------------------------------- # # Transliterated from DBD-SQLite-1.78 lib/DBD/SQLite.pm, which # implements these in pure Perl on top of PRAGMA/sqlite_master # rather than in the XS half - so this is upstream's own logic, not a # reimplementation of it. Kept verbatim apart from indentation: # every SQL string, rule code and column order here is load-bearing # for DBI's documented catalogue shape, and "tidying" one of these # queries silently changes what the caller gets back. # # type_info_all is deliberately NOT included - separate feature. sub _attached_database_list { my $dbh = shift; my @attached; my $sth_databases = $dbh->prepare( 'PRAGMA database_list' ) or return; $sth_databases->execute or return; while ( my $db_info = $sth_databases->fetchrow_hashref ) { push @attached, $db_info->{name} if $db_info->{seq} >= 2; } return @attached; } sub table_info { my ($dbh, $cat_val, $sch_val, $tbl_val, $typ_val, $attr) = @_; my @where = (); my $sql; if ( defined($cat_val) && $cat_val eq '%' && defined($sch_val) && $sch_val eq '' && defined($tbl_val) && $tbl_val eq '') { # Rule 19a $sql = <<'END_SQL'; SELECT NULL TABLE_CAT , NULL TABLE_SCHEM , NULL TABLE_NAME , NULL TABLE_TYPE , NULL REMARKS END_SQL } elsif ( defined($cat_val) && $cat_val eq '' && defined($sch_val) && $sch_val eq '%' && defined($tbl_val) && $tbl_val eq '') { # Rule 19b $sql = <<'END_SQL'; SELECT NULL TABLE_CAT , t.tn TABLE_SCHEM , NULL TABLE_NAME , NULL TABLE_TYPE , NULL REMARKS FROM ( SELECT 'main' tn UNION SELECT 'temp' tn END_SQL for my $db_name (_attached_database_list($dbh)) { $sql .= " UNION SELECT '$db_name' tn\n"; } $sql .= ") t\n"; } elsif ( defined($cat_val) && $cat_val eq '' && defined($sch_val) && $sch_val eq '' && defined($tbl_val) && $tbl_val eq '' && defined($typ_val) && $typ_val eq '%') { # Rule 19c $sql = <<'END_SQL'; SELECT NULL TABLE_CAT , NULL TABLE_SCHEM , NULL TABLE_NAME , t.tt TABLE_TYPE , NULL REMARKS FROM ( SELECT 'TABLE' tt UNION SELECT 'VIEW' tt UNION SELECT 'LOCAL TEMPORARY' tt UNION SELECT 'SYSTEM TABLE' tt ) t ORDER BY TABLE_TYPE END_SQL } else { $sql = <<'END_SQL'; SELECT * FROM ( SELECT NULL TABLE_CAT , TABLE_SCHEM , tbl_name TABLE_NAME , TABLE_TYPE , NULL REMARKS , sql sqlite_sql FROM ( SELECT 'main' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql FROM sqlite_master UNION ALL SELECT 'temp' TABLE_SCHEM, tbl_name, 'LOCAL TEMPORARY' TABLE_TYPE, sql FROM sqlite_temp_master END_SQL for my $db_name (_attached_database_list($dbh)) { $sql .= <<"END_SQL"; UNION ALL SELECT '$db_name' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql FROM "$db_name".sqlite_master END_SQL } $sql .= <<'END_SQL'; UNION ALL SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql UNION ALL SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql ) ) END_SQL $attr = {} unless ref $attr eq 'HASH'; my $escape = defined $attr->{Escape} ? " ESCAPE '$attr->{Escape}'" : ''; if ( defined $sch_val ) { push @where, "TABLE_SCHEM LIKE '$sch_val'$escape"; } if ( defined $tbl_val ) { push @where, "TABLE_NAME LIKE '$tbl_val'$escape"; } if ( defined $typ_val ) { my $table_type_list; $typ_val =~ s/^\s+//; $typ_val =~ s/\s+$//; my @ttype_list = split (/\s*,\s*/, $typ_val); foreach my $table_type (@ttype_list) { if ($table_type !~ /^'.*'$/) { $table_type = "'" . $table_type . "'"; } } $table_type_list = join(', ', @ttype_list); push @where, "TABLE_TYPE IN (\U$table_type_list)" if $table_type_list; } $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where; $sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n"; } my $sth = $dbh->prepare($sql) or return undef; $sth->execute or return undef; $sth; } sub primary_key_info { my ($dbh, $catalog, $schema, $table, $attr) = @_; my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}}); my @pk_info; for my $database (@$databases) { my $dbname = $database->{name}; next if defined $schema && $schema ne '%' && $schema ne $dbname; my $quoted_dbname = $dbh->quote_identifier($dbname); my $master_table = ($dbname eq 'main') ? 'sqlite_master' : ($dbname eq 'temp') ? 'sqlite_temp_master' : $quoted_dbname.'.sqlite_master'; my $sth = $dbh->prepare("SELECT name, sql FROM $master_table WHERE type = ?") or return; $sth->execute("table") or return; while(my $row = $sth->fetchrow_hashref) { my $tbname = $row->{name}; next if defined $table && $table ne '%' && $table ne $tbname; my $quoted_tbname = $dbh->quote_identifier($tbname); my $t_sth = $dbh->prepare("PRAGMA $quoted_dbname.table_xinfo($quoted_tbname)") or return; $t_sth->execute or return; my @pk; while(my $col = $t_sth->fetchrow_hashref) { push @pk, $col->{name} if $col->{pk}; } # If there're multiple primary key columns, we need to # find their order from one of the auto-generated unique # indices (note that single column integer primary key # doesn't create an index). if (@pk > 1 and $row->{sql} =~ /\bPRIMARY\s+KEY\s*\(\s* ( (?: ( [a-z_][a-z0-9_]* | (["'`])(?:\3\3|(?!\3).)+?\3(?!\3) | \[[^\]]+\] ) \s*,\s* )+ ( [a-z_][a-z0-9_]* | (["'`])(?:\5\5|(?!\5).)+?\5(?!\5) | \[[^\]]+\] ) ) \s*\)/six) { my $pk_sql = $1; @pk = (); while($pk_sql =~ / ( [a-z_][a-z0-9_]* | (["'`])(?:\2\2|(?!\2).)+?\2(?!\2) | \[([^\]]+)\] ) (?:\s*,\s*|$) /sixg) { my($col, $quote, $brack) = ($1, $2, $3); if ( defined $quote ) { # Dequote "'` $col = substr $col, 1, -1; $col =~ s/$quote$quote/$quote/g; } elsif ( defined $brack ) { # Dequote [] $col = $brack; } push @pk, $col; } } my $key_name = $row->{sql} =~ /\bCONSTRAINT\s+(\S+|"[^"]+")\s+PRIMARY\s+KEY\s*\(/i ? $1 : 'PRIMARY KEY'; my $key_seq = 0; foreach my $pk_field (@pk) { push @pk_info, { TABLE_SCHEM => $dbname, TABLE_NAME => $tbname, COLUMN_NAME => $pk_field, KEY_SEQ => ++$key_seq, PK_NAME => $key_name, }; } } } my $sponge = DBI->connect("DBI:Sponge:", '','') or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME); my $sth = $sponge->prepare( "primary_key_info", { rows => [ map { [ @{$_}{@names} ] } @pk_info ], NUM_OF_FIELDS => scalar @names, NAME => \@names, }) or return $dbh->DBI::set_err( $sponge->err, $sponge->errstr, ); return $sth; } our %DBI_code_for_rule = ( # from DBI doc; curiously, they are not exported # by the DBI module. # codes for update/delete constraints 'CASCADE' => 0, 'RESTRICT' => 1, 'SET NULL' => 2, 'NO ACTION' => 3, 'SET DEFAULT' => 4, # codes for deferrability 'INITIALLY DEFERRED' => 5, 'INITIALLY IMMEDIATE' => 6, 'NOT DEFERRABLE' => 7, ); my @FOREIGN_KEY_INFO_ODBC = ( 'PKTABLE_CAT', # The primary (unique) key table catalog identifier. 'PKTABLE_SCHEM', # The primary (unique) key table schema identifier. 'PKTABLE_NAME', # The primary (unique) key table identifier. 'PKCOLUMN_NAME', # The primary (unique) key column identifier. 'FKTABLE_CAT', # The foreign key table catalog identifier. 'FKTABLE_SCHEM', # The foreign key table schema identifier. 'FKTABLE_NAME', # The foreign key table identifier. 'FKCOLUMN_NAME', # The foreign key column identifier. 'KEY_SEQ', # The column sequence number (starting with 1). 'UPDATE_RULE', # The referential action for the UPDATE rule. 'DELETE_RULE', # The referential action for the DELETE rule. 'FK_NAME', # The foreign key name. 'PK_NAME', # The primary (unique) key name. 'DEFERRABILITY', # The deferrability of the foreign key constraint. 'UNIQUE_OR_PRIMARY', # qualifies the key referenced by the foreign key ); # Column names below are not used, but listed just for completeness's sake. # Maybe we could add an option so that the user can choose which field # names will be returned; the DBI spec is not very clear about ODBC vs. CLI. my @FOREIGN_KEY_INFO_SQL_CLI = qw( UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME UK_COLUMN_NAME FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME ORDINAL_POSITION UPDATE_RULE DELETE_RULE FK_NAME UK_NAME DEFERABILITY UNIQUE_OR_PRIMARY ); my $DEFERRABLE_RE = qr/ (?:(?: on \s+ (?:delete|update) \s+ (?:set \s+ null|set \s+ default|cascade|restrict|no \s+ action) | match \s* (?:\S+|".+?(?selectall_arrayref("PRAGMA database_list", {Slice => {}}) or return; my @fk_info; my %table_info; for my $database (@$databases) { my $dbname = $database->{name}; next if defined $fk_schema && $fk_schema ne '%' && $fk_schema ne $dbname; my $quoted_dbname = $dbh->quote_identifier($dbname); my $master_table = ($dbname eq 'main') ? 'sqlite_master' : ($dbname eq 'temp') ? 'sqlite_temp_master' : $quoted_dbname.'.sqlite_master'; my $tables = $dbh->selectall_arrayref("SELECT name, sql FROM $master_table WHERE type = ?", undef, "table") or return; for my $table (@$tables) { my $tbname = $table->[0]; my $ddl = $table->[1]; my (@rels, %relid2rels); next if defined $fk_table && $fk_table ne '%' && $fk_table ne $tbname; my $quoted_tbname = $dbh->quote_identifier($tbname); my $sth = $dbh->prepare("PRAGMA $quoted_dbname.foreign_key_list($quoted_tbname)") or return; $sth->execute or return; while(my $row = $sth->fetchrow_hashref) { next if defined $pk_table && $pk_table ne '%' && $pk_table ne $row->{table}; unless ($table_info{$row->{table}}) { my $quoted_tb = $dbh->quote_identifier($row->{table}); for my $db (@$databases) { my $quoted_db = $dbh->quote_identifier($db->{name}); my $t_sth = $dbh->prepare("PRAGMA $quoted_db.table_xinfo($quoted_tb)") or return; $t_sth->execute or return; my $cols = {}; while(my $r = $t_sth->fetchrow_hashref) { $cols->{$r->{name}} = $r->{pk}; } if (keys %$cols) { $table_info{$row->{table}} = { schema => $db->{name}, columns => $cols, }; last; } } } next if defined $pk_schema && $pk_schema ne '%' && $pk_schema ne $table_info{$row->{table}}{schema}; # cribbed from DBIx::Class::Schema::Loader::DBI::SQLite my $rel = $rels[ $row->{id} ] ||= { local_columns => [], remote_columns => undef, remote_table => $row->{table}, }; push @{ $rel->{local_columns} }, $row->{from}; push @{ $rel->{remote_columns} }, $row->{to} if defined $row->{to}; my $fk_row = { PKTABLE_CAT => undef, PKTABLE_SCHEM => $table_info{$row->{table}}{schema}, PKTABLE_NAME => $row->{table}, PKCOLUMN_NAME => $row->{to}, FKTABLE_CAT => undef, FKTABLE_SCHEM => $dbname, FKTABLE_NAME => $tbname, FKCOLUMN_NAME => $row->{from}, KEY_SEQ => $row->{seq} + 1, UPDATE_RULE => $DBI_code_for_rule{$row->{on_update}}, DELETE_RULE => $DBI_code_for_rule{$row->{on_delete}}, FK_NAME => undef, PK_NAME => undef, DEFERRABILITY => undef, UNIQUE_OR_PRIMARY => $table_info{$row->{table}}{columns}{$row->{to}} ? 'PRIMARY' : 'UNIQUE', }; push @fk_info, $fk_row; push @{ $relid2rels{$row->{id}} }, $fk_row; # keep so can fixup } # cribbed from DBIx::Class::Schema::Loader::DBI::SQLite # but with additional parsing of which kind of deferrable REL: for my $relid (keys %relid2rels) { my $rel = $rels[$relid]; my $deferrable = $DBI_code_for_rule{'NOT DEFERRABLE'}; my $local_cols = '"?' . (join '"? \s* , \s* "?', map quotemeta, @{ $rel->{local_columns} }) . '"?'; my $remote_cols = '"?' . (join '"? \s* , \s* "?', map quotemeta, @{ $rel->{remote_columns} || [] }) . '"?'; my ($deferrable_clause) = $ddl =~ / foreign \s+ key \s* \( \s* $local_cols \s* \) \s* references \s* (?:\S+|".+?(?{local_columns} } == 1) { my ($local_col) = @{ $rel->{local_columns} }; my ($remote_col) = @{ $rel->{remote_columns} || [] }; $remote_col ||= ''; ($deferrable_clause) = $ddl =~ / "?\Q$local_col\E"? \s* (?:\w+\s*)* (?: \( \s* \d\+ (?:\s*,\s*\d+)* \s* \) )? \s* references \s+ (?:\S+|".+?(?{DEFERRABILITY} = $deferrable for @{ $relid2rels{$relid} }; } } } my $sponge_dbh = DBI->connect("DBI:Sponge:", "", "") or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); my $sponge_sth = $sponge_dbh->prepare("foreign_key_info", { NAME => \@FOREIGN_KEY_INFO_ODBC, rows => [ map { [@{$_}{@FOREIGN_KEY_INFO_ODBC} ] } @fk_info ], NUM_OF_FIELDS => scalar(@FOREIGN_KEY_INFO_ODBC), }) or return $dbh->DBI::set_err( $sponge_dbh->err, $sponge_dbh->errstr, ); return $sponge_sth; } my @STATISTICS_INFO_ODBC = ( 'TABLE_CAT', # The catalog identifier. 'TABLE_SCHEM', # The schema identifier. 'TABLE_NAME', # The table identifier. 'NON_UNIQUE', # Unique index indicator. 'INDEX_QUALIFIER', # Index qualifier identifier. 'INDEX_NAME', # The index identifier. 'TYPE', # The type of information being returned. 'ORDINAL_POSITION', # Column sequence number (starting with 1). 'COLUMN_NAME', # The column identifier. 'ASC_OR_DESC', # Column sort sequence. 'CARDINALITY', # Cardinality of the table or index. 'PAGES', # Number of storage pages used by this table or index. 'FILTER_CONDITION', # The index filter condition as a string. ); sub statistics_info { my ($dbh, $catalog, $schema, $table, $unique_only, $quick) = @_; my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}}) or return; my @statistics_info; for my $database (@$databases) { my $dbname = $database->{name}; next if defined $schema && $schema ne '%' && $schema ne $dbname; my $quoted_dbname = $dbh->quote_identifier($dbname); my $master_table = ($dbname eq 'main') ? 'sqlite_master' : ($dbname eq 'temp') ? 'sqlite_temp_master' : $quoted_dbname.'.sqlite_master'; my $tables = $dbh->selectall_arrayref("SELECT name FROM $master_table WHERE type = ?", undef, "table") or return; for my $table_ref (@$tables) { my $tbname = $table_ref->[0]; next if defined $table && $table ne '%' && uc($table) ne uc($tbname); my $quoted_tbname = $dbh->quote_identifier($tbname); my $sth = $dbh->prepare("PRAGMA $quoted_dbname.index_list($quoted_tbname)") or return; $sth->execute or return; while(my $row = $sth->fetchrow_hashref) { next if $unique_only && !$row->{unique}; my $quoted_idx = $dbh->quote_identifier($row->{name}); for my $db (@$databases) { my $quoted_db = $dbh->quote_identifier($db->{name}); my $i_sth = $dbh->prepare("PRAGMA $quoted_db.index_info($quoted_idx)") or return; $i_sth->execute or return; my $cols = {}; while(my $info = $i_sth->fetchrow_hashref) { push @statistics_info, { TABLE_CAT => undef, TABLE_SCHEM => $db->{name}, TABLE_NAME => $tbname, NON_UNIQUE => $row->{unique} ? 0 : 1, INDEX_QUALIFIER => undef, INDEX_NAME => $row->{name}, TYPE => 'btree', # see https://www.sqlite.org/version3.html esp. "Traditional B-trees are still used for indices" ORDINAL_POSITION => $info->{seqno} + 1, COLUMN_NAME => $info->{name}, ASC_OR_DESC => undef, CARDINALITY => undef, PAGES => undef, FILTER_CONDITION => undef, }; } } } } } my $sponge_dbh = DBI->connect("DBI:Sponge:", "", "") or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); my $sponge_sth = $sponge_dbh->prepare("statistics_info", { NAME => \@STATISTICS_INFO_ODBC, rows => [ map { [@{$_}{@STATISTICS_INFO_ODBC} ] } @statistics_info ], NUM_OF_FIELDS => scalar(@STATISTICS_INFO_ODBC), }) or return $dbh->DBI::set_err( $sponge_dbh->err, $sponge_dbh->errstr, ); return $sponge_sth; } my @COLUMN_INFO = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE ); sub column_info { my ($dbh, $cat_val, $sch_val, $tbl_val, $col_val) = @_; if ( defined $col_val and $col_val eq '%' ) { $col_val = undef; } # Get a list of all tables ordered by TABLE_SCHEM, TABLE_NAME my $sql = <<'END_SQL'; SELECT TABLE_SCHEM, tbl_name TABLE_NAME FROM ( SELECT 'main' TABLE_SCHEM, tbl_name FROM sqlite_master WHERE type IN ('table','view') UNION ALL SELECT 'temp' TABLE_SCHEM, tbl_name FROM sqlite_temp_master WHERE type IN ('table','view') END_SQL for my $db_name (_attached_database_list($dbh)) { $sql .= <<"END_SQL"; UNION ALL SELECT '$db_name' TABLE_SCHEM, tbl_name FROM "$db_name".sqlite_master WHERE type IN ('table','view') END_SQL } $sql .= <<'END_SQL'; UNION ALL SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name UNION ALL SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name ) END_SQL my @where; if ( defined $sch_val ) { push @where, "TABLE_SCHEM LIKE '$sch_val'"; } if ( defined $tbl_val ) { push @where, "TABLE_NAME LIKE '$tbl_val'"; } $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where; $sql .= " ORDER BY TABLE_SCHEM, TABLE_NAME\n"; my $sth_tables = $dbh->prepare($sql) or return undef; $sth_tables->execute or return undef; # Taken from Fey::Loader::SQLite my @cols; while ( my ($schema, $table) = $sth_tables->fetchrow_array ) { my $sth_columns = $dbh->prepare(qq{PRAGMA "$schema".table_xinfo("$table")}) or return; $sth_columns->execute or return; for ( my $position = 1; my $col_info = $sth_columns->fetchrow_hashref; $position++ ) { if ( defined $col_val ) { # This must do a LIKE comparison my $sth = $dbh->prepare("SELECT '$col_info->{name}' LIKE '$col_val'") or return undef; $sth->execute or return undef; # Skip columns that don't match $col_val next unless ($sth->fetchrow_array)[0]; } my %col = ( TABLE_SCHEM => $schema, TABLE_NAME => $table, COLUMN_NAME => $col_info->{name}, ORDINAL_POSITION => $position, ); my $type = $col_info->{type}; if ( $type =~ s/(\w+)\s*\(\s*(\d+)(?:\s*,\s*(\d+))?\s*\)/$1/ ) { $col{COLUMN_SIZE} = $2; $col{DECIMAL_DIGITS} = $3; } $col{TYPE_NAME} = $type; if ( defined $col_info->{dflt_value} ) { $col{COLUMN_DEF} = $col_info->{dflt_value} } if ( $col_info->{notnull} ) { $col{NULLABLE} = 0; $col{IS_NULLABLE} = 'NO'; } else { $col{NULLABLE} = 1; $col{IS_NULLABLE} = 'YES'; } push @cols, \%col; } $sth_columns->finish; } $sth_tables->finish; my $sponge = DBI->connect("DBI:Sponge:", '','') or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); $sponge->prepare( "column_info", { rows => [ map { [ @{$_}{@COLUMN_INFO} ] } @cols ], NUM_OF_FIELDS => scalar @COLUMN_INFO, NAME => [ @COLUMN_INFO ], } ) or return $dbh->DBI::set_err( $sponge->err, $sponge->errstr, ); } # ---- User-defined functions -------------------------------------- # # sqlite3 hands a UDF its arguments as sqlite3_value* and takes the # answer through sqlite3_result_*. Upstream registers a static C # dispatcher and passes the coderef as pApp; here the closure itself # carries the coderef, so the dispatcher is Perl and the driver stays # pure Perl over Peta::FFI. # Size of one sqlite3_value* in the argv array, derived rather than # assumed - argv is a C array of pointers and we index it by hand. my $PTRSIZE = length Peta::FFI::pack_ptr(0); # sqlite3.h storage classes. use constant { SQLITE_INTEGER_T => 1, SQLITE_FLOAT_T => 2, SQLITE_TEXT_T => 3, SQLITE_BLOB_T => 4, SQLITE_NULL_T => 5, SQLITE_UTF8 => 1, }; # sqlite_value_to_sv(): the storage class decides, not the column - # SQLite is dynamically typed per VALUE. TEXT and BLOB both go # through sqlite3_value_bytes rather than a NUL scan, because a BLOB # may legitimately contain NUL and a text value may not be # NUL-terminated in the way peek_cstr assumes. sub _sqlite_value_to_perl { my ($v, $string_mode) = @_; my $t = DBD::SQLite::_c("sqlite3_value_type", "(o)i", $v); return undef if $t == SQLITE_NULL_T; return DBD::SQLite::_c("sqlite3_value_int64", "(o)l", $v) if $t == SQLITE_INTEGER_T; return DBD::SQLite::_c("sqlite3_value_double", "(o)d", $v) if $t == SQLITE_FLOAT_T; my $n = DBD::SQLite::_c("sqlite3_value_bytes", "(o)i", $v); return '' unless $n; my $p = DBD::SQLite::_c( $t == SQLITE_BLOB_T ? "sqlite3_value_blob" : "sqlite3_value_text", "(o)o", $v); return '' unless $p; my $s = Peta::FFI::peek($p, $n); DBD::SQLite::_decode_text($s, $string_mode) if $t != SQLITE_BLOB_T; return $s; } # sqlite_set_result(): undef is NULL; an arrayref is upstream's # [$value, $type] form used to force a BLOB; otherwise the value's # own numeric-ness decides, exactly as sqlite_is_number gates it. # SQLITE_TRANSIENT throughout - the Perl scalar does not outlive the # call, so SQLite must copy. sub _sqlite_result_from_perl { my ($ctx, $val) = @_; if (!defined $val) { DBD::SQLite::_c("sqlite3_result_null", "(o)v", $ctx); return; } if (ref $val eq 'ARRAY') { my ($bytes, undef) = @$val; $bytes = DBD::SQLite::_pv_bytes(defined $bytes ? $bytes : ''); DBD::SQLite::_c("sqlite3_result_blob", "(opio)v", $ctx, $bytes, length($bytes), DBD::SQLite::SQLITE_TRANSIENT()); return; } my $num = DBD::SQLite::_is_number($val); if ($num == 1) { DBD::SQLite::_c("sqlite3_result_int64", "(ol)v", $ctx, $val); } elsif ($num == 2) { DBD::SQLite::_c("sqlite3_result_double", "(od)v", $ctx, $val); } else { # sqlite_set_result(): s = SvPV(result, len) - the internal # bytes and their BYTE count. my $bytes = DBD::SQLite::_pv_bytes($val); DBD::SQLite::_c("sqlite3_result_text", "(opio)v", $ctx, $bytes, length($bytes), DBD::SQLite::SQLITE_TRANSIENT()); } return; } # Keep every closure alive for the life of the handle and release # them at disconnect: SQLite holds the raw function pointer, so a # closure freed early leaves it calling into released memory. sub _sqlite_keep_closure { my ($dbh, $ptr) = @_; push @{ $dbh->{sqlite_closures} ||= [] }, $ptr; return $ptr; } # sqlite_db_create_function. argc of -1 means variadic. sub create_function { my ($dbh, $name, $argc, $func, $flags) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to create function on inactive database handle'); $flags = 0 unless defined $flags; # Deregistering: a false coderef removes the function. if (!defined $func) { my $rc = DBD::SQLite::_c("sqlite3_create_function", "(opiioooo)i", $db, $name, $argc, SQLITE_UTF8() | $flags, undef, undef, undef, undef); return $rc == 0 ? 1 : _err($dbh, $db); } my $cb = Peta::FFI::closure('(oio)v', sub { my ($ctx, $n, $argv) = @_; # Everything is evalled here, not left to the closure's own # G_EVAL. Two reasons: a die in the USER's function has to # become sqlite3_result_error, which is how the message # reaches DBI::errstr instead of vanishing into $@; and a bug # in the marshalling BELOW would otherwise be swallowed just # as silently, surfacing only as an unexplained NULL - which # is exactly how the first version of this failed. my $ok = eval { my @args = map { _sqlite_value_to_perl( Peta::FFI::unpack_ptr( Peta::FFI::peek($argv + $_ * $PTRSIZE, $PTRSIZE)), $dbh->{sqlite_string_mode}) } 0 .. $n - 1; _sqlite_result_from_perl($ctx, scalar $func->(@args)); 1; }; if (!$ok) { my $msg = $@; $msg = 'unknown error in user-defined function' unless defined $msg && length $msg; $msg =~ s/\s+\z//; DBD::SQLite::_c("sqlite3_result_error", "(opi)v", $ctx, $msg, length($msg)); } return; }); _sqlite_keep_closure($dbh, $cb); my $rc = DBD::SQLite::_c("sqlite3_create_function", "(opiioooo)i", $db, $name, $argc, SQLITE_UTF8() | $flags, undef, $cb, undef, undef); return $rc == 0 ? 1 : _err($dbh, $db); } # sqlite_db_progress_handler. The handler is invoked every # n_opcodes VM instructions; a true return aborts the running # statement. Passing undef removes it. sub progress_handler { my ($dbh, $n_opcodes, $handler) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to set progress handler on inactive database handle'); if (!defined $handler) { DBD::SQLite::_c("sqlite3_progress_handler", "(oioo)v", $db, 0, undef, undef); return 1; } # The C prototype is int(*)(void*), but upstream's dispatcher # calls the Perl sub with NO arguments - it pushes a mark and # calls straight away - so the userdata slot is dropped here too. my $cb = Peta::FFI::closure('(o)i', sub { my $r = eval { scalar $handler->() }; # A die cannot cross the C frame. Upstream lets it propagate # from XS; here the safe reading is "do not abort the query". return 0 if $@; return defined $r ? int($r) : 0; }); _sqlite_keep_closure($dbh, $cb); DBD::SQLite::_c("sqlite3_progress_handler", "(oioo)v", $db, $n_opcodes, $cb, undef); return 1; } # sqlite_db_create_aggregate. $pkg is a class name (or object) that # answers new/step/finalize. # # State lives per AGGREGATION, not per registration: sqlite3 hands # each one its own sqlite3_aggregate_context, and that pointer is # stable across every step of one aggregation. Upstream stores the # instance inside that C memory; we key a Perl hash by the pointer # instead, which keeps Perl refcounts out of malloc'd C storage. The # entry is deleted in finalize, so an address sqlite3 later reuses # starts clean. sub create_aggregate { my ($dbh, $name, $argc, $pkg, $flags) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to create aggregate on inactive database handle'); $flags = 0 unless defined $flags; my %inst; my $new_inst = sub { my $o = eval { scalar $pkg->new }; return { obj => undef, err => "error during aggregator's new(): $@" } if $@; # sqlite_db_aggr_new_dispatcher checks sv_isobject: a new() # that hands back something unblessed is an error, not an # instance to call step() on. return { obj => undef, err => "new() should return a blessed reference" } unless Scalar::Util::blessed($o); return { obj => $o, err => undef }; }; my $step = Peta::FFI::closure('(oio)v', sub { my ($ctx, $n, $argv) = @_; my $actx = DBD::SQLite::_c("sqlite3_aggregate_context", "(oi)o", $ctx, $PTRSIZE); return unless $actx; my $s = ($inst{$actx} ||= $new_inst->()); return if $s->{err} || !defined $s->{obj}; my $ok = eval { my @args = map { _sqlite_value_to_perl( Peta::FFI::unpack_ptr( Peta::FFI::peek($argv + $_ * $PTRSIZE, $PTRSIZE)), $dbh->{sqlite_string_mode}) } 0 .. $n - 1; $s->{obj}->step(@args); 1; }; $s->{err} = "error during aggregator's step(): $@" unless $ok; return; }); my $final = Peta::FFI::closure('(o)v', sub { my ($ctx) = @_; # ZERO bytes, deliberately: this returns NULL when no step # ever ran, which is how an aggregate over an empty result # set is detected. Upstream then builds a throwaway instance # so new/finalize still happen, and so does this. my $actx = DBD::SQLite::_c("sqlite3_aggregate_context", "(oi)o", $ctx, 0); my $s = $actx ? delete $inst{$actx} : undef; $s ||= $new_inst->(); if (!$s->{err} && defined $s->{obj}) { my $ok = eval { _sqlite_result_from_perl($ctx, scalar $s->{obj}->finalize); 1; }; $s->{err} = "error during aggregator's finalize(): $@" unless $ok; } # An aggregate error is WARNED, not reported to SQLite: the # result is simply left unset, which SQLite reads as NULL. # Upstream's sqlite_set_result call for this path is # commented out in dbdimp.c, and its tests assert the # warning plus an undef value - so reporting the error # properly here would be a divergence, not an improvement. if ($s->{err}) { my $msg = $s->{err}; $msg =~ s/\s+\z//; warn "DBD::SQLite: error in aggregator cannot be reported to SQLite: $msg\n"; } return; }); _sqlite_keep_closure($dbh, $step); _sqlite_keep_closure($dbh, $final); my $rc = DBD::SQLite::_c("sqlite3_create_function", "(opiioooo)i", $db, $name, $argc, SQLITE_UTF8() | $flags, undef, undef, $step, $final); return $rc == 0 ? 1 : _err($dbh, $db); } # ---- Hooks ------------------------------------------------------- # # Each registrar returns the PREVIOUSLY registered coderef (undef # the first time) and 36_hooks.t compares it by identity, so the # coderef itself is remembered on the handle. Upstream gets this for # free by handing sqlite3 the coderef as pApp and reading back the # old pApp; our closure carries the coderef instead, so the previous # one is tracked here. sub _sqlite_set_hook { my ($dbh, $slot, $cfunc, $sig, $hook, $wrap) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, "attempt to set $slot on inactive database handle"); my $previous = $dbh->{"sqlite_hook_$slot"}; if (!defined $hook) { DBD::SQLite::_c($cfunc, "(ooo)o", $db, undef, undef); $dbh->{"sqlite_hook_$slot"} = undef; return $previous; } my $cb = Peta::FFI::closure($sig, $wrap->($hook)); _sqlite_keep_closure($dbh, $cb); DBD::SQLite::_c($cfunc, "(ooo)o", $db, $cb, undef); $dbh->{"sqlite_hook_$slot"} = $hook; return $previous; } # sqlite_db_generic_callback_dispatcher: no arguments, integer back. # A non-zero commit hook return makes SQLite convert the COMMIT into # a ROLLBACK, so a die must not be read as "abort" - it returns 0. sub commit_hook { my ($dbh, $hook) = @_; return _sqlite_set_hook($dbh, 'commit', 'sqlite3_commit_hook', '(o)i', $hook, sub { my $h = shift; return sub { my $r = eval { scalar $h->() }; return $@ ? 0 : (defined $r ? int($r) : 0) }; }); } sub rollback_hook { my ($dbh, $hook) = @_; return _sqlite_set_hook($dbh, 'rollback', 'sqlite3_rollback_hook', '(o)v', $hook, sub { my $h = shift; return sub { eval { $h->() }; return } }); } # sqlite_db_update_dispatcher passes (op, database, table, rowid) - # the userdata slot is dropped, as with the progress handler. sub update_hook { my ($dbh, $hook) = @_; return _sqlite_set_hook($dbh, 'update', 'sqlite3_update_hook', '(oippl)v', $hook, sub { my $h = shift; return sub { my (undef, $op, $database, $table, $rowid) = @_; eval { $h->($op, $database, $table, $rowid) }; return; }; }); } # sqlite3_set_authorizer: consulted while a statement is PREPARED. # The callback is handed the action code plus four detail strings, # any of which may be NULL and arrive as undef, and answers OK, # DENY or IGNORE. As with the other hooks the userdata slot is # dropped before the Perl sub sees it. sub set_authorizer { my ($dbh, $authorizer) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to set authorizer on inactive database handle'); my $previous = $dbh->{sqlite_hook_authorizer}; if (!defined $authorizer) { DBD::SQLite::_c("sqlite3_set_authorizer", "(ooo)i", $db, undef, undef); $dbh->{sqlite_hook_authorizer} = undef; return $previous; } my $cb = Peta::FFI::closure('(oipppp)i', sub { my (undef, $action, $a1, $a2, $dbname, $trigger) = @_; my $r = eval { scalar $authorizer->($action, $a1, $a2, $dbname, $trigger) }; # A die must not abort preparation in an unexplained way; # DENY is the conservative reading of "the authorizer failed". return DENY() if $@; return defined $r ? int($r) : OK(); }); _sqlite_keep_closure($dbh, $cb); DBD::SQLite::_c("sqlite3_set_authorizer", "(ooo)i", $db, $cb, undef); $dbh->{sqlite_hook_authorizer} = $authorizer; return $previous; } # sqlite3_create_collation. xCompare is handed two length-counted # byte buffers, NOT C strings - a collated value may contain NUL and # is not terminated - so each side is read with its explicit length. sub create_collation { my ($dbh, $name, $collation) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to create collation on inactive database handle'); # dbdimp.c _COLLATION_DISPATCHER, indexed by the handle's string # mode AT REGISTRATION TIME. The comparator must see CHARACTERS # in every unicode mode - a length() or a tr/// inside the # caller's collation is meaningless on UTF-8 bytes, and # t/13_create_collation.t sorts accented French with both. # # Note STRICT maps to the *fallback* dispatcher upstream: bad # bytes warn here, they do not die, because a comparator cannot # abort a sort from inside C anyway. my $mode = $dbh->{sqlite_string_mode}; my $decode_mode = !defined $mode || !($mode & DBD::SQLite::STRING_MODE_UNICODE_ANY()) ? undef : $mode == DBD::SQLite::STRING_MODE_UNICODE_NAIVE() ? DBD::SQLite::STRING_MODE_UNICODE_NAIVE() : DBD::SQLite::STRING_MODE_UNICODE_FALLBACK(); my $cb = Peta::FFI::closure('(oioio)i', sub { my (undef, $n1, $p1, $n2, $p2) = @_; my $r = eval { my $a = $n1 ? Peta::FFI::peek($p1, $n1) : ''; my $b = $n2 ? Peta::FFI::peek($p2, $n2) : ''; if (defined $decode_mode) { DBD::SQLite::_decode_text($a, $decode_mode); DBD::SQLite::_decode_text($b, $decode_mode); } scalar $collation->($a, $b); }; # A comparator that dies cannot abort the sort from inside # C; "equal" is the only answer that keeps the ordering # total and the sort well-defined. return 0 if $@; return defined $r ? int($r) : 0; }); _sqlite_keep_closure($dbh, $cb); my $rc = DBD::SQLite::_c("sqlite3_create_collation", "(opioo)i", $db, $name, SQLITE_UTF8(), undef, $cb); return $rc == 0 ? 1 : _err($dbh, $db); } # sqlite3_collation_needed: fired when a statement names a collation # SQLite does not know yet. The callback receives the dbh and the # name, and is expected to register it. sub collation_needed { my ($dbh, $handler) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to set collation_needed on inactive database handle'); if (!defined $handler) { DBD::SQLite::_c("sqlite3_collation_needed", "(ooo)i", $db, undef, undef); return 1; } my $cb = Peta::FFI::closure('(ooip)v', sub { my (undef, undef, undef, $name) = @_; eval { $handler->($dbh, $name) }; return; }); _sqlite_keep_closure($dbh, $cb); # Argument order differs from every other hook: this one is # (db, pArg, xCallback), not (db, xCallback, pArg). Passing the # closure in the pArg slot registers nothing and fails silently. DBD::SQLite::_c("sqlite3_collation_needed", "(ooo)i", $db, undef, $cb); return 1; } # sqlite3_table_column_metadata fills five OUT parameters: two # char** (pointing at storage sqlite3 owns, not to be freed) and # three int*. data_type is lowercased, as upstream's _lc does. sub table_column_metadata { my ($dbh, $dbname, $table, $column) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to fetch table column metadata on inactive database handle'); # Upstream tests SvPOK, not length: an EMPTY string is a valid # name here and must not be refused - only undef is an error. return $dbh->set_err(-2, 'table_column_metadata requires a table name') unless defined $table; return $dbh->set_err(-2, 'table_column_metadata requires a column name') unless defined $column; my @cell = map { Peta::FFI::alloc($PTRSIZE) } 1 .. 5; # dbname is optional and NULL means "search every attached # database". An undef under 'p' would be marshalled as a string, # so the slot switches to 'o' - which passes NULL - exactly as # DBD::MariaDB's connect builds its signature per argument. my $sig = "(o" . (defined $dbname ? 'p' : 'o') . "ppooooo)i"; my $rc = DBD::SQLite::_c("sqlite3_table_column_metadata", $sig, $db, $dbname, $table, $column, @cell); my %meta; if ($rc == 0) { my ($dt, $cs) = map { my $p = Peta::FFI::unpack_ptr(Peta::FFI::peek($_, $PTRSIZE)); $p ? Peta::FFI::peek_cstr($p) : undef; } @cell[0, 1]; %meta = ( data_type => defined $dt ? lc $dt : undef, collation_name => $cs, not_null => unpack('l', Peta::FFI::peek($cell[2], 4)), primary => unpack('l', Peta::FFI::peek($cell[3], 4)), auto_increment => unpack('l', Peta::FFI::peek($cell[4], 4)), ); } Peta::FFI::free($_) for @cell; return \%meta; } # sqlite3_trace: the callback sees each statement as it starts. sub sqlite_trace { my ($dbh, $handler) = @_; return _sqlite_set_hook($dbh, 'trace', 'sqlite3_trace', '(op)v', $handler, sub { my $h = shift; return sub { my (undef, $sql) = @_; eval { $h->($sql) }; return }; }); } # sqlite3_profile: (sql, elapsed). SQLite reports nanoseconds but # only has millisecond resolution, so upstream divides by 1e6 and # the six least significant digits are meaningless either way. sub sqlite_profile { my ($dbh, $handler) = @_; return _sqlite_set_hook($dbh, 'profile', 'sqlite3_profile', '(opL)v', $handler, sub { my $h = shift; return sub { my (undef, $sql, $elapsed) = @_; eval { $h->($sql, int($elapsed / 1_000_000)) }; return; }; }); } # sqlite3_db_config is variadic in C; every id below takes # (int new_value, int *pResult), and -1 as the value means "query # without changing". Upstream refuses the two ids whose payload is # not that shape rather than guessing at it. my %DBCONFIG_UNSUPPORTED = ( 1000 => 'SQLITE_DBCONFIG_MAINDBNAME', 1001 => 'SQLITE_DBCONFIG_LOOKASIDE', ); sub db_config { my ($dbh, $id, $new_value) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to configure an inactive database handle'); if (my $name = $DBCONFIG_UNSUPPORTED{$id}) { return $dbh->set_err(-1, "$name is not supported"); } $new_value = -1 unless defined $new_value; my $cell = Peta::FFI::alloc(4); my $rc = DBD::SQLite::_c("sqlite3_db_config", "(oiio)i", $db, $id, $new_value, $cell); my $ret = unpack('l', Peta::FFI::peek($cell, 4)); Peta::FFI::free($cell); return $rc == 0 ? $ret : _err($dbh, $db); } # ---- FTS3 perl tokenizer ----------------------------------------- # # dbdimp_tokenizer.inc. FTS3 takes a tokenizer as a struct of five # function pointers, registered by binding the struct's ADDRESS as a # blob to `SELECT fts3_tokenizer('perl', ?)`. # # The C side keeps two objects alive across calls: a tokenizer (one # per FTS table) and a cursor (one per tokenized string). Upstream # stores the Perl coderefs inside those C structs; we allocate the # structs with only the fields sqlite3 itself reads - the module # pointer / tokenizer pointer - and key the Perl state by their # ADDRESS, the same trick create_aggregate uses to keep Perl # refcounts out of C storage. my (%TOKENIZER, %TOKCURSOR, $TOK_MODULE, @TOK_CLOSURES); # The tokenizer and cursor structs, and the token buffer, are # allocated with sqlite3_malloc and released with sqlite3_free - # exactly as dbdimp_tokenizer.inc does. This is not # interchangeable with libc malloc/free: sqlite3 frees these on its # own error paths, and handing it a pointer from a different # allocator corrupts the heap. sub _tok_malloc { my $p = DBD::SQLite::_c("sqlite3_malloc", "(i)o", $_[0]); Peta::FFI::poke($p, "\0" x $_[0]) if $p; return $p; } sub _tok_free { DBD::SQLite::_c("sqlite3_free", "(o)v", $_[0]) if $_[0] } sub _tok_int { unpack 'l', Peta::FFI::peek($_[0], 4) } sub _tok_poke_int { Peta::FFI::poke($_[0], pack 'l', $_[1]) } sub _tok_poke_ptr { Peta::FFI::poke($_[0], Peta::FFI::pack_ptr($_[1])) } sub _fts3_build_module { return $TOK_MODULE if $TOK_MODULE; # fts3_tokenizer.h sqlite3_tokenizer_module: # int iVersion; xCreate; xDestroy; xOpen; xClose; xNext; # xLanguageid <- only used when iVersion >= 1 # SIX function pointers, not five. The int is padded to pointer # alignment, so the first sits at offset 8 and the struct is # 8 + 6*8 = 56 bytes. Upstream's initializer names only five, but # the C compiler still allocates the whole struct with the last # slot NULL - allocating 48 here left fts3 reading heap garbage # where xLanguageid should be. my $create = Peta::FFI::closure('(ioo)i', \&_fts3_create); my $destroy = Peta::FFI::closure('(o)i', \&_fts3_destroy); my $open = Peta::FFI::closure('(ooio)i', \&_fts3_open); my $close = Peta::FFI::closure('(o)i', \&_fts3_close); my $next = Peta::FFI::closure('(oooooo)i', \&_fts3_next); @TOK_CLOSURES = ($create, $destroy, $open, $close, $next); my $m = Peta::FFI::alloc(8 + 6 * $PTRSIZE); # Zero the whole struct first, so xLanguageid is NULL rather # than whatever the allocator left there. Peta::FFI::poke($m, "\0" x (8 + 6 * $PTRSIZE)); Peta::FFI::poke($m, pack('l', 0)); # iVersion = 0 _tok_poke_ptr($m + 8 + $PTRSIZE * $_, $TOK_CLOSURES[$_]) for 0 .. 4; return $TOK_MODULE = $m; } # xCreate(argc, argv, ppTokenizer): argv[0] is the fully qualified # Perl function named in `tokenize=perl My::func`. sub _fts3_create { my ($argc, $argv, $pp) = @_; return DBD::SQLite::SQLITE_ERROR() unless $argc; my $name = Peta::FFI::peek_cstr( Peta::FFI::unpack_ptr(Peta::FFI::peek($argv, $PTRSIZE))); my $coderef = eval { no strict 'refs'; scalar &{$name}() }; if ($@ || ref $coderef ne 'CODE') { warn "fts3 tokenizer $name: $@" if $@; return DBD::SQLite::SQLITE_ERROR(); } # fts3_tokenizer.h on xCreate: "The generic # sqlite3_tokenizer.pModule variable should not be initialized # by this callback. The caller will do so." So the struct is # allocated and ZEROED and left alone; the coderef lives on the # Perl side, keyed by this address. my $t = _tok_malloc($PTRSIZE); $TOKENIZER{$t} = $coderef; _tok_poke_ptr($pp, $t); return DBD::SQLite::SQLITE_OK(); } sub _fts3_destroy { my ($t) = @_; delete $TOKENIZER{$t}; _tok_free($t); return DBD::SQLite::SQLITE_OK(); } # xOpen(pTokenizer, pInput, nBytes, ppCursor). fts3 passes -1 for # nBytes in some paths, meaning "NUL-terminated". # NOTE: every one of these callbacks must catch its own errors. The # closure trampoline turns a die into "zero of the declared return # type", and zero here is SQLITE_OK - so a swallowed error tells # fts3 the call succeeded while *ppCursor was never written, and # fts3 then writes pCsr->pTokenizer through a garbage pointer. That # is a SEGFAULT, not a wrong answer. sub _fts3_open { my ($t, $pInput, $nBytes, $pp) = @_; my $rc = eval { _fts3_open_inner($t, $pInput, $nBytes, $pp) }; return $rc unless $@; warn "fts3 tokenizer xOpen: $@"; return DBD::SQLite::SQLITE_ERROR(); } sub _fts3_open_inner { my ($t, $pInput, $nBytes, $pp) = @_; my $coderef = $TOKENIZER{$t} or return DBD::SQLite::SQLITE_ERROR(); my $bytes = $nBytes < 0 ? Peta::FFI::peek_cstr($pInput) : ($nBytes ? Peta::FFI::peek($pInput, $nBytes) : ''); my $mode = $DBD::SQLite::last_string_mode; my $text = $bytes; DBD::SQLite::_decode_text($text, $mode); my $cursor = eval { scalar $coderef->($text) }; if ($@ || ref $cursor ne 'CODE') { warn "fts3 tokenizer cursor: $@" if $@; return DBD::SQLite::SQLITE_ERROR(); } # Same rule for the cursor: fts3 sets base.pTokenizer itself. my $c = _tok_malloc($PTRSIZE); # Offsets come back from the Perl tokenizer in CHARACTERS but # fts3 wants BYTES. Precompute the mapping once per string # rather than re-walking it per token, which would make # tokenizing quadratic in the input length. my @byte_at; if (defined $mode && ($mode & DBD::SQLite::STRING_MODE_UNICODE_ANY())) { my $off = 0; for my $ch (split //, $text) { push @byte_at, $off; my $e = $ch; utf8::encode($e); $off += length $e; } push @byte_at, $off; } $TOKCURSOR{$c} = { code => $cursor, buf => undef, buflen => 0, byte_at => (@byte_at ? \@byte_at : undef) }; _tok_poke_ptr($pp, $c); return DBD::SQLite::SQLITE_OK(); } sub _fts3_close { my ($c) = @_; my $st = delete $TOKCURSOR{$c}; _tok_free($st->{buf}) if $st && $st->{buf}; _tok_free($c); return DBD::SQLite::SQLITE_OK(); } # xNext: the cursor coderef yields (token, len, start, end, pos) or # an empty list when it is done. sub _fts3_next { my ($c, $ppToken, $pnBytes, $piStart, $piEnd, $piPos) = @_; my $st = $TOKCURSOR{$c} or return DBD::SQLite::SQLITE_ERROR(); my @r = eval { $st->{code}->() }; if ($@) { warn "fts3 tokenizer: $@"; return DBD::SQLite::SQLITE_ERROR(); } return DBD::SQLite::SQLITE_DONE() unless @r; my ($token, undef, $start, $end, $pos) = @r; utf8::encode($token) if utf8::is_utf8($token); my $len = length $token; # The token bytes must outlive this call - fts3 reads them after # we return - so they live in a per-cursor buffer that grows but # is never freed until Close. if (!$st->{buf} || $st->{buflen} < $len) { _tok_free($st->{buf}) if $st->{buf}; $st->{buf} = _tok_malloc($len || 1); $st->{buflen} = $len || 1; } Peta::FFI::poke($st->{buf}, $token) if $len; if (my $ba = $st->{byte_at}) { $start = $ba->[$start] // $ba->[-1]; $end = $ba->[$end] // $ba->[-1]; } _tok_poke_ptr($ppToken, $st->{buf}); _tok_poke_int($pnBytes, $len); _tok_poke_int($piStart, $start); _tok_poke_int($piEnd, $end); _tok_poke_int($piPos, $pos); return DBD::SQLite::SQLITE_OK(); } sub register_fts3_perl_tokenizer { my ($dbh) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to register fts3 tokenizer on inactive database handle'); # SQLITE_DBCONFIG_ENABLE_FTS3_TOKENIZER: since 3.12 the # two-argument fts3_tokenizer() is disabled by default. DBD::SQLite::_c("sqlite3_db_config", "(oiio)i", $db, 1004, 1, undef); my $m = _fts3_build_module(); my $pstmt = Peta::FFI::alloc($PTRSIZE); my $rc = DBD::SQLite::_c("sqlite3_prepare_v2", "(opioo)i", $db, 'SELECT fts3_tokenizer(?, ?)', -1, $pstmt, undef); my $stmt = Peta::FFI::unpack_ptr(Peta::FFI::peek($pstmt, $PTRSIZE)); Peta::FFI::free($pstmt); return _err($dbh, $db) if $rc != 0 || !$stmt; # The blob is the ADDRESS of the module struct, not the struct. my $addr = Peta::FFI::alloc($PTRSIZE); _tok_poke_ptr($addr, $m); DBD::SQLite::_c("sqlite3_bind_text", "(oipio)i", $stmt, 1, 'perl', -1, DBD::SQLite::SQLITE_TRANSIENT()); DBD::SQLite::_c("sqlite3_bind_blob", "(oioio)i", $stmt, 2, $addr, $PTRSIZE, DBD::SQLite::SQLITE_TRANSIENT()); DBD::SQLite::_c("sqlite3_step", "(o)i", $stmt); my $fin = DBD::SQLite::_c("sqlite3_finalize", "(o)i", $stmt); Peta::FFI::free($addr); return $fin == 0 ? 1 : _err($dbh, $db); } # ---- Online backup ----------------------------------------------- # # No closures involved: sqlite3_backup_init/step/finish is a plain # three-call sequence. -1 pages means "everything in one step", which # is what upstream's file-level helpers use. sub _sqlite_backup { my ($dbh, $from_db, $to_db) = @_; my $bk = DBD::SQLite::_c("sqlite3_backup_init", "(opop)o", $to_db, 'main', $from_db, 'main'); if (!$bk) { # The error belongs to the DESTINATION handle, which is where # sqlite3_backup_init records it. return _err($dbh, $to_db); } DBD::SQLite::_c("sqlite3_backup_step", "(oi)i", $bk, -1); my $rc = DBD::SQLite::_c("sqlite3_backup_finish", "(o)i", $bk); return $rc == 0 ? 1 : _err($dbh, $to_db); } # Open a second connection to $file, copy in the requested # direction, close it again. sub _sqlite_backup_file { my ($dbh, $file, $dir) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'attempt to backup on inactive database handle'); my $cell = Peta::FFI::alloc($PTRSIZE); my $rc = DBD::SQLite::_c("sqlite3_open", "(po)i", $file, $cell); my $other = Peta::FFI::unpack_ptr(Peta::FFI::peek($cell, $PTRSIZE)); Peta::FFI::free($cell); if ($rc != 0 || !$other) { DBD::SQLite::_c("sqlite3_close_v2", "(o)i", $other) if $other; return $dbh->set_err($rc, "cannot open $file for backup"); } my $ok = $dir eq 'to' ? _sqlite_backup($dbh, $db, $other) : _sqlite_backup($dbh, $other, $db); DBD::SQLite::_c("sqlite3_close_v2", "(o)i", $other); return $ok; } sub backup_to_file { _sqlite_backup_file($_[0], $_[1], 'to') } sub backup_from_file { _sqlite_backup_file($_[0], $_[1], 'from') } sub backup_to_dbh { my ($dbh, $other) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'inactive database handle'); return _sqlite_backup($dbh, $db, $other->{sqlite_db}); } sub backup_from_dbh { my ($dbh, $other) = @_; my $db = _db($dbh) or return $dbh->set_err(-2, 'inactive database handle'); return _sqlite_backup($dbh, $other->{sqlite_db}, $db); } # SQLite.xs gives these two the same ALIAS treatment as the rest: # func() reaches the bare name, the prefixed one is documented. *trace = \&sqlite_trace; *profile = \&sqlite_profile; sub disconnect { my $dbh = shift; my $db = _db($dbh) or return 1; # Driver.xst disconnect(): warn when statement handles are still # active, since disconnecting invalidates them. That warning is # in the generated XS glue every C driver gets for free, so a # pure-Perl driver has to emit it itself. # # DBIc_ACTIVE_KIDS has no counterpart here - DBI::PurePerl leaves # ActiveKids at 0 ("XXX not maintained") - so the live children # are counted instead. ChildHandles holds weak refs to the OUTER # handles, and destroyed ones read back as undef. if ($dbh->FETCH('Warn')) { my $kids = grep { $_ && $_->{Active} } @{ $dbh->{ChildHandles} || [] }; warn sprintf( "%s->disconnect invalidates %d active statement handle%s %s", $dbh, $kids, ($kids == 1 ? '' : 's'), '(either destroy statement handles or call finish on them' . ' before disconnecting)') if $kids; } # An open transaction is rolled back, not silently committed - # same as the reference and as every other DBD. _exec($dbh, 'ROLLBACK') if _in_txn($dbh); DBD::SQLite::_c("sqlite3_close_v2", "(o)i", $db); # Only now: SQLite held these function pointers for the life of # the connection, so they must outlive it, not the other way # round. Peta::FFI::closure_free($_) for @{ $dbh->{sqlite_closures} || [] }; $dbh->{sqlite_closures} = []; $dbh->{sqlite_db} = undef; $dbh->STORE(Active => 0); return 1; } sub STORE { my ($dbh, $attr, $val) = @_; if ($attr eq 'AutoCommit') { my $old = $dbh->FETCH('AutoCommit'); # DBI::PurePerl DBD::_::common::STORE stores flag attributes # as !!$value, and the XS layer materialises them from # PL_sv_yes/PL_sv_no - either way "off" is the EMPTY STRING, # not 0, and t/54_literal_txn.t compares it with ''. $dbh->{AutoCommit} = !!$val; # Turning AutoCommit back ON ends any transaction that the # OFF period opened; turning it off does NOT begin one, the # next statement does (DBI's documented "defer" behaviour). if ($val && !$old && _in_txn($dbh)) { _exec($dbh, 'COMMIT'); } return 1; } # The legacy boolean and the mode enum are two spellings of one # setting, so writing either must be visible through the other. if ($attr eq 'sqlite_unicode' || $attr eq 'unicode') { $dbh->{sqlite_string_mode} = $val ? DBD::SQLite::STRING_MODE_UNICODE_NAIVE() : DBD::SQLite::STRING_MODE_PV(); return 1; } if ($attr eq 'sqlite_see_if_its_a_number') { # dbdimp.c keeps this on the dbh; a single process-wide flag is # enough while it is the only knob reading it, but it is stored # on the handle too so FETCH reports what was set. $DBD::SQLite::see_if_its_a_number = $val ? 1 : 0; $dbh->{$attr} = $val ? 1 : 0; return 1; } # dbdimp.c: an already-open database cannot be made read-only, so # a late ReadOnly=1 is recorded as a WARNING (err 0, not an # error) and then stored anyway - it stays advisory. if ($attr eq 'ReadOnly' && $val) { my $db = _db($dbh); $dbh->set_err(0, "ReadOnly is set but it's only advisory") if $db && !DBD::SQLite::_c("sqlite3_db_readonly", "(op)i", $db, 'main'); } if ($attr =~ /^sqlite_/) { $dbh->{$attr} = $val; return 1; } return $dbh->SUPER::STORE($attr, $val); } sub FETCH { my ($dbh, $attr) = @_; return $dbh->{AutoCommit} if $attr eq 'AutoCommit'; return $dbh->{$attr} if $attr =~ /^sqlite_/; return $dbh->SUPER::FETCH($attr); } sub DESTROY { my $dbh = shift; local $@; eval { $dbh->disconnect } if $dbh->{sqlite_db}; return; } } { package DBD::SQLite::st; our $imp_data_size = 0; # dbdimp.c sqlite_bind_col(): remember the requested SQL type, then # let DBI's own implementation do the aliasing ("Allow default # implementation to continue"). The type is not cosmetic - fetch() # uses it to OVERRIDE the value's own storage class, which is how # bind_col($i, \$x, SQL_BLOB) keeps a column out of the unicode # decode (t/rt_71311). sub bind_col { my ($sth, $col, $ref, $attr) = @_; my $type = ref $attr ? $attr->{TYPE} : $attr; $sth->{sqlite_col_types}[$col - 1] = $type; return $sth->SUPER::bind_col($col, $ref, $attr); } # dbdimp.c sqlite_bind_ph(). A $index that does not look like a # number is a NAMED placeholder, and only the prepared statement # knows which position it occupies - ":foo", "?1", "@foo" and "$foo" # are all legal spellings of one, so the name including its prefix # goes to sqlite3_bind_parameter_index rather than being parsed here. sub bind_param { my ($sth, $index, $value, $attr) = @_; my $type = ref $attr ? $attr->{TYPE} : $attr; if (!Scalar::Util::looks_like_number($index)) { # Upstream rejects a name it cannot hand to C as a string # rather than letting it be truncated at the NUL. return $sth->set_err(-2, ' could not be coerced to a C string') if !defined($index) || $index =~ /\0/; my $stmt = $sth->{sqlite_stmt} or return $sth->set_err(DBD::SQLite::SQLITE_MISUSE(), 'bind_param without a statement'); my $pos = DBD::SQLite::_c("sqlite3_bind_parameter_index", "(op)i", $stmt, $index); return $sth->set_err(-2, "Unknown named parameter: $index") unless $pos; $index = $pos; } $sth->{sqlite_params}[$index - 1] = $value; $sth->{sqlite_ptypes}[$index - 1] = $type if defined $type; return 1; } # Bind one value into slot $i (1-based), mirroring dbdimp.c # sqlite_st_execute()'s bind loop. # # The storage class SQLite ends up with is observable through # typeof(), so the decision has to be upstream's and not a # reasonable-looking one of our own: # # undef -> bind_null # explicit BLOB-ish TYPE -> bind_blob # explicit INTEGER/FLOAT -> bind_int64/bind_double if the string # really is a number, else bind_text # everything else -> bind_text, ALWAYS # # That last line is the one worth stating plainly: with no explicit # TYPE, upstream binds text even for a Perl IV or NV, because the # value reaches SQLite through SvPV and `see_if_its_a_number` is off # by default. Guessing INTEGER for a digit string is a divergence - # it was one here, and `SELECT typeof(v)` showed it. # # Text and blobs both go through an allocated buffer with an explicit # byte count rather than the `p` marshalling, because `p` is # NUL-terminated and would truncate a value containing a NUL. Upstream # passes SvPV's (data, len) pair for exactly the same reason. The # buffer is returned so the caller can free it after the step. sub _bind_one { my ($stmt, $i, $val, $sql_type, $warn, $string_mode) = @_; return (DBD::SQLite::_c("sqlite3_bind_null", "(oi)i", $stmt, $i), undef) unless defined $val; my $type = DBD::SQLite::_sqlite_type_from_odbc_type($sql_type); if ($type == DBD::SQLite::SQLITE_BLOB()) { # dbdimp.c: data = SvPVbyte(value, len) - a blob is the # scalar's BYTES, so an upgraded scalar is downgraded first # (t/12_unicode round-trips exactly such a value). $val = DBD::SQLite::_pvbyte($val); my $len = length $val; my $buf = Peta::FFI::alloc($len || 1); Peta::FFI::poke($buf, $val) if $len; return (DBD::SQLite::_c("sqlite3_bind_blob", "(oioio)i", $stmt, $i, $buf, $len, DBD::SQLite::SQLITE_TRANSIENT()), $buf); } # dbdimp.c: numeric binding happens only for an explicit # INTEGER/FLOAT type, or when sqlite_see_if_its_a_number is on. my $numtype = 0; if ($type == DBD::SQLite::SQLITE_NULL()) { $numtype = DBD::SQLite::_is_number($val, DBD::SQLite::SQLITE_NULL()) if $DBD::SQLite::see_if_its_a_number; } elsif ($type == DBD::SQLite::SQLITE_INTEGER() || $type == DBD::SQLite::SQLITE_FLOAT()) { $numtype = DBD::SQLite::_is_number($val, $type); } if ($numtype == 1) { return (DBD::SQLite::_c("sqlite3_bind_int64", "(oil)i", $stmt, $i, $val), undef); } if ($numtype == 2 && $type != DBD::SQLite::SQLITE_INTEGER()) { return (DBD::SQLite::_c("sqlite3_bind_double", "(oid)i", $stmt, $i, $val), undef); } # dbdimp.c: an explicit INTEGER/FLOAT that the value cannot satisfy # still binds as text, but warns under PrintWarn. Upstream's # comment records why it warns instead of dying: "die on datatype # mismatch did more harm than good". if ($warn && ($type == DBD::SQLite::SQLITE_INTEGER() || $type == DBD::SQLite::SQLITE_FLOAT())) { DBD::SQLite::_warn_at_caller( sprintf("datatype mismatch: bind param (%d) %s as %s", $i - 1, $val, $type == DBD::SQLite::SQLITE_INTEGER() ? 'integer' : 'float')); } # PREP_SV_FOR_SQLITE, then SvPV: under PV mode the prep is a # no-op, so an already-upgraded scalar still has to be counted in # bytes rather than characters. $val = DBD::SQLite::_pv_bytes(DBD::SQLite::_encode_text($val, $string_mode)); my $len = length $val; my $buf = Peta::FFI::alloc($len || 1); Peta::FFI::poke($buf, $val) if $len; return (DBD::SQLite::_c("sqlite3_bind_text", "(oioio)i", $stmt, $i, $buf, $len, DBD::SQLite::SQLITE_TRANSIENT()), $buf); } sub execute { my ($sth, @bind) = @_; my $dbh = $sth->{Database}; my $stmt = $sth->{sqlite_stmt}; my $db = $dbh->{sqlite_db} or return $sth->set_err(DBD::SQLite::SQLITE_MISUSE(), 'attempt to execute on inactive database handle'); # An empty statement prepared to a NULL stmt: nothing to run. return '0E0' unless $stmt; $sth->{sqlite_params} = [@bind] if @bind; my $params = $sth->{sqlite_params} || []; my $nparams = $sth->FETCH('NUM_OF_PARAMS'); return $sth->set_err(DBD::SQLite::SQLITE_ERROR(), 'called with ' . scalar(@$params) . " bind variables when $nparams are needed") if @$params != $nparams; # dbdimp.c sniffs the STATEMENT's own SQL, not the string the # caller passed prepare() - with multiple statements those differ. DBD::SQLite::db::_maybe_begin($dbh, DBD::SQLite::_c("sqlite3_sql", "(o)p", $stmt)) or return undef; $sth->finish if $sth->FETCH('Active'); DBD::SQLite::_c("sqlite3_reset", "(o)i", $stmt); # dbdimp.c: imp_sth->nrow = 0 before the step. A statement WITH # columns keeps that 0 - ->rows on a SELECT is 0, not the row # count and not the changes counter left over from some earlier # statement. Only the no-columns branch overwrites it. $sth->{sqlite_rows} = 0; my @bufs; for my $i (1 .. $nparams) { my ($rc, $buf) = _bind_one($stmt, $i, $params->[$i - 1], $sth->{sqlite_ptypes}[$i - 1], $sth->FETCH("PrintWarn"), $sth->{Database}{sqlite_string_mode}); push @bufs, $buf if defined $buf; if ($rc != DBD::SQLite::SQLITE_OK()) { Peta::FFI::free($_) for @bufs; return DBD::SQLite::db::_err($sth, $db, "bind param $i failed"); } } my $rc = DBD::SQLite::_c("sqlite3_step", "(o)i", $stmt); Peta::FFI::free($_) for @bufs; if ($rc == DBD::SQLite::SQLITE_ROW()) { # A row is already sitting in the statement; fetch must return # THIS one before stepping again. $sth->{sqlite_pending} = 1; $sth->STORE(Active => 1); DBD::SQLite::db::_note_implicit_txn($dbh); return '0E0'; } if ($rc == DBD::SQLite::SQLITE_DONE()) { $sth->{sqlite_pending} = 0; # A DONE with columns is an empty result set, not a row count. if ($sth->FETCH('NUM_OF_FIELDS')) { $sth->STORE(Active => 1); DBD::SQLite::db::_note_implicit_txn($dbh); return '0E0'; } # A COMMIT/ROLLBACK/RELEASE run as a statement ended the # transaction behind DBI's back; this is where BegunWork is # handed back as AutoCommit. DBD::SQLite::db::_maybe_end($dbh); DBD::SQLite::_c("sqlite3_reset", "(o)i", $stmt); my $rows = DBD::SQLite::_c("sqlite3_changes", "(o)i", $db); $sth->{sqlite_rows} = $rows; return $rows ? $rows : '0E0'; } DBD::SQLite::_c("sqlite3_reset", "(o)i", $stmt); return DBD::SQLite::db::_err($sth, $db, "execute failed"); } sub fetch { my $sth = shift; my $stmt = $sth->{sqlite_stmt} or return undef; my $dbh = $sth->{Database}; # dbdimp.c sqlite_st_fetch(): a fetch after the database went # away is an error, not an empty result set - silence here reads # as "no more rows" and loses the disconnect entirely. my $db = $dbh->{sqlite_db} or return $sth->set_err(-2, 'attempt to fetch on inactive database handle'); # execute() already stepped onto the first row; only step again # once that one has been handed out. unless ($sth->{sqlite_pending}) { my $rc = DBD::SQLite::_c("sqlite3_step", "(o)i", $stmt); if ($rc == DBD::SQLite::SQLITE_DONE()) { $sth->finish; return undef; } if ($rc != DBD::SQLite::SQLITE_ROW()) { DBD::SQLite::db::_err($sth, $db, "fetch failed"); $sth->finish; return undef; } } $sth->{sqlite_pending} = 0; my $nfields = $sth->FETCH('NUM_OF_FIELDS'); my $chop = $sth->FETCH('ChopBlanks'); my $string_mode = $sth->{Database}{sqlite_string_mode}; my $col_types = $sth->{sqlite_col_types} || []; my @out; for my $col (0 .. $nfields - 1) { my $t = DBD::SQLite::_c("sqlite3_column_type", "(oi)i", $stmt, $col); # dbdimp.c: a type recorded by bind_col OVERRIDES the value's # own storage class. A zero type means "no opinion". $t = DBD::SQLite::_sqlite_type_from_odbc_type($col_types->[$col]) if defined $col_types->[$col] && $col_types->[$col]; if ($t == DBD::SQLite::SQLITE_NULL()) { push @out, undef; } elsif ($t == DBD::SQLite::SQLITE_INTEGER()) { push @out, DBD::SQLite::_c("sqlite3_column_int64", "(oi)l", $stmt, $col); } elsif ($t == DBD::SQLite::SQLITE_FLOAT()) { push @out, DBD::SQLite::_c("sqlite3_column_double", "(oi)d", $stmt, $col); } elsif ($t == DBD::SQLite::SQLITE_BLOB()) { my $len = DBD::SQLite::_c("sqlite3_column_bytes", "(oi)i", $stmt, $col); my $ptr = DBD::SQLite::_c("sqlite3_column_blob", "(oi)o", $stmt, $col); push @out, ($len && $ptr) ? Peta::FFI::peek($ptr, $len) : ''; } else { # dbdimp.c: sv_setpvn(val, sqlite3_column_bytes(...)) - TEXT # is length-delimited too, so the pointer is taken as an # opaque address and read with an explicit count. Reading it # as a `p` string stops at the first NUL, which silently # shortened a value SQLite had stored in full. my $len = DBD::SQLite::_c("sqlite3_column_bytes", "(oi)i", $stmt, $col); my $ptr = DBD::SQLite::_c("sqlite3_column_text", "(oi)o", $stmt, $col); my $v = ($len && $ptr) ? Peta::FFI::peek($ptr, $len) : ''; # dbdimp.c trims ' ' only, and does it by shortening len - # not \s, which would also eat a trailing tab or newline. $v =~ s/ +\z// if $chop; DBD::SQLite::_decode_text($v, $string_mode); push @out, $v; } } # Column types are per VALUE in SQLite, so TYPE is only meaningful # once a row exists - record what this row actually held. $sth->{sqlite_types} = [ map { DBD::SQLite::_c("sqlite3_column_type", "(oi)i", $stmt, $_) } 0 .. $nfields - 1 ]; return $sth->_set_fbav(\@out); } *fetchrow_arrayref = \&fetch; sub rows { defined $_[0]->{sqlite_rows} ? $_[0]->{sqlite_rows} : -1 } sub finish { my $sth = shift; my $stmt = $sth->{sqlite_stmt}; DBD::SQLite::_c("sqlite3_reset", "(o)i", $stmt) if $stmt; $sth->{sqlite_pending} = 0; $sth->STORE(Active => 0); return 1; } sub FETCH { my ($sth, $attr) = @_; # dbdimp.c sqlite_st_FETCH_attrib() guards EVERY statement # attribute on the database handle still being active, because # each one is answered out of the live sqlite3_stmt. Returning a # stale cached value instead would hide the disconnect. my $dbh = $sth->{Database}; return $sth->set_err(-2, 'attempt to fetch on inactive database handle') if $dbh && !$dbh->{Active}; # dbdimp.c sqlite_st_FETCH_attrib(), "NAME": read from the # statement and DECODED per the handle's string mode, so a # unicode column name comes back as characters - fetchrow_hashref # keys off this, and t/rt_78833 checks that the decoded name is # the key and the encoded one is not. Like NUM_OF_PARAMS it must # stay out of the handle hash or quick_FETCH would answer first. if ($attr eq 'NAME') { my $stmt = $sth->{sqlite_stmt} or return []; my $mode = $dbh && $dbh->{sqlite_string_mode}; my @names; for my $n (0 .. ($sth->FETCH('NUM_OF_FIELDS') || 0) - 1) { my $name = DBD::SQLite::_c("sqlite3_column_name", "(oi)p", $stmt, $n); DBD::SQLite::_decode_text($name, $mode) if defined $name; push @names, $name; } return \@names; } # dbdimp.c answers this from the statement, and it has to STAY out # of the handle hash: DBI's quick_FETCH (DBI.xs, and the same # shortcut in DBI::PurePerl) returns any key that is already in # the hash WITHOUT calling the driver, so caching it here would # silently bypass every check above - including the inactive-handle # one that t/32_inactive_error.t exercises through this attribute. if ($attr eq 'NUM_OF_PARAMS') { my $stmt = $sth->{sqlite_stmt} or return 0; return DBD::SQLite::_c("sqlite3_bind_parameter_count", "(o)i", $stmt); } if ($attr eq 'TYPE') { my $t = $sth->{sqlite_types} || []; return [ map { DBD::SQLite::_sql_type($_) } @$t ]; } # dbdimp.c sqlite_st_FETCH_attrib(), "ParamValues": keyed by the # placeholder's own NAME when it has one (":AAA"), by its 1-based # position when it does not. An unbound placeholder is present # with an undef value - the key set is the statement's, not the # set of values supplied so far. if ($attr eq 'ParamValues') { my $stmt = $sth->{sqlite_stmt} or return {}; my $params = $sth->{sqlite_params} || []; my %values; for my $n (1 .. ($sth->FETCH('NUM_OF_PARAMS') || 0)) { my $name = DBD::SQLite::_c("sqlite3_bind_parameter_name", "(oi)p", $stmt, $n); $values{ defined $name ? $name : $n } = $params->[$n - 1]; } return \%values; } # dbdimp.c sqlite_st_FETCH_attrib(), "NULLABLE": ask sqlite3 about # the column's ORIGIN, not about the value we happened to fetch. # A column that no table owns - an expression, a function result - # has no metadata, and upstream answers SQL_NULLABLE_UNKNOWN (2) # for it rather than guessing. if ($attr eq 'NULLABLE') { my $stmt = $sth->{sqlite_stmt} or return []; my $dbh = $sth->{Database}; my @nullable; for my $n (0 .. ($sth->FETCH('NUM_OF_FIELDS') || 0) - 1) { my $table = DBD::SQLite::_c("sqlite3_column_table_name", "(oi)p", $stmt, $n); my $field = DBD::SQLite::_c("sqlite3_column_name", "(oi)p", $stmt, $n); # No owning table means no metadata to ask for, and # table_column_metadata() refuses an undef name outright. if (!defined $table || !defined $field) { push @nullable, 2; next } my $meta = DBD::SQLite::db::table_column_metadata( $dbh, DBD::SQLite::_c("sqlite3_column_database_name", "(oi)p", $stmt, $n), $table, $field, ); push @nullable, ref $meta && exists $meta->{not_null} ? ($meta->{not_null} ? 0 : 1) : 2; } return \@nullable; } return $sth->{$attr} if $attr =~ /^sqlite_/; return $sth->SUPER::FETCH($attr); } sub STORE { my ($sth, $attr, $val) = @_; if ($attr =~ /^sqlite_/) { $sth->{$attr} = $val; return 1 } return $sth->SUPER::STORE($attr, $val); } # dbdimp.c _sqlite_st_status(): sqlite3_stmt_status returns the # counter directly, so unlike the db/library statuses there is no # highwater pair - the values are plain integers. sub st_status { my ($sth, $reset) = @_; my $stmt = $sth->{sqlite_stmt} or return {}; $reset = $reset ? 1 : 0; my %status; for my $op ([1, 'fullscan_step'], [2, 'sort'], [3, 'autoindex']) { $status{ $op->[1] } = DBD::SQLite::_c("sqlite3_stmt_status", "(oii)i", $stmt, $op->[0], $reset); } return \%status; } { no strict 'refs'; *{"DBD::SQLite::st::sqlite_st_status"} = \&st_status; } sub DESTROY { my $sth = shift; local $@; # finalize, not reset: this statement is going away for good, and # SQLite will not close the database while a statement is open. DBD::SQLite::_c("sqlite3_finalize", "(o)i", $sth->{sqlite_stmt}) if $sth->{sqlite_stmt}; $sth->{sqlite_stmt} = undef; return; } } # An internal tied hash for %DBD::SQLite::COLLATION, so a globally # registered collation cannot be overridden or removed by accident. { package DBD::SQLite::_WriteOnceHash; require Tie::Hash; our @ISA = qw(Tie::StdHash); sub TIEHASH { bless {}, $_[0] } sub STORE { !exists $_[0]->{$_[1]} or die "entry $_[1] already registered"; $_[0]->{$_[1]} = $_[2]; } sub DELETE { die "deletion of entry $_[1] is forbidden" } } 1;