[perl5.git] / ext / GDBM_File / GDBM_File.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include <gdbm.h>
#include <fcntl.h>

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 */

typedef void (*FATALFUNC)();

static int
not_here(char *s)
{
    croak("GDBM_File::%s not implemented on this architecture", s);
    return -1;
}

/* GDBM allocates the datum with system malloc() and expects the user
 * to free() it.  So we either have to free() it immediately, or have
 * perl free() it when it deallocates the SV, depending on whether
 * perl uses malloc()/free() or not. */
static void
output_datum(pTHX_ SV *arg, char *str, int size)
{
#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))
	sv_usepvn(arg, str, size);
#else
	sv_setpvn(arg, str, size);
	safesysfree(str);
#endif
}

/* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
   gdbm_exists, and gdbm_setopt functions.  Apparently Slackware
   (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
*/
#ifndef GDBM_FAST
#define gdbm_exists(db,key) not_here("gdbm_exists")
#define gdbm_sync(db) (void) not_here("gdbm_sync")
#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
#endif

static double
constant(char *name, int arg)
{
    errno = 0;
    switch (*name) {
    case 'A':
	break;
    case 'B':
	break;
    case 'C':
	break;
    case 'D':
	break;
    case 'E':
	break;
    case 'F':
	break;
    case 'G':
	if (strEQ(name, "GDBM_CACHESIZE"))
#ifdef GDBM_CACHESIZE
	    return GDBM_CACHESIZE;
#else
	    goto not_there;
#endif
	if (strEQ(name, "GDBM_FAST"))
#ifdef GDBM_FAST
	    return GDBM_FAST;
#else
	    goto not_there;
#endif
	if (strEQ(name, "GDBM_FASTMODE"))
#ifdef GDBM_FASTMODE
	    return GDBM_FASTMODE;
#else
	    goto not_there;
#endif
	if (strEQ(name, "GDBM_INSERT"))
#ifdef GDBM_INSERT
	    return GDBM_INSERT;
#else
	    goto not_there;
#endif
	if (strEQ(name, "GDBM_NEWDB"))
#ifdef GDBM_NEWDB
	    return GDBM_NEWDB;
#else
	    goto not_there;
#endif
	if (strEQ(name, "GDBM_READER"))
#ifdef GDBM_READER
	    return GDBM_READER;
#else
	    goto not_there;
#endif
	if (strEQ(name, "GDBM_REPLACE"))
#ifdef GDBM_REPLACE
	    return GDBM_REPLACE;
#else
	    goto not_there;
#endif
	if (strEQ(name, "GDBM_WRCREAT"))
#ifdef GDBM_WRCREAT
	    return GDBM_WRCREAT;
#else
	    goto not_there;
#endif
	if (strEQ(name, "GDBM_WRITER"))
#ifdef GDBM_WRITER
	    return GDBM_WRITER;
#else
	    goto not_there;
#endif
	break;
    case 'H':
	break;
    case 'I':
	break;
    case 'J':
	break;
    case 'K':
	break;
    case 'L':
	break;
    case 'M':
	break;
    case 'N':
	break;
    case 'O':
	break;
    case 'P':
	break;
    case 'Q':
	break;
    case 'R':
	break;
    case 'S':
	break;
    case 'T':
	break;
    case 'U':
	break;
    case 'V':
	break;
    case 'W':
	break;
    case 'X':
	break;
    case 'Y':
	break;
    case 'Z':
	break;
    }
    errno = EINVAL;
    return 0;

not_there:
    errno = ENOENT;
    return 0;
}

MODULE = GDBM_File	PACKAGE = GDBM_File	PREFIX = gdbm_

double
constant(name,arg)
	char *		name
	int		arg


GDBM_File
gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
	char *		dbtype
	char *		name
	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
	CLEANUP:

void
gdbm_DESTROY(db)
	GDBM_File	db
	CODE:
	gdbm_close(db);
	safefree(db);

#define gdbm_FETCH(db,key)			gdbm_fetch(db->dbp,key)
datum_value
gdbm_FETCH(db, key)
	GDBM_File	db
	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	key
	datum_value	value
	int		flags
    CLEANUP:
	if (RETVAL) {
	    if (RETVAL < 0 && errno == EPERM)
		croak("No write permission to gdbm file");
	    croak("gdbm store returned %d, errno %d, key \"%.*s\"",
			RETVAL,errno,key.dsize,key.dptr);
	}

