From 78984a9de82676c68b62ee9c97cad744144c4556 Mon Sep 17 00:00:00 2001 From: Laurent Dami Date: Fri, 4 Jul 2014 10:07:19 +0200 Subject: [PATCH 1/8] initial support for virtual tables in Perl (WORK IN PROGRESS) --- MANIFEST | 5 + Makefile.PL | 3 + SQLite.xs | 15 + dbdimp.c | 822 ++++++++++++++++++++++++- dbdimp.h | 3 +- lib/DBD/SQLite.pm | 1 + lib/DBD/SQLite/VirtualTable.pm | 272 ++++++++ lib/DBD/SQLite/VirtualTable/Filesys.pm | 208 +++++++ t/virtual_table/00_base.t | 135 ++++ t/virtual_table/01_destroy.t | 81 +++ t/virtual_table/10_filesys.t | 65 ++ t/virtual_table/11_fulltext_search.t | 100 +++ 12 files changed, 1704 insertions(+), 6 deletions(-) create mode 100644 lib/DBD/SQLite/VirtualTable.pm create mode 100644 lib/DBD/SQLite/VirtualTable/Filesys.pm create mode 100644 t/virtual_table/00_base.t create mode 100644 t/virtual_table/01_destroy.t create mode 100644 t/virtual_table/10_filesys.t create mode 100644 t/virtual_table/11_fulltext_search.t diff --git a/MANIFEST b/MANIFEST index 2b0a7da..0dec102 100644 --- a/MANIFEST +++ b/MANIFEST @@ -7,6 +7,8 @@ inc/Test/NoWarnings/Warning.pm lib/DBD/SQLite.pm lib/DBD/SQLite/Cookbook.pod lib/DBD/SQLite/Fulltext_search.pod +lib/DBD/SQLite/VirtualTable.pm +lib/DBD/SQLite/VirtualTable/Filesys.pm LICENSE Makefile.PL MANIFEST This list of files @@ -107,6 +109,9 @@ t/rt_78833_utf8_flag_for_column_names.t t/rt_81536_multi_column_primary_key_info.t t/rt_88228_sqlite_3_8_0_crash.t t/rt_96878_fts_contentless_table.t +t/virtual_table/00_base.t +t/virtual_table/01_destroy.t +t/virtual_table/10_filesys.t typemap util/getsqlite.pl xt/meta.t diff --git a/Makefile.PL b/Makefile.PL index ebfc4d7..ba70991 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -367,6 +367,9 @@ WriteMakefile( clean => { FILES => 'SQLite.xsi config.h tv.log *.old', }, + test => { + TESTS => 't/*.t t/**/*.t', + }, PL_FILES => {}, EXE_FILES => [], diff --git a/SQLite.xs b/SQLite.xs index ee307e8..5f9b415 100644 --- a/SQLite.xs +++ b/SQLite.xs @@ -283,6 +283,21 @@ db_status(dbh, reset = 0) RETVAL +static int +create_module(dbh, name, perl_class) + SV *dbh + char *name + char *perl_class + ALIAS: + DBD::SQLite::db::sqlite_create_module = 1 + CODE: + { + RETVAL = sqlite_db_create_module(aTHX_ dbh, name, perl_class); + } + OUTPUT: + RETVAL + + MODULE = DBD::SQLite PACKAGE = DBD::SQLite::st PROTOTYPES: DISABLE diff --git a/dbdimp.c b/dbdimp.c index f47e618..d192c21 100644 --- a/dbdimp.c +++ b/dbdimp.c @@ -1,3 +1,12 @@ +/* -*- c-basic-offset: 4; -*- */ + +/* TODO : refactoring + - generalized use of stacked_sv_from_sqlite3_value + - decide about policy for errors in vtab methods : use G_EVAL or just die? + - find better name instead of "perl_instance" + */ + + #define PERL_NO_GET_CONTEXT #define NEED_newSVpvn_flags @@ -27,8 +36,7 @@ DBISTATE_DECLARE; /*-----------------------------------------------------* * Globals *-----------------------------------------------------*/ -imp_dbh_t *last_executed_dbh; /* needed by perl_tokenizer - to know if unicode is on/off */ +imp_dbh_t *last_prepared_dbh; /* see _last_dbh_is_unicode() */ /*-----------------------------------------------------* @@ -42,6 +50,15 @@ imp_dbh_t *last_executed_dbh; /* needed by perl_tokenizer #define sqlite_open2(dbname,db,flags) _sqlite_open(aTHX_ dbh, dbname, db, flags) #define _isspace(c) (c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\v' || c == '\f') + +int _last_dbh_is_unicode() { + /* some functions need to know if the unicode flag is on, but + don't have a dbh pointer ... so unfortunately the only way is + to use a global variable */ + return last_prepared_dbh && last_prepared_dbh->unicode; +} + + static void _sqlite_trace(pTHX_ char *file, int line, SV *h, imp_xxh_t *imp_xxh, const char *what) { @@ -134,6 +151,56 @@ sqlite_type_from_odbc_type(int type) } } + + + + + +SV * +stacked_sv_from_sqlite3_value(pTHX_ sqlite3_value *value, int is_unicode) +{ + STRLEN len; + sqlite_int64 iv; + int type = sqlite3_value_type(value); + + switch(type) { + case SQLITE_INTEGER: + iv = sqlite3_value_int64(value); + if ( iv >= IV_MIN && iv <= IV_MAX ) { + /* ^^^ compile-time constant (= true) when IV == int64 */ + return sv_2mortal(newSViv((IV)iv)); + } + else if ( iv >= 0 && iv <= UV_MAX ) { + /* warn("integer overflow, cast to UV"); */ + return sv_2mortal(newSVuv((UV)iv)); + } + else { + /* warn("integer overflow, cast to NV"); */ + return sv_2mortal(newSVnv((NV)iv)); + } + case SQLITE_FLOAT: + return sv_2mortal(newSVnv(sqlite3_value_double(value))); + break; + case SQLITE_TEXT: + len = sqlite3_value_bytes(value); + SV *sv = newSVpvn((const char *)sqlite3_value_text(value), len); + if (is_unicode) { + SvUTF8_on(sv); + } + return sv_2mortal(sv); + case SQLITE_BLOB: + len = sqlite3_value_bytes(value); + return sv_2mortal(newSVpvn(sqlite3_value_blob(value), len)); + default: + return &PL_sv_undef; + } +} + + + + + + static void sqlite_set_result(pTHX_ sqlite3_context *context, SV *result, int is_error) { @@ -593,6 +660,8 @@ sqlite_st_prepare(SV *sth, imp_sth_t *imp_sth, char *statement, SV *attribs) const char *extra; D_imp_dbh_from_sth; + last_prepared_dbh = imp_dbh; + if (!DBIc_ACTIVE(imp_dbh)) { sqlite_error(sth, -2, "attempt to prepare on inactive database handle"); return FALSE; /* -> undef in lib/DBD/SQLite.pm */ @@ -665,8 +734,6 @@ sqlite_st_execute(SV *sth, imp_sth_t *imp_sth) croak_if_db_is_null(); croak_if_stmt_is_null(); - last_executed_dbh = imp_dbh; - /* COMPAT: sqlite3_sql is only available for 3006000 or newer */ sqlite_trace(sth, imp_sth, 3, form("executing %s", sqlite3_sql(imp_sth->stmt))); @@ -1416,6 +1483,8 @@ sqlite_db_func_dispatcher(int is_unicode, sqlite3_context *context, int argc, sq PUSHMARK(SP); for ( i=0; i < argc; i++ ) { + /* TODO: XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ value[i], is_unicode)); */ + SV *arg; STRLEN len; int type = sqlite3_value_type(value[i]); @@ -1458,6 +1527,7 @@ sqlite_db_func_dispatcher(int is_unicode, sqlite3_context *context, int argc, sq } XPUSHs(arg); + } PUTBACK; @@ -1705,9 +1775,14 @@ sqlite_db_aggr_step_dispatcher(sqlite3_context *context, if ( aggr->err || !aggr->aggr_inst ) goto cleanup; + int is_unicode = 0; /* TODO : find out from db handle */ + + PUSHMARK(SP); XPUSHs( sv_2mortal( newSVsv( aggr->aggr_inst ) )); for ( i=0; i < argc; i++ ) { + /* TODO: XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ value[i], is_unicode)); */ + SV *arg; int len = sqlite3_value_bytes(value[i]); int type = sqlite3_value_type(value[i]); @@ -2587,7 +2662,7 @@ static int perl_tokenizer_Open( flags = SVs_TEMP; /* will call sv_2mortal */ /* special handling if working with utf8 strings */ - if (last_executed_dbh->unicode) { /* global var ... no better way ! */ + if (_last_dbh_is_unicode()) { /* data to keep track of byte offsets */ c->lastByteOffset = c->pInput = pInput; @@ -2769,4 +2844,741 @@ int sqlite_db_register_fts3_perl_tokenizer(pTHX_ SV *dbh) return sqlite3_finalize(pStmt); } + + +/*********************************************************************** +** The set of routines that implement the perl "module" +** (i.e support for virtual table) +************************************************************************/ + + +typedef struct perl_vtab { + sqlite3_vtab base; + SV *perl_vtab_instance; +} perl_vtab; + +typedef struct perl_vtab_cursor { + sqlite3_vtab_cursor base; + SV *perl_cursor_instance; +} perl_vtab_cursor; + +typedef struct perl_vtab_init { + SV *dbh; + const char *perl_class; +} perl_vtab_init; + + + +static int _call_perl_vtab_method(sqlite3_vtab *pVTab, const char *method) { + dTHX; + dSP; + ENTER; + SAVETMPS; + int count; + + PUSHMARK(SP); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_instance); + PUTBACK; + count = call_method (method, G_VOID); + SPAGAIN; + SP -= count; + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + + + static int _call_perl_vtab_method_int(sqlite3_vtab *pVTab, + const char *method, int i) { + dTHX; + dSP; + ENTER; + SAVETMPS; + int count; + + PUSHMARK(SP); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs(sv_2mortal(newSViv(i))); + PUTBACK; + count = call_method (method, G_VOID); + SPAGAIN; + SP -= count; + + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + + + + + +static int perl_vt_New(const char *method, + sqlite3 *db, void *pAux, + int argc, const char *const *argv, + sqlite3_vtab **ppVTab, char **pzErr){ + dTHX; + dSP; + perl_vtab *vt; + perl_vtab_init *init_data = (perl_vtab_init *)pAux; + int count, i; + + /* allocate a perl_vtab structure */ + vt = (perl_vtab *) sqlite3_malloc(sizeof(*vt)); + if( vt==NULL ) return SQLITE_NOMEM; + memset(vt, 0, sizeof(*vt)); + + ENTER; + SAVETMPS; + + /* call the ->CREATE/CONNECT() method */ + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(init_data->perl_class, 0))); + XPUSHs(init_data->dbh); + for(i = 0; i < argc; i++) { + XPUSHs(newSVpvn_flags(argv[i], strlen(argv[i]), SVs_TEMP|SVf_UTF8)); + } + PUTBACK; + count = call_method (method, G_SCALAR); + SPAGAIN; + + /* check the return value */ + if ( count != 1 ) { + *pzErr = sqlite3_mprintf("vtab->NEW() should return one value, got %d", + count ); + SP -= count; /* Clear the stack */ + goto cleanup; + } + + /* get the VirtualTable instance */ + SV *perl_instance = POPs; + if ( !sv_isobject(perl_instance) ) { + *pzErr = sqlite3_mprintf("vtab->NEW() should return a blessed reference"); + goto cleanup; + } + + /* call the ->DECLARE_VTAB() method */ + PUSHMARK(SP); + XPUSHs(perl_instance); + PUTBACK; + count = call_method ("VTAB_TO_DECLARE", G_SCALAR); + SPAGAIN; + + /* check the return value */ + if (count != 1 ) { + int i; + *pzErr = sqlite3_mprintf("vtab->VTAB_TO_DECLARE() should return one value, got %d", + count ); + SP -= count; /* Clear the stack */ + goto cleanup; + } + + /* call sqlite3_declare_vtab with the sql returned from + method VTAB_TO_DECLARE(), converted to utf8 */ + SV *sql = POPs; + int rc; + rc = sqlite3_declare_vtab(db, SvPVutf8_nolen(sql)); + + /* record the VirtualTable perl instance within the vtab structure */ + vt->perl_vtab_instance = SvREFCNT_inc(perl_instance); + + cleanup: + *ppVTab = &vt->base; + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + + +static int perl_vt_Create(sqlite3 *db, void *pAux, + int argc, const char *const *argv, + sqlite3_vtab **ppVTab, char **pzErr){ + return perl_vt_New("CREATE", db, pAux, argc, argv, ppVTab, pzErr); +} + +static int perl_vt_Connect(sqlite3 *db, void *pAux, + int argc, const char *const *argv, + sqlite3_vtab **ppVTab, char **pzErr){ + return perl_vt_New("CONNECT", db, pAux, argc, argv, ppVTab, pzErr); +} + + +static int perl_vt_Disconnect(sqlite3_vtab *pVTab){ + dTHX; + + _call_perl_vtab_method(pVTab, "DISCONNECT"); + + perl_vtab *perl_pVTab = (perl_vtab *) pVTab; + SvREFCNT_dec(perl_pVTab->perl_vtab_instance); + + sqlite3_free(perl_pVTab); + + return SQLITE_OK; +} + + +static int perl_vt_Drop(sqlite3_vtab *pVTab){ + dTHX; + + _call_perl_vtab_method(pVTab, "DROP"); + + perl_vtab *perl_pVTab = (perl_vtab *) pVTab; + SvREFCNT_dec(perl_pVTab->perl_vtab_instance); + + sqlite3_free(perl_pVTab); + + return SQLITE_OK; +} + + +static char * +op2str(unsigned char op) { + switch (op) { + case SQLITE_INDEX_CONSTRAINT_EQ: + return "="; + case SQLITE_INDEX_CONSTRAINT_GT: + return ">"; + case SQLITE_INDEX_CONSTRAINT_LE: + return "<="; + case SQLITE_INDEX_CONSTRAINT_LT: + return "<"; + case SQLITE_INDEX_CONSTRAINT_GE: + return ">="; + case SQLITE_INDEX_CONSTRAINT_MATCH: + return "MATCH"; + default: + return "unknown"; + } +} + + +static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ + int i, count; + + dTHX; + dSP; + ENTER; + SAVETMPS; + + /* build the "where_constraints" datastructure */ + AV *constraints = newAV(); + for (i=0; inConstraint; i++){ + struct sqlite3_index_constraint const *pCons = &pIdxInfo->aConstraint[i]; + HV *constraint = newHV(); + hv_stores(constraint, "col", newSViv(pCons->iColumn)); + hv_stores(constraint, "op", newSVpv(op2str(pCons->op), 0)); + hv_stores(constraint, "usable", pCons->usable ? &PL_sv_yes : &PL_sv_no); + av_push(constraints, newRV_noinc((SV*) constraint)); + } + + /* build the "order_by" datastructure */ + AV *order_by = newAV(); + for (i=0; inOrderBy; i++){ + struct sqlite3_index_orderby const *pOrder = &pIdxInfo->aOrderBy[i]; + HV *order = newHV(); + hv_stores(order, "col", newSViv(pOrder->iColumn)); + hv_stores(order, "desc", pOrder->desc ? &PL_sv_yes : &PL_sv_no); + av_push( order_by, newRV_noinc((SV*) order)); + } + + /* call the ->best_index() method */ + PUSHMARK(SP); + XPUSHs( ((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs( sv_2mortal( newRV_noinc((SV*) constraints))); + XPUSHs( sv_2mortal( newRV_noinc((SV*) order_by))); + PUTBACK; + count = call_method ("BEST_INDEX", G_SCALAR); + SPAGAIN; + + /* get values back from the returned hashref */ + if (count != 1) + croak("BEST_INDEX() method returned %d vals instead of 1", count); + SV *hashref = POPs; + if (!(hashref && SvROK(hashref) && SvTYPE(SvRV(hashref)) == SVt_PVHV)) + croak("BEST_INDEX() method did not return a hashref"); + HV *hv = (HV*)SvRV(hashref); + SV **val; + val = hv_fetch(hv, "idxNum", 6, FALSE); + pIdxInfo->idxNum = (val && SvOK(*val)) ? SvIV(*val) : 0; + val = hv_fetch(hv, "idxStr", 6, FALSE); + if (val && SvOK(*val)) { + char *str = SvPVutf8_nolen(*val); + pIdxInfo->idxStr = sqlite3_mprintf(str); + pIdxInfo->needToFreeIdxStr = 1; + } + val = hv_fetch(hv, "orderByConsumed", 15, FALSE); + pIdxInfo->orderByConsumed = (val && SvTRUE(*val)) ? 1 : 0; + val = hv_fetch(hv, "estimatedCost", 13, FALSE); + pIdxInfo->estimatedCost = (val && SvOK(*val)) ? SvNV(*val) : 0; + val = hv_fetch(hv, "estimatedRows", 13, FALSE); + pIdxInfo->estimatedRows = (val && SvOK(*val)) ? SvIV(*val) : 0; + + /* loop over constraints to get back the "argvIndex" and "omit" keys + that shoud have been added by the best_index() method call */ + for (i=0; inConstraint; i++){ + struct sqlite3_index_constraint_usage *pConsUsage + = &pIdxInfo->aConstraintUsage[i]; + SV **rv = av_fetch(constraints, i, FALSE); + if (!(rv && SvROK(*rv) && SvTYPE(SvRV(*rv)) == SVt_PVHV)) + croak("the call to BEST_INDEX() has corrupted constraint data"); + HV *hv = (HV*)SvRV(*rv); + SV **val; + val = hv_fetch(hv, "argvIndex", 9, FALSE); + + int argvIndex = (val && SvOK(*val)) ? SvIV(*val) + 1: 0; + + pConsUsage->argvIndex = argvIndex; + val = hv_fetch(hv, "omit", 4, FALSE); + pConsUsage->omit = (val && SvTRUE(*val)) ? 1 : 0; + } + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + + + +static int perl_vt_Open(sqlite3_vtab *pVTab, sqlite3_vtab_cursor **ppCursor){ + dTHX; + dSP; + ENTER; + SAVETMPS; + + int count; + + /* call the ->OPEN() method */ + PUSHMARK(SP); + XPUSHs( ((perl_vtab *) pVTab)->perl_vtab_instance); + PUTBACK; + count = call_method ("OPEN", G_SCALAR); + SPAGAIN; + if (count != 1) + croak("vtab->OPEN() method returned %d vals instead of 1", count); + SV *perl_cursor = POPs; + if ( !sv_isobject(perl_cursor) ) + croak("vtab->OPEN() method did not return a blessed cursor"); + + + /* allocate a perl_vtab_cursor structure */ + perl_vtab_cursor *cursor; + cursor = (perl_vtab_cursor *) sqlite3_malloc(sizeof(*cursor)); + if( cursor==NULL ) return SQLITE_NOMEM; + memset(cursor, 0, sizeof(*cursor)); + cursor->perl_cursor_instance = SvREFCNT_inc(perl_cursor); + + /* return that cursor */ + *ppCursor = &cursor->base; + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + +static int perl_vt_Close(sqlite3_vtab_cursor *pVtabCursor){ + dTHX; + dSP; + ENTER; + SAVETMPS; + int count; + + /* call the close() method */ + PUSHMARK(SP); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + PUTBACK; + count = call_method("CLOSE", G_VOID); + SPAGAIN; + SP -= count; + + + perl_vtab_cursor *perl_pVTabCursor = (perl_vtab_cursor *) pVtabCursor; + SvREFCNT_dec(perl_pVTabCursor->perl_cursor_instance); + sqlite3_free(perl_pVTabCursor); + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + +static int perl_vt_Filter( + sqlite3_vtab_cursor *pVtabCursor, + int idxNum, const char *idxStr, + int argc, sqlite3_value **argv +){ + + dTHX; + dSP; + ENTER; + SAVETMPS; + int i, count; + int is_unicode = _last_dbh_is_unicode(); + + /* call the FILTER() method with ($idxNum, $idxStr, @args) */ + PUSHMARK(SP); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + XPUSHs(sv_2mortal(newSViv(idxNum))); + XPUSHs(sv_2mortal(newSVpv(idxStr, 0))); + for(i = 0; i < argc; i++) { + XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ argv[i], is_unicode)); + } + PUTBACK; + count = call_method("FILTER", G_VOID); + SPAGAIN; + SP -= count; + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + + +static int perl_vt_Next(sqlite3_vtab_cursor *pVtabCursor){ + dTHX; + dSP; + ENTER; + SAVETMPS; + int i, count; + + /* call the next() method */ + PUSHMARK(SP); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + PUTBACK; + count = call_method ("NEXT", G_VOID); + SPAGAIN; + SP -= count; + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + +static int perl_vt_Eof(sqlite3_vtab_cursor *pVtabCursor){ + dTHX; + dSP; + ENTER; + SAVETMPS; + int count, eof; + + /* call the eof() method */ + PUSHMARK(SP); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + PUTBACK; + count = call_method ("EOF", G_SCALAR); + SPAGAIN; + if (count != 1) { + warn("cursor->EOF() method returned %d vals instead of 1", count); + SP -= count; + } + else { + SV *sv = POPs; /* need 2 lines, because this doesn't work : */ + eof = SvTRUE(sv); /* eof = SvTRUE(POPs); # I don't understand why :-( */ + } + + PUTBACK; + FREETMPS; + LEAVE; + + return eof; +} + + +static int perl_vt_Column(sqlite3_vtab_cursor *pVtabCursor, + sqlite3_context* context, + int col){ + dTHX; + dSP; + ENTER; + SAVETMPS; + int count; + + /* call the column() method */ + PUSHMARK(SP); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + XPUSHs(sv_2mortal(newSViv(col))); + PUTBACK; + count = call_method ("COLUMN", G_SCALAR); + SPAGAIN; + if (count != 1) { + warn("cursor->COLUMN() method returned %d vals instead of 1", count); + SP -= count; + sqlite3_result_error(context, "column error", 12); + } + else { + SV *result = POPs; + sqlite_set_result(aTHX_ context, result, 0 ); + } + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + +static int perl_vt_Rowid(sqlite3_vtab_cursor *pVtabCursor, sqlite3_int64 *pRowid){ + dTHX; + dSP; + ENTER; + SAVETMPS; + int count; + + /* call the rowid() method */ + PUSHMARK(SP); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + PUTBACK; + count = call_method ("ROWID", G_SCALAR); + SPAGAIN; + if (count != 1) { + warn("cursor->ROWID() returned %d vals instead of 1", count); + SP -= count; + } + else { + *pRowid =POPi; + } + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + +static int perl_vt_Update(sqlite3_vtab *pVTab, + int argc, sqlite3_value **argv, + sqlite3_int64 *pRowid){ + dTHX; + dSP; + ENTER; + SAVETMPS; + int count, i; + int is_unicode = _last_dbh_is_unicode(); + + /* call the update() method */ + PUSHMARK(SP); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_instance); + for(i = 0; i < argc; i++) { + XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ argv[i], is_unicode)); + } + + PUTBACK; + count = call_method ("_SQLITE_UPDATE", G_SCALAR); + SPAGAIN; + if (count != 1) { + warn("cursor->_SQLITE_UPDATE() returned %d vals instead of 1", count); + SP -= count; + } + else if (argc > 1 && sqlite3_value_type(argv[0]) == SQLITE_NULL + && sqlite3_value_type(argv[1]) == SQLITE_NULL) { + /* this was an insert without any given rowid, so the result of + the method call must be passed in *pRowid*/ + SV *rowidsv = POPs; + if (!SvOK(rowidsv)) + *pRowid = 0; + else if (SvUOK(rowidsv)) + *pRowid = SvUV(rowidsv); + else if (SvIOK(rowidsv)) + *pRowid = SvIV(rowidsv); + else + *pRowid = SvNV(rowidsv); + } + + + PUTBACK; + FREETMPS; + LEAVE; + + return SQLITE_OK; +} + + + + + +static int perl_vt_Begin(sqlite3_vtab *pVTab){ + return _call_perl_vtab_method(pVTab, "BEGIN_TRANSACTION"); +} + +static int perl_vt_Sync(sqlite3_vtab *pVTab){ + return _call_perl_vtab_method(pVTab, "SYNC_TRANSACTION"); +} + +static int perl_vt_Commit(sqlite3_vtab *pVTab){ + return _call_perl_vtab_method(pVTab, "COMMIT_TRANSACTION"); +} + +static int perl_vt_Rollback(sqlite3_vtab *pVTab){ + return _call_perl_vtab_method(pVTab, "ROLLBACK_TRANSACTION"); +} + +static int perl_vt_FindMethod(sqlite3_vtab *pVtab, int nArg, const char *zName, + void (**pxFunc)(sqlite3_context*,int,sqlite3_value**), + void **ppArg){ + croak("VT_FINDMETHOD: not implemented yet"); /* TODO */ + return SQLITE_OK; +} + +static int perl_vt_Rename(sqlite3_vtab *pVTab, const char *zNew){ + dTHX; + dSP; + ENTER; + SAVETMPS; + int count; + int rc = SQLITE_ERROR; + + PUSHMARK(SP); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs(sv_2mortal(newSVpv(zNew, 0))); + PUTBACK; + count = call_method("RENAME", G_SCALAR); + SPAGAIN; + if (count != 1) { + warn("vtab->RENAME() returned %d args instead of 1", count); + SP -= count; + } + else { + rc = POPi; + } + + + PUTBACK; + FREETMPS; + LEAVE; + + return rc; +} + +static int perl_vt_Savepoint(sqlite3_vtab *pVTab, int point){ + return _call_perl_vtab_method_int(pVTab, "SAVEPOINT", point); +} + +static int perl_vt_Release(sqlite3_vtab *pVTab, int point){ + return _call_perl_vtab_method_int(pVTab, "RELEASE", point); +} + +static int perl_vt_RollbackTo(sqlite3_vtab *pVTab, int point){ + return _call_perl_vtab_method_int(pVTab, "ROLLBACK_TO", point); +} + +static sqlite3_module perl_vt_Module = { + 1, /* iVersion */ + perl_vt_Create, /* xCreate */ + perl_vt_Connect, /* xConnect */ + perl_vt_BestIndex, /* xBestIndex */ + perl_vt_Disconnect, /* xDisconnect */ + perl_vt_Drop, /* xDestroy */ + perl_vt_Open, /* xOpen - open a cursor */ + perl_vt_Close, /* xClose - close a cursor */ + perl_vt_Filter, /* xFilter - configure scan constraints */ + perl_vt_Next, /* xNext - advance a cursor */ + perl_vt_Eof, /* xEof - check for end of scan */ + perl_vt_Column, /* xColumn - read data */ + perl_vt_Rowid, /* xRowid - read data */ + perl_vt_Update, /* xUpdate (optional) */ + perl_vt_Begin, /* xBegin (optional) */ + perl_vt_Sync, /* xSync (optional) */ + perl_vt_Commit, /* xCommit (optional) */ + perl_vt_Rollback, /* xRollback (optional) */ + /* perl_vt_FindMethod, /\* xFindMethod (optional) *\/ */ + NULL, /* xFindMethod not implemented yet */ + perl_vt_Rename, /* xRename */ + perl_vt_Savepoint, /* xSavepoint (optional) */ + perl_vt_Release, /* xRelease (optional) */ + perl_vt_RollbackTo /* xRollbackTo (optional) */ +}; + + +void +sqlite_db_destroy_module_data(void *pAux) +{ + dTHX; + dSP; + ENTER; + SAVETMPS; + int count; + int rc = SQLITE_ERROR; + + perl_vtab_init *init_data = (perl_vtab_init *)pAux; + + /* call the DESTROY_MODULE() method */ + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(init_data->perl_class, 0))); + PUTBACK; + count = call_method("DESTROY_MODULE", G_VOID); + SPAGAIN; + SP -= count; + + /* free module memory */ + SvREFCNT_dec(init_data->dbh); + sqlite3_free((char *)init_data->perl_class); + + PUTBACK; + FREETMPS; + LEAVE; +} + + + +int +sqlite_db_create_module(pTHX_ SV *dbh, const char *name, const char *perl_class) +{ + D_imp_dbh(dbh); + int rc; + + if (!DBIc_ACTIVE(imp_dbh)) { + sqlite_error(dbh, -2, "attempt to create module on inactive database handle"); + return FALSE; + } + + /* load the module if needed */ + char *module_ISA = sqlite3_mprintf("%s::ISA", perl_class); + if (!get_av(module_ISA, 0)) { + char *loading_code = sqlite3_mprintf("require %s", perl_class); + eval_pv(loading_code, TRUE); + sqlite3_free(loading_code); + } + sqlite3_free(module_ISA); + + /* build the init datastructure that will be passed to perl_vt_New() */ + perl_vtab_init *init_data; + init_data = sqlite3_malloc(sizeof(*init_data)); + init_data->dbh = newRV(dbh); + sv_rvweaken(init_data->dbh); + init_data->perl_class = sqlite3_mprintf(perl_class); + + + rc = sqlite3_create_module_v2( imp_dbh->db, + name, + &perl_vt_Module, + init_data, + sqlite_db_destroy_module_data + ); + + if ( rc != SQLITE_OK ) { + sqlite_error(dbh, rc, form("sqlite_create_module failed with error %s", + sqlite3_errmsg(imp_dbh->db))); + return FALSE; + } + return TRUE; +} + + + /* end */ diff --git a/dbdimp.h b/dbdimp.h index 944d5d2..bf6588a 100644 --- a/dbdimp.h +++ b/dbdimp.h @@ -110,10 +110,11 @@ int sqlite_db_profile(pTHX_ SV *dbh, SV *func); HV* sqlite_db_table_column_metadata(pTHX_ SV *dbh, SV *dbname, SV *tablename, SV *columnname); HV* _sqlite_db_status(pTHX_ SV *dbh, int reset); SV* sqlite_db_filename(pTHX_ SV *dbh); - int sqlite_db_register_fts3_perl_tokenizer(pTHX_ SV *dbh); HV* _sqlite_status(int reset); HV* _sqlite_st_status(pTHX_ SV *sth, int reset); +int sqlite_db_create_module(pTHX_ SV *dbh, const char *name, const char *perl_class); + #ifdef SvUTF8_on diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm index c5d0649..54c0f99 100644 --- a/lib/DBD/SQLite.pm +++ b/lib/DBD/SQLite.pm @@ -56,6 +56,7 @@ sub driver { DBD::SQLite::db->install_method('sqlite_db_filename', { O => 0x0004 }); DBD::SQLite::db->install_method('sqlite_db_status', { O => 0x0004 }); DBD::SQLite::st->install_method('sqlite_st_status', { O => 0x0004 }); + DBD::SQLite::db->install_method('sqlite_create_module'); $methods_are_installed++; } diff --git a/lib/DBD/SQLite/VirtualTable.pm b/lib/DBD/SQLite/VirtualTable.pm new file mode 100644 index 0000000..707ed85 --- /dev/null +++ b/lib/DBD/SQLite/VirtualTable.pm @@ -0,0 +1,272 @@ +package DBD::SQLite::VirtualTable; +use strict; +use warnings; +use Scalar::Util qw/weaken/; +use List::MoreUtils qw/part/; +use YAML::XS; +use Data::Dumper; + +our $VERSION = '0.01'; +our @ISA; + + +sub DESTROY_MODULE { + my $class = shift; +} + +sub CREATE { + my $class = shift; + return $class->NEW(@_); +} + +sub CONNECT { + my $class = shift; + return $class->NEW(@_); +} + + +sub NEW { # called when instanciating a virtual table + my ($class, $dbh_ref, $module_name, $db_name, $vtab_name, @args) = @_; + + my @columns; + my %options; + + # args containing '=' are options; others are column declarations + foreach my $arg (@args) { + if ($arg =~ /^([^=\s]+)\s*=\s*(.*)/) { + my ($key, $val) = ($1, $2); + $val =~ s/^"(.*)"$/$1/; + $options{$key} = $val; + } + else { + push @columns, $arg; + } + } + + # build $self and initialize + my $self = { + dbh_ref => $dbh_ref, + module_name => $module_name, + db_name => $db_name, + vtab_name => $vtab_name, + columns => \@columns, + options => \%options, + }; + weaken $self->{dbh_ref}; + bless $self, $class; + $self->initialize(); + + return $self; +} + +sub dbh { + my $self = shift; + return ${$self->{dbh_ref}}; +} + + +sub initialize { + my $self = shift; +} + + +sub connect { + my $class = shift; + + warn "TODO -- VTAB called connect() instead of new()"; + return $class->new(@_); +} + + +sub DROP { + my $self = shift; +} + +sub DISCONNECT { + my $self = shift; +} + + +sub VTAB_TO_DECLARE { + my $self = shift; + + local $" = ", "; + my $sql = "CREATE TABLE $self->{vtab_name}(@{$self->{columns}})"; + + return $sql; +} + + +sub BEST_INDEX { + my ($self, $constraints, $order_by) = @_; + + # print STDERR Dump [BEST_INDEX => { + # where => $constraints, + # order => $order_by, + # }]; + + my $ix = 0; + + foreach my $constraint (@$constraints) { + # TMP HACK -- should put real values instead + $constraint->{argvIndex} = $ix++; + $constraint->{omit} = 0; + } + + # TMP HACK -- should put real values instead + my $outputs = { + idxNum => 1, + idxStr => "foobar", + orderByConsumed => 0, + estimatedCost => 1.0, + estimatedRows => undef, + }; + + return $outputs; +} + + +sub OPEN { + my $self = shift; + my $class = ref $self; + + my $cursor_class = $class . "::Cursor"; + + return $cursor_class->new($self, @_); +} + + + +sub _SQLITE_UPDATE { + my ($self, $old_rowid, $new_rowid, @values) = @_; + + warn "CURSOR->_SQLITE_UPDATE"; + + if (! defined $old_rowid) { + return $self->INSERT($new_rowid, @values); + } + elsif (!@values) { + return $self->DELETE($old_rowid); + } + else { + return $self->UPDATE($old_rowid, $new_rowid, @values); + } +} + +sub INSERT { + my ($self, $new_rowid, @values) = @_; + + warn "vtab->insert()"; + my $new_computed_rowid; + return $new_computed_rowid; +} + +sub DELETE { + my ($self, $old_rowid) = @_; +} + +sub UPDATE { + my ($self, $old_rowid, $new_rowid, @values) = @_; +} + + + +sub BEGIN_TRANSACTION {return 0} +sub SYNC_TRANSACTION {return 0} +sub COMMIT_TRANSACTION {return 0} +sub ROLLBACK_TRANSACTION {return 0} + +sub SAVEPOINT {return 0} +sub RELEASE {return 0} +sub ROLLBACK_TO {return 0} + +sub DESTROY { + my $self = shift; +} + + +package DBD::SQLite::VirtualTable::Cursor; +use strict; +use warnings; + +sub new { + my ($class, $vtable, @args) = @_; + my $self = {vtable => $vtable, + args => \@args}; + bless $self, $class; +} + +sub FILTER { + my ($self, $idxNum, $idxStr, @values) = @_; + + return; +} + + +sub EOF { + my ($self) = @_; + + # stupid implementation, to be redefined in subclasses + return 1; +} + + +sub NEXT { + my ($self) = @_; +} + + +sub COLUMN { + my ($self, $idxCol) = @_; +} + +sub ROWID { + my ($self) = @_; + + # stupid implementation, to be redefined in subclasses + return 1; +} + + +sub CLOSE { + my ($self) = @_; +} + + + +1; + +__END__ + +=head1 NAME + +DBD::SQLite::VirtualTable -- Abstract parent class for implementing virtual tables + +=head1 SYNOPSIS + + package My::Virtual::Table; + use parent 'DBD::SQLite::VirtualTable'; + + sub ... + +=head1 DESCRIPTION + +TODO + +=head1 METHODS + +TODO + + + +=head1 COPYRIGHT AND LICENSE + +Copyright Laurent Dami, 2014. + +Parts of the code are borrowed from L, +copyright (C) 2006, 2009 by Qindel Formacion y Servicios, S. L. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/DBD/SQLite/VirtualTable/Filesys.pm b/lib/DBD/SQLite/VirtualTable/Filesys.pm new file mode 100644 index 0000000..5a1fd26 --- /dev/null +++ b/lib/DBD/SQLite/VirtualTable/Filesys.pm @@ -0,0 +1,208 @@ +package DBD::SQLite::VirtualTable::Filesys; +use strict; +use warnings; +use base 'DBD::SQLite::VirtualTable'; + + +=head1 NAME + +DBD::SQLite::VirtualTable::Filesys -- virtual table for viewing file contents + + +=head1 SYNOPSIS + + -- $dbh->sqlite_create_module(filesys => "DBD::SQLite::VirtualTable::Filesys"); + + CREATE VIRTUAL TABLE tbl USING filesys(file_content, + index_table = idx, + path_col = path, + expose = "path, col1, col2, col3", + root = "/foo/bar") + + +=head1 DESCRIPTION + +A "Filesys" virtual table is like a database view on some underlying +I, which has a column containing paths to +files; the virtual table then adds a supplementary column which exposes +the content from those files. + +This is especially useful as an "external content" to some +fulltext table (see L) : the index +table stores some metadata about files, and then the fulltext engine +can index both the metadata and the file contents. + +=head1 METHODS + +=head2 new + + +=cut + + +sub initialize { + my $self = shift; + + # verifications + @{$self->{columns}} == 1 + or die "Filesys virtual table should declare exactly 1 content column"; + for my $opt (qw/index_table path_col/) { + $self->{options}{$opt} + or die "Filesys virtual table: option '$opt' is missing"; + } + + # get list of columns from the index table + my $ix_table = $self->{options}{index_table}; + my $sql = "PRAGMA table_info($ix_table)"; + my $base_cols = $self->dbh->selectcol_arrayref($sql, {Columns => [2]}); + @$base_cols + or die "wrong index table: $ix_table"; + + # check / complete the exposed columns + $self->{options}{expose} = "*" if not exists $self->{options}{expose}; + my @exposed_cols; + if ($self->{options}{expose} eq '*') { + @exposed_cols = @$base_cols; + } + else { + @exposed_cols = split /\s*,\s*/, ($self->{options}{expose} || ""); + my %is_ok_col = map {$_ => 1} @$base_cols; + my @bad_cols = grep {!$is_ok_col{$_}} @exposed_cols; + local $" = ", "; + die "table $ix_table has no column named @bad_cols" if @bad_cols; + } + push @{$self->{columns}}, @exposed_cols; +} + + +sub _SQLITE_UPDATE { + my ($self, $old_rowid, $new_rowid, @values) = @_; + + die "readonly database"; +} + + +sub BEST_INDEX { + my ($self, $constraints, $order_by) = @_; + + my @conditions; + my $ix = 0; + foreach my $constraint (grep {$_->{usable}} @$constraints) { + my $col = $constraint->{col}; + + # if this is the content column, skip because we can't filter on it + next if $col == 0; + + # for other columns, build a fragment for SQL WHERE on the underlying table + my $colname = $col == -1 ? "rowid" : $self->{columns}[$col]; + push @conditions, "$colname $constraint->{op} ?"; + $constraint->{argvIndex} = $ix++; + $constraint->{omit} = 1; # SQLite doesn't need to re-check the op + } + + my $outputs = { + idxNum => 1, + idxStr => join(" AND ", @conditions), + orderByConsumed => 0, + estimatedCost => 1.0, + estimatedRows => undef, + }; + + return $outputs; +} + +package DBD::SQLite::VirtualTable::Filesys::Cursor; +use 5.010; +use strict; +use warnings; +use base "DBD::SQLite::VirtualTable::Cursor"; + + +sub FILTER { + my ($self, $idxNum, $idxStr, @values) = @_; + + my $vtable = $self->{vtable}; + + # build SQL + local $" = ", "; + my @cols = @{$vtable->{columns}}; + $cols[0] = 'rowid'; # replace the content column by the rowid + push @cols, $vtable->{options}{path_col}; # path col in last position + my $sql = "SELECT @cols FROM $vtable->{options}{index_table}"; + $sql .= " WHERE $idxStr" if $idxStr; + + # request on the index table + my $dbh = $vtable->dbh; + $self->{sth} = $dbh->prepare($sql) + or die DBI->errstr; + $self->{sth}->execute(@values); + $self->{row} = $self->{sth}->fetchrow_arrayref; + + return; +} + + +sub EOF { + my ($self) = @_; + + return !$self->{row}; +} + +sub NEXT { + my ($self) = @_; + + $self->{row} = $self->{sth}->fetchrow_arrayref; +} + + +sub COLUMN { + my ($self, $idxCol) = @_; + + return $idxCol == 0 ? $self->file_content : $self->{row}[$idxCol]; +} + +sub ROWID { + my ($self) = @_; + + return $self->{row}[0]; +} + + +sub file_content { + my ($self) = @_; + + my $root = $self->{vtable}{options}{root}; + my $path = $self->{row}[-1]; + $path = "$root/$path" if $root; + + my $content = ""; + if (open my $fh, "<", $path) { + local $/; # slurp the whole file into a scalar + $content = <$fh>; + close $fh; + } + else { + warn "can't open $path"; + } + + return $content; +} + +1; + +__END__ + + + + +=head1 COPYRIGHT AND LICENSE + +Copyright Laurent Dami, 2014. + +Parts of the code are borrowed from L, +copyright (C) 2006, 2009 by Qindel Formacion y Servicios, S. L. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/virtual_table/00_base.t b/t/virtual_table/00_base.t new file mode 100644 index 0000000..cba5a12 --- /dev/null +++ b/t/virtual_table/00_base.t @@ -0,0 +1,135 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +# use Test::NoWarnings; +use DBI qw(:sql_types); + +plan tests => 9; + +my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 ); + +$dbh->sqlite_create_module(vtab => "DBD::SQLite::VirtualTable::T"); + +ok $dbh->do("CREATE VIRTUAL TABLE foobar USING vtab(foo INTEGER, bar INTEGER)"); + +my $sql = "SELECT rowid, foo, bar FROM foobar "; +my $rows = $dbh->selectall_arrayref($sql, {Slice => {}}); +is scalar(@$rows), 5, "got 5 rows"; +is $rows->[0]{rowid}, 5, "rowid column"; +is $rows->[0]{foo}, "auto_vivify:0", "foo column"; +is $rows->[0]{bar}, "auto_vivify:1", "bar column"; + + +$sql = "SELECT * FROM foobar "; +$rows = $dbh->selectall_arrayref($sql, {Slice => {}}); +is scalar(@$rows), 5, "got 5 rows again"; +is_deeply([sort keys %{$rows->[0]}], [qw/bar foo/], "col list OK"); + + +$sql = "SELECT * FROM foobar WHERE foo > -1 and bar < 33"; +$rows = $dbh->selectall_arrayref($sql, {Slice => {}}); +is scalar(@$rows), 5, "got 5 rows (because of omitted constraints)"; + + +package DBD::SQLite::VirtualTable::T; +use strict; +use warnings; +use base 'DBD::SQLite::VirtualTable'; +use YAML; + +sub initialize { + my $self = shift; + # stupid pragma call, just to check that the dbh is OK + $self->dbh->do("PRAGMA application_id=999"); +} + + +sub BEST_INDEX { + my ($self, $constraints, $order_by) = @_; + + # print STDERR Dump [BEST_INDEX => { + # where => $constraints, + # order => $order_by, + # }]; + + my $ix = 0; + + foreach my $constraint (@$constraints) { + $constraint->{argvIndex} = $ix++; + $constraint->{omit} = 1; # to prevent sqlite core to check values + } + + # TMP HACK -- should put real values instead + my $outputs = { + idxNum => 1, + idxStr => "foobar", + orderByConsumed => 0, + estimatedCost => 1.0, + estimatedRows => undef, + }; + + return $outputs; +} + + + +package DBD::SQLite::VirtualTable::T::Cursor; +use strict; +use warnings; +use base 'DBD::SQLite::VirtualTable::Cursor'; +use YAML; + +sub new { + my $class = shift; + + my $self = $class->SUPER::new(@_); + $self->{row_count} = 5; + + return $self; +} + +sub FILTER { + my ($self, $idxNum, $idxStr, @values) = @_; + + return; +} + + + +sub EOF { + my $self = shift; + + return !$self->{row_count}; +} + +sub NEXT { + my $self = shift; + + $self->{row_count}--; +} + +sub COLUMN { + my ($self, $idxCol) = @_; + + return "auto_vivify:$idxCol"; + return $idxCol; +} + +sub ROWID { + my ($self) = @_; + + return $self->{row_count}; +} + + +1; + + + diff --git a/t/virtual_table/01_destroy.t b/t/virtual_table/01_destroy.t new file mode 100644 index 0000000..d1dce00 --- /dev/null +++ b/t/virtual_table/01_destroy.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; + +plan tests => 23; + +my $dbfile = "tmp.sqlite"; +my $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); + +ok !$DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, "no vtab initialized"; + +# create 2 separate SQLite modules from the same Perl class +$dbh->sqlite_create_module(vtab1 => "DBD::SQLite::VirtualTable::T"); +$dbh->sqlite_create_module(vtab2 => "DBD::SQLite::VirtualTable::T"); +ok !$DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, "still no vtab"; + +# create 2 virtual tables from module vtab1 +ok $dbh->do("CREATE VIRTUAL TABLE foobar USING vtab1(foo, bar)"), "create foobar"; +ok $dbh->do("CREATE VIRTUAL TABLE barfoo USING vtab1(foo, bar)"), "create barfoo"; +is $DBD::SQLite::VirtualTable::T::CREATE_COUNT, 2, "2 vtab created"; +ok !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab connected"; +is $DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, 2, "2 vtab initialized"; + +# destructor is called when a vtable is dropped +ok !$DBD::SQLite::VirtualTable::T::DESTROY_COUNT, "no vtab destroyed"; +ok $dbh->do("DROP TABLE foobar"), "dropped foobar"; +is $DBD::SQLite::VirtualTable::T::DESTROY_COUNT, 1, "one vtab destroyed"; + +# all vtable and module destructors are called when the dbh is disconnected +undef $dbh; +is $DBD::SQLite::VirtualTable::T::DESTROY_COUNT, 2, "both vtab destroyed"; +is $DBD::SQLite::VirtualTable::T::DISCONNECT_COUNT, 1, "1 vtab disconnected"; +is $DBD::SQLite::VirtualTable::T::DROP_COUNT, 1, "1 vtab dropped"; +is $DBD::SQLite::VirtualTable::T::DESTROY_MODULE_COUNT, 2, "2 modules destroyed"; + +# reconnect, check that we go through the CONNECT method +undef $DBD::SQLite::VirtualTable::T::CREATE_COUNT; +undef $DBD::SQLite::VirtualTable::T::CONNECT_COUNT; +undef $DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT; + +$dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); +$dbh->sqlite_create_module(vtab1 => "DBD::SQLite::VirtualTable::T"); +ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created"; +ok !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab connected"; +ok !$DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, "no vtab initialized"; + +my $sth = $dbh->prepare("SELECT * FROM barfoo"); +ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created"; +is $DBD::SQLite::VirtualTable::T::CONNECT_COUNT, 1, "1 vtab connected"; +is $DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, 1, "1 vtab initialized"; + + +package DBD::SQLite::VirtualTable::T; +use base 'DBD::SQLite::VirtualTable'; + +our $CREATE_COUNT; +our $CONNECT_COUNT; +our $INITIALIZE_COUNT; +our $DESTROY_COUNT; +our $DESTROY_MODULE_COUNT; +our $DROP_COUNT; +our $DISCONNECT_COUNT; + +sub CREATE {$CREATE_COUNT++; return shift->SUPER::CREATE(@_)} +sub CONNECT {$CONNECT_COUNT++; return shift->SUPER::CONNECT(@_)} +sub initialize {$INITIALIZE_COUNT++} +sub DROP {$DROP_COUNT++} +sub DISCONNECT {$DISCONNECT_COUNT++} +sub DESTROY {$DESTROY_COUNT++} +sub DESTROY_MODULE {$DESTROY_MODULE_COUNT++} + +1; + diff --git a/t/virtual_table/10_filesys.t b/t/virtual_table/10_filesys.t new file mode 100644 index 0000000..88fc7a7 --- /dev/null +++ b/t/virtual_table/10_filesys.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + + +use t::lib::Test qw/connect_ok/; +use Test::More; +# use Test::NoWarnings; +use DBI qw(:sql_types); +use FindBin; + +plan tests => 12; + +my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 ); + +# create index table +$dbh->do(<<""); + CREATE TABLE base (id INTEGER PRIMARY KEY, foo TEXT, path TEXT, bar TEXT) + +$dbh->do(<<""); + INSERT INTO base VALUES(1, 'foo1', '00_base.t', 'bar1') + +$dbh->do(<<""); + INSERT INTO base VALUES(2, 'foo2', '10_filesys.t', 'bar2') + + +# start tests + +ok $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys"), + "create_module"; + + +ok $dbh->do(<<""), "create vtable"; + CREATE VIRTUAL TABLE vfs USING fs(content, + index_table = base, + path_col = path, + expose = "path, foo, bar", + root = "$FindBin::Bin") + +my $sql = "SELECT content, bar, rowid FROM vfs WHERE foo='foo2'"; +my $rows = $dbh->selectall_arrayref($sql, {Slice => {}}); + +is scalar(@$rows), 1, "got 1 row"; + +is $rows->[0]{bar}, 'bar2', 'got bar2'; +is $rows->[0]{rowid}, 2, 'got rowid'; + +like $rows->[0]{content}, qr/VIRTUAL TABLE vfs/, 'file content'; + +$sql = "SELECT * FROM vfs ORDER BY rowid"; +$rows = $dbh->selectall_arrayref($sql, {Slice => {}}); +is scalar(@$rows), 2, "got 2 rows"; +is_deeply([sort keys %{$rows->[0]}], [qw/bar content foo path/], "col list OK"); +is $rows->[0]{bar}, 'bar1', 'got bar1'; +is $rows->[1]{bar}, 'bar2', 'got bar2'; + + +# expensive request (reads content from all files in table) ! +$sql = "SELECT * FROM vfs WHERE content LIKE '%filesys%'"; +$rows = $dbh->selectall_arrayref($sql, {Slice => {}}); +is scalar(@$rows), 1, "got 1 row"; + diff --git a/t/virtual_table/11_fulltext_search.t b/t/virtual_table/11_fulltext_search.t new file mode 100644 index 0000000..32add66 --- /dev/null +++ b/t/virtual_table/11_fulltext_search.t @@ -0,0 +1,100 @@ +#!/usr/bin/perl + +# TMP HACK +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; +use FindBin; + +my $dbfile = "tmp.sqlite"; + +my @tests = ( + ["VirtualTable" => qw[lib/DBD/SQLite/VirtualTable.pm + lib/DBD/SQLite/VirtualTable/Filesys.pm]], + ["install_method" => qw[lib/DBD/SQLite.pm]], + ['"use strict"' => qw[inc/Test/NoWarnings.pm + inc/Test/NoWarnings/Warning.pm + lib/DBD/SQLite.pm + lib/DBD/SQLite/VirtualTable.pm + lib/DBD/SQLite/VirtualTable/Filesys.pm + t/lib/Test.pm + util/getsqlite.pl]], + ['"use strict" AND "use warnings"' => qw[inc/Test/NoWarnings.pm + lib/DBD/SQLite/VirtualTable.pm + lib/DBD/SQLite/VirtualTable/Filesys.pm + ]], +); + +plan tests => 3 + 3 * @tests; + +# find out perl files in this distrib +my $distrib_dir = "$FindBin::Bin/../.."; +open my $fh, "<", "$distrib_dir/MANIFEST" or die "open $distrib_dir/MANIFEST: $!"; +my @files = <$fh>; +close $fh; +chomp foreach @files; +my @perl_files = grep {/\.(pl|pm|pod)$/} @files; + +# open database +my $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); + +# create index table +$dbh->do("CREATE TABLE files (id INTEGER PRIMARY KEY, path TEXT)"); +my $sth = $dbh->prepare("INSERT INTO files(path) VALUES (?)"); +$sth->execute($_) foreach @perl_files; + + +# create vtab table +$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys"); +$dbh->do(<<""); + CREATE VIRTUAL TABLE vfs USING fs(content, + index_table = files, + path_col = path, + expose = "path", + root = "$distrib_dir") + +# create fts table +$dbh->do('CREATE VIRTUAL TABLE fts USING fts4(content="vfs")'); +note "building fts index...."; +$dbh->do("INSERT INTO fts(fts) VALUES ('rebuild')"); +note "done"; + +# start tests +my $sql = "SELECT path FROM fts WHERE fts MATCH ?"; +foreach my $test (@tests) { + my ($pattern, @expected) = @$test; + my $paths = $dbh->selectcol_arrayref($sql, {}, $pattern); + is_deeply([sort @$paths], \@expected, "search '$pattern'"); +} + +# remove one document +my $remove_path = 'lib/DBD/SQLite/VirtualTable.pm'; +$dbh->do("DELETE FROM fts WHERE path='$remove_path'"); + + +# test again +foreach my $test (@tests) { + my ($pattern, @expected) = @$test; + @expected = grep {$_ ne $remove_path} @expected; + my $paths = $dbh->selectcol_arrayref($sql, {}, $pattern); + is_deeply([sort @$paths], \@expected, "search '$pattern' -- no $remove_path"); +} + +# see if data was properly stored: disconnect, reconnect and test again +undef $dbh; +$dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); +$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys"); + +foreach my $test (@tests) { + my ($pattern, @expected) = @$test; + @expected = grep {$_ ne $remove_path} @expected; + my $paths = $dbh->selectcol_arrayref($sql, {}, $pattern); + is_deeply([sort @$paths], \@expected, "search '$pattern' -- after reconnect"); +} + From d6a77c88ea5d1555547f2688ddc40b5332a1c8d4 Mon Sep 17 00:00:00 2001 From: Laurent Dami Date: Thu, 10 Jul 2014 04:07:50 +0200 Subject: [PATCH 2/8] bug corrections & addition of class VirtualTable/PerlData --- MANIFEST | 7 +- dbdimp.c | 7 +- lib/DBD/SQLite.pm | 32 ++ lib/DBD/SQLite/VirtualTable.pm | 24 +- .../{Filesys.pm => FileContent.pm} | 16 +- lib/DBD/SQLite/VirtualTable/PerlData.pm | 292 ++++++++++++++++++ t/virtual_table/00_base.t | 5 +- t/virtual_table/01_destroy.t | 1 - .../{10_filesys.t => 10_filecontent.t} | 8 +- ...ext_search.t => 11_filecontent_fulltext.t} | 18 +- t/virtual_table/20_perldata.t | 105 +++++++ 11 files changed, 473 insertions(+), 42 deletions(-) rename lib/DBD/SQLite/VirtualTable/{Filesys.pm => FileContent.pm} (91%) create mode 100644 lib/DBD/SQLite/VirtualTable/PerlData.pm rename t/virtual_table/{10_filesys.t => 10_filecontent.t} (93%) rename t/virtual_table/{11_fulltext_search.t => 11_filecontent_fulltext.t} (85%) create mode 100644 t/virtual_table/20_perldata.t diff --git a/MANIFEST b/MANIFEST index 0dec102..e660ef1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -8,7 +8,8 @@ lib/DBD/SQLite.pm lib/DBD/SQLite/Cookbook.pod lib/DBD/SQLite/Fulltext_search.pod lib/DBD/SQLite/VirtualTable.pm -lib/DBD/SQLite/VirtualTable/Filesys.pm +lib/DBD/SQLite/VirtualTable/FileContent.pm +lib/DBD/SQLite/VirtualTable/PerlData.pm LICENSE Makefile.PL MANIFEST This list of files @@ -111,7 +112,9 @@ t/rt_88228_sqlite_3_8_0_crash.t t/rt_96878_fts_contentless_table.t t/virtual_table/00_base.t t/virtual_table/01_destroy.t -t/virtual_table/10_filesys.t +t/virtual_table/10_filecontent.t +t/virtual_table/11_filecontent_fulltext.t +t/virtual_table/20_perldata.t typemap util/getsqlite.pl xt/meta.t diff --git a/dbdimp.c b/dbdimp.c index d192c21..0fac6b4 100644 --- a/dbdimp.c +++ b/dbdimp.c @@ -3111,8 +3111,11 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ pIdxInfo->idxNum = (val && SvOK(*val)) ? SvIV(*val) : 0; val = hv_fetch(hv, "idxStr", 6, FALSE); if (val && SvOK(*val)) { - char *str = SvPVutf8_nolen(*val); - pIdxInfo->idxStr = sqlite3_mprintf(str); + STRLEN len; + char *str = SvPVutf8(*val, len); + pIdxInfo->idxStr = sqlite3_malloc(len+1); + memcpy(pIdxInfo->idxStr, str, len); + pIdxInfo->idxStr[len] = 0; pIdxInfo->needToFreeIdxStr = 1; } val = hv_fetch(hv, "orderByConsumed", 15, FALSE); diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm index 54c0f99..8efa7a5 100644 --- a/lib/DBD/SQLite.pm +++ b/lib/DBD/SQLite.pm @@ -2406,6 +2406,38 @@ For more detail, please see the SQLite R-Tree page queries using callbacks, as mentioned in the prior link, have not been implemented yet. +=head1 VIRTUAL TABLES IMPLEMENTED IN PERL + +SQLite has a concept of "virtual tables" which look like regular +tables but are implemented internally through specific functions. +The fulltext or R* tree features described in the previous chapters +are examples of such virtual tables, implemented in C code. + +C also supports virtual tables implemented in Perl code: +see L. This can have many interesting uses +for joining regular DBMS data with some other kind of data within your +Perl programs. Bundled with the present distribution are : + +=over + +=item * + +L : implements a virtual +column that exposes content from files. This is especially useful +in conjuction with a fulltext index; see L. + +=item * + +L : binds to a Perl array +within your main program. This can be used for simple import/export +operations, for debugging purposes, for joining data from different +sources, etc. + +=back + +Other Perl virtual tables may also be published separately on CPAN. + + =head1 FOR DBD::SQLITE EXTENSION AUTHORS Since 1.30_01, you can retrieve the bundled sqlite C source and/or diff --git a/lib/DBD/SQLite/VirtualTable.pm b/lib/DBD/SQLite/VirtualTable.pm index 707ed85..56ceff5 100644 --- a/lib/DBD/SQLite/VirtualTable.pm +++ b/lib/DBD/SQLite/VirtualTable.pm @@ -1,3 +1,5 @@ +# TODO : fix bug with column name / type + package DBD::SQLite::VirtualTable; use strict; use warnings; @@ -24,7 +26,6 @@ sub CONNECT { return $class->NEW(@_); } - sub NEW { # called when instanciating a virtual table my ($class, $dbh_ref, $module_name, $db_name, $vtab_name, @args) = @_; @@ -70,12 +71,6 @@ sub initialize { } -sub connect { - my $class = shift; - - warn "TODO -- VTAB called connect() instead of new()"; - return $class->new(@_); -} sub DROP { @@ -132,7 +127,7 @@ sub OPEN { my $cursor_class = $class . "::Cursor"; - return $cursor_class->new($self, @_); + return $cursor_class->NEW($self, @_); } @@ -140,8 +135,6 @@ sub OPEN { sub _SQLITE_UPDATE { my ($self, $old_rowid, $new_rowid, @values) = @_; - warn "CURSOR->_SQLITE_UPDATE"; - if (! defined $old_rowid) { return $self->INSERT($new_rowid, @values); } @@ -156,19 +149,20 @@ sub _SQLITE_UPDATE { sub INSERT { my ($self, $new_rowid, @values) = @_; - warn "vtab->insert()"; - my $new_computed_rowid; - return $new_computed_rowid; + die "INSERT() should be redefined in subclass"; } sub DELETE { my ($self, $old_rowid) = @_; + + die "DELETE() should be redefined in subclass"; } sub UPDATE { my ($self, $old_rowid, $new_rowid, @values) = @_; -} + die "UPDATE() should be redefined in subclass"; +} sub BEGIN_TRANSACTION {return 0} @@ -189,7 +183,7 @@ package DBD::SQLite::VirtualTable::Cursor; use strict; use warnings; -sub new { +sub NEW { my ($class, $vtable, @args) = @_; my $self = {vtable => $vtable, args => \@args}; diff --git a/lib/DBD/SQLite/VirtualTable/Filesys.pm b/lib/DBD/SQLite/VirtualTable/FileContent.pm similarity index 91% rename from lib/DBD/SQLite/VirtualTable/Filesys.pm rename to lib/DBD/SQLite/VirtualTable/FileContent.pm index 5a1fd26..7e4e3a2 100644 --- a/lib/DBD/SQLite/VirtualTable/Filesys.pm +++ b/lib/DBD/SQLite/VirtualTable/FileContent.pm @@ -1,4 +1,4 @@ -package DBD::SQLite::VirtualTable::Filesys; +package DBD::SQLite::VirtualTable::FileContent; use strict; use warnings; use base 'DBD::SQLite::VirtualTable'; @@ -6,12 +6,12 @@ use base 'DBD::SQLite::VirtualTable'; =head1 NAME -DBD::SQLite::VirtualTable::Filesys -- virtual table for viewing file contents +DBD::SQLite::VirtualTable::FileContent -- virtual table for viewing file contents =head1 SYNOPSIS - -- $dbh->sqlite_create_module(filesys => "DBD::SQLite::VirtualTable::Filesys"); + -- $dbh->sqlite_create_module(filesys => "DBD::SQLite::VirtualTable::FileContent"); CREATE VIRTUAL TABLE tbl USING filesys(file_content, index_table = idx, @@ -20,9 +20,11 @@ DBD::SQLite::VirtualTable::Filesys -- virtual table for viewing file contents root = "/foo/bar") + -- OR : expose = * + =head1 DESCRIPTION -A "Filesys" virtual table is like a database view on some underlying +A "FileContent" virtual table is like a database view on some underlying I, which has a column containing paths to files; the virtual table then adds a supplementary column which exposes the content from those files. @@ -45,10 +47,10 @@ sub initialize { # verifications @{$self->{columns}} == 1 - or die "Filesys virtual table should declare exactly 1 content column"; + or die "FileContent virtual table should declare exactly 1 content column"; for my $opt (qw/index_table path_col/) { $self->{options}{$opt} - or die "Filesys virtual table: option '$opt' is missing"; + or die "FileContent virtual table: option '$opt' is missing"; } # get list of columns from the index table @@ -111,7 +113,7 @@ sub BEST_INDEX { return $outputs; } -package DBD::SQLite::VirtualTable::Filesys::Cursor; +package DBD::SQLite::VirtualTable::FileContent::Cursor; use 5.010; use strict; use warnings; diff --git a/lib/DBD/SQLite/VirtualTable/PerlData.pm b/lib/DBD/SQLite/VirtualTable/PerlData.pm new file mode 100644 index 0000000..cd30c6e --- /dev/null +++ b/lib/DBD/SQLite/VirtualTable/PerlData.pm @@ -0,0 +1,292 @@ +package DBD::SQLite::VirtualTable::PerlData; +use strict; +use warnings; +use base 'DBD::SQLite::VirtualTable'; +use List::MoreUtils qw/mesh/; + + +=head1 NAME + +DBD::SQLite::VirtualTable::PerlData -- virtual table for connecting to perl data + + +=head1 SYNOPSIS + + -- $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"); + + CREATE VIRTUAL TABLE tbl USING perl(foo, bar, etc, + arrayrefs="some_global_variable") + + CREATE VIRTUAL TABLE tbl USING perl(foo, bar, etc, + hashrefs="some_global_variable") + + CREATE VIRTUAL TABLE tbl USING perl(single_col + colref="some_global_variable") + + +=head1 DESCRIPTION + + +=head1 METHODS + +=head2 new + +=cut + + + +# private data for translating comparison operators from Sqlite to Perl +my $TXT = 0; +my $NUM = 1; +my %SQLOP2PERLOP = ( +# TXT NUM + '=' => [ 'eq', '==' ], + '<' => [ 'lt', '<' ], + '<=' => [ 'le', '<=' ], + '>' => [ 'gt', '>' ], + '>=' => [ 'ge', '>=' ], + 'MATCH' => [ '=~', '=~' ], +); + + +sub initialize { + my $self = shift; + my $class = ref $self; + + # verifications + my $n_cols = @{$self->{columns}}; + $n_cols > 0 + or die "$class: no declared columns"; + !$self->{options}{colref} || $n_cols == 1 + or die "$class: must have exactly 1 column when using 'colref'"; + my $symbolic_ref = $self->{options}{arrayrefs} + || $self->{options}{hashrefs} + || $self->{options}{colref} + or die "$class: missing option 'arrayrefs' or 'hashrefs' or 'colref'"; + + # bind to the Perl variable + no strict "refs"; + defined ${$symbolic_ref} + or die "$class: can't find global variable \$$symbolic_ref"; + $self->{rows} = \${$symbolic_ref}; +} + + +sub initialize_bis { + my $self = shift; + + # the code below cannot happen within initialize() because VTAB_TO_DECLARE() + # has not been called until the end of NEW(). So we do it here, which is + # called lazily at the first invocation if BEST_INDEX(). + + # get names and types of columns after they have been parsed by sqlite + my $sth = $self->dbh->prepare("PRAGMA table_info($self->{vtab_name})"); + $sth->execute; + + # build private data 'headers' and 'optypes' + while (my $row = $sth->fetch) { + my ($colname, $coltype) = @{$row}[1, 2]; + push @{$self->{headers}}, $colname; + + # apply algorithm from datatype3.html" for type affinity + push @{$self->{optypes}}, $coltype =~ /INT|REAL|FLOA|DOUB/i ? $NUM : $TXT; + } +} + + +sub BEST_INDEX { + my ($self, $constraints, $order_by) = @_; + + $self->initialize_bis if not exists $self->{headers}; + + # for each constraint, build a Perl code fragment. Those will be gathered + # in FILTER() for deciding which rows match the constraints. + my @conditions; + my $ix = 0; + foreach my $constraint (grep {$_->{usable}} @$constraints) { + my $col = $constraint->{col}; + my ($member, $optype); + + # build a Perl code fragment. Those will be gathered + # in FILTER() for deciding which rows match the constraints. + if ($col == -1) { + # constraint on rowid + $member = '$i'; + $optype = $NUM; + } + else { + my $get_col = $self->{options}{arrayrefs} ? "->[$col]" + : $self->{options}{hashrefs} ? "->{$self->{headers}[$col]}" + : $self->{options}{colref} ? "" + : die "corrupted data in ->{options}"; + $member = '$self->row($i)' . $get_col; + $optype = $self->{optypes}[$col]; + } + my $op = $SQLOP2PERLOP{$constraint->{op}}[$optype]; + my $quote = $op eq '=~' ? 'qr' : 'q'; + push @conditions, "($member $op ${quote}{%s})"; + + # info passed back to the sqlite kernel -- see vtab.html in sqlite doc + $constraint->{argvIndex} = $ix++; + $constraint->{omit} = 1; + } + + # further info for the sqlite kernel + my $outputs = { + idxNum => 1, + idxStr => (join(" && ", @conditions) || "1"), + orderByConsumed => 0, + estimatedCost => 1.0, + estimatedRows => undef, + }; + + return $outputs; +} + + +sub _build_new_row { + my ($self, $values) = @_; + + return $self->{options}{arrayrefs} ? $values + : $self->{options}{hashrefs} ? { mesh @{$self->{headers}}, @$values } + : $self->{options}{colref} ? $values->[0] + : die "corrupted data in ->{options}"; +} + + +sub INSERT { + my ($self, $new_rowid, @values) = @_; + + my $new_row = $self->_build_new_row(\@values); + + if (defined $new_rowid) { + not ${$self->{rows}}->[$new_rowid] + or die "can't INSERT : rowid $new_rowid already in use"; + ${$self->{rows}}->[$new_rowid] = $new_row; + } + else { + push @${$self->{rows}}, $new_row; + return $#${$self->{rows}}; + } +} + +sub DELETE { + my ($self, $old_rowid) = @_; + + delete ${$self->{rows}}->[$old_rowid]; +} + +sub UPDATE { + my ($self, $old_rowid, $new_rowid, @values) = @_; + + my $new_row = $self->_build_new_row(\@values); + + if ($new_rowid == $old_rowid) { + ${$self->{rows}}->[$old_rowid] = $new_row; + } + else { + delete ${$self->{rows}}->[$old_rowid]; + ${$self->{rows}}->[$new_rowid] = $new_row; + } +} + + + + +package DBD::SQLite::VirtualTable::PerlData::Cursor; +use 5.010; +use strict; +use warnings; +use base "DBD::SQLite::VirtualTable::Cursor"; + + +sub row { + my ($self, $i) = @_; + return ${$self->{vtable}{rows}}->[$i]; +} + +sub FILTER { + my ($self, $idxNum, $idxStr, @values) = @_; + + # build a method coderef to fetch matching rows + my $perl_code = sprintf "sub {my (\$self, \$i) = \@_; $idxStr}", @values; + +# print STDERR "PERL $perl_code\n"; + + $self->{is_wanted_row} = eval $perl_code + or die "couldn't eval q{$perl_code} : $@"; + + # position the cursor to the first matching row (or to eof) + $self->{row_ix} = -1; + $self->NEXT; +} + + +sub EOF { + my ($self) = @_; + + return $self->{row_ix} > $#${$self->{vtable}{rows}}; +} + +sub NEXT { + my ($self) = @_; + + do { + $self->{row_ix} += 1 + } until $self->EOF || $self->{is_wanted_row}->($self, $self->{row_ix}); +} + + +sub COLUMN { + my ($self, $idxCol) = @_; + + my $row = $self->row($self->{row_ix}); + + + return $self->{vtable}{options}{arrayrefs} ? $row->[$idxCol] + : $self->{vtable}{options}{hashrefs} ? + $row->{$self->{vtable}{headers}[$idxCol]} + : $self->{vtable}{options}{colref} ? $row + : die "corrupted data in ->{options}"; +} + +sub ROWID { + my ($self) = @_; + + return $self->{row_ix}; +} + + +1; + +__END__ + +=head1 NAME + +DBD::SQLite::VirtualTable -- Abstract parent class for implementing virtual tables + +=head1 SYNOPSIS + + package My::Virtual::Table; + use parent 'DBD::SQLite::VirtualTable'; + + sub ... + +=head1 DESCRIPTION + +TODO + +=head1 METHODS + +TODO + + + +=head1 COPYRIGHT AND LICENSE + +Copyright Laurent Dami, 2014. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/virtual_table/00_base.t b/t/virtual_table/00_base.t index cba5a12..6c8f7c1 100644 --- a/t/virtual_table/00_base.t +++ b/t/virtual_table/00_base.t @@ -1,5 +1,4 @@ #!/usr/bin/perl - use strict; BEGIN { $| = 1; @@ -86,10 +85,10 @@ use warnings; use base 'DBD::SQLite::VirtualTable::Cursor'; use YAML; -sub new { +sub NEW { my $class = shift; - my $self = $class->SUPER::new(@_); + my $self = $class->SUPER::NEW(@_); $self->{row_count} = 5; return $self; diff --git a/t/virtual_table/01_destroy.t b/t/virtual_table/01_destroy.t index d1dce00..75e71c5 100644 --- a/t/virtual_table/01_destroy.t +++ b/t/virtual_table/01_destroy.t @@ -1,5 +1,4 @@ #!/usr/bin/perl - use strict; BEGIN { $| = 1; diff --git a/t/virtual_table/10_filesys.t b/t/virtual_table/10_filecontent.t similarity index 93% rename from t/virtual_table/10_filesys.t rename to t/virtual_table/10_filecontent.t index 88fc7a7..603d112 100644 --- a/t/virtual_table/10_filesys.t +++ b/t/virtual_table/10_filecontent.t @@ -8,11 +8,11 @@ BEGIN { use t::lib::Test qw/connect_ok/; use Test::More; -# use Test::NoWarnings; +use Test::NoWarnings; use DBI qw(:sql_types); use FindBin; -plan tests => 12; +plan tests => 13; my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 ); @@ -24,12 +24,12 @@ $dbh->do(<<""); INSERT INTO base VALUES(1, 'foo1', '00_base.t', 'bar1') $dbh->do(<<""); - INSERT INTO base VALUES(2, 'foo2', '10_filesys.t', 'bar2') + INSERT INTO base VALUES(2, 'foo2', '10_filecontent.t', 'bar2') # start tests -ok $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys"), +ok $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"), "create_module"; diff --git a/t/virtual_table/11_fulltext_search.t b/t/virtual_table/11_filecontent_fulltext.t similarity index 85% rename from t/virtual_table/11_fulltext_search.t rename to t/virtual_table/11_filecontent_fulltext.t index 32add66..def5b7d 100644 --- a/t/virtual_table/11_fulltext_search.t +++ b/t/virtual_table/11_filecontent_fulltext.t @@ -1,6 +1,4 @@ #!/usr/bin/perl - -# TMP HACK use strict; BEGIN { $| = 1; @@ -15,19 +13,23 @@ use FindBin; my $dbfile = "tmp.sqlite"; my @tests = ( - ["VirtualTable" => qw[lib/DBD/SQLite/VirtualTable.pm - lib/DBD/SQLite/VirtualTable/Filesys.pm]], + ["VirtualTable" => qw[lib/DBD/SQLite.pm + lib/DBD/SQLite/VirtualTable.pm + lib/DBD/SQLite/VirtualTable/FileContent.pm + lib/DBD/SQLite/VirtualTable/PerlData.pm]], ["install_method" => qw[lib/DBD/SQLite.pm]], ['"use strict"' => qw[inc/Test/NoWarnings.pm inc/Test/NoWarnings/Warning.pm lib/DBD/SQLite.pm lib/DBD/SQLite/VirtualTable.pm - lib/DBD/SQLite/VirtualTable/Filesys.pm + lib/DBD/SQLite/VirtualTable/FileContent.pm + lib/DBD/SQLite/VirtualTable/PerlData.pm t/lib/Test.pm util/getsqlite.pl]], ['"use strict" AND "use warnings"' => qw[inc/Test/NoWarnings.pm lib/DBD/SQLite/VirtualTable.pm - lib/DBD/SQLite/VirtualTable/Filesys.pm + lib/DBD/SQLite/VirtualTable/FileContent.pm + lib/DBD/SQLite/VirtualTable/PerlData.pm ]], ); @@ -51,7 +53,7 @@ $sth->execute($_) foreach @perl_files; # create vtab table -$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys"); +$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"); $dbh->do(<<""); CREATE VIRTUAL TABLE vfs USING fs(content, index_table = files, @@ -89,7 +91,7 @@ foreach my $test (@tests) { # see if data was properly stored: disconnect, reconnect and test again undef $dbh; $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); -$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys"); +$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"); foreach my $test (@tests) { my ($pattern, @expected) = @$test; diff --git a/t/virtual_table/20_perldata.t b/t/virtual_table/20_perldata.t new file mode 100644 index 0000000..b16f8ce --- /dev/null +++ b/t/virtual_table/20_perldata.t @@ -0,0 +1,105 @@ +#!/usr/bin/perl +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; +use DBI qw(:sql_types); +use FindBin; + +our $perl_rows = [ + [1, 2, 'three'], + [4, 5, 'six' ], + [7, 8, 'nine' ], +]; + +plan tests => 24; + +my $dbh = connect_ok( RaiseError => 1, AutoCommit => 1 ); + +ok $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"), + "create_module"; + +#====================================================================== +# test the arrayrefs implementation +#====================================================================== + +ok $dbh->do(<<""), "create vtable"; + CREATE VIRTUAL TABLE vtb USING perl(a INT, b INT, c TEXT, + arrayrefs="main::perl_rows") + +my $sql = "SELECT * FROM vtb"; +my $res = $dbh->selectall_arrayref($sql, {Slice => {}}); +is scalar(@$res), 3, "got 3 rows"; +is $res->[0]{a}, 1, 'got 1 in a'; +is $res->[0]{b}, 2, 'got 2 in b'; + + +$sql = "SELECT * FROM vtb WHERE b < 8 ORDER BY a DESC"; +$res = $dbh->selectall_arrayref($sql, {Slice => {}}); +is scalar(@$res), 2, "got 2 rows"; +is $res->[0]{a}, 4, 'got 4 in first a'; +is $res->[1]{a}, 1, 'got 1 in second a'; + + +$sql = "SELECT rowid FROM vtb WHERE c = 'six'"; +$res = $dbh->selectall_arrayref($sql, {Slice => {}}); +is_deeply $res, [{rowid => 1}], $sql; + +$sql = "SELECT c FROM vtb WHERE c MATCH '^.i' ORDER BY c"; +$res = $dbh->selectcol_arrayref($sql); +is_deeply $res, [qw/nine six/], $sql; + + +$dbh->do("INSERT INTO vtb(a, b, c) VALUES (11, 22, 33)"); +my $row_id = $dbh->last_insert_id('', '', '', ''); +is $row_id, 3, 'new rowid is 3'; +is scalar(@$perl_rows), 4, 'perl_rows expanded'; +is_deeply $perl_rows->[-1], [11, 22, 33], 'new row is correct'; + + +#====================================================================== +# test the hashref implementation +#====================================================================== +our $perl_hrows = [ map {my %row; @row{qw/a b c/} = @$_; \%row} @$perl_rows]; + +ok $dbh->do(<<""), "create vtable"; + CREATE VIRTUAL TABLE temp.vtb2 USING perl(a INT, b INT, c TEXT, + hashrefs="main::perl_hrows") + +$sql = "SELECT * FROM vtb2 WHERE b < 8 ORDER BY a DESC"; +$res = $dbh->selectall_arrayref($sql, {Slice => {}}); +is scalar(@$res), 2, "got 2 rows"; +is $res->[0]{a}, 4, 'got 4 in first a'; +is $res->[1]{a}, 1, 'got 1 in second a'; + + +#====================================================================== +# test the colref implementation +#====================================================================== + +our $integers = [1 .. 10]; +ok $dbh->do(<<""), "create vtable intarray"; + CREATE VIRTUAL TABLE intarray USING perl(i INT, colref="main::integers") + +$sql = "SELECT i FROM intarray WHERE i BETWEEN 0 AND 5"; +$res = $dbh->selectcol_arrayref($sql); +is_deeply $res, [1 .. 5], $sql; + + +$sql = "INSERT INTO intarray VALUES (98), (99)"; +ok $dbh->do($sql), $sql; +is_deeply $integers, [1 .. 10, 98, 99], "added 2 ints"; + + +# test below inspired by sqlite "test_intarray.{h,c}) +$integers = [ 1, 7 ]; +$sql = "SELECT a FROM vtb WHERE a IN intarray"; +$res = $dbh->selectcol_arrayref($sql); +is_deeply $res, [ 1, 7 ], "intarray as a virtual table"; + From 9018a4683ce0bf32cd6bd9dfb64c794893678bf4 Mon Sep 17 00:00:00 2001 From: Laurent Dami Date: Fri, 11 Jul 2014 06:06:19 +0200 Subject: [PATCH 3/8] various code refactorings, completion of the doc --- dbdimp.c | 59 +- lib/DBD/SQLite.pm | 12 +- lib/DBD/SQLite/VirtualTable.pm | 707 ++++++++++++++++++--- lib/DBD/SQLite/VirtualTable/FileContent.pm | 286 ++++++--- lib/DBD/SQLite/VirtualTable/PerlData.pm | 163 +++-- t/virtual_table/00_base.t | 3 +- t/virtual_table/01_destroy.t | 14 +- t/virtual_table/10_filecontent.t | 8 +- t/virtual_table/11_filecontent_fulltext.t | 15 +- 9 files changed, 973 insertions(+), 294 deletions(-) diff --git a/dbdimp.c b/dbdimp.c index 0fac6b4..36bb26c 100644 --- a/dbdimp.c +++ b/dbdimp.c @@ -2950,8 +2950,8 @@ static int perl_vt_New(const char *method, /* check the return value */ if ( count != 1 ) { - *pzErr = sqlite3_mprintf("vtab->NEW() should return one value, got %d", - count ); + *pzErr = sqlite3_mprintf("vtab->%s() should return one value, got %d", + method, count ); SP -= count; /* Clear the stack */ goto cleanup; } @@ -2959,11 +2959,12 @@ static int perl_vt_New(const char *method, /* get the VirtualTable instance */ SV *perl_instance = POPs; if ( !sv_isobject(perl_instance) ) { - *pzErr = sqlite3_mprintf("vtab->NEW() should return a blessed reference"); + *pzErr = sqlite3_mprintf("vtab->%s() should return a blessed reference", + method); goto cleanup; } - /* call the ->DECLARE_VTAB() method */ + /* call the ->VTAB_TO_DECLARE() method */ PUSHMARK(SP); XPUSHs(perl_instance); PUTBACK; @@ -3047,12 +3048,12 @@ op2str(unsigned char op) { return "="; case SQLITE_INDEX_CONSTRAINT_GT: return ">"; - case SQLITE_INDEX_CONSTRAINT_LE: - return "<="; - case SQLITE_INDEX_CONSTRAINT_LT: - return "<"; case SQLITE_INDEX_CONSTRAINT_GE: return ">="; + case SQLITE_INDEX_CONSTRAINT_LT: + return "<"; + case SQLITE_INDEX_CONSTRAINT_LE: + return "<="; case SQLITE_INDEX_CONSTRAINT_MATCH: return "MATCH"; default: @@ -3081,7 +3082,7 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ } /* build the "order_by" datastructure */ - AV *order_by = newAV(); + AV *order_by = newAV(); for (i=0; inOrderBy; i++){ struct sqlite3_index_orderby const *pOrder = &pIdxInfo->aOrderBy[i]; HV *order = newHV(); @@ -3197,14 +3198,8 @@ static int perl_vt_Close(sqlite3_vtab_cursor *pVtabCursor){ SAVETMPS; int count; - /* call the close() method */ - PUSHMARK(SP); - XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); - PUTBACK; - count = call_method("CLOSE", G_VOID); - SPAGAIN; - SP -= count; - + /* Note : no call to a CLOSE() method; if needed, the Perl class + can implement a DESTROY() method */ perl_vtab_cursor *perl_pVTabCursor = (perl_vtab_cursor *) pVtabCursor; SvREFCNT_dec(perl_pVTabCursor->perl_cursor_instance); @@ -3542,8 +3537,12 @@ sqlite_db_destroy_module_data(void *pAux) int sqlite_db_create_module(pTHX_ SV *dbh, const char *name, const char *perl_class) { + dSP; + ENTER; + SAVETMPS; + D_imp_dbh(dbh); - int rc; + int count, rc, retval = TRUE; if (!DBIc_ACTIVE(imp_dbh)) { sqlite_error(dbh, -2, "attempt to create module on inactive database handle"); @@ -3553,7 +3552,7 @@ sqlite_db_create_module(pTHX_ SV *dbh, const char *name, const char *perl_class) /* load the module if needed */ char *module_ISA = sqlite3_mprintf("%s::ISA", perl_class); if (!get_av(module_ISA, 0)) { - char *loading_code = sqlite3_mprintf("require %s", perl_class); + char *loading_code = sqlite3_mprintf("use %s", perl_class); eval_pv(loading_code, TRUE); sqlite3_free(loading_code); } @@ -3566,20 +3565,34 @@ sqlite_db_create_module(pTHX_ SV *dbh, const char *name, const char *perl_class) sv_rvweaken(init_data->dbh); init_data->perl_class = sqlite3_mprintf(perl_class); - + /* register within sqlite */ rc = sqlite3_create_module_v2( imp_dbh->db, name, &perl_vt_Module, init_data, sqlite_db_destroy_module_data ); - if ( rc != SQLITE_OK ) { sqlite_error(dbh, rc, form("sqlite_create_module failed with error %s", sqlite3_errmsg(imp_dbh->db))); - return FALSE; + retval = FALSE; } - return TRUE; + + + /* call the CREATE_MODULE() method */ + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(perl_class, 0))); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + PUTBACK; + count = call_method("CREATE_MODULE", G_VOID); + SPAGAIN; + SP -= count; + + PUTBACK; + FREETMPS; + LEAVE; + + return retval; } diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm index 8efa7a5..663ee4e 100644 --- a/lib/DBD/SQLite.pm +++ b/lib/DBD/SQLite.pm @@ -2413,8 +2413,9 @@ tables but are implemented internally through specific functions. The fulltext or R* tree features described in the previous chapters are examples of such virtual tables, implemented in C code. -C also supports virtual tables implemented in Perl code: -see L. This can have many interesting uses +C also supports virtual tables implemented in I: +see L for using or implementing such +virtual tables. These can have many interesting uses for joining regular DBMS data with some other kind of data within your Perl programs. Bundled with the present distribution are : @@ -2423,13 +2424,13 @@ Perl programs. Bundled with the present distribution are : =item * L : implements a virtual -column that exposes content from files. This is especially useful -in conjuction with a fulltext index; see L. +column that exposes file contents. This is especially useful +in conjunction with a fulltext index; see L. =item * L : binds to a Perl array -within your main program. This can be used for simple import/export +within the Perl program. This can be used for simple import/export operations, for debugging purposes, for joining data from different sources, etc. @@ -2437,7 +2438,6 @@ sources, etc. Other Perl virtual tables may also be published separately on CPAN. - =head1 FOR DBD::SQLITE EXTENSION AUTHORS Since 1.30_01, you can retrieve the bundled sqlite C source and/or diff --git a/lib/DBD/SQLite/VirtualTable.pm b/lib/DBD/SQLite/VirtualTable.pm index 56ceff5..16376a8 100644 --- a/lib/DBD/SQLite/VirtualTable.pm +++ b/lib/DBD/SQLite/VirtualTable.pm @@ -1,6 +1,6 @@ -# TODO : fix bug with column name / type - +#====================================================================== package DBD::SQLite::VirtualTable; +#====================================================================== use strict; use warnings; use Scalar::Util qw/weaken/; @@ -12,21 +12,21 @@ our $VERSION = '0.01'; our @ISA; -sub DESTROY_MODULE { - my $class = shift; -} +#---------------------------------------------------------------------- +# methods for registering/destroying the module +#---------------------------------------------------------------------- -sub CREATE { - my $class = shift; - return $class->NEW(@_); -} +sub CREATE_MODULE { my ($class, $mod_name) = @_; } +sub DESTROY_MODULE { my ($class, $mod_name) = @_; } -sub CONNECT { - my $class = shift; - return $class->NEW(@_); -} +#---------------------------------------------------------------------- +# methods for creating/destroying instances +#---------------------------------------------------------------------- -sub NEW { # called when instanciating a virtual table +sub CREATE { my $class = shift; return $class->NEW(@_); } +sub CONNECT { my $class = shift; return $class->NEW(@_); } + +sub _PREPARE_SELF { my ($class, $dbh_ref, $module_name, $db_name, $vtab_name, @args) = @_; my @columns; @@ -44,7 +44,7 @@ sub NEW { # called when instanciating a virtual table } } - # build $self and initialize + # build $self my $self = { dbh_ref => $dbh_ref, module_name => $module_name, @@ -54,31 +54,15 @@ sub NEW { # called when instanciating a virtual table options => \%options, }; weaken $self->{dbh_ref}; - bless $self, $class; - $self->initialize(); return $self; } -sub dbh { - my $self = shift; - return ${$self->{dbh_ref}}; -} +sub NEW { + my $class = shift; - -sub initialize { - my $self = shift; -} - - - - -sub DROP { - my $self = shift; -} - -sub DISCONNECT { - my $self = shift; + my $self = $class->_PREPARE_SELF(@_); + bless $self, $class; } @@ -91,27 +75,27 @@ sub VTAB_TO_DECLARE { return $sql; } +sub DROP { my $self = shift; } +sub DISCONNECT { my $self = shift; } + + +#---------------------------------------------------------------------- +# methods for initiating a search +#---------------------------------------------------------------------- sub BEST_INDEX { my ($self, $constraints, $order_by) = @_; - # print STDERR Dump [BEST_INDEX => { - # where => $constraints, - # order => $order_by, - # }]; - my $ix = 0; - - foreach my $constraint (@$constraints) { - # TMP HACK -- should put real values instead + foreach my $constraint (grep {$_->{usable}} @$constraints) { $constraint->{argvIndex} = $ix++; $constraint->{omit} = 0; } - # TMP HACK -- should put real values instead + # stupid default values -- subclasses should put real values instead my $outputs = { idxNum => 1, - idxStr => "foobar", + idxStr => "", orderByConsumed => 0, estimatedCost => 1.0, estimatedRows => undef, @@ -126,11 +110,13 @@ sub OPEN { my $class = ref $self; my $cursor_class = $class . "::Cursor"; - return $cursor_class->NEW($self, @_); } +#---------------------------------------------------------------------- +# methods for insert/delete/update +#---------------------------------------------------------------------- sub _SQLITE_UPDATE { my ($self, $old_rowid, $new_rowid, @values) = @_; @@ -164,22 +150,41 @@ sub UPDATE { die "UPDATE() should be redefined in subclass"; } +#---------------------------------------------------------------------- +# remaining methods of the sqlite API +#---------------------------------------------------------------------- sub BEGIN_TRANSACTION {return 0} sub SYNC_TRANSACTION {return 0} sub COMMIT_TRANSACTION {return 0} sub ROLLBACK_TRANSACTION {return 0} - sub SAVEPOINT {return 0} sub RELEASE {return 0} sub ROLLBACK_TO {return 0} +sub FIND_METHOD {return 0} +sub RENAME {return 0} -sub DESTROY { + +#---------------------------------------------------------------------- +# utility methods +#---------------------------------------------------------------------- + +sub dbh { my $self = shift; + return ${$self->{dbh_ref}}; } +sub sqlite_table_info { + my $self = shift; + + my $sql = "PRAGMA table_info($self->{vtab_name})"; + return $self->dbh->selectall_arrayref($sql, {Slice => {}}); +} + +#====================================================================== package DBD::SQLite::VirtualTable::Cursor; +#====================================================================== use strict; use warnings; @@ -190,42 +195,13 @@ sub NEW { bless $self, $class; } -sub FILTER { - my ($self, $idxNum, $idxStr, @values) = @_; - - return; -} - - -sub EOF { - my ($self) = @_; - - # stupid implementation, to be redefined in subclasses - return 1; -} - - -sub NEXT { - my ($self) = @_; -} - - -sub COLUMN { - my ($self, $idxCol) = @_; -} - -sub ROWID { - my ($self) = @_; - - # stupid implementation, to be redefined in subclasses - return 1; -} - - -sub CLOSE { - my ($self) = @_; -} +# methods to be redefined in subclasses (here are stupid implementations) +sub FILTER { my ($self, $idxNum, $idxStr, @values) = @_; return } +sub EOF { my ($self) = @_; return 1 } +sub NEXT { my ($self) = @_; return } +sub COLUMN { my ($self, $idxCol) = @_; return } +sub ROWID { my ($self) = @_; return 1 } 1; @@ -234,23 +210,572 @@ __END__ =head1 NAME -DBD::SQLite::VirtualTable -- Abstract parent class for implementing virtual tables +DBD::SQLite::VirtualTable -- SQLite virtual tables implemented in Perl =head1 SYNOPSIS - package My::Virtual::Table; - use parent 'DBD::SQLite::VirtualTable'; - - sub ... + # register the virtual table module within sqlite + $dbh->sqlite_create_module(mod_name => "DBD::SQLite::VirtualTable::Subclass"); + + # create a virtual table + $dbh->do("CREATE VIRTUAL TABLE vtbl USING mod_name(arg1, arg2, ...)") + + # use it as any regular table + my $sth = $dbh->prepare("SELECT * FROM vtbl WHERE ..."); + +B : VirtualTable subclasses or instances are not called +directly from Perl code; everything happens indirectly through SQL +statements within SQLite. + =head1 DESCRIPTION -TODO +This module is an abstract class for implementing SQLite virtual tables, +written in Perl. Such tables look like regular tables, and are accessed +through regular SQL instructions and regular L API; but the implementation +is done through hidden calls to a Perl class. +This is the same idea as Perl's L, but +at the SQLite level. -=head1 METHODS +The current abstract class cannot be used directly, so the +synopsis above is just to give a general idea. Concrete, usable +classes bundled with the present distribution are : -TODO +=over +=item * + +L : implements a virtual +column that exposes file contents. This is especially useful +in conjunction with a fulltext index; see L. + +=item * + +L : binds to a Perl array +within the Perl program. This can be used for simple import/export +operations, for debugging purposes, for joining data from different +sources, etc. + +=back + +Other Perl virtual tables may also be published separately on CPAN. + +The following chapters document the structure of the abstract class +and explain how to write new subclasses; this is meant for +B, not for end users. If you just need to use a +virtual table module, refer to that module's documentation. + + +=head1 ARCHITECTURE + +=head2 Classes + +A virtual table module for SQLite is implemented through a pair +of classes : + +=over + +=item * + +the B class implements methods for creating or connecting +a virtual table, for destroying it, for opening new searches, etc. + +=item * + +the B class implements methods for performing a specific +SQL statement + +=back + + +=head2 Methods + +Most methods in both classes are not called directly from Perl +code : instead, they are callbacks, called from the sqlite kernel. +Following common Perl conventions, such methods have names in +uppercase. + + +=head1 TABLE METHODS + +=head2 Class methods for registering the module + +=head3 CREATE_MODULE + + $class->CREATE_MODULE($sqlite_module_name); + +Called when the client code invokes + + $dbh->sqlite_create_module($sqlite_module_name => $class); + +The default implementation is empty. + + +=head3 DESTROY_MODULE + + $class->DESTROY_MODULE(); + +Called automatically when the database handle is disconnected. +The default implementation is empty. + + +=head2 Class methods for creating a vtable instance + + +=head3 CREATE + + $class->CREATE($dbh_ref, $module_name, $db_name, $vtab_name, @args); + +Called when sqlite receives a statement + + CREATE VIRTUAL TABLE $db_name.$vtab_name USING $module_name(@args) + +The default implementation just calls L. + +=head3 CONNECT + + $class->CONNECT($dbh_ref, $module_name, $db_name, $vtab_name, @args); + +Called when attempting to access a virtual table that had been created +during previous database connection. The creation arguments were stored +within the sqlite database and are passed again to the CONNECT method. + +The default implementation just calls L. + + +=head3 _PREPARE_SELF + + $class->_PREPARE_SELF($dbh_ref, $module_name, $db_name, $vtab_name, @args); + +Prepares the datastructure for a virtual table instance. + C<@args> is just the collection +of strings (comma-separated) that were given within the +C statement; each subclass should decide +what to do with this information, + +The method parses C<@args> to differentiate between I +(strings of shape C<$key>=C<$value> or C<$key>=C<"$value">, stored in +C<< $self->{options} >>), and I (other C<@args>, stored in +C<< $self->{columns} >>). It creates a hashref with the following fields : + +=over + +=item C + +a weak reference to the C<$dbh> database handle (see +L for an explanation of weak references). + +=item C + +name of the module as declared to sqlite (not to be confounded +with the Perl class name). + +=item C + +name of the database (usuallly C<'main'> or C<'temp'>), but it +may also be an attached database + +=item C + +name of the virtual table + +=item C + +arrayref of column declarations + +=item C + +hashref of option declarations + +=back + +This method should not be redefined, since it performs +general work which is supposed to be useful for all subclasses. +Instead, subclasses may override the L method. + + +=head3 NEW + + $class->NEW($dbh_ref, $module_name, $db_name, $vtab_name, @args); + +Instantiates a virtual table. + + +=head2 Instance methods called from the sqlite kernel + + +=head3 DROP + +Called whenever a virtual table is destroyed from the +database through the C SQL instruction. + +Just after the C call, the Perl instance +will be destroyed (and will therefore automatically +call the C method if such a method is present). + +The default implementation for DROP is empty. + +B : this corresponds to the C method +in the SQLite documentation; here it was not named +C, to avoid any confusion with the standard +Perl method C for object destruction. + + +=head3 DISCONNECT + +Called for every virtual table just before the database handle +is disconnected. + +Just after the C call, the Perl instance +will be destroyed (and will therefore automatically +call the C method if such a method is present). + +The default implementation for DISCONNECT is empty. + +=head3 VTAB_TO_DECLARE + +This method is called automatically just after L or L, +to register the columns of the virtual table within the sqlite kernel. +The method should return a string containing a SQL C statement; +but only the column declaration parts will be considered (see +L). + +The default implementation returns: + + CREATE TABLE $self->{vtab_name}(@{$self->{columns}}) + +=head3 BEST_INDEX + + my $index_info = $vtab->BEST_INDEX($constraints, $order_by) + +This is the most complex method to redefined in subclasses. +This method will be called at the beginning of a new query on the +virtual table; the job of the method is to assemble some information +that will be used + +=over + +=item a) + +by the sqlite kernel to decide about the best search strategy + +=item b) + +by the cursor L method to produce the desired subset +of rows from the virtual table. + +=back + +By calling this method, the SQLite core is saying to the virtual table +that it needs to access some subset of the rows in the virtual table +and it wants to know the most efficient way to do that access. The +C method replies with information that the SQLite core can +then use to conduct an efficient search of the virtual table. + +The method takes as input a list of C<$constraints> and a list +of C<$order_by> instructions. It returns a hashref of indexing +properties, described below; furthermore, the method also adds +supplementary information within the input C<$constraints>. +Detailed explanations are given in +L. + +=head4 Input constraints + +Elements of the C<$constraints> arrayref correspond to +specific clauses of the C part of the SQL query. +Each constraint is a hashref with keys : + +=over + +=item C+ +the integer index of the column on the left-hand side of the constraint + +=item C + +the comparison operator, expressed as string containing +C<< '=' >>, C<< '>' >>, C<< '>=' >>, C<< '<' >>, C<< '<=' >> or C<< 'MATCH' >>. + +=item C + +a boolean indicating if that constraint is usable; some constraints +might not be usable because of the way tables are ordered in a join. + +=back + +The C<$constraints> arrayref is used both for input and for output. +While iterating over the array, the method should +add the following keys into usable constraints : + +=over + +=item C + +An index into the C<@values> array that will be passed to +the cursor's L method. In other words, if the current +constraint corresponds to the SQL fragment C, +and the corresponding C takes value 5, this means that +the C method will receive C<123> in C<$values[5]>. + +=item C + +A boolean telling to the sqlite core that it can safely omit +to double check that constraint before returning the resultset +to the calling program; this means that the FILTER method has fulfilled +the filtering job on that constraint and there is no need to do any +further checking. + +=back + +The C method will not necessarily receive all constraints +from the SQL C clause : for example a constraint like +C<< col1 < col2 + col3 >> cannot be handled at this level. +Furthemore, the C might decide to ignore some of the +received constraints. This is why a second pass over the results +will be performed by the sqlite core. + + +=head4 "order_by" input information + +The C<$order_by> arrayref corresponds to the C clauses +in the SQL query. Each entry is a hashref with keys : + +=over + +=item C+ +the integer index of the column being ordered + +=item C + +a boolean telling of the ordering is DESCending or ascending + +=back + +This information could be used by some subclasses for +optimizing the query strategfy; but usually the sqlite core will +perform another sorting pass once all results are gathered. + +=head4 Hashref information returned by BEST_INDEX + +The method should return a hashref with the following keys : + +=over + +=item C + +An arbitrary integer associated with that index; this information will +be passed back to L. + +=item C + +An arbitrary str associated with that index; this information will +be passed back to L. + +=item C + +A boolean telling the sqlite core if the C<$order_by> information +has been taken into account or not. + +=item C + +A float that should be set to the estimated number of disk access +operations required to execute this query against the virtual +table. The SQLite core will often call BEST_INDEX multiple times with +different constraints, obtain multiple cost estimates, then choose the +query plan that gives the lowest estimate. + +=item C + +An integer giving the estimated number of rows returned by that query. + +=back + + + +=head3 OPEN + +Called to instanciate a new cursor. +The default implementation appends C<"::Cursor"> to the current +classname and calls C within that cursor class. + +=head3 _SQLITE_UPDATE + +This is the dispatch method implementing the C callback +for virtual tables. The default implementation applies the algorithm +described in L to decide +to call L, L or L; so there is no reason +to override this method in subclasses. + +=head3 INSERT + + my $rowid = $vtab->INSERT($new_rowid, @values); + +This method should be overridden in subclasses to implement +insertion of a new row into the virtual table. +The size of the C<@values> array corresponds to the +number of columns declared through L. +The C<$new_rowid> may be explicitly given, or it may be +C, in which case the method must compute a new id +and return it as the result of the method call. + +=head3 DELETE + + $vtab->INSERT($old_rowid); + +This method should be overridden in subclasses to implement +deletion of a row from the virtual table. + +=head3 UPDATE + + $vtab->UPDATE($old_rowid, $new_rowid, @values); + +This method should be overridden in subclasses to implement +a row update within the virtual table. Usually C<$old_rowid> is equal +to C<$new_rowid>, which is a regular update; however, the rowid +could be changed from a SQL statement such as + + UPDATE table SET rowid=rowid+1 WHERE ...; + +=head3 BEGIN_TRANSACTION + +Called to begin a transaction on the virtual table. + +=head3 SYNC_TRANSACTION + +Called to signal the start of a two-phase commit on the virtual table. + +=head3 SYNC_TRANSACTION + +Called to commit a virtual table transaction. + +=head3 ROLLBACK_TRANSACTION + +Called to rollback a virtual table transaction. + +=head3 RENAME + + $vtab->RENAME($new_name) + +Called to rename a virtual table. + +=head3 SAVEPOINT + + $vtab->SAVEPOINT($savepoint) + +Called to signal the virtual table to save its current state +at savepoint C<$savepoint> (an integer). + +=head3 ROLLBACK_TO + + $vtab->ROLLBACK_TO($savepoint) + +Called to signal the virtual table to return to the state +C<$savepoint>. This will invalidate all savepoints with values +greater than C<$savepoint>. + +=head3 RELEASE + + $vtab->RELEASE($savepoint) + +Called to invalidate all savepoints with values +greater or equal to C<$savepoint>. + + +=head2 Utility instance methods + +Methods in this section are in lower case, because they +are not called directly from the sqlite kernel; these +are utility methods to be called from other methods +described above. + +=head3 dbh + +This method returns the database handle (C<$dbh>) associated with +the current virtual table. + + +=head1 CURSOR METHODS + +=head2 Class methods + +=head3 NEW + + my $cursor = $cursor_class->NEW($vtable, @args) + +Instanciates a new cursor. +The default implementation just returns a blessed hashref +with keys C and C. + +=head2 Instance methods + +=head3 FILTER + + $cursor->FILTER($idxNum, $idxStr, @values); + +This method begins a search of a virtual table. + +The C<$idxNum> and C<$idxStr> arguments correspond to values returned +by L for the chosen index. The specific meanings of +those values are unimportant to SQLite, as long as C and +C agree on what that meaning is. + +The C method may have requested the values of certain +expressions using the C values of the +C<$constraints> list. Those values are passed to C through +the C<@values> array. + +If the virtual table contains one or more rows that match the search +criteria, then the cursor must be left point at the first +row. Subsequent calls to L must return false. If there are +no rows match, then the cursor must be left in a state that will cause +L to return true. The SQLite engine will use the +L and L methods to access that row content. The L +method will be used to advance to the next row. + + +=head3 EOF + +This method must return false if the cursor currently points to a +valid row of data, or true otherwise. This method is called by the SQL +engine immediately after each L and L invocation. + +=head3 NEXT + +This method advances the cursor to the next row of a +result set initiated by L. If the cursor is already pointing at +the last row when this method is called, then the cursor no longer +points to valid data and a subsequent call to the L method must +return true. If the cursor is successfully advanced to +another row of content, then subsequent calls to L must return +false. + +=head3 COLUMN + + my $value = $cursor->COLUMN($idxCol); + +The SQLite core invokes this method in order to find the value for the +N-th column of the current row. N is zero-based so the first column is +numbered 0. + +=head3 ROWID + + my $value = $cursor->ROWID; + +Returns the I of row that the cursor is currently pointing at. + + +=head1 SEE ALSO + +L is another module for virtual tables written +in Perl, but designed for the reverse use case : instead of starting a +Perl program, and embedding the SQLite library into it, the intended +use is to start an sqlite program, and embed the Perl interpreter +into it. + +=head1 AUTHOR + +Laurent Dami Edami@cpan.orgE =head1 COPYRIGHT AND LICENSE diff --git a/lib/DBD/SQLite/VirtualTable/FileContent.pm b/lib/DBD/SQLite/VirtualTable/FileContent.pm index 7e4e3a2..d01fce8 100644 --- a/lib/DBD/SQLite/VirtualTable/FileContent.pm +++ b/lib/DBD/SQLite/VirtualTable/FileContent.pm @@ -1,92 +1,104 @@ +#====================================================================== package DBD::SQLite::VirtualTable::FileContent; +#====================================================================== use strict; use warnings; use base 'DBD::SQLite::VirtualTable'; +use List::MoreUtils qw/none/; + +my %option_ok = map {($_ => 1)} qw/source content_col path_col + expose root get_content/; + +my %defaults = ( + content_col => "content", + path_col => "path", + expose => "*", + get_content => "DBD::SQLite::VirtualTable::FileContent::get_content", +); -=head1 NAME +#---------------------------------------------------------------------- +# object instanciation +#---------------------------------------------------------------------- -DBD::SQLite::VirtualTable::FileContent -- virtual table for viewing file contents +sub NEW { + my $class = shift; + my $self = $class->_PREPARE_SELF(@_); -=head1 SYNOPSIS + local $" = ", "; # for array interpolation in strings - -- $dbh->sqlite_create_module(filesys => "DBD::SQLite::VirtualTable::FileContent"); + # initial parameter check + !@{$self->{columns}} + or die "${class}->NEW(): illegal options: @{$self->{columns}}"; + $self->{options}{source} + or die "${class}->NEW(): missing (source=...)"; + my @bad_options = grep {!$option_ok{$_}} keys %{$self->{options}}; + !@bad_options + or die "${class}->NEW(): bad options: @bad_options"; - CREATE VIRTUAL TABLE tbl USING filesys(file_content, - index_table = idx, - path_col = path, - expose = "path, col1, col2, col3", - root = "/foo/bar") - - - -- OR : expose = * - -=head1 DESCRIPTION - -A "FileContent" virtual table is like a database view on some underlying -I, which has a column containing paths to -files; the virtual table then adds a supplementary column which exposes -the content from those files. - -This is especially useful as an "external content" to some -fulltext table (see L) : the index -table stores some metadata about files, and then the fulltext engine -can index both the metadata and the file contents. - -=head1 METHODS - -=head2 new - - -=cut - - -sub initialize { - my $self = shift; - - # verifications - @{$self->{columns}} == 1 - or die "FileContent virtual table should declare exactly 1 content column"; - for my $opt (qw/index_table path_col/) { - $self->{options}{$opt} - or die "FileContent virtual table: option '$opt' is missing"; + # defaults ... tempted to use //= but we still want to support perl 5.8 :-( + foreach my $k (keys %defaults) { + defined $self->{options}{$k} + or $self->{options}{$k} = $defaults{$k}; } - # get list of columns from the index table - my $ix_table = $self->{options}{index_table}; - my $sql = "PRAGMA table_info($ix_table)"; - my $base_cols = $self->dbh->selectcol_arrayref($sql, {Columns => [2]}); - @$base_cols - or die "wrong index table: $ix_table"; + # get list of columns from the source table + my $src_table = $self->{options}{source}; + my $sql = "PRAGMA table_info($src_table)"; + my $dbh = ${$self->{dbh_ref}}; # can't use method ->dbh, not blessed yet + my $src_info = $dbh->selectall_arrayref($sql, {Slice => [1, 2]}); + @$src_info + or die "${class}->NEW(source=$src_table): no such table in database"; + + # associate each source colname with its type info or " " (should eval true) + my %src_col = map { ($_->[0] => $_->[1] || " ") } @$src_info; + # check / complete the exposed columns - $self->{options}{expose} = "*" if not exists $self->{options}{expose}; my @exposed_cols; if ($self->{options}{expose} eq '*') { - @exposed_cols = @$base_cols; + @exposed_cols = map {$_->[0]} @$src_info; } else { - @exposed_cols = split /\s*,\s*/, ($self->{options}{expose} || ""); - my %is_ok_col = map {$_ => 1} @$base_cols; - my @bad_cols = grep {!$is_ok_col{$_}} @exposed_cols; - local $" = ", "; - die "table $ix_table has no column named @bad_cols" if @bad_cols; + @exposed_cols = split /\s*,\s*/, $self->{options}{expose}; + my @bad_cols = grep { !$src_col{$_} } @exposed_cols; + die "table $src_table has no column named @bad_cols" if @bad_cols; } - push @{$self->{columns}}, @exposed_cols; + none {$_ eq $self->{options}{content_col}} @exposed_cols + or die "$class: $self->{options}{content_col} cannot be both the " + . "content_col and an exposed col"; + + # build the list of columns for this table + $self->{columns} = [ "$self->{options}{content_col} TEXT", + map {"$_ $src_col{$_}"} @exposed_cols ]; + + # acquire a coderef to the get_content() implementation + no strict 'refs'; + $self->{get_content} = \ &{$self->{options}{get_content}}; + + bless $self, $class; +} + +sub _build_headers { + my $self = shift; + + my $cols = $self->sqlite_table_info; + + # headers : names of columns, without type information + $self->{headers} = [ map {$_->{name}} @$cols ]; } -sub _SQLITE_UPDATE { - my ($self, $old_rowid, $new_rowid, @values) = @_; - - die "readonly database"; -} - +#---------------------------------------------------------------------- +# method for initiating a search +#---------------------------------------------------------------------- sub BEST_INDEX { my ($self, $constraints, $order_by) = @_; + $self->_build_headers if !$self->{headers}; + my @conditions; my $ix = 0; foreach my $constraint (grep {$_->{usable}} @$constraints) { @@ -96,12 +108,14 @@ sub BEST_INDEX { next if $col == 0; # for other columns, build a fragment for SQL WHERE on the underlying table - my $colname = $col == -1 ? "rowid" : $self->{columns}[$col]; + my $colname = $col == -1 ? "rowid" : $self->{headers}[$col]; push @conditions, "$colname $constraint->{op} ?"; $constraint->{argvIndex} = $ix++; $constraint->{omit} = 1; # SQLite doesn't need to re-check the op } + # TODO : exploit $order_by to add ordering clauses within idxStr + my $outputs = { idxNum => 1, idxStr => join(" AND ", @conditions), @@ -113,8 +127,46 @@ sub BEST_INDEX { return $outputs; } + +#---------------------------------------------------------------------- +# method for preventing updates +#---------------------------------------------------------------------- + +sub _SQLITE_UPDATE { + my ($self, $old_rowid, $new_rowid, @values) = @_; + + die "attempt to update a readonly virtual table"; +} + + +#---------------------------------------------------------------------- +# file slurping function (not a method!) +#---------------------------------------------------------------------- + +sub get_content { + my ($path, $root) = @_; + + $path = "$root/$path" if $root; + + my $content = ""; + if (open my $fh, "<", $path) { + local $/; # slurp the whole file into a scalar + $content = <$fh>; + close $fh; + } + else { + warn "can't open $path"; + } + + return $content; +} + + + + +#====================================================================== package DBD::SQLite::VirtualTable::FileContent::Cursor; -use 5.010; +#====================================================================== use strict; use warnings; use base "DBD::SQLite::VirtualTable::Cursor"; @@ -127,10 +179,10 @@ sub FILTER { # build SQL local $" = ", "; - my @cols = @{$vtable->{columns}}; + my @cols = @{$vtable->{headers}}; $cols[0] = 'rowid'; # replace the content column by the rowid push @cols, $vtable->{options}{path_col}; # path col in last position - my $sql = "SELECT @cols FROM $vtable->{options}{index_table}"; + my $sql = "SELECT @cols FROM $vtable->{options}{source}"; $sql .= " WHERE $idxStr" if $idxStr; # request on the index table @@ -175,35 +227,107 @@ sub file_content { my $root = $self->{vtable}{options}{root}; my $path = $self->{row}[-1]; - $path = "$root/$path" if $root; - my $content = ""; - if (open my $fh, "<", $path) { - local $/; # slurp the whole file into a scalar - $content = <$fh>; - close $fh; - } - else { - warn "can't open $path"; - } - - return $content; + return $self->{vtable}{get_content}->($path, $root); } + 1; __END__ +=head1 NAME +DBD::SQLite::VirtualTable::FileContent -- virtual table for viewing file contents + + +=head1 SYNOPSIS + +Within Perl : + + $dbh->sqlite_create_module(fcontent => "DBD::SQLite::VirtualTable::FileContent"); + +Then, within SQL : + + CREATE VIRTUAL TABLE tbl USING fcontent( + source = src_table, + content_col = content, + path_col = path, + expose = "path, col1, col2, col3", -- or "*" + root = "/foo/bar" + get_content = Foo::Bar::read_from_file + ); + + SELECT col1, path, content FROM tbl WHERE ...; + +=head1 DESCRIPTION + +A "FileContent" virtual table is bound to some underlying I, which has a column containing paths to files. The virtual +table behaves like a database view on the source table, with an added +column which exposes the content from those files. + +This is especially useful as an "external content" to some +fulltext table (see L) : the index +table stores some metadata about files, and then the fulltext engine +can index both the metadata and the file contents. + +=head1 PARAMETERS + +Parameters for creating a C virtual table are +specified within the C statement, just +like regular column declarations, but with an '=' sign. +Authorized parameters are : + +=over + +=item C + +The name of the I. +This parameter is mandatory. All other parameters are optional. + +=item C + +The name of the virtual column exposing file contents. +The default is C. + +=item C + +The name of the column in C that contains paths to files. +The default is C. + +=item C + +A comma-separated list (within double quotes) of source column names +to be exposed by the virtual table. The default is C<"*">, which means +all source columns. + +=item C + +An optional root directory that will be prepended to the I column +when opening files. + +=item C + +Fully qualified name of a Perl function for reading file contents. +The default implementation just slurps the entire file into a string; +but this hook can point to more sophisticated implementations, like for +example a function that would remove html tags. The hooked function is +called like this : + + $file_content = $get_content->($path, $root); + +=back + +=head1 AUTHOR + +Laurent Dami Edami@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright Laurent Dami, 2014. -Parts of the code are borrowed from L, -copyright (C) 2006, 2009 by Qindel Formacion y Servicios, S. L. - This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/DBD/SQLite/VirtualTable/PerlData.pm b/lib/DBD/SQLite/VirtualTable/PerlData.pm index cd30c6e..5e3f15c 100644 --- a/lib/DBD/SQLite/VirtualTable/PerlData.pm +++ b/lib/DBD/SQLite/VirtualTable/PerlData.pm @@ -1,40 +1,12 @@ +#====================================================================== package DBD::SQLite::VirtualTable::PerlData; +#====================================================================== use strict; use warnings; use base 'DBD::SQLite::VirtualTable'; use List::MoreUtils qw/mesh/; -=head1 NAME - -DBD::SQLite::VirtualTable::PerlData -- virtual table for connecting to perl data - - -=head1 SYNOPSIS - - -- $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"); - - CREATE VIRTUAL TABLE tbl USING perl(foo, bar, etc, - arrayrefs="some_global_variable") - - CREATE VIRTUAL TABLE tbl USING perl(foo, bar, etc, - hashrefs="some_global_variable") - - CREATE VIRTUAL TABLE tbl USING perl(single_col - colref="some_global_variable") - - -=head1 DESCRIPTION - - -=head1 METHODS - -=head2 new - -=cut - - - # private data for translating comparison operators from Sqlite to Perl my $TXT = 0; my $NUM = 1; @@ -48,10 +20,13 @@ my %SQLOP2PERLOP = ( 'MATCH' => [ '=~', '=~' ], ); +#---------------------------------------------------------------------- +# instanciation methods +#---------------------------------------------------------------------- -sub initialize { - my $self = shift; - my $class = ref $self; +sub NEW { + my $class = shift; + my $self = $class->_PREPARE_SELF(@_); # verifications my $n_cols = @{$self->{columns}}; @@ -68,36 +43,33 @@ sub initialize { no strict "refs"; defined ${$symbolic_ref} or die "$class: can't find global variable \$$symbolic_ref"; - $self->{rows} = \${$symbolic_ref}; + $self->{rows} = \ ${$symbolic_ref}; + + bless $self, $class; } - -sub initialize_bis { +sub _build_headers_optypes { my $self = shift; - # the code below cannot happen within initialize() because VTAB_TO_DECLARE() - # has not been called until the end of NEW(). So we do it here, which is - # called lazily at the first invocation if BEST_INDEX(). + my $cols = $self->sqlite_table_info; - # get names and types of columns after they have been parsed by sqlite - my $sth = $self->dbh->prepare("PRAGMA table_info($self->{vtab_name})"); - $sth->execute; + # headers : names of columns, without type information + $self->{headers} = [ map {$_->{name}} @$cols ]; - # build private data 'headers' and 'optypes' - while (my $row = $sth->fetch) { - my ($colname, $coltype) = @{$row}[1, 2]; - push @{$self->{headers}}, $colname; - - # apply algorithm from datatype3.html" for type affinity - push @{$self->{optypes}}, $coltype =~ /INT|REAL|FLOA|DOUB/i ? $NUM : $TXT; - } + # optypes : either $NUM or $TEXT for each column + # (applying algorithm from datatype3.html" for type affinity) + $self->{optypes} + = [ map {$_->{type} =~ /INT|REAL|FLOA|DOUB/i ? $NUM : $TXT} @$cols ]; } +#---------------------------------------------------------------------- +# method for initiating a search +#---------------------------------------------------------------------- sub BEST_INDEX { my ($self, $constraints, $order_by) = @_; - $self->initialize_bis if not exists $self->{headers}; + $self->_build_headers_optypes if !$self->{headers}; # for each constraint, build a Perl code fragment. Those will be gathered # in FILTER() for deciding which rows match the constraints. @@ -107,8 +79,8 @@ sub BEST_INDEX { my $col = $constraint->{col}; my ($member, $optype); - # build a Perl code fragment. Those will be gathered - # in FILTER() for deciding which rows match the constraints. + # build a Perl code fragment. Those fragments will be gathered + # and eval-ed in FILTER(), for deciding which rows match the constraints. if ($col == -1) { # constraint on rowid $member = '$i'; @@ -126,12 +98,12 @@ sub BEST_INDEX { my $quote = $op eq '=~' ? 'qr' : 'q'; push @conditions, "($member $op ${quote}{%s})"; - # info passed back to the sqlite kernel -- see vtab.html in sqlite doc + # info passed back to the SQLite core -- see vtab.html in sqlite doc $constraint->{argvIndex} = $ix++; $constraint->{omit} = 1; } - # further info for the sqlite kernel + # further info for the SQLite core my $outputs = { idxNum => 1, idxStr => (join(" && ", @conditions) || "1"), @@ -144,6 +116,10 @@ sub BEST_INDEX { } +#---------------------------------------------------------------------- +# methods for data update +#---------------------------------------------------------------------- + sub _build_new_row { my ($self, $values) = @_; @@ -191,10 +167,9 @@ sub UPDATE { } - - +#====================================================================== package DBD::SQLite::VirtualTable::PerlData::Cursor; -use 5.010; +#====================================================================== use strict; use warnings; use base "DBD::SQLite::VirtualTable::Cursor"; @@ -211,8 +186,6 @@ sub FILTER { # build a method coderef to fetch matching rows my $perl_code = sprintf "sub {my (\$self, \$i) = \@_; $idxStr}", @values; -# print STDERR "PERL $perl_code\n"; - $self->{is_wanted_row} = eval $perl_code or die "couldn't eval q{$perl_code} : $@"; @@ -263,24 +236,74 @@ __END__ =head1 NAME -DBD::SQLite::VirtualTable -- Abstract parent class for implementing virtual tables +DBD::SQLite::VirtualTable::PerlData -- virtual table hooked to Perl data =head1 SYNOPSIS - package My::Virtual::Table; - use parent 'DBD::SQLite::VirtualTable'; - - sub ... +Within Perl : + + $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"); + +Then, within SQL : + + + CREATE VIRTUAL TABLE atbl USING perl(foo, bar, etc, + arrayrefs="some::global::var::aref") + + CREATE VIRTUAL TABLE htbl USING perl(foo, bar, etc, + hashrefs="some::global::var::href") + + CREATE VIRTUAL TABLE ctbl USING perl(single_col + colref="some::global::var::ref") + + + SELECT foo, bar FROM atbl WHERE ...; + =head1 DESCRIPTION -TODO - -=head1 METHODS - -TODO +A C virtual table is a database view on some datastructure +within a Perl program. The data can be read or modified both from SQL +and from Perl. This is useful for simple import/export +operations, for debugging purposes, for joining data from different +sources, etc. +=head1 PARAMETERS + +Parameters for creating a C virtual table are specified +within the C statement, mixed with regular +column declarations, but with an '=' sign. + +The only authorized (and mandatory) parameter is the one that +specifies the Perl datastructure to which the virtual table is bound. +The Perl data must be given as a fully qualified name of a global variable; +it can be one of three different kinds : + +=over + +=item C + +arrayref that contains an arrayref for each row + +=item C + +arrayref that contains a hashref for each row + +=item C + +arrayref that contains a single scalar for each row +(obviously this is a single-column virtual table) + +=back + +=head1 USAGE + +[TODO] + +=head1 AUTHOR + +Laurent Dami Edami@cpan.orgE =head1 COPYRIGHT AND LICENSE diff --git a/t/virtual_table/00_base.t b/t/virtual_table/00_base.t index 6c8f7c1..89c20e1 100644 --- a/t/virtual_table/00_base.t +++ b/t/virtual_table/00_base.t @@ -29,6 +29,7 @@ is $rows->[0]{bar}, "auto_vivify:1", "bar column"; $sql = "SELECT * FROM foobar "; $rows = $dbh->selectall_arrayref($sql, {Slice => {}}); is scalar(@$rows), 5, "got 5 rows again"; + is_deeply([sort keys %{$rows->[0]}], [qw/bar foo/], "col list OK"); @@ -43,7 +44,7 @@ use warnings; use base 'DBD::SQLite::VirtualTable'; use YAML; -sub initialize { +sub INITIALIZE { my $self = shift; # stupid pragma call, just to check that the dbh is OK $self->dbh->do("PRAGMA application_id=999"); diff --git a/t/virtual_table/01_destroy.t b/t/virtual_table/01_destroy.t index 75e71c5..0e15205 100644 --- a/t/virtual_table/01_destroy.t +++ b/t/virtual_table/01_destroy.t @@ -9,24 +9,25 @@ use t::lib::Test qw/connect_ok/; use Test::More; use Test::NoWarnings; -plan tests => 23; +plan tests => 20; my $dbfile = "tmp.sqlite"; my $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); -ok !$DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, "no vtab initialized"; +ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT && + !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab created"; # create 2 separate SQLite modules from the same Perl class $dbh->sqlite_create_module(vtab1 => "DBD::SQLite::VirtualTable::T"); $dbh->sqlite_create_module(vtab2 => "DBD::SQLite::VirtualTable::T"); -ok !$DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, "still no vtab"; +ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT && + !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "still no vtab"; # create 2 virtual tables from module vtab1 ok $dbh->do("CREATE VIRTUAL TABLE foobar USING vtab1(foo, bar)"), "create foobar"; ok $dbh->do("CREATE VIRTUAL TABLE barfoo USING vtab1(foo, bar)"), "create barfoo"; is $DBD::SQLite::VirtualTable::T::CREATE_COUNT, 2, "2 vtab created"; ok !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab connected"; -is $DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, 2, "2 vtab initialized"; # destructor is called when a vtable is dropped ok !$DBD::SQLite::VirtualTable::T::DESTROY_COUNT, "no vtab destroyed"; @@ -43,18 +44,15 @@ is $DBD::SQLite::VirtualTable::T::DESTROY_MODULE_COUNT, 2, "2 modules destroyed" # reconnect, check that we go through the CONNECT method undef $DBD::SQLite::VirtualTable::T::CREATE_COUNT; undef $DBD::SQLite::VirtualTable::T::CONNECT_COUNT; -undef $DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT; $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); $dbh->sqlite_create_module(vtab1 => "DBD::SQLite::VirtualTable::T"); ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created"; ok !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab connected"; -ok !$DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, "no vtab initialized"; my $sth = $dbh->prepare("SELECT * FROM barfoo"); ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created"; is $DBD::SQLite::VirtualTable::T::CONNECT_COUNT, 1, "1 vtab connected"; -is $DBD::SQLite::VirtualTable::T::INITIALIZE_COUNT, 1, "1 vtab initialized"; package DBD::SQLite::VirtualTable::T; @@ -62,7 +60,6 @@ use base 'DBD::SQLite::VirtualTable'; our $CREATE_COUNT; our $CONNECT_COUNT; -our $INITIALIZE_COUNT; our $DESTROY_COUNT; our $DESTROY_MODULE_COUNT; our $DROP_COUNT; @@ -70,7 +67,6 @@ our $DISCONNECT_COUNT; sub CREATE {$CREATE_COUNT++; return shift->SUPER::CREATE(@_)} sub CONNECT {$CONNECT_COUNT++; return shift->SUPER::CONNECT(@_)} -sub initialize {$INITIALIZE_COUNT++} sub DROP {$DROP_COUNT++} sub DISCONNECT {$DISCONNECT_COUNT++} sub DESTROY {$DESTROY_COUNT++} diff --git a/t/virtual_table/10_filecontent.t b/t/virtual_table/10_filecontent.t index 603d112..4b9fae7 100644 --- a/t/virtual_table/10_filecontent.t +++ b/t/virtual_table/10_filecontent.t @@ -34,11 +34,9 @@ ok $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"), ok $dbh->do(<<""), "create vtable"; - CREATE VIRTUAL TABLE vfs USING fs(content, - index_table = base, - path_col = path, - expose = "path, foo, bar", - root = "$FindBin::Bin") + CREATE VIRTUAL TABLE vfs USING fs(source = base, + expose = "path, foo, bar", + root = "$FindBin::Bin") my $sql = "SELECT content, bar, rowid FROM vfs WHERE foo='foo2'"; my $rows = $dbh->selectall_arrayref($sql, {Slice => {}}); diff --git a/t/virtual_table/11_filecontent_fulltext.t b/t/virtual_table/11_filecontent_fulltext.t index def5b7d..8b6c577 100644 --- a/t/virtual_table/11_filecontent_fulltext.t +++ b/t/virtual_table/11_filecontent_fulltext.t @@ -46,22 +46,20 @@ my @perl_files = grep {/\.(pl|pm|pod)$/} @files; # open database my $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); -# create index table +# create the source table and populate it $dbh->do("CREATE TABLE files (id INTEGER PRIMARY KEY, path TEXT)"); my $sth = $dbh->prepare("INSERT INTO files(path) VALUES (?)"); $sth->execute($_) foreach @perl_files; -# create vtab table +# create the virtual table $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"); $dbh->do(<<""); - CREATE VIRTUAL TABLE vfs USING fs(content, - index_table = files, - path_col = path, - expose = "path", - root = "$distrib_dir") + CREATE VIRTUAL TABLE vfs USING fs(source = files, + expose = "path", + root = "$distrib_dir") -# create fts table +# create the fulltext indexing table and populate it $dbh->do('CREATE VIRTUAL TABLE fts USING fts4(content="vfs")'); note "building fts index...."; $dbh->do("INSERT INTO fts(fts) VALUES ('rebuild')"); @@ -89,6 +87,7 @@ foreach my $test (@tests) { } # see if data was properly stored: disconnect, reconnect and test again +$dbh->disconnect; undef $dbh; $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"); From bf65db231fea175d3acde0b23c098315490c370f Mon Sep 17 00:00:00 2001 From: Laurent Dami Date: Sat, 12 Jul 2014 08:20:19 +0200 Subject: [PATCH 4/8] various fixes / improvements --- lib/DBD/SQLite.pm | 7 + lib/DBD/SQLite/VirtualTable/FileContent.pm | 1 - lib/DBD/SQLite/VirtualTable/PerlData.pm | 189 ++++++++++++++++++--- t/virtual_table/00_base.t | 5 +- t/virtual_table/10_filecontent.t | 1 - t/virtual_table/20_perldata.t | 22 ++- 6 files changed, 193 insertions(+), 32 deletions(-) diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm index 663ee4e..360886f 100644 --- a/lib/DBD/SQLite.pm +++ b/lib/DBD/SQLite.pm @@ -2160,6 +2160,13 @@ Returns a hash reference that holds a set of status information of SQLite statem You may also pass 0 as an argument to reset the status. +=head2 $sth->sqlite_create_module() + +Registers a name for a I. Module names must be +registered before creating a new virtual table using the module and +before using a preexisting virtual table for the module. +Virtual tables are explained in L. + =head1 DRIVER CONSTANTS A subset of SQLite C constants are made available to Perl, diff --git a/lib/DBD/SQLite/VirtualTable/FileContent.pm b/lib/DBD/SQLite/VirtualTable/FileContent.pm index d01fce8..5b45c61 100644 --- a/lib/DBD/SQLite/VirtualTable/FileContent.pm +++ b/lib/DBD/SQLite/VirtualTable/FileContent.pm @@ -163,7 +163,6 @@ sub get_content { - #====================================================================== package DBD::SQLite::VirtualTable::FileContent::Cursor; #====================================================================== diff --git a/lib/DBD/SQLite/VirtualTable/PerlData.pm b/lib/DBD/SQLite/VirtualTable/PerlData.pm index 5e3f15c..e6ba8a6 100644 --- a/lib/DBD/SQLite/VirtualTable/PerlData.pm +++ b/lib/DBD/SQLite/VirtualTable/PerlData.pm @@ -87,12 +87,13 @@ sub BEST_INDEX { $optype = $NUM; } else { - my $get_col = $self->{options}{arrayrefs} ? "->[$col]" - : $self->{options}{hashrefs} ? "->{$self->{headers}[$col]}" - : $self->{options}{colref} ? "" - : die "corrupted data in ->{options}"; - $member = '$self->row($i)' . $get_col; - $optype = $self->{optypes}[$col]; + # cnstraint on regular column + my $opts = $self->{options}; + $member = $opts->{arrayrefs} ? "\$row->[$col]" + : $opts->{hashrefs} ? "\$row->{$self->{headers}[$col]}" + : $opts->{colref} ? "\$row" + : die "corrupted data in ->{options}"; + $optype = $self->{optypes}[$col]; } my $op = $SQLOP2PERLOP{$constraint->{op}}[$optype]; my $quote = $op eq '=~' ? 'qr' : 'q'; @@ -123,10 +124,11 @@ sub BEST_INDEX { sub _build_new_row { my ($self, $values) = @_; - return $self->{options}{arrayrefs} ? $values - : $self->{options}{hashrefs} ? { mesh @{$self->{headers}}, @$values } - : $self->{options}{colref} ? $values->[0] - : die "corrupted data in ->{options}"; + my $opts = $self->{options}; + return $opts->{arrayrefs} ? $values + : $opts->{hashrefs} ? { mesh @{$self->{headers}}, @$values } + : $opts->{colref} ? $values->[0] + : die "corrupted data in ->{options}"; } @@ -183,8 +185,15 @@ sub row { sub FILTER { my ($self, $idxNum, $idxStr, @values) = @_; + # escape '\' and '}' in values before they are sprintf'ed into q{%s} + s/\\/\\\\/g, s/}/\\}/g foreach @values; + # build a method coderef to fetch matching rows - my $perl_code = sprintf "sub {my (\$self, \$i) = \@_; $idxStr}", @values; + my $perl_code = 'sub {my ($self, $i) = @_; my $row = $self->row($i); ' + . sprintf($idxStr, @values) + . '}'; + + # print STDERR $perl_code, "\n"; $self->{is_wanted_row} = eval $perl_code or die "couldn't eval q{$perl_code} : $@"; @@ -215,12 +224,11 @@ sub COLUMN { my $row = $self->row($self->{row_ix}); - - return $self->{vtable}{options}{arrayrefs} ? $row->[$idxCol] - : $self->{vtable}{options}{hashrefs} ? - $row->{$self->{vtable}{headers}[$idxCol]} - : $self->{vtable}{options}{colref} ? $row - : die "corrupted data in ->{options}"; + my $opts = $self->{vtable}{options}; + return $opts->{arrayrefs} ? $row->[$idxCol] + : $opts->{hashrefs} ? $row->{$self->{vtable}{headers}[$idxCol]} + : $opts->{colref} ? $row + : die "corrupted data in ->{options}"; } sub ROWID { @@ -277,29 +285,162 @@ column declarations, but with an '=' sign. The only authorized (and mandatory) parameter is the one that specifies the Perl datastructure to which the virtual table is bound. -The Perl data must be given as a fully qualified name of a global variable; -it can be one of three different kinds : +It must be given as the fully qualified name of a global variable; +the parameter can be one of three different kinds : =over =item C -arrayref that contains an arrayref for each row +arrayref that contains an arrayref for each row. +Each such row will have a size equivalent to the number +of columns declared for the virtual table. =item C -arrayref that contains a hashref for each row +arrayref that contains a hashref for each row. +Keys in each hashref should correspond to the +columns declared for the virtual table. =item C -arrayref that contains a single scalar for each row -(obviously this is a single-column virtual table) +arrayref that contains a single scalar for each row; +obviously, this is a single-column virtual table. =back =head1 USAGE -[TODO] +=head2 Common part of all examples : declaring the module + +In all examples below, the common part is that the Perl +program should connect to the database and then declare the +C virtual table module, like this + + # connect to the database + my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", '', '', + {RaiseError => 1, AutoCommit => 1}); + # or any other options suitable to your needs + + # register the module + $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"); + +Then create a global arrayref variable, using C instead of C, +so that the variable is stored in the symbol table of the enclosing module. + + package Foo::Bar; # could as well be just "main" + our $rows = [ ... ]; + +Finally, create the virtual table and bind it to the global +variable (here we assume that C<@$rows> contains arrayrefs) : + + $dbh->do('CREATE VIRTUAL TABLE temp.vtab' + .' USING perl(col1 INT, col2 TEXT, etc, + arrayrefs="Foo::Bar::rows'); + +In most cases, the virtual table will be for temporary use, which is +the reason why this example prepends C in front of the table +name : this tells SQLite to cleanup that table when the database +handle will be disconnected, without the need to emit an explicit DROP +statement. + +Column names (and optionally their types) are specified in the +virtual table declaration, just like for any regular table. + +=head2 Arrayref example : statistics from files + +Let's suppose we want to perform some searches over a collection of +files, where search constraints may be based on some of the fields +returned by L, such as the size of the file or its last modify +time. Here is a way to do it with a virtual table : + + my @files = ... ; # list of files to inspect + + # apply the L function to each file + our $file_stats = [ map {($_, stat $_)} @files]; + + # create a temporary virtual table + $dbh->do(<<""); + CREATE VIRTUAL TABLE temp.file_stats' + USING perl(path, dev, ino, mode, nlink, uid, gid, rdev, size, + atime, mtime, ctime, blksize, blocks, + arrayrefs="main::file_stats"); + + # search files + my $sth = $dbh->prepare(<<""); + SELECT * FROM file_stats + WHERE mtime BETWEEN ? AND ? + AND uid IN (...) + +=head2 Hashref example : unicode characters + +Given any unicode character, the L function +returns a hashref with various bits of information about that character. +So this can be exploited in a virtual table : + + use Unicode::UCD 'charinfo'; + our $chars = [map {charinfo($_)} 0x300..0x400]; # arbitrary subrange + + # create a temporary virtual table + $dbh->do(<<""); + CREATE VIRTUAL TABLE charinfo USING perl( + code, name, block, script, category, + hashrefs="main::chars" + ) + + # search characters + my $sth = $dbh->prepare(<<""); + SELECT * FROM charinfo + WHERE script='Greek' + AND name LIKE '%SIGMA%' + + +=head2 Colref example: SELECT WHERE ... IN ... + +I file in SQLite's source +(L).> + +A C virtual table is designed to facilitate using an +array of values as the right-hand side of an IN operator. The +usual syntax for IN is to prepare a statement like this: + + SELECT * FROM table WHERE x IN (?,?,?,...,?); + +and then bind individual values to each of the ? slots; but this has +the disadvantage that the number of values must be known in +advance. Instead, we can store values in a Perl array, bind that array +to a virtual table, and then write a statement like this + + SELECT * FROM table WHERE x IN perl_array; + +Here is how such a program would look like : + + # connect to the database + my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", '', '', + {RaiseError => 1, AutoCommit => 1}); + + # Declare a global arrayref containing the values. Here we assume + # they are taken from @ARGV, but any other datasource would do. + # Note the use of "our" instead of "my". + our $valuess = \@ARGV; + + # register the module and declare the virtual table + $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"); + $dbh->do('CREATE VIRTUAL TABLE temp.intarray' + .' USING perl(i INT, colref="main::values'); + + # now we can SELECT from another table, using the intarray as a constraint + my $sql = "SELECT * FROM some_table WHERE some_col IN intarray"; + my $result = $dbh->selectall_arrayref($sql); + + +Beware that the virtual table is read-write, so the statement below +would push 99 into @ARGV ! + + INSERT INTO intarray VALUES (99); + + =head1 AUTHOR diff --git a/t/virtual_table/00_base.t b/t/virtual_table/00_base.t index 89c20e1..94f17c0 100644 --- a/t/virtual_table/00_base.t +++ b/t/virtual_table/00_base.t @@ -7,10 +7,9 @@ BEGIN { use t::lib::Test qw/connect_ok/; use Test::More; -# use Test::NoWarnings; -use DBI qw(:sql_types); +use Test::NoWarnings; -plan tests => 9; +plan tests => 10; my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 ); diff --git a/t/virtual_table/10_filecontent.t b/t/virtual_table/10_filecontent.t index 4b9fae7..123b4c6 100644 --- a/t/virtual_table/10_filecontent.t +++ b/t/virtual_table/10_filecontent.t @@ -9,7 +9,6 @@ BEGIN { use t::lib::Test qw/connect_ok/; use Test::More; use Test::NoWarnings; -use DBI qw(:sql_types); use FindBin; plan tests => 13; diff --git a/t/virtual_table/20_perldata.t b/t/virtual_table/20_perldata.t index b16f8ce..3043f64 100644 --- a/t/virtual_table/20_perldata.t +++ b/t/virtual_table/20_perldata.t @@ -9,7 +9,6 @@ BEGIN { use t::lib::Test qw/connect_ok/; use Test::More; use Test::NoWarnings; -use DBI qw(:sql_types); use FindBin; our $perl_rows = [ @@ -18,7 +17,7 @@ our $perl_rows = [ [7, 8, 'nine' ], ]; -plan tests => 24; +plan tests => 29; my $dbh = connect_ok( RaiseError => 1, AutoCommit => 1 ); @@ -101,5 +100,22 @@ is_deeply $integers, [1 .. 10, 98, 99], "added 2 ints"; $integers = [ 1, 7 ]; $sql = "SELECT a FROM vtb WHERE a IN intarray"; $res = $dbh->selectcol_arrayref($sql); -is_deeply $res, [ 1, 7 ], "intarray as a virtual table"; +is_deeply $res, [ 1, 7 ], "IN intarray"; + +# same thing with strings +our $strings = [qw/one two three/]; +ok $dbh->do(<<""), "create vtable strarray"; + CREATE VIRTUAL TABLE strarray USING perl(str TEXT, colref="main::strings") + +$sql = "INSERT INTO strarray VALUES ('aa'), ('bb')"; +ok $dbh->do($sql), $sql; +is_deeply $strings, [qw/one two three aa bb/], "added 2 strings"; + +$sql = "SELECT a FROM vtb WHERE c IN strarray"; +$res = $dbh->selectcol_arrayref($sql); +is_deeply $res, [ 1 ], "IN strarray"; + +$sql = "SELECT a FROM vtb WHERE c IN (SELECT str FROM strarray WHERE str > 'a')"; +$res = $dbh->selectcol_arrayref($sql); +is_deeply $res, [ 1 ], "IN SELECT FROM strarray"; From 7af00e7eddabb2002c31aefbe6be24af51b53291 Mon Sep 17 00:00:00 2001 From: Laurent Dami Date: Sat, 19 Jul 2014 03:39:07 +0200 Subject: [PATCH 5/8] cleanup - Emacs settings no longer in dbdimp.c source - remove duplicated code (generalize cals to stacked_sv_from_sqlite3_value()) - variables renamed --- .dir-locals.el | 1 + dbdimp.c | 124 +++++----------------- t/virtual_table/11_filecontent_fulltext.t | 8 +- 3 files changed, 29 insertions(+), 104 deletions(-) create mode 100644 .dir-locals.el diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..aba2ab6 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1 @@ +(( nil . ((c-basic-offset . 4)))) diff --git a/dbdimp.c b/dbdimp.c index 36bb26c..19a6d71 100644 --- a/dbdimp.c +++ b/dbdimp.c @@ -1,12 +1,3 @@ -/* -*- c-basic-offset: 4; -*- */ - -/* TODO : refactoring - - generalized use of stacked_sv_from_sqlite3_value - - decide about policy for errors in vtab methods : use G_EVAL or just die? - - find better name instead of "perl_instance" - */ - - #define PERL_NO_GET_CONTEXT #define NEED_newSVpvn_flags @@ -1483,51 +1474,7 @@ sqlite_db_func_dispatcher(int is_unicode, sqlite3_context *context, int argc, sq PUSHMARK(SP); for ( i=0; i < argc; i++ ) { - /* TODO: XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ value[i], is_unicode)); */ - - SV *arg; - STRLEN len; - int type = sqlite3_value_type(value[i]); - sqlite_int64 iv; - - /* warn("func dispatch type: %d, value: %s\n", type, sqlite3_value_text(value[i])); */ - switch(type) { - case SQLITE_INTEGER: - iv = sqlite3_value_int64(value[i]); - if ( iv >= IV_MIN && iv <= IV_MAX ) { - /* ^^^ compile-time constant (= true) when IV == int64 */ - arg = sv_2mortal(newSViv((IV)iv)); - } - else if ( iv >= 0 && iv <= UV_MAX ) { - /* warn("integer overflow, cast to UV"); */ - arg = sv_2mortal(newSVuv((UV)iv)); - } - else { - /* warn("integer overflow, cast to NV"); */ - arg = sv_2mortal(newSVnv((NV)iv)); - } - break; - case SQLITE_FLOAT: - arg = sv_2mortal(newSVnv(sqlite3_value_double(value[i]))); - break; - case SQLITE_TEXT: - len = sqlite3_value_bytes(value[i]); - arg = newSVpvn((const char *)sqlite3_value_text(value[i]), len); - if (is_unicode) { - SvUTF8_on(arg); - } - arg = sv_2mortal(arg); - break; - case SQLITE_BLOB: - len = sqlite3_value_bytes(value[i]); - arg = sv_2mortal(newSVpvn(sqlite3_value_blob(value[i]), len)); - break; - default: - arg = &PL_sv_undef; - } - - XPUSHs(arg); - + XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ value[i], is_unicode)); } PUTBACK; @@ -1781,30 +1728,7 @@ sqlite_db_aggr_step_dispatcher(sqlite3_context *context, PUSHMARK(SP); XPUSHs( sv_2mortal( newSVsv( aggr->aggr_inst ) )); for ( i=0; i < argc; i++ ) { - /* TODO: XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ value[i], is_unicode)); */ - - SV *arg; - int len = sqlite3_value_bytes(value[i]); - int type = sqlite3_value_type(value[i]); - - switch(type) { - case SQLITE_INTEGER: - arg = sv_2mortal(newSViv(sqlite3_value_int(value[i]))); - break; - case SQLITE_FLOAT: - arg = sv_2mortal(newSVnv(sqlite3_value_double(value[i]))); - break; - case SQLITE_TEXT: - arg = sv_2mortal(newSVpvn((const char *)sqlite3_value_text(value[i]), len)); - break; - case SQLITE_BLOB: - arg = sv_2mortal(newSVpvn(sqlite3_value_blob(value[i]), len)); - break; - default: - arg = &PL_sv_undef; - } - - XPUSHs(arg); + XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ value[i], is_unicode)); } PUTBACK; @@ -2848,18 +2772,18 @@ int sqlite_db_register_fts3_perl_tokenizer(pTHX_ SV *dbh) /*********************************************************************** ** The set of routines that implement the perl "module" -** (i.e support for virtual table) +** (i.e support for virtual tables written in Perl) ************************************************************************/ typedef struct perl_vtab { sqlite3_vtab base; - SV *perl_vtab_instance; + SV *perl_vtab_obj; } perl_vtab; typedef struct perl_vtab_cursor { sqlite3_vtab_cursor base; - SV *perl_cursor_instance; + SV *perl_cursor_obj; } perl_vtab_cursor; typedef struct perl_vtab_init { @@ -2877,7 +2801,7 @@ static int _call_perl_vtab_method(sqlite3_vtab *pVTab, const char *method) { int count; PUSHMARK(SP); - XPUSHs(((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); PUTBACK; count = call_method (method, G_VOID); SPAGAIN; @@ -2900,7 +2824,7 @@ static int _call_perl_vtab_method(sqlite3_vtab *pVTab, const char *method) { int count; PUSHMARK(SP); - XPUSHs(((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); XPUSHs(sv_2mortal(newSViv(i))); PUTBACK; count = call_method (method, G_VOID); @@ -2957,8 +2881,8 @@ static int perl_vt_New(const char *method, } /* get the VirtualTable instance */ - SV *perl_instance = POPs; - if ( !sv_isobject(perl_instance) ) { + SV *perl_vtab_obj = POPs; + if ( !sv_isobject(perl_vtab_obj) ) { *pzErr = sqlite3_mprintf("vtab->%s() should return a blessed reference", method); goto cleanup; @@ -2966,7 +2890,7 @@ static int perl_vt_New(const char *method, /* call the ->VTAB_TO_DECLARE() method */ PUSHMARK(SP); - XPUSHs(perl_instance); + XPUSHs(perl_vtab_obj); PUTBACK; count = call_method ("VTAB_TO_DECLARE", G_SCALAR); SPAGAIN; @@ -2987,7 +2911,7 @@ static int perl_vt_New(const char *method, rc = sqlite3_declare_vtab(db, SvPVutf8_nolen(sql)); /* record the VirtualTable perl instance within the vtab structure */ - vt->perl_vtab_instance = SvREFCNT_inc(perl_instance); + vt->perl_vtab_obj = SvREFCNT_inc(perl_vtab_obj); cleanup: *ppVTab = &vt->base; @@ -3019,7 +2943,7 @@ static int perl_vt_Disconnect(sqlite3_vtab *pVTab){ _call_perl_vtab_method(pVTab, "DISCONNECT"); perl_vtab *perl_pVTab = (perl_vtab *) pVTab; - SvREFCNT_dec(perl_pVTab->perl_vtab_instance); + SvREFCNT_dec(perl_pVTab->perl_vtab_obj); sqlite3_free(perl_pVTab); @@ -3033,7 +2957,7 @@ static int perl_vt_Drop(sqlite3_vtab *pVTab){ _call_perl_vtab_method(pVTab, "DROP"); perl_vtab *perl_pVTab = (perl_vtab *) pVTab; - SvREFCNT_dec(perl_pVTab->perl_vtab_instance); + SvREFCNT_dec(perl_pVTab->perl_vtab_obj); sqlite3_free(perl_pVTab); @@ -3093,7 +3017,7 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ /* call the ->best_index() method */ PUSHMARK(SP); - XPUSHs( ((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs( ((perl_vtab *) pVTab)->perl_vtab_obj); XPUSHs( sv_2mortal( newRV_noinc((SV*) constraints))); XPUSHs( sv_2mortal( newRV_noinc((SV*) order_by))); PUTBACK; @@ -3164,7 +3088,7 @@ static int perl_vt_Open(sqlite3_vtab *pVTab, sqlite3_vtab_cursor **ppCursor){ /* call the ->OPEN() method */ PUSHMARK(SP); - XPUSHs( ((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs( ((perl_vtab *) pVTab)->perl_vtab_obj); PUTBACK; count = call_method ("OPEN", G_SCALAR); SPAGAIN; @@ -3180,7 +3104,7 @@ static int perl_vt_Open(sqlite3_vtab *pVTab, sqlite3_vtab_cursor **ppCursor){ cursor = (perl_vtab_cursor *) sqlite3_malloc(sizeof(*cursor)); if( cursor==NULL ) return SQLITE_NOMEM; memset(cursor, 0, sizeof(*cursor)); - cursor->perl_cursor_instance = SvREFCNT_inc(perl_cursor); + cursor->perl_cursor_obj = SvREFCNT_inc(perl_cursor); /* return that cursor */ *ppCursor = &cursor->base; @@ -3202,7 +3126,7 @@ static int perl_vt_Close(sqlite3_vtab_cursor *pVtabCursor){ can implement a DESTROY() method */ perl_vtab_cursor *perl_pVTabCursor = (perl_vtab_cursor *) pVtabCursor; - SvREFCNT_dec(perl_pVTabCursor->perl_cursor_instance); + SvREFCNT_dec(perl_pVTabCursor->perl_cursor_obj); sqlite3_free(perl_pVTabCursor); PUTBACK; @@ -3227,7 +3151,7 @@ static int perl_vt_Filter( /* call the FILTER() method with ($idxNum, $idxStr, @args) */ PUSHMARK(SP); - XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_obj); XPUSHs(sv_2mortal(newSViv(idxNum))); XPUSHs(sv_2mortal(newSVpv(idxStr, 0))); for(i = 0; i < argc; i++) { @@ -3255,7 +3179,7 @@ static int perl_vt_Next(sqlite3_vtab_cursor *pVtabCursor){ /* call the next() method */ PUSHMARK(SP); - XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_obj); PUTBACK; count = call_method ("NEXT", G_VOID); SPAGAIN; @@ -3277,7 +3201,7 @@ static int perl_vt_Eof(sqlite3_vtab_cursor *pVtabCursor){ /* call the eof() method */ PUSHMARK(SP); - XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_obj); PUTBACK; count = call_method ("EOF", G_SCALAR); SPAGAIN; @@ -3309,7 +3233,7 @@ static int perl_vt_Column(sqlite3_vtab_cursor *pVtabCursor, /* call the column() method */ PUSHMARK(SP); - XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_obj); XPUSHs(sv_2mortal(newSViv(col))); PUTBACK; count = call_method ("COLUMN", G_SCALAR); @@ -3340,7 +3264,7 @@ static int perl_vt_Rowid(sqlite3_vtab_cursor *pVtabCursor, sqlite3_int64 *pRowid /* call the rowid() method */ PUSHMARK(SP); - XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_instance); + XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_obj); PUTBACK; count = call_method ("ROWID", G_SCALAR); SPAGAIN; @@ -3371,7 +3295,7 @@ static int perl_vt_Update(sqlite3_vtab *pVTab, /* call the update() method */ PUSHMARK(SP); - XPUSHs(((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); for(i = 0; i < argc; i++) { XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ argv[i], is_unicode)); } @@ -3442,7 +3366,7 @@ static int perl_vt_Rename(sqlite3_vtab *pVTab, const char *zNew){ int rc = SQLITE_ERROR; PUSHMARK(SP); - XPUSHs(((perl_vtab *) pVTab)->perl_vtab_instance); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); XPUSHs(sv_2mortal(newSVpv(zNew, 0))); PUTBACK; count = call_method("RENAME", G_SCALAR); diff --git a/t/virtual_table/11_filecontent_fulltext.t b/t/virtual_table/11_filecontent_fulltext.t index 8b6c577..6c85206 100644 --- a/t/virtual_table/11_filecontent_fulltext.t +++ b/t/virtual_table/11_filecontent_fulltext.t @@ -53,14 +53,14 @@ $sth->execute($_) foreach @perl_files; # create the virtual table -$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"); +$dbh->sqlite_create_module(fc => "DBD::SQLite::VirtualTable::FileContent"); $dbh->do(<<""); - CREATE VIRTUAL TABLE vfs USING fs(source = files, + CREATE VIRTUAL TABLE vfc USING fc(source = files, expose = "path", root = "$distrib_dir") # create the fulltext indexing table and populate it -$dbh->do('CREATE VIRTUAL TABLE fts USING fts4(content="vfs")'); +$dbh->do('CREATE VIRTUAL TABLE fts USING fts4(content="vfc")'); note "building fts index...."; $dbh->do("INSERT INTO fts(fts) VALUES ('rebuild')"); note "done"; @@ -90,7 +90,7 @@ foreach my $test (@tests) { $dbh->disconnect; undef $dbh; $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 ); -$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"); +$dbh->sqlite_create_module(fc => "DBD::SQLite::VirtualTable::FileContent"); foreach my $test (@tests) { my ($pattern, @expected) = @$test; From 0ec13083f19731d2fb673ab3846693fd2c4a0797 Mon Sep 17 00:00:00 2001 From: Laurent Dami Date: Sun, 20 Jul 2014 18:57:19 +0200 Subject: [PATCH 6/8] implementation of FIND_FUNCTION, plus a couple of cosmetic changes in various places --- MANIFEST | 1 + dbdimp.c | 337 ++++++++++++--------- lib/DBD/SQLite/VirtualTable.pm | 64 +++- lib/DBD/SQLite/VirtualTable/FileContent.pm | 10 +- t/virtual_table/00_base.t | 11 +- t/virtual_table/01_destroy.t | 4 +- t/virtual_table/02_find_function.t | 173 +++++++++++ 7 files changed, 432 insertions(+), 168 deletions(-) create mode 100644 t/virtual_table/02_find_function.t diff --git a/MANIFEST b/MANIFEST index e660ef1..5b588e4 100644 --- a/MANIFEST +++ b/MANIFEST @@ -112,6 +112,7 @@ t/rt_88228_sqlite_3_8_0_crash.t t/rt_96878_fts_contentless_table.t t/virtual_table/00_base.t t/virtual_table/01_destroy.t +t/virtual_table/02_find_function.t t/virtual_table/10_filecontent.t t/virtual_table/11_filecontent_fulltext.t t/virtual_table/20_perldata.t diff --git a/dbdimp.c b/dbdimp.c index 19a6d71..5185199 100644 --- a/dbdimp.c +++ b/dbdimp.c @@ -1500,7 +1500,6 @@ sqlite_db_func_dispatcher(int is_unicode, sqlite3_context *context, int argc, sq } PUTBACK; - FREETMPS; LEAVE; } @@ -2779,6 +2778,7 @@ int sqlite_db_register_fts3_perl_tokenizer(pTHX_ SV *dbh) typedef struct perl_vtab { sqlite3_vtab base; SV *perl_vtab_obj; + HV *functions; } perl_vtab; typedef struct perl_vtab_cursor { @@ -2793,30 +2793,9 @@ typedef struct perl_vtab_init { -static int _call_perl_vtab_method(sqlite3_vtab *pVTab, const char *method) { - dTHX; - dSP; - ENTER; - SAVETMPS; - int count; - - PUSHMARK(SP); - XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); - PUTBACK; - count = call_method (method, G_VOID); - SPAGAIN; - SP -= count; - - PUTBACK; - FREETMPS; - LEAVE; - - return SQLITE_OK; -} - - - static int _call_perl_vtab_method_int(sqlite3_vtab *pVTab, - const char *method, int i) { +/* auxiliary routine for generalized method calls. Arg "i" may be unused */ +static int _call_perl_vtab_method(sqlite3_vtab *pVTab, + const char *method, int i) { dTHX; dSP; ENTER; @@ -2831,7 +2810,6 @@ static int _call_perl_vtab_method(sqlite3_vtab *pVTab, const char *method) { SPAGAIN; SP -= count; - PUTBACK; FREETMPS; LEAVE; @@ -2841,8 +2819,6 @@ static int _call_perl_vtab_method(sqlite3_vtab *pVTab, const char *method) { - - static int perl_vt_New(const char *method, sqlite3 *db, void *pAux, int argc, const char *const *argv, @@ -2852,11 +2828,13 @@ static int perl_vt_New(const char *method, perl_vtab *vt; perl_vtab_init *init_data = (perl_vtab_init *)pAux; int count, i; + int rc = SQLITE_ERROR; /* allocate a perl_vtab structure */ vt = (perl_vtab *) sqlite3_malloc(sizeof(*vt)); if( vt==NULL ) return SQLITE_NOMEM; memset(vt, 0, sizeof(*vt)); + vt->functions = newHV(); ENTER; SAVETMPS; @@ -2907,20 +2885,23 @@ static int perl_vt_New(const char *method, /* call sqlite3_declare_vtab with the sql returned from method VTAB_TO_DECLARE(), converted to utf8 */ SV *sql = POPs; - int rc; rc = sqlite3_declare_vtab(db, SvPVutf8_nolen(sql)); - /* record the VirtualTable perl instance within the vtab structure */ - vt->perl_vtab_obj = SvREFCNT_inc(perl_vtab_obj); - cleanup: - *ppVTab = &vt->base; + if (rc == SQLITE_OK) { + /* record the VirtualTable perl instance within the vtab structure */ + vt->perl_vtab_obj = SvREFCNT_inc(perl_vtab_obj); + *ppVTab = &vt->base; + } + else { + sqlite3_free(vt); + } PUTBACK; FREETMPS; LEAVE; - return SQLITE_OK; + return rc; } @@ -2937,36 +2918,32 @@ static int perl_vt_Connect(sqlite3 *db, void *pAux, } -static int perl_vt_Disconnect(sqlite3_vtab *pVTab){ +static int _free_perl_vtab(perl_vtab *pVTab){ dTHX; - _call_perl_vtab_method(pVTab, "DISCONNECT"); + SvREFCNT_dec(pVTab->perl_vtab_obj); - perl_vtab *perl_pVTab = (perl_vtab *) pVTab; - SvREFCNT_dec(perl_pVTab->perl_vtab_obj); - - sqlite3_free(perl_pVTab); + /* deallocate coderefs that were declared through FindFunction() */ + hv_undef(pVTab->functions); + SvREFCNT_dec(pVTab->functions); + sqlite3_free(pVTab); return SQLITE_OK; } +static int perl_vt_Disconnect(sqlite3_vtab *pVTab){ + _call_perl_vtab_method(pVTab, "DISCONNECT", 0); + return _free_perl_vtab((perl_vtab *)pVTab); +} static int perl_vt_Drop(sqlite3_vtab *pVTab){ - dTHX; - - _call_perl_vtab_method(pVTab, "DROP"); - - perl_vtab *perl_pVTab = (perl_vtab *) pVTab; - SvREFCNT_dec(perl_pVTab->perl_vtab_obj); - - sqlite3_free(perl_pVTab); - - return SQLITE_OK; + _call_perl_vtab_method(pVTab, "DROP", 0); + return _free_perl_vtab((perl_vtab *)pVTab); } static char * -op2str(unsigned char op) { +_constraint_op_to_string(unsigned char op) { switch (op) { case SQLITE_INDEX_CONSTRAINT_EQ: return "="; @@ -2987,20 +2964,21 @@ op2str(unsigned char op) { static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ - int i, count; - dTHX; dSP; ENTER; SAVETMPS; + int i, count; + /* build the "where_constraints" datastructure */ AV *constraints = newAV(); for (i=0; inConstraint; i++){ struct sqlite3_index_constraint const *pCons = &pIdxInfo->aConstraint[i]; HV *constraint = newHV(); + char *op_str = _constraint_op_to_string(pCons->op); hv_stores(constraint, "col", newSViv(pCons->iColumn)); - hv_stores(constraint, "op", newSVpv(op2str(pCons->op), 0)); + hv_stores(constraint, "op", newSVpv(op_str, 0)); hv_stores(constraint, "usable", pCons->usable ? &PL_sv_yes : &PL_sv_no); av_push(constraints, newRV_noinc((SV*) constraint)); } @@ -3015,7 +2993,7 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ av_push( order_by, newRV_noinc((SV*) order)); } - /* call the ->best_index() method */ + /* call the ->BEST_INDEX() method */ PUSHMARK(SP); XPUSHs( ((perl_vtab *) pVTab)->perl_vtab_obj); XPUSHs( sv_2mortal( newRV_noinc((SV*) constraints))); @@ -3038,7 +3016,7 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ if (val && SvOK(*val)) { STRLEN len; char *str = SvPVutf8(*val, len); - pIdxInfo->idxStr = sqlite3_malloc(len+1); + pIdxInfo->idxStr = sqlite3_malloc(len+1); memcpy(pIdxInfo->idxStr, str, len); pIdxInfo->idxStr[len] = 0; pIdxInfo->needToFreeIdxStr = 1; @@ -3053,17 +3031,15 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ /* loop over constraints to get back the "argvIndex" and "omit" keys that shoud have been added by the best_index() method call */ for (i=0; inConstraint; i++){ - struct sqlite3_index_constraint_usage *pConsUsage - = &pIdxInfo->aConstraintUsage[i]; SV **rv = av_fetch(constraints, i, FALSE); if (!(rv && SvROK(*rv) && SvTYPE(SvRV(*rv)) == SVt_PVHV)) croak("the call to BEST_INDEX() has corrupted constraint data"); - HV *hv = (HV*)SvRV(*rv); - SV **val; - val = hv_fetch(hv, "argvIndex", 9, FALSE); - + HV *hv = (HV*)SvRV(*rv); + SV **val = hv_fetch(hv, "argvIndex", 9, FALSE); int argvIndex = (val && SvOK(*val)) ? SvIV(*val) + 1: 0; + struct sqlite3_index_constraint_usage *pConsUsage + = &pIdxInfo->aConstraintUsage[i]; pConsUsage->argvIndex = argvIndex; val = hv_fetch(hv, "omit", 4, FALSE); pConsUsage->omit = (val && SvTRUE(*val)) ? 1 : 0; @@ -3085,6 +3061,14 @@ static int perl_vt_Open(sqlite3_vtab *pVTab, sqlite3_vtab_cursor **ppCursor){ SAVETMPS; int count; + int rc = SQLITE_ERROR; + SV *perl_cursor; + + /* allocate a perl_vtab_cursor structure */ + perl_vtab_cursor *cursor; + cursor = (perl_vtab_cursor *) sqlite3_malloc(sizeof(*cursor)); + if( cursor==NULL ) return SQLITE_NOMEM; + memset(cursor, 0, sizeof(*cursor)); /* call the ->OPEN() method */ PUSHMARK(SP); @@ -3092,27 +3076,36 @@ static int perl_vt_Open(sqlite3_vtab *pVTab, sqlite3_vtab_cursor **ppCursor){ PUTBACK; count = call_method ("OPEN", G_SCALAR); SPAGAIN; - if (count != 1) - croak("vtab->OPEN() method returned %d vals instead of 1", count); - SV *perl_cursor = POPs; - if ( !sv_isobject(perl_cursor) ) - croak("vtab->OPEN() method did not return a blessed cursor"); + if (count != 1) { + warn("vtab->OPEN() method returned %d vals instead of 1", count); + SP -= count; + goto cleanup; + } + perl_cursor = POPs; + if ( !sv_isobject(perl_cursor) ) { + warn("vtab->OPEN() method did not return a blessed cursor"); + goto cleanup; + } - /* allocate a perl_vtab_cursor structure */ - perl_vtab_cursor *cursor; - cursor = (perl_vtab_cursor *) sqlite3_malloc(sizeof(*cursor)); - if( cursor==NULL ) return SQLITE_NOMEM; - memset(cursor, 0, sizeof(*cursor)); - cursor->perl_cursor_obj = SvREFCNT_inc(perl_cursor); + /* everything went OK */ + rc = SQLITE_OK; + + cleanup: + + if (rc == SQLITE_OK) { + cursor->perl_cursor_obj = SvREFCNT_inc(perl_cursor); + *ppCursor = &cursor->base; + } + else { + sqlite3_free(cursor); + } - /* return that cursor */ - *ppCursor = &cursor->base; PUTBACK; FREETMPS; LEAVE; - return SQLITE_OK; + return rc; } static int perl_vt_Close(sqlite3_vtab_cursor *pVtabCursor){ @@ -3122,8 +3115,8 @@ static int perl_vt_Close(sqlite3_vtab_cursor *pVtabCursor){ SAVETMPS; int count; - /* Note : no call to a CLOSE() method; if needed, the Perl class - can implement a DESTROY() method */ + /* Note : there is no explicit call to a CLOSE() method; if + needed, the Perl class can implement a DESTROY() method */ perl_vtab_cursor *perl_pVTabCursor = (perl_vtab_cursor *) pVtabCursor; SvREFCNT_dec(perl_pVTabCursor->perl_cursor_obj); @@ -3136,12 +3129,9 @@ static int perl_vt_Close(sqlite3_vtab_cursor *pVtabCursor){ return SQLITE_OK; } -static int perl_vt_Filter( - sqlite3_vtab_cursor *pVtabCursor, - int idxNum, const char *idxStr, - int argc, sqlite3_value **argv -){ - +static int perl_vt_Filter( sqlite3_vtab_cursor *pVtabCursor, + int idxNum, const char *idxStr, + int argc, sqlite3_value **argv ){ dTHX; dSP; ENTER; @@ -3230,6 +3220,7 @@ static int perl_vt_Column(sqlite3_vtab_cursor *pVtabCursor, ENTER; SAVETMPS; int count; + int rc = SQLITE_ERROR; /* call the column() method */ PUSHMARK(SP); @@ -3246,21 +3237,24 @@ static int perl_vt_Column(sqlite3_vtab_cursor *pVtabCursor, else { SV *result = POPs; sqlite_set_result(aTHX_ context, result, 0 ); + rc = SQLITE_OK; } PUTBACK; FREETMPS; LEAVE; - return SQLITE_OK; + return rc; } -static int perl_vt_Rowid(sqlite3_vtab_cursor *pVtabCursor, sqlite3_int64 *pRowid){ +static int perl_vt_Rowid( sqlite3_vtab_cursor *pVtabCursor, + sqlite3_int64 *pRowid ){ dTHX; dSP; ENTER; SAVETMPS; int count; + int rc = SQLITE_ERROR; /* call the rowid() method */ PUSHMARK(SP); @@ -3274,32 +3268,33 @@ static int perl_vt_Rowid(sqlite3_vtab_cursor *pVtabCursor, sqlite3_int64 *pRowid } else { *pRowid =POPi; + rc = SQLITE_OK; } PUTBACK; FREETMPS; LEAVE; - return SQLITE_OK; + return rc; } -static int perl_vt_Update(sqlite3_vtab *pVTab, - int argc, sqlite3_value **argv, - sqlite3_int64 *pRowid){ +static int perl_vt_Update( sqlite3_vtab *pVTab, + int argc, sqlite3_value **argv, + sqlite3_int64 *pRowid ){ dTHX; dSP; ENTER; SAVETMPS; int count, i; int is_unicode = _last_dbh_is_unicode(); + int rc = SQLITE_ERROR; - /* call the update() method */ + /* call the _SQLITE_UPDATE() method */ PUSHMARK(SP); XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); for(i = 0; i < argc; i++) { XPUSHs(stacked_sv_from_sqlite3_value(aTHX_ argv[i], is_unicode)); } - PUTBACK; count = call_method ("_SQLITE_UPDATE", G_SCALAR); SPAGAIN; @@ -3307,19 +3302,22 @@ static int perl_vt_Update(sqlite3_vtab *pVTab, warn("cursor->_SQLITE_UPDATE() returned %d vals instead of 1", count); SP -= count; } - else if (argc > 1 && sqlite3_value_type(argv[0]) == SQLITE_NULL + else { + if (argc > 1 && sqlite3_value_type(argv[0]) == SQLITE_NULL && sqlite3_value_type(argv[1]) == SQLITE_NULL) { - /* this was an insert without any given rowid, so the result of - the method call must be passed in *pRowid*/ - SV *rowidsv = POPs; - if (!SvOK(rowidsv)) - *pRowid = 0; - else if (SvUOK(rowidsv)) - *pRowid = SvUV(rowidsv); - else if (SvIOK(rowidsv)) - *pRowid = SvIV(rowidsv); - else - *pRowid = SvNV(rowidsv); + /* this was an insert without any given rowid, so the result of + the method call must be passed in *pRowid*/ + SV *rowidsv = POPs; + if (!SvOK(rowidsv)) + *pRowid = 0; + else if (SvUOK(rowidsv)) + *pRowid = SvUV(rowidsv); + else if (SvIOK(rowidsv)) + *pRowid = SvIV(rowidsv); + else + *pRowid = SvNV(rowidsv); + } + rc = SQLITE_OK; } @@ -3327,36 +3325,89 @@ static int perl_vt_Update(sqlite3_vtab *pVTab, FREETMPS; LEAVE; - return SQLITE_OK; + return rc; } - - - - static int perl_vt_Begin(sqlite3_vtab *pVTab){ - return _call_perl_vtab_method(pVTab, "BEGIN_TRANSACTION"); + return _call_perl_vtab_method(pVTab, "BEGIN_TRANSACTION", 0); } static int perl_vt_Sync(sqlite3_vtab *pVTab){ - return _call_perl_vtab_method(pVTab, "SYNC_TRANSACTION"); + return _call_perl_vtab_method(pVTab, "SYNC_TRANSACTION", 0); } static int perl_vt_Commit(sqlite3_vtab *pVTab){ - return _call_perl_vtab_method(pVTab, "COMMIT_TRANSACTION"); + return _call_perl_vtab_method(pVTab, "COMMIT_TRANSACTION", 0); } static int perl_vt_Rollback(sqlite3_vtab *pVTab){ - return _call_perl_vtab_method(pVTab, "ROLLBACK_TRANSACTION"); + return _call_perl_vtab_method(pVTab, "ROLLBACK_TRANSACTION", 0); } -static int perl_vt_FindMethod(sqlite3_vtab *pVtab, int nArg, const char *zName, +static int perl_vt_FindFunction(sqlite3_vtab *pVTab, + int nArg, const char *zName, void (**pxFunc)(sqlite3_context*,int,sqlite3_value**), void **ppArg){ - croak("VT_FINDMETHOD: not implemented yet"); /* TODO */ - return SQLITE_OK; + dTHX; + dSP; + ENTER; + SAVETMPS; + int count; + int is_overloaded = 0; + char *func_name = sqlite3_mprintf("%s\t%d", zName, nArg); + STRLEN len = strlen(func_name); + HV *functions = ((perl_vtab *) pVTab)->functions; + SV* coderef = NULL; + + /* check if that function was already in cache */ + if (hv_exists(functions, func_name, len)) { + SV** val = hv_fetch(functions, func_name, len, FALSE); + if (val && SvOK(*val)) { + coderef = *val; + } + } + else { + /* call the FIND_FUNCTION() method */ + PUSHMARK(SP); + XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); + XPUSHs(sv_2mortal(newSViv(nArg))); + XPUSHs(sv_2mortal(newSVpv(zName, 0))); + PUTBACK; + count = call_method ("FIND_FUNCTION", G_SCALAR); + SPAGAIN; + if (count != 1) { + warn("vtab->FIND_FUNCTION() method returned %d vals instead of 1", count); + SP -= count; + goto cleanup; + } + SV *result = POPs; + if (SvTRUE(result)) { + /* the coderef must be valid for the lifetime of pVTab, so + make a copy */ + coderef = newSVsv(result); + } + + /* store result in cache */ + hv_store(functions, func_name, len, coderef ? coderef : &PL_sv_undef, 0); + } + + /* return function information for sqlite3 within *pxFunc and *ppArg */ + is_overloaded = coderef && SvTRUE(coderef); + if (is_overloaded) { + *pxFunc = _last_dbh_is_unicode() ? sqlite_db_func_dispatcher_unicode + : sqlite_db_func_dispatcher_no_unicode; + *ppArg = coderef; + } + + cleanup: + PUTBACK; + FREETMPS; + LEAVE; + sqlite3_free(func_name); + return is_overloaded; } + static int perl_vt_Rename(sqlite3_vtab *pVTab, const char *zNew){ dTHX; dSP; @@ -3379,7 +3430,6 @@ static int perl_vt_Rename(sqlite3_vtab *pVTab, const char *zNew){ rc = POPi; } - PUTBACK; FREETMPS; LEAVE; @@ -3388,42 +3438,41 @@ static int perl_vt_Rename(sqlite3_vtab *pVTab, const char *zNew){ } static int perl_vt_Savepoint(sqlite3_vtab *pVTab, int point){ - return _call_perl_vtab_method_int(pVTab, "SAVEPOINT", point); + return _call_perl_vtab_method(pVTab, "SAVEPOINT", point); } static int perl_vt_Release(sqlite3_vtab *pVTab, int point){ - return _call_perl_vtab_method_int(pVTab, "RELEASE", point); + return _call_perl_vtab_method(pVTab, "RELEASE", point); } static int perl_vt_RollbackTo(sqlite3_vtab *pVTab, int point){ - return _call_perl_vtab_method_int(pVTab, "ROLLBACK_TO", point); + return _call_perl_vtab_method(pVTab, "ROLLBACK_TO", point); } static sqlite3_module perl_vt_Module = { - 1, /* iVersion */ - perl_vt_Create, /* xCreate */ - perl_vt_Connect, /* xConnect */ - perl_vt_BestIndex, /* xBestIndex */ - perl_vt_Disconnect, /* xDisconnect */ - perl_vt_Drop, /* xDestroy */ - perl_vt_Open, /* xOpen - open a cursor */ - perl_vt_Close, /* xClose - close a cursor */ - perl_vt_Filter, /* xFilter - configure scan constraints */ - perl_vt_Next, /* xNext - advance a cursor */ - perl_vt_Eof, /* xEof - check for end of scan */ - perl_vt_Column, /* xColumn - read data */ - perl_vt_Rowid, /* xRowid - read data */ - perl_vt_Update, /* xUpdate (optional) */ - perl_vt_Begin, /* xBegin (optional) */ - perl_vt_Sync, /* xSync (optional) */ - perl_vt_Commit, /* xCommit (optional) */ - perl_vt_Rollback, /* xRollback (optional) */ - /* perl_vt_FindMethod, /\* xFindMethod (optional) *\/ */ - NULL, /* xFindMethod not implemented yet */ - perl_vt_Rename, /* xRename */ - perl_vt_Savepoint, /* xSavepoint (optional) */ - perl_vt_Release, /* xRelease (optional) */ - perl_vt_RollbackTo /* xRollbackTo (optional) */ + 1, /* iVersion */ + perl_vt_Create, /* xCreate */ + perl_vt_Connect, /* xConnect */ + perl_vt_BestIndex, /* xBestIndex */ + perl_vt_Disconnect, /* xDisconnect */ + perl_vt_Drop, /* xDestroy */ + perl_vt_Open, /* xOpen - open a cursor */ + perl_vt_Close, /* xClose - close a cursor */ + perl_vt_Filter, /* xFilter - configure scan constraints */ + perl_vt_Next, /* xNext - advance a cursor */ + perl_vt_Eof, /* xEof - check for end of scan */ + perl_vt_Column, /* xColumn - read data */ + perl_vt_Rowid, /* xRowid - read data */ + perl_vt_Update, /* xUpdate (optional) */ + perl_vt_Begin, /* xBegin (optional) */ + perl_vt_Sync, /* xSync (optional) */ + perl_vt_Commit, /* xCommit (optional) */ + perl_vt_Rollback, /* xRollback (optional) */ + perl_vt_FindFunction, /* xFindFunction (optional) */ + perl_vt_Rename, /* xRename */ + perl_vt_Savepoint, /* xSavepoint (optional) */ + perl_vt_Release, /* xRelease (optional) */ + perl_vt_RollbackTo /* xRollbackTo (optional) */ }; diff --git a/lib/DBD/SQLite/VirtualTable.pm b/lib/DBD/SQLite/VirtualTable.pm index 16376a8..fb7af50 100644 --- a/lib/DBD/SQLite/VirtualTable.pm +++ b/lib/DBD/SQLite/VirtualTable.pm @@ -161,7 +161,7 @@ sub ROLLBACK_TRANSACTION {return 0} sub SAVEPOINT {return 0} sub RELEASE {return 0} sub ROLLBACK_TO {return 0} -sub FIND_METHOD {return 0} +sub FIND_FUNCTION {return 0} sub RENAME {return 0} @@ -196,12 +196,30 @@ sub NEW { } -# methods to be redefined in subclasses (here are stupid implementations) -sub FILTER { my ($self, $idxNum, $idxStr, @values) = @_; return } -sub EOF { my ($self) = @_; return 1 } -sub NEXT { my ($self) = @_; return } -sub COLUMN { my ($self, $idxCol) = @_; return } -sub ROWID { my ($self) = @_; return 1 } +sub FILTER { + my ($self, $idxNum, $idxStr, @values) = @_; + die "FILTER() should be redefined in cursor subclass"; +} + +sub EOF { + my ($self) = @_; + die "EOF() should be redefined in cursor subclass"; +} + +sub NEXT { + my ($self) = @_; + die "NEXT() should be redefined in cursor subclass"; +} + +sub COLUMN { + my ($self, $idxCol) = @_; + die "COLUMN() should be redefined in cursor subclass"; +} + +sub ROWID { + my ($self) = @_; + die "ROWID() should be redefined in cursor subclass"; +} 1; @@ -347,11 +365,10 @@ The default implementation just calls L. $class->_PREPARE_SELF($dbh_ref, $module_name, $db_name, $vtab_name, @args); -Prepares the datastructure for a virtual table instance. - C<@args> is just the collection -of strings (comma-separated) that were given within the -C statement; each subclass should decide -what to do with this information, +Prepares the datastructure for a virtual table instance. C<@args> is + just the collection of strings (comma-separated) that were given + within the C statement; each subclass should + decide what to do with this information, The method parses C<@args> to differentiate between I (strings of shape C<$key>=C<$value> or C<$key>=C<"$value">, stored in @@ -437,8 +454,11 @@ The default implementation for DISCONNECT is empty. This method is called automatically just after L or L, to register the columns of the virtual table within the sqlite kernel. The method should return a string containing a SQL C statement; -but only the column declaration parts will be considered (see -L). +but only the column declaration parts will be considered. +Columns may be declared with the special keyword "HIDDEN", which means that +they are used internally for the the virtual table implementation, and are +not visible to users -- see L +and L for detailed explanations. The default implementation returns: @@ -637,6 +657,22 @@ could be changed from a SQL statement such as UPDATE table SET rowid=rowid+1 WHERE ...; +=head3 FIND_FUNCTION + + $vtab->FIND_FUNCTION($num_args, $func_name); + +When a function uses a column from a virtual table as its first +argument, this method is called to see if the virtual table would like +to overload the function. Parameters are the number of arguments to +the function, and the name of the function. If no overloading is +desired, this method should return false. To overload the function, +this method should return a coderef to the function implementation. + +Each virtual table keeps a cache of results from L calls, +so the method will be called only once for each pair +C<< ($num_args, $func_name) >>. + + =head3 BEGIN_TRANSACTION Called to begin a transaction on the virtual table. diff --git a/lib/DBD/SQLite/VirtualTable/FileContent.pm b/lib/DBD/SQLite/VirtualTable/FileContent.pm index 5b45c61..113e6f3 100644 --- a/lib/DBD/SQLite/VirtualTable/FileContent.pm +++ b/lib/DBD/SQLite/VirtualTable/FileContent.pm @@ -73,7 +73,8 @@ sub NEW { $self->{columns} = [ "$self->{options}{content_col} TEXT", map {"$_ $src_col{$_}"} @exposed_cols ]; - # acquire a coderef to the get_content() implementation + # acquire a coderef to the get_content() implementation, which + # was given as a symbolic reference in %options no strict 'refs'; $self->{get_content} = \ &{$self->{options}{get_content}}; @@ -179,7 +180,7 @@ sub FILTER { # build SQL local $" = ", "; my @cols = @{$vtable->{headers}}; - $cols[0] = 'rowid'; # replace the content column by the rowid + $cols[0] = 'rowid'; # replace the content column by the rowid push @cols, $vtable->{options}{path_col}; # path col in last position my $sql = "SELECT @cols FROM $vtable->{options}{source}"; $sql .= " WHERE $idxStr" if $idxStr; @@ -207,7 +208,6 @@ sub NEXT { $self->{row} = $self->{sth}->fetchrow_arrayref; } - sub COLUMN { my ($self, $idxCol) = @_; @@ -220,14 +220,14 @@ sub ROWID { return $self->{row}[0]; } - sub file_content { my ($self) = @_; my $root = $self->{vtable}{options}{root}; my $path = $self->{row}[-1]; + my $get_content_func = $self->{vtable}{get_content}; - return $self->{vtable}{get_content}->($path, $root); + return $get_content_func->($path, $root); } diff --git a/t/virtual_table/00_base.t b/t/virtual_table/00_base.t index 94f17c0..1865c11 100644 --- a/t/virtual_table/00_base.t +++ b/t/virtual_table/00_base.t @@ -43,10 +43,16 @@ use warnings; use base 'DBD::SQLite::VirtualTable'; use YAML; -sub INITIALIZE { - my $self = shift; +sub NEW { + my $class = shift; + + my $self = $class->_PREPARE_SELF(@_); + bless $self, $class; + # stupid pragma call, just to check that the dbh is OK $self->dbh->do("PRAGMA application_id=999"); + + return $self; } @@ -118,7 +124,6 @@ sub COLUMN { my ($self, $idxCol) = @_; return "auto_vivify:$idxCol"; - return $idxCol; } sub ROWID { diff --git a/t/virtual_table/01_destroy.t b/t/virtual_table/01_destroy.t index 0e15205..50d29c5 100644 --- a/t/virtual_table/01_destroy.t +++ b/t/virtual_table/01_destroy.t @@ -51,8 +51,8 @@ ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created"; ok !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab connected"; my $sth = $dbh->prepare("SELECT * FROM barfoo"); -ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created"; -is $DBD::SQLite::VirtualTable::T::CONNECT_COUNT, 1, "1 vtab connected"; +ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created"; +is $DBD::SQLite::VirtualTable::T::CONNECT_COUNT, 1, "1 vtab connected"; package DBD::SQLite::VirtualTable::T; diff --git a/t/virtual_table/02_find_function.t b/t/virtual_table/02_find_function.t new file mode 100644 index 0000000..b7e49d4 --- /dev/null +++ b/t/virtual_table/02_find_function.t @@ -0,0 +1,173 @@ +#!/usr/bin/perl +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; + +plan tests => 15; + +my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 ); + +$dbh->sqlite_create_module(vtab => "DBD::SQLite::VirtualTable::T"); + +ok $dbh->do("CREATE VIRTUAL TABLE foobar USING vtab(foo INTEGER, bar INTEGER)"), + "created foobar"; + +# overload functions "abs" and "substr" +$DBD::SQLite::VirtualTable::T::funcs{abs}{overloaded} + = sub {my $val = shift; return "fake_abs($val)" }; +$DBD::SQLite::VirtualTable::T::funcs{substr}{overloaded} + = sub {my ($val, $offset, $len) = @_; return "fake_substr($val, $offset, $len)" }; + +# make a first query +my $row = $dbh->selectrow_hashref(<<""); + SELECT abs(foo) afoo, + abs(bar) abar, + substr(foo, 3, 5) sfoo, + trim(foo) tfoo + FROM foobar + +is $DBD::SQLite::VirtualTable::T::funcs{abs}{calls}, 1, "abs called"; +is $DBD::SQLite::VirtualTable::T::funcs{substr}{calls}, 1, "substr called"; +is $DBD::SQLite::VirtualTable::T::funcs{trim}{calls}, 1, "trim called"; + +is_deeply $row, { 'abar' => 'fake_abs(1)', + 'afoo' => 'fake_abs(0)', + 'sfoo' => 'fake_substr(0, 3, 5)', + 'tfoo' => '0' }, "func results"; + +# new query : FIND_FUNCTION should not be called again +$row = $dbh->selectrow_hashref(<<""); + SELECT abs(foo) afoo, + abs(bar) abar, + substr(foo, 3, 5) sfoo, + trim(foo) tfoo + FROM foobar + +is $DBD::SQLite::VirtualTable::T::funcs{abs}{calls}, 1, "abs still 1"; +is $DBD::SQLite::VirtualTable::T::funcs{substr}{calls}, 1, "substr still 1"; +is $DBD::SQLite::VirtualTable::T::funcs{trim}{calls}, 1, "trim still 1"; + + +# new table : should issue new calls to FIND_FUNCTION +ok $dbh->do("CREATE VIRTUAL TABLE barfoo USING vtab(foo INTEGER, bar INTEGER)"), + "created barfoo"; + +$row = $dbh->selectrow_hashref(<<""); + SELECT abs(foo) afoo, + abs(bar) abar, + substr(foo, 3, 5) sfoo, + trim(foo) tfoo + FROM barfoo + +is $DBD::SQLite::VirtualTable::T::funcs{abs}{calls}, 2, "abs now 2"; +is $DBD::SQLite::VirtualTable::T::funcs{substr}{calls}, 2, "substr now 2"; +is $DBD::SQLite::VirtualTable::T::funcs{trim}{calls}, 2, "trim now 2"; + + +# drop table : should free references to functions +ok $dbh->do("DROP TABLE foobar"); + +# drop connection +undef $dbh; + +note "done"; + +package DBD::SQLite::VirtualTable::T; +use strict; +use warnings; +use base 'DBD::SQLite::VirtualTable'; +use YAML; + + + +sub BEST_INDEX { + my ($self, $constraints, $order_by) = @_; + + my $ix = 0; + + foreach my $constraint (@$constraints) { + $constraint->{argvIndex} = $ix++; + $constraint->{omit} = 1; # to prevent sqlite core to check values + } + + my $outputs = { + idxNum => 1, + idxStr => "foobar", + orderByConsumed => 0, + estimatedCost => 1.0, + estimatedRows => undef, + }; + + return $outputs; +} + +our %funcs; + + +sub FIND_FUNCTION { + my ($self, $n_arg, $function_name) = @_; + + $funcs{$function_name}{calls} += 1; + my $func = $funcs{$function_name}{overloaded}; + return $func; +} + + +package DBD::SQLite::VirtualTable::T::Cursor; +use strict; +use warnings; +use base 'DBD::SQLite::VirtualTable::Cursor'; +use YAML; + +sub NEW { + my $class = shift; + + my $self = $class->DBD::SQLite::VirtualTable::Cursor::NEW(@_); + $self->{row_count} = 5; + + return $self; +} + +sub FILTER { + my ($self, $idxNum, $idxStr, @values) = @_; + + return; +} + + + +sub EOF { + my $self = shift; + + return !$self->{row_count}; +} + +sub NEXT { + my $self = shift; + + $self->{row_count}--; +} + +sub COLUMN { + my ($self, $idxCol) = @_; + + return $idxCol; +} + +sub ROWID { + my ($self) = @_; + + return $self->{row_count}; +} + + +1; + + + From ab008be4e31e6b365bc5c9d6a4a682c23ab107cb Mon Sep 17 00:00:00 2001 From: Laurent Dami Date: Sun, 20 Jul 2014 20:29:02 +0200 Subject: [PATCH 7/8] test the example described in L --- MANIFEST | 1 + t/virtual_table/21_perldata_charinfo.t | 52 ++++++++++++++++++++++++++ 2 files changed, 53 insertions(+) create mode 100644 t/virtual_table/21_perldata_charinfo.t diff --git a/MANIFEST b/MANIFEST index 5b588e4..317850f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -116,6 +116,7 @@ t/virtual_table/02_find_function.t t/virtual_table/10_filecontent.t t/virtual_table/11_filecontent_fulltext.t t/virtual_table/20_perldata.t +t/virtual_table/21_perldata_charinfo.t typemap util/getsqlite.pl xt/meta.t diff --git a/t/virtual_table/21_perldata_charinfo.t b/t/virtual_table/21_perldata_charinfo.t new file mode 100644 index 0000000..6ae5522 --- /dev/null +++ b/t/virtual_table/21_perldata_charinfo.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +# test the example described in +# L + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; + +use Unicode::UCD 'charinfo'; + +our $chars = [map {charinfo($_)} 0x300..0x400]; + +plan tests => 10; + +my $dbh = connect_ok( RaiseError => 1, AutoCommit => 1 ); + +ok $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"), + "create_module"; + +ok $dbh->do(<<""), "create table"; + CREATE VIRTUAL TABLE charinfo USING perl( + code, name, block, script, category, + hashrefs="main::chars") + +my $sql = "SELECT * FROM charinfo WHERE script='Greek' AND name LIKE '%SIGMA%'"; +my $res = $dbh->selectall_arrayref($sql, {Slice => {}}); +ok scalar(@$res), "found sigma letters"; +is $res->[0]{block}, "Greek and Coptic", "letter in proper block"; + +# The former example used SQLite's LIKE operator; now do the same with MATCH +# which gets translated to a Perl regex +$sql = "SELECT * FROM charinfo WHERE script='Greek' AND name MATCH 'SIGMA'"; +$res = $dbh->selectall_arrayref($sql, {Slice => {}}); +ok scalar(@$res), "found sigma letters"; +is $res->[0]{block}, "Greek and Coptic", "letter in proper block"; + +# the following does not work because \b gets escaped as a literal +#$sql = "SELECT * FROM charinfo WHERE script='Greek' AND name MATCH '\\bSIGMA\\b'"; + + +# but the following does work because the REGEXP operator is handled +# outside of the BEST_INDEX / FILTER methods +$sql = "SELECT * FROM charinfo WHERE script='Greek' AND name REGEXP '\\bSIGMA\\b'"; +$res = $dbh->selectall_arrayref($sql, {Slice => {}}); +ok scalar(@$res), "found sigma letters"; +is $res->[0]{block}, "Greek and Coptic", "letter in proper block"; From c1ddd221202df13791153658bb1d957427ce08da Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Mon, 21 Jul 2014 08:22:47 +0900 Subject: [PATCH 8/8] fixes for VC6 --- dbdimp.c | 126 +++++++++++++++++++++++++++++++++---------------------- 1 file changed, 75 insertions(+), 51 deletions(-) diff --git a/dbdimp.c b/dbdimp.c index 5185199..fe99dfd 100644 --- a/dbdimp.c +++ b/dbdimp.c @@ -153,6 +153,7 @@ stacked_sv_from_sqlite3_value(pTHX_ sqlite3_value *value, int is_unicode) STRLEN len; sqlite_int64 iv; int type = sqlite3_value_type(value); + SV *sv; switch(type) { case SQLITE_INTEGER: @@ -174,7 +175,7 @@ stacked_sv_from_sqlite3_value(pTHX_ sqlite3_value *value, int is_unicode) break; case SQLITE_TEXT: len = sqlite3_value_bytes(value); - SV *sv = newSVpvn((const char *)sqlite3_value_text(value), len); + sv = newSVpvn((const char *)sqlite3_value_text(value), len); if (is_unicode) { SvUTF8_on(sv); } @@ -1703,7 +1704,7 @@ sqlite_db_aggr_step_dispatcher(sqlite3_context *context, { dTHX; dSP; - int i; + int i, is_unicode = 0; /* TODO : find out from db handle */ aggrInfo *aggr; aggr = sqlite3_aggregate_context(context, sizeof (aggrInfo)); @@ -1721,8 +1722,6 @@ sqlite_db_aggr_step_dispatcher(sqlite3_context *context, if ( aggr->err || !aggr->aggr_inst ) goto cleanup; - int is_unicode = 0; /* TODO : find out from db handle */ - PUSHMARK(SP); XPUSHs( sv_2mortal( newSVsv( aggr->aggr_inst ) )); @@ -2798,9 +2797,10 @@ static int _call_perl_vtab_method(sqlite3_vtab *pVTab, const char *method, int i) { dTHX; dSP; + int count; + ENTER; SAVETMPS; - int count; PUSHMARK(SP); XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); @@ -2829,6 +2829,8 @@ static int perl_vt_New(const char *method, perl_vtab_init *init_data = (perl_vtab_init *)pAux; int count, i; int rc = SQLITE_ERROR; + SV *perl_vtab_obj; + SV *sql; /* allocate a perl_vtab structure */ vt = (perl_vtab *) sqlite3_malloc(sizeof(*vt)); @@ -2859,7 +2861,7 @@ static int perl_vt_New(const char *method, } /* get the VirtualTable instance */ - SV *perl_vtab_obj = POPs; + perl_vtab_obj = POPs; if ( !sv_isobject(perl_vtab_obj) ) { *pzErr = sqlite3_mprintf("vtab->%s() should return a blessed reference", method); @@ -2884,7 +2886,7 @@ static int perl_vt_New(const char *method, /* call sqlite3_declare_vtab with the sql returned from method VTAB_TO_DECLARE(), converted to utf8 */ - SV *sql = POPs; + sql = POPs; rc = sqlite3_declare_vtab(db, SvPVutf8_nolen(sql)); cleanup: @@ -2966,13 +2968,20 @@ _constraint_op_to_string(unsigned char op) { static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ dTHX; dSP; + int i, count; + int argvIndex; + AV *constraints; + AV *order_by; + SV *hashref; + SV **val; + HV *hv; + struct sqlite3_index_constraint_usage *pConsUsage; + ENTER; SAVETMPS; - int i, count; - /* build the "where_constraints" datastructure */ - AV *constraints = newAV(); + constraints = newAV(); for (i=0; inConstraint; i++){ struct sqlite3_index_constraint const *pCons = &pIdxInfo->aConstraint[i]; HV *constraint = newHV(); @@ -2984,7 +2993,7 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ } /* build the "order_by" datastructure */ - AV *order_by = newAV(); + order_by = newAV(); for (i=0; inOrderBy; i++){ struct sqlite3_index_orderby const *pOrder = &pIdxInfo->aOrderBy[i]; HV *order = newHV(); @@ -3005,11 +3014,10 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ /* get values back from the returned hashref */ if (count != 1) croak("BEST_INDEX() method returned %d vals instead of 1", count); - SV *hashref = POPs; + hashref = POPs; if (!(hashref && SvROK(hashref) && SvTYPE(SvRV(hashref)) == SVt_PVHV)) croak("BEST_INDEX() method did not return a hashref"); - HV *hv = (HV*)SvRV(hashref); - SV **val; + hv = (HV*)SvRV(hashref); val = hv_fetch(hv, "idxNum", 6, FALSE); pIdxInfo->idxNum = (val && SvOK(*val)) ? SvIV(*val) : 0; val = hv_fetch(hv, "idxStr", 6, FALSE); @@ -3034,12 +3042,11 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ SV **rv = av_fetch(constraints, i, FALSE); if (!(rv && SvROK(*rv) && SvTYPE(SvRV(*rv)) == SVt_PVHV)) croak("the call to BEST_INDEX() has corrupted constraint data"); - HV *hv = (HV*)SvRV(*rv); - SV **val = hv_fetch(hv, "argvIndex", 9, FALSE); - int argvIndex = (val && SvOK(*val)) ? SvIV(*val) + 1: 0; + hv = (HV*)SvRV(*rv); + val = hv_fetch(hv, "argvIndex", 9, FALSE); + argvIndex = (val && SvOK(*val)) ? SvIV(*val) + 1: 0; - struct sqlite3_index_constraint_usage *pConsUsage - = &pIdxInfo->aConstraintUsage[i]; + pConsUsage = &pIdxInfo->aConstraintUsage[i]; pConsUsage->argvIndex = argvIndex; val = hv_fetch(hv, "omit", 4, FALSE); pConsUsage->omit = (val && SvTRUE(*val)) ? 1 : 0; @@ -3057,15 +3064,15 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){ static int perl_vt_Open(sqlite3_vtab *pVTab, sqlite3_vtab_cursor **ppCursor){ dTHX; dSP; - ENTER; - SAVETMPS; - int count; int rc = SQLITE_ERROR; SV *perl_cursor; + perl_vtab_cursor *cursor; + + ENTER; + SAVETMPS; /* allocate a perl_vtab_cursor structure */ - perl_vtab_cursor *cursor; cursor = (perl_vtab_cursor *) sqlite3_malloc(sizeof(*cursor)); if( cursor==NULL ) return SQLITE_NOMEM; memset(cursor, 0, sizeof(*cursor)); @@ -3111,14 +3118,16 @@ static int perl_vt_Open(sqlite3_vtab *pVTab, sqlite3_vtab_cursor **ppCursor){ static int perl_vt_Close(sqlite3_vtab_cursor *pVtabCursor){ dTHX; dSP; + int count; + perl_vtab_cursor *perl_pVTabCursor; + ENTER; SAVETMPS; - int count; /* Note : there is no explicit call to a CLOSE() method; if needed, the Perl class can implement a DESTROY() method */ - perl_vtab_cursor *perl_pVTabCursor = (perl_vtab_cursor *) pVtabCursor; + perl_pVTabCursor = (perl_vtab_cursor *) pVtabCursor; SvREFCNT_dec(perl_pVTabCursor->perl_cursor_obj); sqlite3_free(perl_pVTabCursor); @@ -3134,11 +3143,12 @@ static int perl_vt_Filter( sqlite3_vtab_cursor *pVtabCursor, int argc, sqlite3_value **argv ){ dTHX; dSP; - ENTER; - SAVETMPS; int i, count; int is_unicode = _last_dbh_is_unicode(); + ENTER; + SAVETMPS; + /* call the FILTER() method with ($idxNum, $idxStr, @args) */ PUSHMARK(SP); XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_obj); @@ -3163,9 +3173,10 @@ static int perl_vt_Filter( sqlite3_vtab_cursor *pVtabCursor, static int perl_vt_Next(sqlite3_vtab_cursor *pVtabCursor){ dTHX; dSP; + int i, count; + ENTER; SAVETMPS; - int i, count; /* call the next() method */ PUSHMARK(SP); @@ -3185,9 +3196,10 @@ static int perl_vt_Next(sqlite3_vtab_cursor *pVtabCursor){ static int perl_vt_Eof(sqlite3_vtab_cursor *pVtabCursor){ dTHX; dSP; + int count, eof; + ENTER; SAVETMPS; - int count, eof; /* call the eof() method */ PUSHMARK(SP); @@ -3217,11 +3229,12 @@ static int perl_vt_Column(sqlite3_vtab_cursor *pVtabCursor, int col){ dTHX; dSP; - ENTER; - SAVETMPS; int count; int rc = SQLITE_ERROR; + ENTER; + SAVETMPS; + /* call the column() method */ PUSHMARK(SP); XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_obj); @@ -3251,11 +3264,12 @@ static int perl_vt_Rowid( sqlite3_vtab_cursor *pVtabCursor, sqlite3_int64 *pRowid ){ dTHX; dSP; - ENTER; - SAVETMPS; int count; int rc = SQLITE_ERROR; + ENTER; + SAVETMPS; + /* call the rowid() method */ PUSHMARK(SP); XPUSHs(((perl_vtab_cursor *) pVtabCursor)->perl_cursor_obj); @@ -3283,11 +3297,13 @@ static int perl_vt_Update( sqlite3_vtab *pVTab, sqlite3_int64 *pRowid ){ dTHX; dSP; - ENTER; - SAVETMPS; int count, i; int is_unicode = _last_dbh_is_unicode(); int rc = SQLITE_ERROR; + SV *rowidsv; + + ENTER; + SAVETMPS; /* call the _SQLITE_UPDATE() method */ PUSHMARK(SP); @@ -3307,7 +3323,7 @@ static int perl_vt_Update( sqlite3_vtab *pVTab, && sqlite3_value_type(argv[1]) == SQLITE_NULL) { /* this was an insert without any given rowid, so the result of the method call must be passed in *pRowid*/ - SV *rowidsv = POPs; + rowidsv = POPs; if (!SvOK(rowidsv)) *pRowid = 0; else if (SvUOK(rowidsv)) @@ -3350,18 +3366,21 @@ static int perl_vt_FindFunction(sqlite3_vtab *pVTab, void **ppArg){ dTHX; dSP; - ENTER; - SAVETMPS; int count; int is_overloaded = 0; char *func_name = sqlite3_mprintf("%s\t%d", zName, nArg); STRLEN len = strlen(func_name); HV *functions = ((perl_vtab *) pVTab)->functions; SV* coderef = NULL; + SV** val; + SV *result; + + ENTER; + SAVETMPS; /* check if that function was already in cache */ if (hv_exists(functions, func_name, len)) { - SV** val = hv_fetch(functions, func_name, len, FALSE); + val = hv_fetch(functions, func_name, len, FALSE); if (val && SvOK(*val)) { coderef = *val; } @@ -3380,7 +3399,7 @@ static int perl_vt_FindFunction(sqlite3_vtab *pVTab, SP -= count; goto cleanup; } - SV *result = POPs; + result = POPs; if (SvTRUE(result)) { /* the coderef must be valid for the lifetime of pVTab, so make a copy */ @@ -3411,11 +3430,12 @@ static int perl_vt_FindFunction(sqlite3_vtab *pVTab, static int perl_vt_Rename(sqlite3_vtab *pVTab, const char *zNew){ dTHX; dSP; - ENTER; - SAVETMPS; int count; int rc = SQLITE_ERROR; + ENTER; + SAVETMPS; + PUSHMARK(SP); XPUSHs(((perl_vtab *) pVTab)->perl_vtab_obj); XPUSHs(sv_2mortal(newSVpv(zNew, 0))); @@ -3481,12 +3501,14 @@ sqlite_db_destroy_module_data(void *pAux) { dTHX; dSP; - ENTER; - SAVETMPS; int count; int rc = SQLITE_ERROR; + perl_vtab_init *init_data; - perl_vtab_init *init_data = (perl_vtab_init *)pAux; + ENTER; + SAVETMPS; + + init_data = (perl_vtab_init *)pAux; /* call the DESTROY_MODULE() method */ PUSHMARK(SP); @@ -3511,11 +3533,14 @@ int sqlite_db_create_module(pTHX_ SV *dbh, const char *name, const char *perl_class) { dSP; - ENTER; - SAVETMPS; - D_imp_dbh(dbh); int count, rc, retval = TRUE; + char *module_ISA; + char *loading_code; + perl_vtab_init *init_data; + + ENTER; + SAVETMPS; if (!DBIc_ACTIVE(imp_dbh)) { sqlite_error(dbh, -2, "attempt to create module on inactive database handle"); @@ -3523,16 +3548,15 @@ sqlite_db_create_module(pTHX_ SV *dbh, const char *name, const char *perl_class) } /* load the module if needed */ - char *module_ISA = sqlite3_mprintf("%s::ISA", perl_class); + module_ISA = sqlite3_mprintf("%s::ISA", perl_class); if (!get_av(module_ISA, 0)) { - char *loading_code = sqlite3_mprintf("use %s", perl_class); + loading_code = sqlite3_mprintf("use %s", perl_class); eval_pv(loading_code, TRUE); sqlite3_free(loading_code); } sqlite3_free(module_ISA); /* build the init datastructure that will be passed to perl_vt_New() */ - perl_vtab_init *init_data; init_data = sqlite3_malloc(sizeof(*init_data)); init_data->dbh = newRV(dbh); sv_rvweaken(init_data->dbh);