[p5sagit/p5-mst-13.2.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)();

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

/* 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))) && !defined(LEAKTEST)
	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

#define PERL_constant_NOTFOUND	1
#define PERL_constant_NOTDEF	2
#define PERL_constant_ISIV	3
#define PERL_constant_ISNO	4
#define PERL_constant_ISNV	5
#define PERL_constant_ISPV	6
#define PERL_constant_ISPVN	7
#define PERL_constant_ISUNDEF	8
#define PERL_constant_ISUV	9
#define PERL_constant_ISYES	10

static int
constant (const char *name, STRLEN len, IV *iv_return) {
  /* Initially switch on the length of the name.  */
  /* When generated this function returned values for the list of names given
     in this section of perl code.  Rather than manually editing these functions
     to add or remove constants, which would result in this comment and section
     of code becoming inaccurate, we recommend that you edit this section of
     code, and use it to regenerate a new set of constant functions which you
     then use to replace the originals.

     Regenerate these constant functions by feeding this entire source file to
     perl -x

#!../../perl -w
use ExtUtils::Constant qw (constant_types C_constant XS_constant);

my $types = {map {($_, 1)} qw(IV)};
my @names = (qw(GDBM_CACHESIZE GDBM_FAST GDBM_FASTMODE GDBM_INSERT GDBM_NEWDB
	       GDBM_NOLOCK GDBM_READER GDBM_REPLACE GDBM_WRCREAT GDBM_WRITER));

print constant_types(); # macro defs
foreach (C_constant ("GDBM_File", 'constant', 'IV', $types, undef, 8, @names) ) {
    print $_, "\n"; # C constant subs
}
print "#### XS Section:\n";
print XS_constant ("GDBM_File", $types);
__END__
   */

  switch (len) {
  case 9:
    if (memEQ(name, "GDBM_FAST", 9)) {
#ifdef GDBM_FAST
      *iv_return = GDBM_FAST;
      return PERL_constant_ISIV;
#else
      return PERL_constant_NOTDEF;
#endif
    }
    break;
  case 10:
    if (memEQ(name, "GDBM_NEWDB", 10)) {
#ifdef GDBM_NEWDB
      *iv_return = GDBM_NEWDB;
      return PERL_constant_ISIV;
#else
      return PERL_constant_NOTDEF;
#endif
    }
    break;
  case 11:
    /* Names all of length 11.  */
    /* GDBM_INSERT GDBM_NOLOCK GDBM_READER GDBM_WRITER */
    /* Offset 6 gives the best switch position.  */
    switch (name[6]) {
    case 'E':
      if (memEQ(name, "GDBM_READER", 11)) {
      /*                     ^           */
#ifdef GDBM_READER
        *iv_return = GDBM_READER;
        return PERL_constant_ISIV;
#else
        return PERL_constant_NOTDEF;
#endif
      }
      break;
    case 'N':
      if (memEQ(name, "GDBM_INSERT", 11)) {
      /*                     ^           */
#ifdef GDBM_INSERT
        *iv_return = GDBM_INSERT;
        return PERL_constant_ISIV;
#else
        return PERL_constant_NOTDEF;
#endif
      }
      break;
    case 'O':
      if (memEQ(name, "GDBM_NOLOCK", 11)) {
      /*                     ^           */
#ifdef GDBM_NOLOCK
        *iv_return = GDBM_NOLOCK;
        return PERL_constant_ISIV;
#else
        return PERL_constant_NOTDEF;
#endif
      }
      break;
    case 'R':
      if (memEQ(name, "GDBM_WRITER", 11)) {
      /*                     ^           */
#ifdef GDBM_WRITER
        *iv_return = GDBM_WRITER;
        return PERL_constant_ISIV;
#else
        return PERL_constant_NOTDEF;
#endif
      }
      break;
    }
    break;
  case 12:
    /* Names all of length 12.  */
    /* GDBM_REPLACE GDBM_WRCREAT */
    /* Offset 10 gives the best switch position.  */
    switch (name[10]) {
    case 'A':
      if (memEQ(name, "GDBM_WRCREAT", 12)) {
      /*                         ^        */
#ifdef GDBM_WRCREAT
        *iv_return = GDBM_WRCREAT;
        return PERL_constant_ISIV;
#else
        return PERL_constant_NOTDEF;
#endif
      }
      break;
    case 'C':
      if (memEQ(name, "GDBM_REPLACE", 12)) {
      /*                         ^        */
#ifdef GDBM_REPLACE
        *iv_return = GDBM_REPLACE;
        return PERL_constant_ISIV;
#else
        return PERL_constant_NOTDEF;
#endif
      }
      break;
    }
    break;
  case 13:
    if (memEQ(name, "GDBM_FASTMODE", 13)) {
#ifdef GDBM_FASTMODE
      *iv_return = GDBM_FASTMODE;
      return PERL_constant_ISIV;
#else
      return PERL_constant_NOTDEF;
#endif
    }
    break;
  case 14:
    if (memEQ(name, "GDBM_CACHESIZE", 14)) {
#ifdef GDBM_CACHESIZE
      *iv_return = GDBM_CACHESIZE;
      return PERL_constant_ISIV;
#else
      return PERL_constant_NOTDEF;
#endif
    }
    break;
  }
  return PERL_constant_NOTFOUND;
}