#define gdbm_DELETE(db,key)			gdbm_delete(db->dbp,key)
int
gdbm_DELETE(db, key)
	GDBM_File	db
	datum_key	key

#define gdbm_FIRSTKEY(db)			gdbm_firstkey(db->dbp)
datum_key
gdbm_FIRSTKEY(db)
	GDBM_File	db

#define gdbm_NEXTKEY(db,key)			gdbm_nextkey(db->dbp,key)
datum_key
gdbm_NEXTKEY(db, key)
	GDBM_File	db
	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	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		optflag
	int		&optval
	int		optlen


#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)
	GDBM_File	db
	SV *		code
	SV *		RETVAL = &PL_sv_undef ;
	CODE:
	    setFilter(filter_fetch_key) ;

SV *
filter_store_key(db, code)
	GDBM_File	db
	SV *		code
	SV *		RETVAL =  &PL_sv_undef ;
	CODE:
	    setFilter(filter_store_key) ;

SV *
filter_fetch_value(db, code)
	GDBM_File	db
	SV *		code
	SV *		RETVAL =  &PL_sv_undef ;
	CODE:
	    setFilter(filter_fetch_value) ;

SV *
filter_store_value(db, code)
	GDBM_File	db
	SV *		code
	SV *		RETVAL =  &PL_sv_undef ;
	CODE:
	    setFilter(filter_store_value) ;
Commit	Line	Data
a0d0e21e LW	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
	4
	5	#include <gdbm.h>
	6	#include <fcntl.h>
	7
9fe6733a PM	8	typedef struct {
	9	GDBM_FILE dbp ;
	10	SV * filter_fetch_key ;
	11	SV * filter_store_key ;
	12	SV * filter_fetch_value ;
	13	SV * filter_store_value ;
	14	int filtering ;
	15	} GDBM_File_type;
	16
	17	typedef GDBM_File_type * GDBM_File ;
	18	typedef datum datum_key ;
	19	typedef datum datum_value ;
	20
	21	#define ckFilter(arg,type,name) \
	22	if (db->type) { \
	23	SV * save_defsv ; \
	24	/* printf("filtering %s\n", name) ;*/ \
	25	if (db->filtering) \
	26	croak("recursion detected in %s", name) ; \
	27	db->filtering = TRUE ; \
	28	save_defsv = newSVsv(DEFSV) ; \
	29	sv_setsv(DEFSV, arg) ; \
	30	PUSHMARK(sp) ; \
	31	(void) perl_call_sv(db->type, G_DISCARD\|G_NOARGS); \
	32	sv_setsv(arg, DEFSV) ; \
	33	sv_setsv(DEFSV, save_defsv) ; \
	34	SvREFCNT_dec(save_defsv) ; \
	35	db->filtering = FALSE ; \
	36	/printf("end of filtering %s\n", name) ;/ \
	37	}
a0d0e21e	38
a0d0e21e	39
9fe6733a PM	40
9fe6733a PM	41	#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
a0d0e21e	42
12f917ad	43	typedef void (*FATALFUNC)();
a0d0e21e LW	44
a0d0e21e LW	45	static int
f0f333f4	46	not_here(char *s)
a0d0e21e LW	47	{
	48	croak("GDBM_File::%s not implemented on this architecture", s);
	49	return -1;
	50	}
	51
097d66a9 GS	52	/* GDBM allocates the datum with system malloc() and expects the user
	53	* to free() it. So we either have to free() it immediately, or have
	54	* perl free() it when it deallocates the SV, depending on whether
	55	* perl uses malloc()/free() or not. */
	56	static void
caa0600b	57	output_datum(pTHX_ SV arg, char str, int size)
097d66a9 GS	58	{
	59	#if !defined(MYMALLOC) \|\| (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))
	60	sv_usepvn(arg, str, size);
	61	#else
	62	sv_setpvn(arg, str, size);
	63	safesysfree(str);
	64	#endif
	65	}
	66
