DB_File.xs -- Perl 5 interface to Berkeley DB
- written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- last modified 19th November 1998
- version 1.61
+ written by Paul Marquess <Paul.Marquess@btinternet.com>
+ last modified 6th June 1999
+ version 1.67
All comments/suggestions/problems are welcome
- Copyright (c) 1995, 1996, 1997, 1998 Paul Marquess. All rights reserved.
+ Copyright (c) 1995-9 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
1.60 - Some code tidy up
1.61 - added flagSet macro for DB 2.5.x
fixed typo in O_RDONLY test.
+ 1.62 - No change to DB_File.xs
+ 1.63 - Fix to alllow DB 2.6.x to build.
+ 1.64 - Tidied up the 1.x to 2.x flags mapping code.
+ Added a patch from Mark Kettenis <kettenis@wins.uva.nl>
+ 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
+ 1.67 - Backed off the use of newSVpvn.
+ Fixed DBM Filter code for Perl 5.004.
+ Fixed a small memory leak in the filter code.
#include "perl.h"
#include "XSUB.h"
+#ifndef PERL_VERSION
+#include "patchlevel.h"
+#define PERL_REVISION 5
+#define PERL_VERSION PATCHLEVEL
+#define PERL_SUBVERSION SUBVERSION
+#endif
+
+#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 ))
+
+# define PL_sv_undef sv_undef
+# define PL_na na
+
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+#define DEFSV GvSV(defgv)
+#endif
+
/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
* shortly #included by the <db.h>) __attribute__ to the possibly
* already defined __attribute__, for example by GNUC or by Perl. */
#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 = 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) ;*/ \
+ }
+
+#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") ; \
+ } \
}
#ifdef DB_VERSION_MAJOR
static int
-db_put(db, key, value, flags)
-DB_File db ;
-DBTKEY key ;
-DBT value ;
-u_int flags ;
-
+db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
{
int status ;
#endif /* DB_VERSION_MAJOR */
static void
-GetVersionInfo()
+GetVersionInfo(pTHX)
{
SV * ver_sv = perl_get_sv("DB_File::db_version", TRUE) ;
#ifdef DB_VERSION_MAJOR
(void)db_version(&Major, &Minor, &Patch) ;
- /* check that libdb is recent enough */
- if (Major == 2 && Minor == 0 && Patch < 5)
- croak("DB_File needs Berkeley DB 2.0.5 or greater, you have %d.%d.%d\n",
+ /* check that libdb is recent enough -- we need 2.3.4 or greater */
+ if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4)))
+ croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n",
Major, Minor, Patch) ;
-#if PATCHLEVEL > 3
+#if PERL_VERSION > 3
sv_setpvf(ver_sv, "%d.%d", Major, Minor) ;
#else
{
static int
-btree_compare(key1, key2)
-const DBT * key1 ;
-const DBT * key2 ;
+btree_compare(const DBT *key1, const DBT *key2)
{
+ dTHX;
dSP ;
void * data1, * data2 ;
int retval ;
}
static DB_Prefix_t
-btree_prefix(key1, key2)
-const DBT * key1 ;
-const DBT * key2 ;
+btree_prefix(const DBT *key1, const DBT *key2)
{
+ dTHX;
dSP ;
void * data1, * data2 ;
int retval ;
}
static DB_Hash_t
-hash_cb(data, size)
-const void * data ;
-size_t size ;
+hash_cb(const void *data, size_t size)
{
+ dTHX;
dSP ;
int retval ;
int count ;
#ifdef TRACE
static void
-PrintHash(hash)
-INFO * hash ;
+PrintHash(INFO *hash)
{
printf ("HASH Info\n") ;
printf (" hash = %s\n",
}
static void
-PrintRecno(recno)
-INFO * recno ;
+PrintRecno(INFO *recno)
{
printf ("RECNO Info\n") ;
printf (" flags = %d\n", recno->db_RE_flags) ;
}
static void
-PrintBtree(btree)
-INFO * btree ;
+PrintBtree(INFO *btree)
{
printf ("BTREE Info\n") ;
printf (" compare = %s\n",
static I32
-GetArrayLength(db)
-DB_File db ;
+GetArrayLength(pTHX_ DB_File db)
{
DBT key ;
DBT value ;
}
static recno_t
-GetRecnoKey(db, value)
-DB_File db ;
-I32 value ;
+GetRecnoKey(pTHX_ DB_File db, I32 value)
{
if (value < 0) {
/* Get the length of the array */
- I32 length = GetArrayLength(db) ;
+ I32 length = GetArrayLength(aTHX_ db) ;
/* check for attempt to write before start of array */
if (length + value + 1 <= 0)
}
static DB_File
-ParseOpenInfo(isHASH, name, flags, mode, sv)
-int isHASH ;
-char * name ;
-int flags ;
-int mode ;
-SV * sv ;
+ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
{
SV ** svp;
HV * action ;
DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
void * openinfo = NULL ;
INFO * info = &RETVAL->info ;
+ STRLEN n_a;
/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
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 ;
#endif
svp = hv_fetch(action, "bfname", 6, FALSE);
if (svp && SvOK(*svp)) {
- char * ptr = SvPV(*svp,PL_na) ;
+ char * ptr = SvPV(*svp,n_a) ;
#ifdef DB_VERSION_MAJOR
- name = (char*) PL_na ? ptr : NULL ;
+ name = (char*) n_a ? ptr : NULL ;
#else
- info->db_RE_bfname = (char*) (PL_na ? ptr : NULL) ;
+ info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
#endif
}
else
{
int value ;
if (SvPOK(*svp))
- value = (int)*SvPV(*svp, PL_na) ;
+ value = (int)*SvPV(*svp, n_a) ;
else
value = SvIV(*svp) ;
if (svp && SvOK(*svp))
{
if (SvPOK(*svp))
- info->db_RE_bval = (u_char)*SvPV(*svp, PL_na) ;
+ info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
else
info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
DB_flags(info->flags, DB_DELIMITER) ;
if ((flags & O_CREAT) == O_CREAT)
Flags |= DB_CREATE ;
-#ifdef O_NONBLOCK
- if ((flags & O_NONBLOCK) == O_NONBLOCK)
- Flags |= DB_EXCL ;
-#endif
-
#if O_RDONLY == 0
if (flags == O_RDONLY)
#else
- if ((flags & O_RDONLY) == O_RDONLY)
+ if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
#endif
Flags |= DB_RDONLY ;
-#ifdef O_NONBLOCK
+#ifdef O_TRUNC
if ((flags & O_TRUNC) == O_TRUNC)
Flags |= DB_TRUNCATE ;
#endif
status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
if (status == 0)
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
+#else
+ status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
+ 0) ;
+#endif
if (status)
RETVAL->dbp = NULL ;
}
-static int
-not_here(s)
-char *s;
-{
- croak("DB_File::%s not implemented on this architecture", s);
- return -1;
-}
-
static double
-constant(name, arg)
-char *name;
-int arg;
+constant(char *name, int arg)
{
errno = 0;
switch (*name) {
BOOT:
{
- GetVersionInfo() ;
+ GetVersionInfo(aTHX) ;
empty.data = &zero ;
empty.size = sizeof(recno_t) ;
{
char * name = (char *) NULL ;
SV * sv = (SV *) NULL ;
+ STRLEN n_a;
if (items >= 3 && SvOK(ST(2)))
- name = (char*) SvPV(ST(2), PL_na) ;
+ name = (char*) SvPV(ST(2), n_a) ;
if (items == 6)
sv = ST(5) ;
- RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
+ RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
if (RETVAL->dbp == NULL)
RETVAL = NULL ;
}
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)
{
DBTKEY key ;
DBT value ;
- DB * Db = db->dbp ;
DBT_flags(key) ;
DBT_flags(value) ;
CODE:
{
DBT value ;
- DB * Db = db->dbp ;
DBT_flags(value) ;
CurrentDB = db ;
int i ;
int One ;
DB * Db = db->dbp ;
+ STRLEN n_a;
DBT_flags(key) ;
DBT_flags(value) ;
#endif
for (i = items-1 ; i > 0 ; --i)
{
- value.data = SvPV(ST(i), PL_na) ;
- value.size = PL_na ;
+ value.data = SvPV(ST(i), n_a) ;
+ value.size = n_a ;
One = 1 ;
key.data = &One ;
key.size = sizeof(int) ;
{
DBTKEY key ;
DBT value ;
- DB * Db = db->dbp ;
DBT_flags(key) ;
DBT_flags(value) ;
{
DBT value ;
DBTKEY key ;
- DB * Db = db->dbp ;
DBT_flags(key) ;
DBT_flags(value) ;
CODE:
{
DBTKEY key ;
- DBTKEY * keyptr = &key ;
DBT value ;
DB * Db = db->dbp ;
int i ;
+ STRLEN n_a;
DBT_flags(key) ;
DBT_flags(value) ;
CurrentDB = db ;
- /* Set the Cursor to the Last element */
- RETVAL = do_SEQ(db, key, value, R_LAST) ;
- if (RETVAL >= 0)
- {
- if (RETVAL == 1)
- keyptr = &empty ;
#ifdef DB_VERSION_MAJOR
+ RETVAL = 0 ;
+ key = empty ;
for (i = 1 ; i < items ; ++i)
{
-
- ++ (* (int*)key.data) ;
- value.data = SvPV(ST(i), PL_na) ;
- value.size = PL_na ;
- RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ;
+ value.data = SvPV(ST(i), n_a) ;
+ value.size = n_a ;
+ RETVAL = (Db->put)(Db, NULL, &key, &value, DB_APPEND) ;
if (RETVAL != 0)
break;
}
-#else
+#else
+
+ /* Set the Cursor to the Last element */
+ RETVAL = do_SEQ(db, key, value, R_LAST) ;
+ if (RETVAL >= 0)
+ {
+ if (RETVAL == 1)
+ key = empty ;
for (i = items - 1 ; i > 0 ; --i)
{
- value.data = SvPV(ST(i), PL_na) ;
- value.size = PL_na ;
- RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
+ value.data = SvPV(ST(i), n_a) ;
+ value.size = n_a ;
+ RETVAL = (Db->put)(Db, &key, &value, R_IAFTER) ;
if (RETVAL != 0)
break;
}
-#endif
}
+#endif
}
OUTPUT:
RETVAL
ALIAS: FETCHSIZE = 1
CODE:
CurrentDB = db ;
- RETVAL = GetArrayLength(db) ;
+ RETVAL = GetArrayLength(aTHX_ db) ;
OUTPUT:
RETVAL
key
value
+#ifdef DBM_FILTERING
+
+#define setFilter(type) \
+ { \
+ if (db->type) \
+ RETVAL = sv_mortalcopy(db->type) ; \
+ ST(0) = RETVAL ; \
+ 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) ;
+
+SV *
+filter_store_key(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_key) ;
+
+SV *
+filter_fetch_value(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_fetch_value) ;
+
+SV *
+filter_store_value(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ setFilter(filter_store_value) ;
+
+#endif /* DBM_FILTERING */
projects / p5sagit/p5-mst-13.2.git / blobdiff