MODULE = GDBM_File	PACKAGE = GDBM_File	PREFIX = gdbm_

void
constant(sv)
    PREINIT:
	dXSTARG;
	STRLEN		len;
        int		type;
	IV		iv;
	/* NV		nv;	Uncomment this if you need to return NVs */
	/* const char	*pv;	Uncomment this if you need to return PVs */
    INPUT:
	SV *		sv;
        const char *	s = SvPV(sv, len);
    PPCODE:
        /* Change this to constant(s, len, &iv, &nv);
           if you need to return both NVs and IVs */
	type = constant(s, len, &iv);
      /* Return 1 or 2 items. First is error message, or undef if no error.
           Second, if present, is found value */
        switch (type) {
        case PERL_constant_NOTFOUND:
          sv = sv_2mortal(newSVpvf("%s is not a valid GDBM_File macro", s));
          PUSHs(sv);
          break;
        case PERL_constant_NOTDEF:
          sv = sv_2mortal(newSVpvf(
	    "Your vendor has not defined GDBM_File macro %s, used", s));
          PUSHs(sv);
          break;
        case PERL_constant_ISIV:
          EXTEND(SP, 1);
          PUSHs(&PL_sv_undef);
          PUSHi(iv);
          break;
        default:
          sv = sv_2mortal(newSVpvf(
	    "Unexpected return type %d while processing GDBM_File macro %s, used",
               type, s));
          PUSHs(sv);
        }


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	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
	4
	5	#include <gdbm.h>
	6	#include <fcntl.h>
	7
9fe6733a	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	40
9fe6733a	41	#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
a0d0e21e	42
12f917ad	43	typedef void (*FATALFUNC)();
a0d0e21e	44
8063af02	45	#ifndef GDBM_FAST
a0d0e21e	46	static int
f0f333f4	47	not_here(char *s)
a0d0e21e	48	{
	49	croak("GDBM_File::%s not implemented on this architecture", s);
	50	return -1;
	51	}
8063af02	52	#endif
a0d0e21e	53
097d66a9	54	/* GDBM allocates the datum with system malloc() and expects the user
	55	* to free() it. So we either have to free() it immediately, or have
	56	* perl free() it when it deallocates the SV, depending on whether
	57	* perl uses malloc()/free() or not. */
	58	static void
caa0600b	59	output_datum(pTHX_ SV arg, char str, int size)
097d66a9	60	{
53e3a7fb	61	#if (!defined(MYMALLOC) \|\| (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))) && !defined(LEAKTEST)
097d66a9	62	sv_usepvn(arg, str, size);
	63	#else
	64	sv_setpvn(arg, str, size);
	65	safesysfree(str);
	66	#endif
	67	}
	68
e50aee73	69	/* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
	70	gdbm_exists, and gdbm_setopt functions. Apparently Slackware
	71	(Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
	72	*/
	73	#ifndef GDBM_FAST
	74	#define gdbm_exists(db,key) not_here("gdbm_exists")
	75	#define gdbm_sync(db) (void) not_here("gdbm_sync")
	76	#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
	77	#endif
	78