e50aee73 AD	67	/* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
	68	gdbm_exists, and gdbm_setopt functions. Apparently Slackware
	69	(Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
	70	*/
	71	#ifndef GDBM_FAST
	72	#define gdbm_exists(db,key) not_here("gdbm_exists")
	73	#define gdbm_sync(db) (void) not_here("gdbm_sync")
	74	#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
	75	#endif
	76
a0d0e21e	77	static double
f0f333f4	78	constant(char *name, int arg)
a0d0e21e LW	79	{
	80	errno = 0;
	81	switch (*name) {
	82	case 'A':
	83	break;
	84	case 'B':
	85	break;
	86	case 'C':
	87	break;
	88	case 'D':
	89	break;
	90	case 'E':
	91	break;
	92	case 'F':
	93	break;
	94	case 'G':
	95	if (strEQ(name, "GDBM_CACHESIZE"))
	96	#ifdef GDBM_CACHESIZE
	97	return GDBM_CACHESIZE;
	98	#else
	99	goto not_there;
	100	#endif
	101	if (strEQ(name, "GDBM_FAST"))
	102	#ifdef GDBM_FAST
	103	return GDBM_FAST;
	104	#else
	105	goto not_there;
	106	#endif
	107	if (strEQ(name, "GDBM_FASTMODE"))
	108	#ifdef GDBM_FASTMODE
	109	return GDBM_FASTMODE;
	110	#else
	111	goto not_there;
	112	#endif
	113	if (strEQ(name, "GDBM_INSERT"))
	114	#ifdef GDBM_INSERT
	115	return GDBM_INSERT;
	116	#else
	117	goto not_there;
	118	#endif
	119	if (strEQ(name, "GDBM_NEWDB"))
	120	#ifdef GDBM_NEWDB
	121	return GDBM_NEWDB;
	122	#else
	123	goto not_there;
	124	#endif
	125	if (strEQ(name, "GDBM_READER"))
	126	#ifdef GDBM_READER
	127	return GDBM_READER;
	128	#else
	129	goto not_there;
	130	#endif
	131	if (strEQ(name, "GDBM_REPLACE"))
	132	#ifdef GDBM_REPLACE
	133	return GDBM_REPLACE;
	134	#else
	135	goto not_there;
	136	#endif
	137	if (strEQ(name, "GDBM_WRCREAT"))
	138	#ifdef GDBM_WRCREAT
	139	return GDBM_WRCREAT;
	140	#else
	141	goto not_there;
	142	#endif
143	if (strEQ(name, "GDBM_WRITER"))
144	#ifdef GDBM_WRITER
145	return GDBM_WRITER;
146	#else
147	goto not_there;
148	#endif
149	break;
150	case 'H':
151	break;
152	case 'I':
153	break;
154	case 'J':
155	break;
156	case 'K':
157	break;
158	case 'L':
159	break;
160	case 'M':
161	break;
162	case 'N':
163	break;
164	case 'O':
165	break;
166	case 'P':
167	break;
168	case 'Q':
169	break;
170	case 'R':
171	break;
172	case 'S':
173	break;
174	case 'T':
175	break;
176	case 'U':
177	break;
178	case 'V':
179	break;
180	case 'W':
181	break;
182	case 'X':
183	break;
184	case 'Y':
185	break;
186	case 'Z':
187	break;
188	}
189	errno = EINVAL;
190	return 0;
191
192	not_there:
193	errno = ENOENT;
194	return 0;
195	}
196
197	MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
198
199	double
200	constant(name,arg)
201	char * name
202	int arg
203
204
205	GDBM_File
206	gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
207	char * dbtype
208	char * name
209	int read_write
210	int mode
211	FATALFUNC fatal_func
9fe6733a PM	212	CODE:
	213	{
	214	GDBM_FILE dbp ;
a0d0e21e	215
9fe6733a PM	216	RETVAL = NULL ;
	217	if (dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)) {
	218	RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ;
	219	Zero(RETVAL, 1, GDBM_File_type) ;
	220	RETVAL->dbp = dbp ;
	221	}
	222
	223	}
	224	OUTPUT:
	225	RETVAL
	226
	227
	228	#define gdbm_close(db) gdbm_close(db->dbp)
a0d0e21e LW	229	void
	230	gdbm_close(db)
	231	GDBM_File db
	232	CLEANUP:
	233
	234	void
	235	gdbm_DESTROY(db)
	236	GDBM_File db
	237	CODE:
	238	gdbm_close(db);
