new implementation for collation_needed, no more malloc -- should no longer leak

new API for global registry of collations, using a "write-once" tied hash

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)

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->in_tran                   = FALSE;
-    imp_dbh->unicode             = FALSE;
+    imp_dbh->unicode                   = FALSE;
-    imp_dbh->functions           = newAV();
+    imp_dbh->functions                 = newAV();
-    imp_dbh->aggregates          = newAV();
+    imp_dbh->aggregates                = newAV();
-    imp_dbh->timeout             = SQL_TIMEOUT;
+    imp_dbh->collation_needed_callback = newSVsv( &PL_sv_undef );
-    imp_dbh->handle_binary_nulls = FALSE;
+    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,
+    SV *dbh,
-    sqlite3* db, /* unused, because we need the Perl dbh */
+    sqlite3* db,               /* unused */
-    int eTextRep,
+    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);
+    /* remember the callback within the dbh */
-    collationNeededInfo* info = sqlite3_malloc(sizeof(collationNeededInfo));
+    sv_setsv(imp_dbh->collation_needed_callback, callback);
-    /* 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;
 
     /* 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 )

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 );

lib/DBD/SQLite.pm

@@ -27,10 +27,10 @@ BEGIN {
 
 __PACKAGE__->bootstrap($VERSION);
 
-%COLLATION = (
+tie  %COLLATION, 'DBD::SQLite::_WriteOnceHash';
-  perl       => sub { $_[0] cmp $_[1] },
+$COLLATION{perl}       = sub { $_[0] cmp $_[1] };
-  perllocale => sub { use locale; $_[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 
+    $DBI::VERSION >= 1.608 
-    #   ? $dbh->sqlite_collation_needed(\&install_collation)
+      ? $dbh->sqlite_collation_needed(\&install_collation)
-    #   : $dbh->func(\&install_collation, "collation_needed");
+      : $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);
-    }
 
     # Register the REGEXP function 
     $DBI::VERSION >= 1.608 
       ? $dbh->sqlite_create_function("REGEXP", 2, \&regexp)
       : $dbh->func("REGEXP", 2, \&regexp, "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.
+be invoked whenever an undefined collation sequence is required
-The callback is invoked as 
+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</"sqlite_create_collation"> and
@@ -1175,8 +1196,24 @@ characters :
   my $rows = $dbh->selectall_arrayref($sql);
 
 
-The builtin C<perl> or C<perllocale> collations are also in
+The builtin C<perl> or C<perllocale> collations are predefined
-the same hash and therefore could be overridden if needed.
+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<perl> and C<perllocale>).  
+
+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<requests> 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</create_collation> method directly.
 
 
 =head1 BLOBS

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
+	berger Bergère bergère Bergere
-	HOT hôôe 
+	HOT hôte 
-	héôéòoclite héôaïòe hêôre héòaut
+	hétéroclite hétaïre hêtre héraut
-	HAT hâôer 
+	HAT hâter 
-	féôu fêôe fèöe ferme
+	fétu fête fève ferme
      };
     if ($use_unicode) {
       utf8::upgrade($_) foreach @words;
@@ -102,3 +141,6 @@ foreach my $call_func (@CALL_FUNCS) {
   }
 }
 
+
+
+

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