97a5fa0b	79	#define PERL_constant_NOTFOUND 1
	80	#define PERL_constant_NOTDEF 2
	81	#define PERL_constant_ISIV 3
	82	#define PERL_constant_ISNO 4
	83	#define PERL_constant_ISNV 5
	84	#define PERL_constant_ISPV 6
	85	#define PERL_constant_ISPVN 7
	86	#define PERL_constant_ISUNDEF 8
	87	#define PERL_constant_ISUV 9
	88	#define PERL_constant_ISYES 10
	89
	90	static int
	91	constant (const char name, STRLEN len, IV iv_return) {
	92	/* Initially switch on the length of the name. */
	93	/* When generated this function returned values for the list of names given
	94	in this section of perl code. Rather than manually editing these functions
	95	to add or remove constants, which would result in this comment and section
	96	of code becoming inaccurate, we recommend that you edit this section of
	97	code, and use it to regenerate a new set of constant functions which you
	98	then use to replace the originals.
	99
	100	Regenerate these constant functions by feeding this entire source file to
	101	perl -x
	102
	103	#!../../perl -w
	104	use ExtUtils::Constant qw (constant_types C_constant XS_constant);
	105
	106	my $types = {map {($_, 1)} qw(IV)};
	107	my @names = (qw(GDBM_CACHESIZE GDBM_FAST GDBM_FASTMODE GDBM_INSERT GDBM_NEWDB
	108	GDBM_NOLOCK GDBM_READER GDBM_REPLACE GDBM_WRCREAT GDBM_WRITER));
	109
	110	print constant_types(); # macro defs
	111	foreach (C_constant ("GDBM_File", 'constant', 'IV', $types, undef, 8, @names) ) {
	112	print $_, "\n"; # C constant subs
	113	}
	114	print "#### XS Section:\n";
	115	print XS_constant ("GDBM_File", $types);
	116	__END__
	117	*/
	118
	119	switch (len) {
	120	case 9:
	121	if (memEQ(name, "GDBM_FAST", 9)) {
	122	#ifdef GDBM_FAST
	123	*iv_return = GDBM_FAST;
	124	return PERL_constant_ISIV;
a0d0e21e	125	#else
97a5fa0b	126	return PERL_constant_NOTDEF;
a0d0e21e	127	#endif
97a5fa0b	128	}
	129	break;
	130	case 10:
	131	if (memEQ(name, "GDBM_NEWDB", 10)) {
	132	#ifdef GDBM_NEWDB
	133	*iv_return = GDBM_NEWDB;
	134	return PERL_constant_ISIV;
a0d0e21e	135	#else
97a5fa0b	136	return PERL_constant_NOTDEF;
a0d0e21e	137	#endif
97a5fa0b	138	}
	139	break;
	140	case 11:
	141	/* Names all of length 11. */
	142	/* GDBM_INSERT GDBM_NOLOCK GDBM_READER GDBM_WRITER */
	143	/* Offset 6 gives the best switch position. */
	144	switch (name[6]) {
	145	case 'E':
	146	if (memEQ(name, "GDBM_READER", 11)) {
	147	/* ^ */
	148	#ifdef GDBM_READER
	149	*iv_return = GDBM_READER;
	150	return PERL_constant_ISIV;
a0d0e21e	151	#else
97a5fa0b	152	return PERL_constant_NOTDEF;
a0d0e21e	153	#endif
97a5fa0b	154	}
	155	break;
	156	case 'N':
	157	if (memEQ(name, "GDBM_INSERT", 11)) {
	158	/* ^ */
a0d0e21e	159	#ifdef GDBM_INSERT
97a5fa0b	160	*iv_return = GDBM_INSERT;
97a5fa0b	161	return PERL_constant_ISIV;
a0d0e21e	162	#else
97a5fa0b	163	return PERL_constant_NOTDEF;
a0d0e21e	164	#endif
97a5fa0b	165	}
	166	break;
	167	case 'O':
	168	if (memEQ(name, "GDBM_NOLOCK", 11)) {
	169	/* ^ */
	170	#ifdef GDBM_NOLOCK
	171	*iv_return = GDBM_NOLOCK;
	172	return PERL_constant_ISIV;
a0d0e21e	173	#else
97a5fa0b	174	return PERL_constant_NOTDEF;
a0d0e21e	175	#endif
97a5fa0b	176	}
	177	break;
	178	case 'R':
	179	if (memEQ(name, "GDBM_WRITER", 11)) {
	180	/* ^ */
	181	#ifdef GDBM_WRITER
	182	*iv_return = GDBM_WRITER;
	183	return PERL_constant_ISIV;
8722d079	184	#else
97a5fa0b	185	return PERL_constant_NOTDEF;
8722d079	186	#endif
97a5fa0b	187	}
	188	break;
	189	}
	190	break;
	191	case 12:
	192	/* Names all of length 12. */
	193	/* GDBM_REPLACE GDBM_WRCREAT */
	194	/* Offset 10 gives the best switch position. */
	195	switch (name[10]) {
	196	case 'A':
	197	if (memEQ(name, "GDBM_WRCREAT", 12)) {
	198	/* ^ */
	199	#ifdef GDBM_WRCREAT
	200	*iv_return = GDBM_WRCREAT;
	201	return PERL_constant_ISIV;
a0d0e21e	202	#else
97a5fa0b	203	return PERL_constant_NOTDEF;
a0d0e21e	204	#endif
97a5fa0b	205	}
	206	break;
	207	case 'C':
	208	if (memEQ(name, "GDBM_REPLACE", 12)) {
	209	/* ^ */
a0d0e21e	210	#ifdef GDBM_REPLACE
97a5fa0b	211	*iv_return = GDBM_REPLACE;
97a5fa0b	212	return PERL_constant_ISIV;
a0d0e21e	213	#else
97a5fa0b	214	return PERL_constant_NOTDEF;
a0d0e21e	215	#endif
97a5fa0b	216	}
	217	break;
	218	}
	219	break;
	220	case 13:
	221	if (memEQ(name, "GDBM_FASTMODE", 13)) {
	222	#ifdef GDBM_FASTMODE
	223	*iv_return = GDBM_FASTMODE;
	224	return PERL_constant_ISIV;
a0d0e21e	225	#else
97a5fa0b	226	return PERL_constant_NOTDEF;
a0d0e21e	227	#endif
97a5fa0b	228	}
	229	break;
	230	case 14:
	231	if (memEQ(name, "GDBM_CACHESIZE", 14)) {
	232	#ifdef GDBM_CACHESIZE
	233	*iv_return = GDBM_CACHESIZE;
	234	return PERL_constant_ISIV;
a0d0e21e	235	#else
97a5fa0b	236	return PERL_constant_NOTDEF;
a0d0e21e	237	#endif
a0d0e21e	238	}
97a5fa0b	239	break;
	240	}
	241	return PERL_constant_NOTFOUND;
a0d0e21e	242	}
	243
	244	MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
	245
