pod/perldelta.pod Changes since last version
pod/perl5005delta.pod Changes from 5.004 to 5.005
pod/perl5004delta.pod Changes from 5.003 to 5.004
+pod/perldbmfilter.pod Info about DBM Filters
pod/perldiag.pod Diagnostic info
pod/perldsc.pod Data Structures Cookbook
pod/perlembed.pod Embedding info
* Updated the message that db-recno.t prints when tests 51, 53 or 55 fail.
1.65 6th March 1999
+
* Fixed a bug in the recno PUSH logic.
* The BOOT version check now needs 2.3.4 when using Berkeley DB version 2
+
+1.66 15th March 1999
+
+ * Added DBM Filter code
#
# written by Paul Marquess (Paul.Marquess@btinternet.com)
# last modified 6th March 1999
-# version 1.65
+# version 1.66
#
# Copyright (c) 1995-9 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
use Carp;
-$VERSION = "1.65" ;
+$VERSION = "1.66" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
=head1 SEE ALSO
-L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>
+L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
+L<dbmfilter>
=head1 AUTHOR
written by Paul Marquess <Paul.Marquess@btinternet.com>
last modified 6th March 1999
- version 1.65
+ version 1.66
All comments/suggestions/problems are welcome
to fix a flag mapping problem with O_RDONLY on the Hurd
1.65 - Fixed a bug in the PUSH logic.
Added BOOT check that using 2.3.4 or greater
+ 1.66 - Added DBM filter code
#include <fcntl.h>
/* #define TRACE */
+#define DBM_FILTERING
#ifdef DB_VERSION_MAJOR
DBC * cursor ;
#endif
+#ifdef DBM_FILTERING
+ SV * filter_fetch_key ;
+ SV * filter_store_key ;
+ SV * filter_fetch_value ;
+ SV * filter_store_value ;
+ int filtering ;
+#endif /* DBM_FILTERING */
+
} DB_File_type;
typedef DB_File_type * DB_File ;
typedef DBT DBTKEY ;
+#ifdef DBM_FILTERING
+
+#define ckFilter(arg,type,name) \
+ if (db->type) { \
+ SV * save_defsv ; \
+ /* printf("filtering %s\n", name) ;*/ \
+ if (db->filtering) \
+ croak("recursion detected in %s", name) ; \
+ db->filtering = TRUE ; \
+ /* SAVE_DEFSV ;*/ /* save $_ */ \
+ save_defsv = newSVsv(DEFSV) ; \
+ sv_setsv(DEFSV, arg) ; \
+ PUSHMARK(sp) ; \
+ (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \
+ /* SPAGAIN ; */ \
+ sv_setsv(arg, DEFSV) ; \
+ sv_setsv(DEFSV, save_defsv) ; \
+ SvREFCNT_dec(save_defsv) ; \
+ /* PUTBACK ; */ \
+ db->filtering = FALSE ; \
+ /*printf("end of filtering %s\n", name) ;*/ \
+ }
+
+#else
+
+#define ckFilter(arg,type, name)
+
+#endif /* DBM_FILTERING */
+
#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
-#define OutputValue(arg, name) \
- { if (RETVAL == 0) { \
- my_sv_setpvn(arg, name.data, name.size) ; \
- } \
+#define OutputValue(arg, name) \
+ { if (RETVAL == 0) { \
+ my_sv_setpvn(arg, name.data, name.size) ; \
+ ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
+ } \
}
-#define OutputKey(arg, name) \
- { if (RETVAL == 0) \
- { \
- if (db->type != DB_RECNO) { \
- my_sv_setpvn(arg, name.data, name.size); \
- } \
- else \
- sv_setiv(arg, (I32)*(I32*)name.data - 1); \
- } \
+#define OutputKey(arg, name) \
+ { if (RETVAL == 0) \
+ { \
+ if (db->type != DB_RECNO) { \
+ my_sv_setpvn(arg, name.data, name.size); \
+ } \
+ else \
+ sv_setiv(arg, (I32)*(I32*)name.data - 1); \
+ ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
+ } \
}
Zero(RETVAL, 1, DB_File_type) ;
/* Default to HASH */
+#ifdef DBM_FILTERING
+ RETVAL->filtering = 0 ;
+ RETVAL->filter_fetch_key = RETVAL->filter_store_key =
+ RETVAL->filter_fetch_value = RETVAL->filter_store_value =
+#endif /* DBM_FILTERING */
RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
RETVAL->type = DB_HASH ;
SvREFCNT_dec(db->compare) ;
if (db->prefix)
SvREFCNT_dec(db->prefix) ;
+#ifdef DBM_FILTERING
+ if (db->filter_fetch_key)
+ SvREFCNT_dec(db->filter_fetch_key) ;
+ if (db->filter_store_key)
+ SvREFCNT_dec(db->filter_store_key) ;
+ if (db->filter_fetch_value)
+ SvREFCNT_dec(db->filter_fetch_value) ;
+ if (db->filter_store_value)
+ SvREFCNT_dec(db->filter_store_value) ;
+#endif /* DBM_FILTERING */
Safefree(db) ;
#ifdef DB_VERSION_MAJOR
if (RETVAL > 0)
if (RETVAL != 0)
break;
}
-#else
+#else
+
/* Set the Cursor to the Last element */
RETVAL = do_SEQ(db, key, value, R_LAST) ;
if (RETVAL >= 0)
key
value
+#ifdef DBM_FILTERING
+
+#define setFilter(type) \
+ { \
+ if (db->type) \
+ RETVAL = newSVsv(db->type) ; \
+ if (db->type && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db->type) ; \
+ db->type = NULL ; \
+ } \
+ else if (code) { \
+ if (db->type) \
+ sv_setsv(db->type, code) ; \
+ else \
+ db->type = newSVsv(code) ; \
+ } \
+ }
+
+
+SV *
+filter_fetch_key(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_key(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_fetch_value(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_value) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_value(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_value) ;
+ OUTPUT:
+ RETVAL
+
+#endif /* DBM_FILTERING */
# typemap for Perl 5 interface to Berkeley
#
# written by Paul Marquess <Paul.Marquess@btinternet.com>
-# last modified 21st February 1999
-# version 1.65
+# last modified 20th March 1999
+# version 1.66
#
#################################### DB SECTION
#
INPUT
T_dbtkeydatum
+ ckFilter($arg, filter_store_key, \"filter_store_key\");
if (db->type != DB_RECNO) {
$var.data = SvPV($arg, PL_na);
$var.size = (int)PL_na;
DBT_flags($var);
}
T_dbtdatum
+ ckFilter($arg, filter_store_value, \"filter_store_value\");
$var.data = SvPV($arg, PL_na);
$var.size = (int)PL_na;
DBT_flags($var);
=head1 SEE ALSO
-L<perl(1)>, L<DB_File(3)>.
+L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>.
=cut
GDBM_WRITER
);
-$VERSION = "1.01";
+$VERSION = "1.02";
sub AUTOLOAD {
my($constname);
#include <gdbm.h>
#include <fcntl.h>
-typedef GDBM_FILE GDBM_File;
+typedef struct {
+ GDBM_FILE dbp ;
+ SV * filter_fetch_key ;
+ SV * filter_store_key ;
+ SV * filter_fetch_value ;
+ SV * filter_store_value ;
+ int filtering ;
+ } GDBM_File_type;
+
+typedef GDBM_File_type * GDBM_File ;
+typedef datum datum_key ;
+typedef datum datum_value ;
+
+#define ckFilter(arg,type,name) \
+ if (db->type) { \
+ SV * save_defsv ; \
+ /* printf("filtering %s\n", name) ;*/ \
+ if (db->filtering) \
+ croak("recursion detected in %s", name) ; \
+ db->filtering = TRUE ; \
+ save_defsv = newSVsv(DEFSV) ; \
+ sv_setsv(DEFSV, arg) ; \
+ PUSHMARK(sp) ; \
+ (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \
+ sv_setsv(arg, DEFSV) ; \
+ sv_setsv(DEFSV, save_defsv) ; \
+ SvREFCNT_dec(save_defsv) ; \
+ db->filtering = FALSE ; \
+ /*printf("end of filtering %s\n", name) ;*/ \
+ }
-#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
-#define gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func) \
- gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)
-#define gdbm_FETCH(db,key) gdbm_fetch(db,key)
-#define gdbm_STORE(db,key,value,flags) gdbm_store(db,key,value,flags)
-#define gdbm_DELETE(db,key) gdbm_delete(db,key)
-#define gdbm_FIRSTKEY(db) gdbm_firstkey(db)
-#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db,key)
-#define gdbm_EXISTS(db,key) gdbm_exists(db,key)
+
+#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
typedef void (*FATALFUNC)();
int read_write
int mode
FATALFUNC fatal_func
+ CODE:
+ {
+ GDBM_FILE dbp ;
+ RETVAL = NULL ;
+ if (dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)) {
+ RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ;
+ Zero(RETVAL, 1, GDBM_File_type) ;
+ RETVAL->dbp = dbp ;
+ }
+
+ }
+ OUTPUT:
+ RETVAL
+
+
+#define gdbm_close(db) gdbm_close(db->dbp)
void
gdbm_close(db)
GDBM_File db
CODE:
gdbm_close(db);
-datum
+#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key)
+datum_value
gdbm_FETCH(db, key)
GDBM_File db
- datum key
+ datum_key key
+#define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags)
int
gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
GDBM_File db
- datum key
- datum value
+ datum_key key
+ datum_value value
int flags
CLEANUP:
if (RETVAL) {
croak("No write permission to gdbm file");
croak("gdbm store returned %d, errno %d, key \"%.*s\"",
RETVAL,errno,key.dsize,key.dptr);
- /* gdbm_clearerr(db); */
+ gdbm_clearerr(db);
}
+#define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key)
int
gdbm_DELETE(db, key)
GDBM_File db
- datum key
+ datum_key key
-datum
+#define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp)
+datum_key
gdbm_FIRSTKEY(db)
GDBM_File db
-datum
+#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key)
+datum_key
gdbm_NEXTKEY(db, key)
GDBM_File db
- datum key
+ datum_key key
+#define gdbm_reorganize(db) gdbm_reorganize(db->dbp)
int
gdbm_reorganize(db)
GDBM_File db
+#define gdbm_sync(db) gdbm_sync(db->dbp)
void
gdbm_sync(db)
GDBM_File db
+#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key)
int
gdbm_EXISTS(db, key)
GDBM_File db
- datum key
+ datum_key key
+#define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen)
int
gdbm_setopt (db, optflag, optval, optlen)
GDBM_File db
int &optval
int optlen
+
+#define setFilter(type) \
+ { \
+ if (db->type) \
+ RETVAL = newSVsv(db->type) ; \
+ if (db->type && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db->type) ; \
+ db->type = NULL ; \
+ } \
+ else if (code) { \
+ if (db->type) \
+ sv_setsv(db->type, code) ; \
+ else \
+ db->type = newSVsv(code) ; \
+ } \
+ }
+
+
+
+SV *
+filter_fetch_key(db, code)
+ GDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_key(db, code)
+ GDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_fetch_value(db, code)
+ GDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_value) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_value(db, code)
+ GDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_value) ;
+ OUTPUT:
+ RETVAL
+
#################################### DBM SECTION
#
-datum T_DATUM
+datum_key T_DATUM_K
+datum_value T_DATUM_V
NDBM_File T_PTROBJ
GDBM_File T_PTROBJ
SDBM_File T_PTROBJ
FATALFUNC T_OPAQUEPTR
INPUT
-T_DATUM
+T_DATUM_K
+ ckFilter($arg, filter_store_key, \"filter_store_key\");
+ $var.dptr = SvPV($arg, PL_na);
+ $var.dsize = (int)PL_na;
+T_DATUM_V
+ ckFilter($arg, filter_store_value, \"filter_store_value\");
$var.dptr = SvPV($arg, PL_na);
$var.dsize = (int)PL_na;
OUTPUT
-T_DATUM
+T_DATUM_K
+ output_datum($arg, $var.dptr, $var.dsize);
+ ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+T_DATUM_V
output_datum($arg, $var.dptr, $var.dsize);
+ ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
T_PTROBJ
sv_setref_pv($arg, dbtype, (void*)$var);
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.01";
+$VERSION = "1.02";
bootstrap NDBM_File $VERSION;
=head1 DESCRIPTION
-See L<perlfunc/tie>
+See L<perlfunc/tie>, L<perldbmfilter>
=cut
#include "XSUB.h"
#include <ndbm.h>
-typedef DBM* NDBM_File;
-#define dbm_TIEHASH(dbtype,filename,flags,mode) dbm_open(filename,flags,mode)
-#define dbm_FETCH(db,key) dbm_fetch(db,key)
-#define dbm_STORE(db,key,value,flags) dbm_store(db,key,value,flags)
-#define dbm_DELETE(db,key) dbm_delete(db,key)
-#define dbm_FIRSTKEY(db) dbm_firstkey(db)
-#define dbm_NEXTKEY(db,key) dbm_nextkey(db)
+typedef struct {
+ DBM * dbp ;
+ SV * filter_fetch_key ;
+ SV * filter_store_key ;
+ SV * filter_fetch_value ;
+ SV * filter_store_value ;
+ int filtering ;
+ } NDBM_File_type;
+
+typedef NDBM_File_type * NDBM_File ;
+typedef datum datum_key ;
+typedef datum datum_value ;
+
+#define ckFilter(arg,type,name) \
+ if (db->type) { \
+ SV * save_defsv ; \
+ /* printf("filtering %s\n", name) ;*/ \
+ if (db->filtering) \
+ croak("recursion detected in %s", name) ; \
+ db->filtering = TRUE ; \
+ save_defsv = newSVsv(DEFSV) ; \
+ sv_setsv(DEFSV, arg) ; \
+ PUSHMARK(sp) ; \
+ (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \
+ sv_setsv(arg, DEFSV) ; \
+ sv_setsv(DEFSV, save_defsv) ; \
+ SvREFCNT_dec(save_defsv) ; \
+ db->filtering = FALSE ; \
+ /*printf("end of filtering %s\n", name) ;*/ \
+ }
+
MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = dbm_
char * filename
int flags
int mode
+ CODE:
+ {
+ DBM * dbp ;
+
+ RETVAL = NULL ;
+ if (dbp = dbm_open(filename, flags, mode)) {
+ RETVAL = (NDBM_File)safemalloc(sizeof(NDBM_File_type)) ;
+ Zero(RETVAL, 1, NDBM_File_type) ;
+ RETVAL->dbp = dbp ;
+ }
+
+ }
+ OUTPUT:
+ RETVAL
void
dbm_DESTROY(db)
NDBM_File db
CODE:
- dbm_close(db);
+ dbm_close(db->dbp);
-datum
+#define dbm_FETCH(db,key) dbm_fetch(db->dbp,key)
+datum_value
dbm_FETCH(db, key)
NDBM_File db
- datum key
+ datum_key key
+#define dbm_STORE(db,key,value,flags) dbm_store(db->dbp,key,value,flags)
int
dbm_STORE(db, key, value, flags = DBM_REPLACE)
NDBM_File db
- datum key
- datum value
+ datum_key key
+ datum_value value
int flags
CLEANUP:
if (RETVAL) {
croak("No write permission to ndbm file");
croak("ndbm store returned %d, errno %d, key \"%s\"",
RETVAL,errno,key.dptr);
- dbm_clearerr(db);
+ dbm_clearerr(db->dbp);
}
+#define dbm_DELETE(db,key) dbm_delete(db->dbp,key)
int
dbm_DELETE(db, key)
NDBM_File db
- datum key
+ datum_key key
-datum
+#define dbm_FIRSTKEY(db) dbm_firstkey(db->dbp)
+datum_key
dbm_FIRSTKEY(db)
NDBM_File db
-datum
+#define dbm_NEXTKEY(db,key) dbm_nextkey(db->dbp)
+datum_key
dbm_NEXTKEY(db, key)
NDBM_File db
- datum key
+ datum_key key
+#define dbm_error(db) dbm_error(db->dbp)
int
dbm_error(db)
NDBM_File db
+#define dbm_clearerr(db) dbm_clearerr(db->dbp)
void
dbm_clearerr(db)
NDBM_File db
+
+#define setFilter(type) \
+ { \
+ if (db->type) \
+ RETVAL = newSVsv(db->type) ; \
+ if (db->type && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db->type) ; \
+ db->type = NULL ; \
+ } \
+ else if (code) { \
+ if (db->type) \
+ sv_setsv(db->type, code) ; \
+ else \
+ db->type = newSVsv(code) ; \
+ } \
+ }
+
+
+
+SV *
+filter_fetch_key(db, code)
+ NDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_key(db, code)
+ NDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_fetch_value(db, code)
+ NDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_value) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_value(db, code)
+ NDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_value) ;
+ OUTPUT:
+ RETVAL
+
#################################### DBM SECTION
#
-datum T_DATUM
+datum_key T_DATUM_K
+datum_value T_DATUM_V
gdatum T_GDATUM
NDBM_File T_PTROBJ
GDBM_File T_PTROBJ
FATALFUNC T_OPAQUEPTR
INPUT
-T_DATUM
+T_DATUM_K
+ ckFilter($arg, filter_store_key, \"filter_store_key\");
+ $var.dptr = SvPV($arg, PL_na);
+ $var.dsize = (int)PL_na;
+T_DATUM_V
+ ckFilter($arg, filter_store_value, \"filter_store_value\");
$var.dptr = SvPV($arg, PL_na);
$var.dsize = (int)PL_na;
T_GDATUM
UNIMPLEMENTED
OUTPUT
-T_DATUM
+T_DATUM_K
+ sv_setpvn($arg, $var.dptr, $var.dsize);
+ ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+T_DATUM_V
sv_setpvn($arg, $var.dptr, $var.dsize);
+ ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
T_GDATUM
sv_usepvn($arg, $var.dptr, $var.dsize);
T_PTROBJ
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.00";
+$VERSION = "1.01";
bootstrap ODBM_File $VERSION;
=head1 DESCRIPTION
-See L<perlfunc/tie>
+See L<perlfunc/tie>, L<perldbmfilter>
=cut
#include <fcntl.h>
-typedef void* ODBM_File;
+typedef struct {
+ void * dbp ;
+ SV * filter_fetch_key ;
+ SV * filter_store_key ;
+ SV * filter_fetch_value ;
+ SV * filter_store_value ;
+ int filtering ;
+ } ODBM_File_type;
+
+typedef ODBM_File_type * ODBM_File ;
+typedef datum datum_key ;
+typedef datum datum_value ;
+
+#define ckFilter(arg,type,name) \
+ if (db->type) { \
+ SV * save_defsv ; \
+ /* printf("filtering %s\n", name) ;*/ \
+ if (db->filtering) \
+ croak("recursion detected in %s", name) ; \
+ db->filtering = TRUE ; \
+ save_defsv = newSVsv(DEFSV) ; \
+ sv_setsv(DEFSV, arg) ; \
+ PUSHMARK(sp) ; \
+ (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \
+ sv_setsv(arg, DEFSV) ; \
+ sv_setsv(DEFSV, save_defsv) ; \
+ SvREFCNT_dec(save_defsv) ; \
+ db->filtering = FALSE ; \
+ /*printf("end of filtering %s\n", name) ;*/ \
+ }
+
#define odbm_FETCH(db,key) fetch(key)
#define odbm_STORE(db,key,value,flags) store(key,value)
CODE:
{
char *tmpbuf;
+ void * dbp ;
if (dbmrefcnt++)
croak("Old dbm can only open one database");
New(0, tmpbuf, strlen(filename) + 5, char);
else
croak("ODBM_FILE: Can't open %s", filename);
}
- RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
+ dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
+ RETVAL = (ODBM_File)safemalloc(sizeof(ODBM_File_type)) ;
+ Zero(RETVAL, 1, ODBM_File_type) ;
+ RETVAL->dbp = dbp ;
ST(0) = sv_mortalcopy(&PL_sv_undef);
sv_setptrobj(ST(0), RETVAL, dbtype);
}
dbmrefcnt--;
dbmclose();
-datum
+datum_key
odbm_FETCH(db, key)
ODBM_File db
- datum key
+ datum_key key
int
odbm_STORE(db, key, value, flags = DBM_REPLACE)
ODBM_File db
- datum key
- datum value
+ datum_key key
+ datum_value value
int flags
CLEANUP:
if (RETVAL) {
int
odbm_DELETE(db, key)
ODBM_File db
- datum key
+ datum_key key
-datum
+datum_key
odbm_FIRSTKEY(db)
ODBM_File db
-datum
+datum_key
odbm_NEXTKEY(db, key)
ODBM_File db
- datum key
+ datum_key key
+
+
+#define setFilter(type) \
+ { \
+ if (db->type) \
+ RETVAL = newSVsv(db->type) ; \
+ if (db->type && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db->type) ; \
+ db->type = NULL ; \
+ } \
+ else if (code) { \
+ if (db->type) \
+ sv_setsv(db->type, code) ; \
+ else \
+ db->type = newSVsv(code) ; \
+ } \
+ }
+
+
+
+SV *
+filter_fetch_key(db, code)
+ ODBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_key(db, code)
+ ODBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_fetch_value(db, code)
+ ODBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_value) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_value(db, code)
+ ODBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_value) ;
+ OUTPUT:
+ RETVAL
#################################### DBM SECTION
#
-datum T_DATUM
+datum_key T_DATUM_K
+datum_value T_DATUM_V
gdatum T_GDATUM
NDBM_File T_PTROBJ
GDBM_File T_PTROBJ
FATALFUNC T_OPAQUEPTR
INPUT
-T_DATUM
+T_DATUM_K
+ ckFilter($arg, filter_store_key, \"filter_store_key\");
+ $var.dptr = SvPV($arg, PL_na);
+ $var.dsize = (int)PL_na;
+T_DATUM_V
+ ckFilter($arg, filter_store_value, \"filter_store_value\");
$var.dptr = SvPV($arg, PL_na);
$var.dsize = (int)PL_na;
T_GDATUM
UNIMPLEMENTED
OUTPUT
-T_DATUM
+T_DATUM_K
+ sv_setpvn($arg, $var.dptr, $var.dsize);
+ ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+T_DATUM_V
sv_setpvn($arg, $var.dptr, $var.dsize);
+ ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
T_GDATUM
sv_usepvn($arg, $var.dptr, $var.dsize);
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.00" ;
+$VERSION = "1.01" ;
bootstrap SDBM_File $VERSION;
=head1 DESCRIPTION
-See L<perlfunc/tie>
+See L<perlfunc/tie>, L<perldbmfilter>
=cut
#include "XSUB.h"
#include "sdbm/sdbm.h"
-typedef DBM* SDBM_File;
+typedef struct {
+ DBM * dbp ;
+ SV * filter_fetch_key ;
+ SV * filter_store_key ;
+ SV * filter_fetch_value ;
+ SV * filter_store_value ;
+ int filtering ;
+ } SDBM_File_type;
+
+typedef SDBM_File_type * SDBM_File ;
+typedef datum datum_key ;
+typedef datum datum_value ;
+
+#define ckFilter(arg,type,name) \
+ if (db->type) { \
+ SV * save_defsv ; \
+ /* printf("filtering %s\n", name) ;*/ \
+ if (db->filtering) \
+ croak("recursion detected in %s", name) ; \
+ db->filtering = TRUE ; \
+ /* SAVE_DEFSV ;*/ /* save $_ */ \
+ save_defsv = newSVsv(DEFSV) ; \
+ sv_setsv(DEFSV, arg) ; \
+ PUSHMARK(sp) ; \
+ (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \
+ /* SPAGAIN ; */ \
+ sv_setsv(arg, DEFSV) ; \
+ sv_setsv(DEFSV, save_defsv) ; \
+ SvREFCNT_dec(save_defsv) ; \
+ /* PUTBACK ; */ \
+ db->filtering = FALSE ; \
+ /*printf("end of filtering %s\n", name) ;*/ \
+ }
+
#define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
-#define sdbm_FETCH(db,key) sdbm_fetch(db,key)
-#define sdbm_STORE(db,key,value,flags) sdbm_store(db,key,value,flags)
-#define sdbm_DELETE(db,key) sdbm_delete(db,key)
-#define sdbm_EXISTS(db,key) sdbm_exists(db,key)
-#define sdbm_FIRSTKEY(db) sdbm_firstkey(db)
-#define sdbm_NEXTKEY(db,key) sdbm_nextkey(db)
+#define sdbm_FETCH(db,key) sdbm_fetch(db->dbp,key)
+#define sdbm_STORE(db,key,value,flags) sdbm_store(db->dbp,key,value,flags)
+#define sdbm_DELETE(db,key) sdbm_delete(db->dbp,key)
+#define sdbm_EXISTS(db,key) sdbm_exists(db->dbp,key)
+#define sdbm_FIRSTKEY(db) sdbm_firstkey(db->dbp)
+#define sdbm_NEXTKEY(db,key) sdbm_nextkey(db->dbp)
MODULE = SDBM_File PACKAGE = SDBM_File PREFIX = sdbm_
char * filename
int flags
int mode
+ CODE:
+ {
+ DBM * dbp ;
+
+ RETVAL = NULL ;
+ if (dbp = sdbm_open(filename,flags,mode) ) {
+ RETVAL = (SDBM_File)safemalloc(sizeof(SDBM_File_type)) ;
+ Zero(RETVAL, 1, SDBM_File_type) ;
+ RETVAL->dbp = dbp ;
+ }
+
+ }
+ OUTPUT:
+ RETVAL
void
sdbm_DESTROY(db)
SDBM_File db
CODE:
- sdbm_close(db);
+ sdbm_close(db->dbp);
+ if (db->filter_fetch_key)
+ SvREFCNT_dec(db->filter_fetch_key) ;
+ if (db->filter_store_key)
+ SvREFCNT_dec(db->filter_store_key) ;
+ if (db->filter_fetch_value)
+ SvREFCNT_dec(db->filter_fetch_value) ;
+ if (db->filter_store_value)
+ SvREFCNT_dec(db->filter_store_value) ;
+ Safefree(db) ;
-datum
+datum_value
sdbm_FETCH(db, key)
SDBM_File db
- datum key
+ datum_key key
int
sdbm_STORE(db, key, value, flags = DBM_REPLACE)
SDBM_File db
- datum key
- datum value
+ datum_key key
+ datum_value value
int flags
CLEANUP:
if (RETVAL) {
croak("No write permission to sdbm file");
croak("sdbm store returned %d, errno %d, key \"%s\"",
RETVAL,errno,key.dptr);
- sdbm_clearerr(db);
+ sdbm_clearerr(db->dbp);
}
int
int
sdbm_EXISTS(db,key)
SDBM_File db
- datum key
+ datum_key key
-datum
+datum_key
sdbm_FIRSTKEY(db)
SDBM_File db
-datum
+datum_key
sdbm_NEXTKEY(db, key)
SDBM_File db
- datum key
+ datum_key key
int
sdbm_error(db)
SDBM_File db
+ CODE:
+ RETVAL = sdbm_error(db->dbp) ;
+ OUTPUT:
+ RETVAL
int
sdbm_clearerr(db)
SDBM_File db
+ CODE:
+ RETVAL = sdbm_clearerr(db->dbp) ;
+ OUTPUT:
+ RETVAL
+
+
+#define setFilter(type) \
+ { \
+ if (db->type) \
+ RETVAL = newSVsv(db->type) ; \
+ if (db->type && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db->type) ; \
+ db->type = NULL ; \
+ } \
+ else if (code) { \
+ if (db->type) \
+ sv_setsv(db->type, code) ; \
+ else \
+ db->type = newSVsv(code) ; \
+ } \
+ }
+
+
+
+SV *
+filter_fetch_key(db, code)
+ SDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_key(db, code)
+ SDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_key) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_fetch_value(db, code)
+ SDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_value) ;
+ OUTPUT:
+ RETVAL
+
+SV *
+filter_store_value(db, code)
+ SDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_value) ;
+ OUTPUT:
+ RETVAL
#################################### DBM SECTION
#
-datum T_DATUM
+datum_key T_DATUM_K
+datum_value T_DATUM_V
gdatum T_GDATUM
NDBM_File T_PTROBJ
GDBM_File T_PTROBJ
FATALFUNC T_OPAQUEPTR
INPUT
-T_DATUM
+T_DATUM_K
+ ckFilter($arg, filter_store_key, \"filter_store_key\");
+ $var.dptr = SvPV($arg, PL_na);
+ $var.dsize = (int)PL_na;
+T_DATUM_V
+ ckFilter($arg, filter_store_value, \"filter_store_value\");
$var.dptr = SvPV($arg, PL_na);
$var.dsize = (int)PL_na;
T_GDATUM
UNIMPLEMENTED
OUTPUT
-T_DATUM
+T_DATUM_K
+ sv_setpvn($arg, $var.dptr, $var.dsize);
+ ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+T_DATUM_V
sv_setpvn($arg, $var.dptr, $var.dsize);
+ ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
T_GDATUM
sv_usepvn($arg, $var.dptr, $var.dsize);
T_PTROBJ
=head1 SEE ALSO
-dbm(3), ndbm(3), DB_File(3)
+dbm(3), ndbm(3), DB_File(3), L<perldbmfilter>
=cut
perlbot.pod \
perlipc.pod \
perlthrtut.pod \
+ perldbmfilter.pod \
perldebug.pod \
perldiag.pod \
perlsec.pod \
perlbot.man \
perlipc.man \
perlthrtut.man \
+ perldbmfilter.man \
perldebug.man \
perldiag.man \
perlsec.man \
perlbot.html \
perlipc.html \
perlthrtut.html \
+ perldbmfilter.html \
perldebug.html \
perldiag.html \
perlsec.html \
perlbot.tex \
perlipc.tex \
perlthrtut.tex \
+ perldbmfilter.tex \
perldebug.tex \
perldiag.tex \
perlsec.tex \
perlsyn perlop perlre perlrun perlfunc perlvar perlsub
perlmod perlmodlib perlmodinstall perlform perllocale
perlref perlreftut perldsc
- perllol perltoot perlobj perltie perlbot perlipc perldebug
+ perllol perltoot perlobj perltie perlbot perlipc perldbmfilter perldebug
perldiag perlsec perltrap perlport perlstyle perlpod perlbook
perlembed perlapio perlxs perlxstut perlguts perlcall
perlhist
perlbot Perl OO tricks and examples
perlipc Perl interprocess communication
perlthrtut Perl threads tutorial
+ perldbmfilter Perl DBM Filters
perldebug Perl debugging
perldiag Perl diagnostic messages
--- /dev/null
+=head1 NAME
+
+perldbmfilter - Perl DBM Filters
+
+=head1 SYNOPSIS
+
+ $db = tie %hash, 'DBM', ...
+
+ $old_filter = $db->filter_store_key ( sub { ... } ) ;
+ $old_filter = $db->filter_store_value( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_key ( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_value( sub { ... } ) ;
+
+=head1 DESCRIPTION
+
+The four C<filter_*> methods shown above are available in all the DBM
+modules that ship with Perl, namely DB_File, GDBM_File, NDBM_File,
+ODBM_File and SDBM_File.
+
+Each of the methods work identically, and are used to install (or
+uninstall) a single DBM Filter. The only difference between them is the
+place that the filter is installed.
+
+To summarise:
+
+=over 5
+
+=item B<filter_store_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a key to a DBM database.
+
+=item B<filter_store_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a value to a DBM database.
+
+
+=item B<filter_fetch_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a key from a DBM database.
+
+=item B<filter_fetch_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a value from a DBM database.
+
+=back
+
+You can use any combination of the methods from none to all four.
+
+All filter methods return the existing filter, if present, or C<undef>
+in not.
+
+To delete a filter pass C<undef> to it.
+
+=head2 The Filter
+
+When each filter is called by Perl, a local copy of C<$_> will contain
+the key or value to be filtered. Filtering is achieved by modifying
+the contents of C<$_>. The return code from the filter is ignored.
+
+=head2 An Example -- the NULL termination problem.
+
+DBM Filters are useful for a class of problems where you I<always>
+want to make the same transformation to all keys, all values or both.
+
+For example, consider the following scenario. You have a DBM database
+that you need to share with a third-party C application. The C application
+assumes that I<all> keys and values are NULL terminated. Unfortunately
+when Perl writes to DBM databases it doesn't use NULL termination, so
+your Perl application will have to manage NULL termination itself. When
+you write to the database you will have to use something like this:
+
+ $hash{"$key\0"} = "$value\0" ;
+
+Similarly the NULL needs to be taken into account when you are considering
+the length of existing keys/values.
+
+It would be much better if you could ignore the NULL terminations issue
+in the main application code and have a mechanism that automatically
+added the terminating NULL to all keys and values whenever you write to
+the database and have them removed when you read from the database. As I'm
+sure you have already guessed, this is a problem that DBM Filters can
+fix very easily.
+
+ use strict ;
+ use SDBM_File ;
+ use Fcntl ;
+
+ my %hash ;
+ my $filename = "/tmp/filt" ;
+ unlink $filename ;
+
+ my $db = tie(%hash, 'SDBM_File', $filename, O_RDWR|O_CREAT, 0640)
+ or die "Cannot open $filename: $!\n" ;
+
+ # Install DBM Filters
+ $db->filter_fetch_key ( sub { s/\0$// } ) ;
+ $db->filter_store_key ( sub { $_ .= "\0" } ) ;
+ $db->filter_fetch_value( sub { s/\0$// } ) ;
+ $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+ $hash{"abc"} = "def" ;
+ my $a = $hash{"ABC"} ;
+ # ...
+ undef $db ;
+ untie %hash ;
+
+The code above uses SDBM_File, but it will work with any of the DBM
+modules.
+
+Hopefully the contents of each of the filters should be
+self-explanatory. Both "fetch" filters remove the terminating NULL,
+and both "store" filters add a terminating NULL.
+
+
+=head2 Another Example -- Key is a C int.
+
+Here is another real-life example. By default, whenever Perl writes to
+a DBM database it always writes the key and value as strings. So when
+you use this:
+
+ $hash{12345} = "soemthing" ;
+
+the key 12345 will get stored in the DBM database as the 5 byte string
+"12345". If you actually want the key to be stored in the DBM database
+as a C int, you will have to use C<pack> when writing, and C<unpack>
+when reading.
+
+Here is a DBM Filter that does it:
+
+ use strict ;
+ use DB_File ;
+ my %hash ;
+ my $filename = "/tmp/filt" ;
+ unlink $filename ;
+
+
+ my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH
+ or die "Cannot open $filename: $!\n" ;
+
+ $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
+ $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ;
+ $hash{123} = "def" ;
+ # ...
+ undef $db ;
+ untie %hash ;
+
+The code above uses DB_File, but again it will work with any of the
+DBM modules.
+
+This time only two filters have been used -- we only need to manipulate
+the contents of the key, so it wasn't necessary to install any value
+filters.
+
+=head1 SEE ALSO
+
+L<DB_File>, L<GDBM_File>, L<NDBM_File>, L<ODBM_File> and L<SDBM_File>.
+
+=head1 AUTHOR
+
+Paul Marquess
+
a two element list containing the fully qualified directory name and
the filename.
+=item DBM Filters
+
+A new feature called "DBM Filters" has been added to all the
+DBM modules -- DB_File, GDBM_File, NDBM_File, ODBM_File and SDBM_File.
+DBM Filters add four new methods to each of the DBM modules
+
+ filter_store_key
+ filter_store_value
+ filter_fetch_key
+ filter_fetch_value
+
+These can be used to filter the contents of keys/values before they are
+written to the database or just after they are read from the database.
+See L<perldbmfilter> for further information.
+
=back
=head2 Pragmata
use DB_File;
use Fcntl;
-print "1..102\n";
+print "1..148\n";
sub ok
{
return @a - @b ;
}
-$Dfile = "dbbtree.tmp";
+my $Dfile = "dbbtree.tmp";
unlink $Dfile;
umask(0);
}
+{
+ # DBM Filter tests
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(104, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(105, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(106, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(107, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(108, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(109, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(110, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(111, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(112, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(113, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(114, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(115, $h{"fred"} eq "joe");
+ ok(116, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(117, $db->FIRSTKEY() eq "fred") ;
+ ok(118, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(119, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(120, $h{"fred"} eq "joe");
+ ok(121, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(122, $db->FIRSTKEY() eq "fred") ;
+ ok(123, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(125, $result{"store key"} eq "store key - 1: [fred]");
+ ok(126, $result{"store value"} eq "store value - 1: [joe]");
+ ok(127, ! defined $result{"fetch key"} );
+ ok(128, ! defined $result{"fetch value"} );
+ ok(129, $_ eq "original") ;
+
+ ok(130, $db->FIRSTKEY() eq "fred") ;
+ ok(131, $result{"store key"} eq "store key - 1: [fred]");
+ ok(132, $result{"store value"} eq "store value - 1: [joe]");
+ ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(134, ! defined $result{"fetch value"} );
+ ok(135, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(136, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(137, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(139, ! defined $result{"fetch value"} );
+ ok(140, $_ eq "original") ;
+
+ ok(141, $h{"fred"} eq "joe");
+ ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(143, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(146, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(148, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+
exit ;
use DB_File;
use Fcntl;
-print "1..62\n";
+print "1..108\n";
sub ok
{
print "ok $no\n" ;
}
-$Dfile = "dbhash.tmp";
+my $Dfile = "dbhash.tmp";
unlink $Dfile;
umask(0);
unlink "SubDB.pm", "dbhash.tmp" ;
}
+
+{
+ # DBM Filter tests
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(64, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(65, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(66, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(67, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(68, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(69, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(70, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(71, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(72, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(73, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(74, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(75, $h{"fred"} eq "joe");
+ ok(76, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(77, $db->FIRSTKEY() eq "fred") ;
+ ok(78, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(79, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(80, $h{"fred"} eq "joe");
+ ok(81, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(82, $db->FIRSTKEY() eq "fred") ;
+ ok(83, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(85, $result{"store key"} eq "store key - 1: [fred]");
+ ok(86, $result{"store value"} eq "store value - 1: [joe]");
+ ok(87, ! defined $result{"fetch key"} );
+ ok(88, ! defined $result{"fetch value"} );
+ ok(89, $_ eq "original") ;
+
+ ok(90, $db->FIRSTKEY() eq "fred") ;
+ ok(91, $result{"store key"} eq "store key - 1: [fred]");
+ ok(92, $result{"store value"} eq "store value - 1: [joe]");
+ ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(94, ! defined $result{"fetch value"} );
+ ok(95, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(96, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(97, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(99, ! defined $result{"fetch value"} );
+ ok(100, $_ eq "original") ;
+
+ ok(101, $h{"fred"} eq "joe");
+ ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(103, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(106, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(108, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
exit ;
EOM
}
-print "1..78\n";
+print "1..124\n";
my $Dfile = "recno.tmp";
unlink $Dfile ;
}
+{
+ # DBM Filter tests
+ use strict ;
+ my (@h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h[0] = "joe" ;
+ # fk sk fv sv
+ ok(80, checkOutput( "", 0, "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(81, $h[0] eq "joe");
+ # fk sk fv sv
+ ok(82, checkOutput( "", 0, "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(83, $db->FIRSTKEY() == 0) ;
+ # fk sk fv sv
+ ok(84, checkOutput( 0, "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { ++ $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ *= 2 ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[1] = "Joe" ;
+ # fk sk fv sv
+ ok(85, checkOutput( "", 2, "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(86, $h[1] eq "[Jxe]");
+ # fk sk fv sv
+ ok(87, checkOutput( "", 2, "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(88, $db->FIRSTKEY() == 1) ;
+ # fk sk fv sv
+ ok(89, checkOutput( 1, "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[0] = "joe" ;
+ ok(90, checkOutput( "", 0, "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(91, $h[0] eq "joe");
+ ok(92, checkOutput( "", 0, "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(93, $db->FIRSTKEY() == 0) ;
+ ok(94, checkOutput( 0, "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[0] = "joe" ;
+ ok(95, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(96, $h[0] eq "joe");
+ ok(97, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(98, $db->FIRSTKEY() == 0) ;
+ ok(99, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (@h, $db) ;
+
+ unlink $Dfile;
+ ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h[0] = "joe" ;
+ ok(101, $result{"store key"} eq "store key - 1: [0]");
+ ok(102, $result{"store value"} eq "store value - 1: [joe]");
+ ok(103, ! defined $result{"fetch key"} );
+ ok(104, ! defined $result{"fetch value"} );
+ ok(105, $_ eq "original") ;
+
+ ok(106, $db->FIRSTKEY() == 0 ) ;
+ ok(107, $result{"store key"} eq "store key - 1: [0]");
+ ok(108, $result{"store value"} eq "store value - 1: [joe]");
+ ok(109, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(110, ! defined $result{"fetch value"} );
+ ok(111, $_ eq "original") ;
+
+ $h[7] = "john" ;
+ ok(112, $result{"store key"} eq "store key - 2: [0 7]");
+ ok(113, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(114, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(115, ! defined $result{"fetch value"} );
+ ok(116, $_ eq "original") ;
+
+ ok(117, $h[0] eq "joe");
+ ok(118, $result{"store key"} eq "store key - 3: [0 7 0]");
+ ok(119, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(120, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(122, $_ eq "original") ;
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (@h, $db) ;
+ unlink $Dfile;
+
+ ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ $db->filter_store_key (sub { $_ = $h[0] }) ;
+
+ eval '$h[1] = 1234' ;
+ ok(124, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+}
+
exit ;
use GDBM_File;
-print "1..20\n";
+print "1..66\n";
unlink <Op.dbmx*>;
unlink "SubDB.pm", <dbhash.tmp*> ;
}
+
+{
+ # DBM Filter tests
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(21, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(24, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(25, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(26, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(30, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(31, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(32, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $h{"fred"} eq "joe");
+ ok(34, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(35, $db->FIRSTKEY() eq "fred") ;
+ ok(36, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $h{"fred"} eq "joe");
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(40, $db->FIRSTKEY() eq "fred") ;
+ ok(41, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(43, $result{"store key"} eq "store key - 1: [fred]");
+ ok(44, $result{"store value"} eq "store value - 1: [joe]");
+ ok(45, !defined $result{"fetch key"} );
+ ok(46, !defined $result{"fetch value"} );
+ ok(47, $_ eq "original") ;
+
+ ok(48, $db->FIRSTKEY() eq "fred") ;
+ ok(49, $result{"store key"} eq "store key - 1: [fred]");
+ ok(50, $result{"store value"} eq "store value - 1: [joe]");
+ ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(52, ! defined $result{"fetch value"} );
+ ok(53, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(55, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(57, $result{"fetch value"} eq "");
+ ok(58, $_ eq "original") ;
+
+ ok(59, $h{"fred"} eq "joe");
+ ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(61, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(64, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(65, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
use Fcntl;
-print "1..18\n";
+print "1..64\n";
unlink <Op.dbmx*>;
unlink "SubDB.pm", <dbhash.tmp*> ;
}
+
+{
+ # DBM Filter tests
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(20, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(21, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(24, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(25, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(26, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(29, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(30, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(31, $h{"fred"} eq "joe");
+ ok(32, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $db->FIRSTKEY() eq "fred") ;
+ ok(34, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(35, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(36, $h{"fred"} eq "joe");
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $db->FIRSTKEY() eq "fred") ;
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(41, $result{"store key"} eq "store key - 1: [fred]");
+ ok(42, $result{"store value"} eq "store value - 1: [joe]");
+ ok(43, !defined $result{"fetch key"} );
+ ok(44, !defined $result{"fetch value"} );
+ ok(45, $_ eq "original") ;
+
+ ok(46, $db->FIRSTKEY() eq "fred") ;
+ ok(47, $result{"store key"} eq "store key - 1: [fred]");
+ ok(48, $result{"store value"} eq "store value - 1: [joe]");
+ ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(50, ! defined $result{"fetch value"} );
+ ok(51, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(53, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(55, $result{"fetch value"} eq "");
+ ok(56, $_ eq "original") ;
+
+ ok(57, $h{"fred"} eq "joe");
+ ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(59, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(62, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
use Fcntl;
-print "1..18\n";
+print "1..64\n";
unlink <Op.dbmx*>;
unlink "SubDB.pm", <dbhash.tmp*> ;
}
+
+{
+ # DBM Filter tests
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(19, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(20, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(21, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(24, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(25, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(26, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(29, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(30, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(31, $h{"fred"} eq "joe");
+ ok(32, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $db->FIRSTKEY() eq "fred") ;
+ ok(34, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(35, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(36, $h{"fred"} eq "joe");
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $db->FIRSTKEY() eq "fred") ;
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(41, $result{"store key"} eq "store key - 1: [fred]");
+ ok(42, $result{"store value"} eq "store value - 1: [joe]");
+ ok(43, !defined $result{"fetch key"} );
+ ok(44, !defined $result{"fetch value"} );
+ ok(45, $_ eq "original") ;
+
+ ok(46, $db->FIRSTKEY() eq "fred") ;
+ ok(47, $result{"store key"} eq "store key - 1: [fred]");
+ ok(48, $result{"store value"} eq "store value - 1: [joe]");
+ ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(50, ! defined $result{"fetch value"} );
+ ok(51, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(53, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(55, $result{"fetch value"} eq "");
+ ok(56, $_ eq "original") ;
+
+ ok(57, $h{"fred"} eq "joe");
+ ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(59, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(62, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(63, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
use Fcntl;
-print "1..20\n";
+print "1..66\n";
unlink <Op_dbmx.*>;
ok(20, exists $h{'foo'});
untie %h;
-if ($^O eq 'VMS') {
- unlink 'Op_dbmx.sdbm_dir', $Dfile;
-} else {
- unlink 'Op_dbmx.dir', $Dfile;
+unlink <Op_dbmx*>, $Dfile;
+
+{
+ # DBM Filter tests
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op_dbmx*>;
+ ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(24, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(25, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(26, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(30, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(31, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(32, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $h{"fred"} eq "joe");
+ ok(34, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(35, $db->FIRSTKEY() eq "fred") ;
+ ok(36, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $h{"fred"} eq "joe");
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(40, $db->FIRSTKEY() eq "fred") ;
+ ok(41, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (%h, $db) ;
+
+ unlink <Op_dbmx*>;
+ ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(43, $result{"store key"} eq "store key - 1: [fred]");
+ ok(44, $result{"store value"} eq "store value - 1: [joe]");
+ ok(45, !defined $result{"fetch key"} );
+ ok(46, !defined $result{"fetch value"} );
+ ok(47, $_ eq "original") ;
+
+ ok(48, $db->FIRSTKEY() eq "fred") ;
+ ok(49, $result{"store key"} eq "store key - 1: [fred]");
+ ok(50, $result{"store value"} eq "store value - 1: [joe]");
+ ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(52, ! defined $result{"fetch value"} );
+ ok(53, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(55, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(57, $result{"fetch value"} eq "");
+ ok(58, $_ eq "original") ;
+
+ ok(59, $h{"fred"} eq "joe");
+ ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(61, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(64, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (%h, $db) ;
+ unlink <Op_dbmx*>;
+
+ ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
}
+
projects / p5sagit/p5-mst-13.2.git / commitdiff