eb99164f	239	safefree(db);
a0d0e21e	240
9fe6733a PM	241	#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key)
9fe6733a PM	242	datum_value
a0d0e21e LW	243	gdbm_FETCH(db, key)
a0d0e21e LW	244	GDBM_File db
9fe6733a	245	datum_key key
a0d0e21e	246
9fe6733a	247	#define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags)
a0d0e21e LW	248	int
	249	gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
	250	GDBM_File db
9fe6733a PM	251	datum_key key
9fe6733a PM	252	datum_value value
a0d0e21e LW	253	int flags
	254	CLEANUP:
	255	if (RETVAL) {
	256	if (RETVAL < 0 && errno == EPERM)
	257	croak("No write permission to gdbm file");
748a9306	258	croak("gdbm store returned %d, errno %d, key \"%.*s\"",
a0d0e21e	259	RETVAL,errno,key.dsize,key.dptr);
a0d0e21e LW	260	}
a0d0e21e LW	261
9fe6733a	262	#define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key)
a0d0e21e LW	263	int
	264	gdbm_DELETE(db, key)
	265	GDBM_File db
9fe6733a	266	datum_key key
a0d0e21e	267
9fe6733a PM	268	#define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp)
9fe6733a PM	269	datum_key
a0d0e21e LW	270	gdbm_FIRSTKEY(db)
	271	GDBM_File db
	272
9fe6733a PM	273	#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key)
9fe6733a PM	274	datum_key
a0d0e21e LW	275	gdbm_NEXTKEY(db, key)
a0d0e21e LW	276	GDBM_File db
9fe6733a	277	datum_key key
a0d0e21e	278
9fe6733a	279	#define gdbm_reorganize(db) gdbm_reorganize(db->dbp)
a0d0e21e LW	280	int
	281	gdbm_reorganize(db)
	282	GDBM_File db
	283
3b35bae3	284
9fe6733a	285	#define gdbm_sync(db) gdbm_sync(db->dbp)
3b35bae3 AD	286	void
	287	gdbm_sync(db)
	288	GDBM_File db
	289
9fe6733a	290	#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key)
3b35bae3	291	int
c07a80fd	292	gdbm_EXISTS(db, key)
3b35bae3	293	GDBM_File db
9fe6733a	294	datum_key key
3b35bae3	295
9fe6733a	296	#define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen)
3b35bae3 AD	297	int
	298	gdbm_setopt (db, optflag, optval, optlen)
	299	GDBM_File db
	300	int optflag
	301	int &optval
	302	int optlen
	303
9fe6733a PM	304
	305	#define setFilter(type) \
	306	{ \
	307	if (db->type) \
e62f7e43 PM	308	RETVAL = sv_mortalcopy(db->type) ; \
e62f7e43 PM	309	ST(0) = RETVAL ; \
9fe6733a PM	310	if (db->type && (code == &PL_sv_undef)) { \
	311	SvREFCNT_dec(db->type) ; \
	312	db->type = NULL ; \
	313	} \
	314	else if (code) { \
	315	if (db->type) \
	316	sv_setsv(db->type, code) ; \
	317	else \
	318	db->type = newSVsv(code) ; \
	319	} \
	320	}
	321
	322
	323
	324	SV *
	325	filter_fetch_key(db, code)
	326	GDBM_File db
	327	SV * code
	328	SV * RETVAL = &PL_sv_undef ;
	329	CODE:
	330	setFilter(filter_fetch_key) ;
9fe6733a PM	331
	332	SV *
	333	filter_store_key(db, code)
	334	GDBM_File db
	335	SV * code
	336	SV * RETVAL = &PL_sv_undef ;
	337	CODE:
	338	setFilter(filter_store_key) ;
9fe6733a PM	339
	340	SV *
	341	filter_fetch_value(db, code)
	342	GDBM_File db
	343	SV * code
	344	SV * RETVAL = &PL_sv_undef ;
	345	CODE:
	346	setFilter(filter_fetch_value) ;
9fe6733a PM	347
	348	SV *
	349	filter_store_value(db, code)
	350	GDBM_File db
	351	SV * code
	352	SV * RETVAL = &PL_sv_undef ;
	353	CODE:
	354	setFilter(filter_store_value) ;
9fe6733a	355