97a5fa0b	246	void
	247	constant(sv)
	248	PREINIT:
	249	dXSTARG;
	250	STRLEN len;
	251	int type;
	252	IV iv;
	253	/* NV nv; Uncomment this if you need to return NVs */
	254	/* const char pv; Uncomment this if you need to return PVs /
	255	INPUT:
	256	SV * sv;
	257	const char * s = SvPV(sv, len);
	258	PPCODE:
	259	/* Change this to constant(s, len, &iv, &nv);
	260	if you need to return both NVs and IVs */
	261	type = constant(s, len, &iv);
	262	/* Return 1 or 2 items. First is error message, or undef if no error.
	263	Second, if present, is found value */
	264	switch (type) {
	265	case PERL_constant_NOTFOUND:
	266	sv = sv_2mortal(newSVpvf("%s is not a valid GDBM_File macro", s));
	267	PUSHs(sv);
	268	break;
	269	case PERL_constant_NOTDEF:
	270	sv = sv_2mortal(newSVpvf(
	271	"Your vendor has not defined GDBM_File macro %s, used", s));
	272	PUSHs(sv);
	273	break;
	274	case PERL_constant_ISIV:
	275	EXTEND(SP, 1);
	276	PUSHs(&PL_sv_undef);
	277	PUSHi(iv);
	278	break;
	279	default:
	280	sv = sv_2mortal(newSVpvf(
	281	"Unexpected return type %d while processing GDBM_File macro %s, used",
	282	type, s));
	283	PUSHs(sv);
	284	}
a0d0e21e	285
	286
	287	GDBM_File
	288	gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
	289	char * dbtype
	290	char * name
	291	int read_write
	292	int mode
	293	FATALFUNC fatal_func
9fe6733a	294	CODE:
	295	{
	296	GDBM_FILE dbp ;
a0d0e21e	297
9fe6733a	298	RETVAL = NULL ;
8063af02	299	if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func))) {
9fe6733a	300	RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ;
	301	Zero(RETVAL, 1, GDBM_File_type) ;
	302	RETVAL->dbp = dbp ;
	303	}
	304
	305	}
	306	OUTPUT:
	307	RETVAL
	308
	309
	310	#define gdbm_close(db) gdbm_close(db->dbp)
