diff --git a/SQLite.xs b/SQLite.xs index d903842..c009e88 100644 --- a/SQLite.xs +++ b/SQLite.xs @@ -81,7 +81,6 @@ create_collation(dbh, name, func) OUTPUT: RETVAL -#if 0 static void collation_needed(dbh, callback) @@ -94,7 +93,6 @@ collation_needed(dbh, callback) sqlite_db_collation_needed(aTHX_ dbh, callback ); } -#endif static int progress_handler(dbh, n_opcodes, handler) diff --git a/dbdimp.c b/dbdimp.c index 25e0aa9..d4f6c72 100644 --- a/dbdimp.c +++ b/dbdimp.c @@ -84,12 +84,13 @@ sqlite_db_login(SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *user, char *pas } DBIc_IMPSET_on(imp_dbh); - imp_dbh->in_tran = FALSE; - imp_dbh->unicode = FALSE; - imp_dbh->functions = newAV(); - imp_dbh->aggregates = newAV(); - imp_dbh->timeout = SQL_TIMEOUT; - imp_dbh->handle_binary_nulls = FALSE; + imp_dbh->in_tran = FALSE; + imp_dbh->unicode = FALSE; + imp_dbh->functions = newAV(); + imp_dbh->aggregates = newAV(); + imp_dbh->collation_needed_callback = newSVsv( &PL_sv_undef ); + imp_dbh->timeout = SQL_TIMEOUT; + imp_dbh->handle_binary_nulls = FALSE; sqlite3_busy_timeout(imp_dbh->db, SQL_TIMEOUT); @@ -172,6 +173,10 @@ sqlite_db_disconnect (SV *dbh, imp_dbh_t *imp_dbh) SvREFCNT_dec(imp_dbh->aggregates); imp_dbh->aggregates = (AV *)NULL; + sv_setsv(imp_dbh->collation_needed_callback, &PL_sv_undef); + SvREFCNT_dec(imp_dbh->collation_needed_callback); + imp_dbh->collation_needed_callback = (SV *)NULL; + return TRUE; } @@ -1312,26 +1317,27 @@ sqlite_db_create_collation(pTHX_ SV *dbh, const char *name, SV *func ) return TRUE; } -#if 0 void sqlite_db_collation_needed_dispatcher ( - void *info, - sqlite3* db, /* unused, because we need the Perl dbh */ - int eTextRep, + SV *dbh, + sqlite3* db, /* unused */ + int eTextRep, /* unused */ const char* collation_name ) { dTHX; dSP; + D_imp_dbh(dbh); + ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs( sv_2mortal ( newSVsv( ((collationNeededInfo*)info)->dbh ) ) ); + XPUSHs( sv_2mortal ( newSVsv(dbh ) ) ); XPUSHs( sv_2mortal ( newSVpv( collation_name, 0) ) ); PUTBACK; - call_sv( ((collationNeededInfo*)info)->callback, G_VOID ); + call_sv( imp_dbh->collation_needed_callback, G_VOID ); SPAGAIN; PUTBACK; @@ -1344,25 +1350,14 @@ sqlite_db_collation_needed(pTHX_ SV *dbh, SV *callback ) { D_imp_dbh(dbh); - SV *callback_sv = newSVsv(callback); - collationNeededInfo* info = sqlite3_malloc(sizeof(collationNeededInfo)); - /* TODO: this struct should probably be freed at some point, not sure - how and when */ - - /* Copy the handler ref so that it can be deallocated at disconnect */ - av_push( imp_dbh->functions, callback_sv ); - - /* the dispatcher will need both the callback and dbh, so build a struct */ - info->callback = callback_sv; - info->dbh = dbh; + /* remember the callback within the dbh */ + sv_setsv(imp_dbh->collation_needed_callback, callback); /* Register the func within sqlite3 */ (void) sqlite3_collation_needed( imp_dbh->db, - (void*) info, + (void*) SvOK(callback) ? dbh : NULL, sqlite_db_collation_needed_dispatcher ); - } -#endif int sqlite_db_generic_callback_dispatcher( void *callback ) diff --git a/dbdimp.h b/dbdimp.h index dd2a76f..ce17302 100644 --- a/dbdimp.h +++ b/dbdimp.h @@ -25,6 +25,7 @@ struct imp_dbh_st { int timeout; AV *functions; AV *aggregates; + SV *collation_needed_callback; }; /* Statement Handle */ @@ -78,13 +79,6 @@ struct aggrInfo { int inited; }; -#if 0 -typedef struct collationNeededInfo collationNeededInfo; -struct collationNeededInfo { - SV *dbh; - SV *callback; -}; -#endif int sqlite_db_create_function(pTHX_ SV *dbh, const char *name, int argc, SV *func); int sqlite_db_enable_load_extension(pTHX_ SV *dbh, int onoff); @@ -96,10 +90,7 @@ int sqlite_bind_col( SV *sth, imp_sth_t *imp_sth, SV *col, SV *ref, IV sql_type, int sqlite_db_busy_timeout (pTHX_ SV *dbh, int timeout ); int sqlite_db_backup_from_file(pTHX_ SV *dbh, char *filename); int sqlite_db_backup_to_file(pTHX_ SV *dbh, char *filename); - -#if 0 void sqlite_db_collation_needed(pTHX_ SV *dbh, SV *callback ); -#endif SV* sqlite_db_commit_hook( pTHX_ SV *dbh, SV *hook ); SV* sqlite_db_rollback_hook( pTHX_ SV *dbh, SV *hook ); SV* sqlite_db_update_hook( pTHX_ SV *dbh, SV *hook ); diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm index ae99fb8..7e055d1 100644 --- a/lib/DBD/SQLite.pm +++ b/lib/DBD/SQLite.pm @@ -27,10 +27,10 @@ BEGIN { __PACKAGE__->bootstrap($VERSION); -%COLLATION = ( - perl => sub { $_[0] cmp $_[1] }, - perllocale => sub { use locale; $_[0] cmp $_[1] }, - ); +tie %COLLATION, 'DBD::SQLite::_WriteOnceHash'; +$COLLATION{perl} = sub { $_[0] cmp $_[1] }; +$COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] }; + my $methods_are_installed; @@ -46,7 +46,7 @@ sub driver { DBD::SQLite::db->install_method('sqlite_create_function'); DBD::SQLite::db->install_method('sqlite_create_aggregate'); DBD::SQLite::db->install_method('sqlite_create_collation'); -# DBD::SQLite::db->install_method('sqlite_collation_needed'); + DBD::SQLite::db->install_method('sqlite_collation_needed'); DBD::SQLite::db->install_method('sqlite_progress_handler'); DBD::SQLite::db->install_method('sqlite_commit_hook'); DBD::SQLite::db->install_method('sqlite_rollback_hook'); @@ -70,6 +70,8 @@ sub CLONE { undef $drh; } + + package DBD::SQLite::dr; sub connect { @@ -120,22 +122,15 @@ sub connect { DBD::SQLite::db::_login($dbh, $real, $user, $auth) or return undef; # Register the on-demand collation installer - # $DBI::VERSION >= 1.608 - # ? $dbh->sqlite_collation_needed(\&install_collation) - # : $dbh->func(\&install_collation, "collation_needed"); - - # XXX: Current collation_needed implementation is leaking badly. - # Don't use it before we fix the leak. - foreach my $collation_name(keys %DBD::SQLite::COLLATION) { - install_collation($dbh, $collation_name); - } + $DBI::VERSION >= 1.608 + ? $dbh->sqlite_collation_needed(\&install_collation) + : $dbh->func(\&install_collation, "collation_needed"); # Register the REGEXP function $DBI::VERSION >= 1.608 ? $dbh->sqlite_create_function("REGEXP", 2, \®exp) : $dbh->func("REGEXP", 2, \®exp, "create_function"); - # HACK: Since PrintWarn = 0 doesn't seem to actually prevent warnings # in DBD::SQLite we set Warn to false if PrintWarn is false. unless ( $attr->{PrintWarn} ) { @@ -498,8 +493,34 @@ sub column_info { return $sth; } + +#====================================================================== +# An internal tied hash package used for %DBD::SQLite::COLLATION, to +# prevent people from unintentionally overriding globally registered collations. + +package DBD::SQLite::_WriteOnceHash; +require Tie::Hash; + +our @ISA = qw(Tie::StdHash); + +sub TIEHASH { + bless {}, $_[0]; +} + +sub STORE { + ! exists $_[0]->{$_[1]} or die "entry $_[1] already registered"; + $_[0]->{$_[1]} = $_[2]; +} + +sub DELETE { + die "deletion of entry $_[1] is forbidden"; +} + 1; + + + __END__ =pod @@ -725,8 +746,8 @@ The driver will check that this is a proper sorting function. =head2 $dbh->sqlite_collation_needed( $code_ref ) This method manually registers a callback function that will -be invoked whenever an undefined collation sequence is required. -The callback is invoked as +be invoked whenever an undefined collation sequence is required +from an SQL statement. The callback is invoked as $code_ref->($dbh, $collation_name) @@ -1148,7 +1169,7 @@ is to set the parameter at connection time : ); -=head2 Adding user-defined collation +=head2 Adding user-defined collations The native SQLite API for adding user-defined collations is exposed through methods L and @@ -1175,8 +1196,24 @@ characters : my $rows = $dbh->selectall_arrayref($sql); -The builtin C or C collations are also in -the same hash and therefore could be overridden if needed. +The builtin C or C collations are predefined +in that same hash. + +The COLLATION hash is a global registry within the current process; + hence there is a risk of undesired side-effects. Therefore, to + prevent action at distance, the hash is implemented as a "write-only" + hash, that will happily accept new entries, but will raise an + exception if any attempt is made to override or delete a existing + entry (including the builtin C and C). + +If you really, really need to change or delete an entry, you can + always grab the tied object underneath C<%DBD::SQLite::COLLATION> --- + but don't do that unless you really know what you are doing. Also +observe that changes in the global hash will not modify existing +collations in existing database handles: it will only affect new +I for collations. In other words, if you want to change +the behaviour of a collation within an existing C<$dbh>, you +need to call the L method directly. =head1 BLOBS diff --git a/t/13_create_collation.t b/t/13_create_collation.t index 9f85e2d..169af4c 100644 --- a/t/13_create_collation.t +++ b/t/13_create_collation.t @@ -6,11 +6,15 @@ BEGIN { $^W = 1; } -use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use t::lib::Test qw/connect_ok dies @CALL_FUNCS/; use Test::More; BEGIN { + my $COLLATION_TESTS = 10; + my $WRITE_ONCE_TESTS = 4; + if ( $] >= 5.008005 ) { - plan( tests => 10 * @CALL_FUNCS + 1 ); + plan( tests => $COLLATION_TESTS * @CALL_FUNCS + + $WRITE_ONCE_TESTS + 1); } else { plan( skip_all => 'Unicode is not supported before 5.8.5' ); } @@ -38,9 +42,17 @@ sub no_accents ($$) { } sub by_length ($$) { - length($_[0]) <=> length($_[1]) + length($_[0]) <=> length($_[1]) } +sub by_num ($$) { + $_[0] <=> $_[1]; +} +sub by_num_desc ($$) { + $_[1] <=> $_[0]; +} + + # collation 'no_accents' will be automatically loaded on demand $DBD::SQLite::COLLATION{no_accents} = \&no_accents; @@ -49,6 +61,33 @@ $" = ", "; # to embed arrays into message strings my $sql = "SELECT txt from collate_test ORDER BY txt"; + + +# test interaction with the global COLLATION hash ("WriteOnce") + +dies (sub {$DBD::SQLite::COLLATION{perl} = sub {}}, + qr/already registered/, + "can't override builtin perl collation"); + +dies (sub {delete $DBD::SQLite::COLLATION{perl}}, + qr/deletion .* is forbidden/, + "can't delete builtin perl collation"); + +# once a collation is registered, we can't override it ... unless by +# digging into the tied object +$DBD::SQLite::COLLATION{foo} = \&by_num; +dies (sub {$DBD::SQLite::COLLATION{foo} = \&by_num_desc}, + qr/already registered/, + "can't override registered collation"); +my $tied = tied %DBD::SQLite::COLLATION; +delete $tied->{foo}; +$DBD::SQLite::COLLATION{foo} = \&by_num_desc; # override, no longer dies +is($DBD::SQLite::COLLATION{foo}, \&by_num_desc, "overridden collation"); + + + +# now really test the collation functions + foreach my $call_func (@CALL_FUNCS) { for my $use_unicode (0, 1) { @@ -58,11 +97,11 @@ foreach my $call_func (@CALL_FUNCS) { # populate test data my @words = qw{ - berger Bergèòe bergèòe Bergere - HOT hôôe - héôéòoclite héôaïòe hêôre héòaut - HAT hâôer - féôu fêôe fèöe ferme + berger Bergère bergère Bergere + HOT hôte + hétéroclite hétaïre hêtre héraut + HAT hâter + fétu fête fève ferme }; if ($use_unicode) { utf8::upgrade($_) foreach @words; @@ -102,3 +141,6 @@ foreach my $call_func (@CALL_FUNCS) { } } + + + diff --git a/t/lib/Test.pm b/t/lib/Test.pm index 81f1101..aa8de85 100644 --- a/t/lib/Test.pm +++ b/t/lib/Test.pm @@ -11,7 +11,7 @@ use vars qw{$VERSION @ISA @EXPORT @CALL_FUNCS}; BEGIN { $VERSION = '1.26_01'; @ISA = 'Exporter'; - @EXPORT = qw/connect_ok @CALL_FUNCS/; + @EXPORT = qw/connect_ok dies @CALL_FUNCS/; # Allow tests to load modules bundled in /inc unshift @INC, 'inc'; @@ -44,6 +44,24 @@ sub connect_ok { return $dbh; } +=head2 dies + + dies(sub {...}, $regex_expected_error, $msg) + +Tests that the given coderef (most probably a closure) dies with the +expected error message. + +=cut + +sub dies { + my ($coderef, $regex, $msg) = @_; + eval {$coderef->()}; + my $exception = $@; + Test::More::ok($exception =~ $regex, + $msg || "dies with exception: $exception"); +} + + =head2 @CALL_FUNCS