a0d0e21e	311	void
	312	gdbm_close(db)
	313	GDBM_File db
	314	CLEANUP:
	315
	316	void
	317	gdbm_DESTROY(db)
	318	GDBM_File db
	319	CODE:
	320	gdbm_close(db);
eb99164f	321	safefree(db);
a0d0e21e	322
9fe6733a	323	#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key)
9fe6733a	324	datum_value
a0d0e21e	325	gdbm_FETCH(db, key)
a0d0e21e	326	GDBM_File db
9fe6733a	327	datum_key key
a0d0e21e	328
9fe6733a	329	#define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags)
a0d0e21e	330	int
	331	gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
	332	GDBM_File db
9fe6733a	333	datum_key key
9fe6733a	334	datum_value value
a0d0e21e	335	int flags
	336	CLEANUP:
	337	if (RETVAL) {
	338	if (RETVAL < 0 && errno == EPERM)
	339	croak("No write permission to gdbm file");
748a9306	340	croak("gdbm store returned %d, errno %d, key \"%.*s\"",
a0d0e21e	341	RETVAL,errno,key.dsize,key.dptr);
a0d0e21e	342	}
a0d0e21e	343
9fe6733a	344	#define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key)
a0d0e21e	345	int
	346	gdbm_DELETE(db, key)
	347	GDBM_File db
9fe6733a	348	datum_key key
a0d0e21e	349
9fe6733a	350	#define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp)
9fe6733a	351	datum_key
a0d0e21e	352	gdbm_FIRSTKEY(db)
	353	GDBM_File db
	354
9fe6733a	355	#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key)
9fe6733a	356	datum_key
a0d0e21e	357	gdbm_NEXTKEY(db, key)
a0d0e21e	358	GDBM_File db
9fe6733a	359	datum_key key
a0d0e21e	360
9fe6733a	361	#define gdbm_reorganize(db) gdbm_reorganize(db->dbp)
a0d0e21e	362	int
	363	gdbm_reorganize(db)
	364	GDBM_File db
	365
3b35bae3	366
9fe6733a	367	#define gdbm_sync(db) gdbm_sync(db->dbp)
3b35bae3	368	void
	369	gdbm_sync(db)
	370	GDBM_File db
	371
9fe6733a	372	#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key)
3b35bae3	373	int
c07a80fd	374	gdbm_EXISTS(db, key)
3b35bae3	375	GDBM_File db
9fe6733a	376	datum_key key
3b35bae3	377
9fe6733a	378	#define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen)
3b35bae3	379	int
	380	gdbm_setopt (db, optflag, optval, optlen)
	381	GDBM_File db
	382	int optflag
	383	int &optval
	384	int optlen
	385
9fe6733a	386
	387	#define setFilter(type) \
	388	{ \
	389	if (db->type) \
e62f7e43	390	RETVAL = sv_mortalcopy(db->type) ; \
e62f7e43	391	ST(0) = RETVAL ; \
9fe6733a	392	if (db->type && (code == &PL_sv_undef)) { \
	393	SvREFCNT_dec(db->type) ; \
	394	db->type = NULL ; \
	395	} \
	396	else if (code) { \
	397	if (db->type) \
	398	sv_setsv(db->type, code) ; \
	399	else \
	400	db->type = newSVsv(code) ; \
	401	} \
	402	}
	403
	404
	405
	406	SV *
	407	filter_fetch_key(db, code)
	408	GDBM_File db
	409	SV * code
	410	SV * RETVAL = &PL_sv_undef ;
	411	CODE:
	412	setFilter(filter_fetch_key) ;
9fe6733a	413
	414	SV *
	415	filter_store_key(db, code)
	416	GDBM_File db
	417	SV * code
	418	SV * RETVAL = &PL_sv_undef ;
	419	CODE:
	420	setFilter(filter_store_key) ;
9fe6733a	421
	422	SV *
	423	filter_fetch_value(db, code)
	424	GDBM_File db
	425	SV * code
	426	SV * RETVAL = &PL_sv_undef ;
	427	CODE:
	428	setFilter(filter_fetch_value) ;
9fe6733a	429
	430	SV *
	431	filter_store_value(db, code)
	432	GDBM_File db
	433	SV * code
	434	SV * RETVAL = &PL_sv_undef ;
	435	CODE:
	436	setFilter(filter_store_value) ;
9fe6733a	437