[p5sagit/p5-mst-13.2.git] / ext / DB_File / DB_File.xs

/* 

 DB_File.xs -- Perl 5 interface to Berkeley DB 

 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
 last modified 7th October 1995
 version 1.0

 All comments/suggestions/problems are welcome

 Changes:
	0.1 - Initial Release
	0.2 - No longer bombs out if dbopen returns an error.
	0.3 - Added some support for multiple btree compares
	1.0 - Complete support for multiple callbacks added.
	      Fixed a problem with pushing a value onto an empty list.
*/

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

#include <db.h>

#include <fcntl.h> 

typedef struct {
	DBTYPE	type ;
	DB * 	dbp ;
	SV *	compare ;
	SV *	prefix ;
	SV *	hash ;
	} DB_File_type;

typedef DB_File_type * DB_File ;
typedef DBT DBTKEY ;

union INFO {
        HASHINFO 	hash ;
        RECNOINFO 	recno ;
        BTREEINFO 	btree ;
      } ;


/* #define TRACE  */

#define db_DESTROY(db)                  (db->dbp->close)(db->dbp)
#define db_DELETE(db, key, flags)       (db->dbp->del)(db->dbp, &key, flags)
#define db_STORE(db, key, value, flags) (db->dbp->put)(db->dbp, &key, &value, flags)
#define db_FETCH(db, key, flags)        (db->dbp->get)(db->dbp, &key, &value, flags)

#define db_close(db)			(db->dbp->close)(db->dbp)
#define db_del(db, key, flags)          (db->dbp->del)(db->dbp, &key, flags)
#define db_fd(db)                       (db->dbp->fd)(db->dbp) 
#define db_put(db, key, value, flags)   (db->dbp->put)(db->dbp, &key, &value, flags)
#define db_get(db, key, value, flags)   (db->dbp->get)(db->dbp, &key, &value, flags)
#define db_seq(db, key, value, flags)   (db->dbp->seq)(db->dbp, &key, &value, flags)
#define db_sync(db, flags)              (db->dbp->sync)(db->dbp, flags)


#define OutputValue(arg, name)  \
	{ if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; }

#define OutputKey(arg, name)	 				\
	{ if (RETVAL == 0) \
	  { 							\
		if (db->type != DB_RECNO) 			\
		    sv_setpvn(arg, name.data, name.size); 	\
		else 						\
		    sv_setiv(arg, (I32)*(I32*)name.data - 1); 	\
	  } 							\
	}

/* Internal Global Data */
static recno_t Value ; 
static DB_File CurrentDB ;
static recno_t zero = 0 ;
static DBTKEY empty = { &zero, sizeof(recno_t) } ;


static int
btree_compare(key1, key2)
const DBT * key1 ;
const DBT * key2 ;
{
    dSP ;
    void * data1, * data2 ;
    int retval ;
    int count ;
    
    data1 = key1->data ;
    data2 = key2->data ;

    /* As newSVpv will assume that the data pointer is a null terminated C 
       string if the size parameter is 0, make sure that data points to an 
       empty string if the length is 0
    */
    if (key1->size == 0)
        data1 = "" ; 
    if (key2->size == 0)
        data2 = "" ;

    ENTER ;
    SAVETMPS;

    PUSHMARK(sp) ;
    EXTEND(sp,2) ;
    PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
    PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
    PUTBACK ;

    count = perl_call_sv(CurrentDB->compare, G_SCALAR); 

    SPAGAIN ;

    if (count != 1)
        croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ;

    retval = POPi ;

    PUTBACK ;
    FREETMPS ;
    LEAVE ;
    return (retval) ;

}

static DB_Prefix_t
btree_prefix(key1, key2)
const DBT * key1 ;
const DBT * key2 ;
{
    dSP ;
    void * data1, * data2 ;
    int retval ;
    int count ;
    
    data1 = key1->data ;
    data2 = key2->data ;

    /* As newSVpv will assume that the data pointer is a null terminated C 
       string if the size parameter is 0, make sure that data points to an 
       empty string if the length is 0
    */
    if (key1->size == 0)
        data1 = "" ;
    if (key2->size == 0)
        data2 = "" ;

    ENTER ;
    SAVETMPS;

    PUSHMARK(sp) ;
    EXTEND(sp,2) ;
    PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
    PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
    PUTBACK ;

    count = perl_call_sv(CurrentDB->prefix, G_SCALAR); 

    SPAGAIN ;

    if (count != 1)
        croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ;
 
    retval = POPi ;
 
    PUTBACK ;
    FREETMPS ;
    LEAVE ;

    return (retval) ;
}

static DB_Hash_t
hash_cb(data, size)
const void * data ;
size_t size ;
{
    dSP ;
    int retval ;
    int count ;

    if (size == 0)
        data = "" ;

    PUSHMARK(sp) ;
    XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
    PUTBACK ;

    count = perl_call_sv(CurrentDB->hash, G_SCALAR); 

    SPAGAIN ;

    if (count != 1)
        croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ;

    retval = POPi ;

    PUTBACK ;
    FREETMPS ;
    LEAVE ;

    return (retval) ;
}


#ifdef TRACE

static void
PrintHash(hash)
HASHINFO hash ;
{
    printf ("HASH Info\n") ;
    printf ("  hash      = %s\n", (hash.hash != NULL ? "redefined" : "default")) ;
    printf ("  bsize     = %d\n", hash.bsize) ;
    printf ("  ffactor   = %d\n", hash.ffactor) ;
    printf ("  nelem     = %d\n", hash.nelem) ;
    printf ("  cachesize = %d\n", hash.cachesize) ;
    printf ("  lorder    = %d\n", hash.lorder) ;

}

static void
PrintRecno(recno)
RECNOINFO recno ;
{
    printf ("RECNO Info\n") ;
    printf ("  flags     = %d\n", recno.flags) ;
    printf ("  cachesize = %d\n", recno.cachesize) ;
    printf ("  psize     = %d\n", recno.psize) ;
    printf ("  lorder    = %d\n", recno.lorder) ;
    printf ("  reclen    = %d\n", recno.reclen) ;
    printf ("  bval      = %d\n", recno.bval) ;
    printf ("  bfname    = %s\n", recno.bfname) ;
}

PrintBtree(btree)
BTREEINFO btree ;
{
    printf ("BTREE Info\n") ;
    printf ("  compare    = %s\n", (btree.compare ? "redefined" : "default")) ;
    printf ("  prefix     = %s\n", (btree.prefix ? "redefined" : "default")) ;
    printf ("  flags      = %d\n", btree.flags) ;
    printf ("  cachesize  = %d\n", btree.cachesize) ;
    printf ("  psize      = %d\n", btree.psize) ;
    printf ("  maxkeypage = %d\n", btree.maxkeypage) ;
    printf ("  minkeypage = %d\n", btree.minkeypage) ;
    printf ("  lorder     = %d\n", btree.lorder) ;
}

#else

#define PrintRecno(recno)
#define PrintHash(hash)
#define PrintBtree(btree)

#endif /* TRACE */


static I32
GetArrayLength(db)
DB * db ;
{
    DBT		key ;
    DBT		value ;
    int		RETVAL ;

    RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
    if (RETVAL == 0)
        RETVAL = *(I32 *)key.data ;
    else if (RETVAL == 1) /* No key means empty file */
        RETVAL = 0 ;

    return (RETVAL) ;
}

static DB_File
ParseOpenInfo(name, flags, mode, sv, string)
char * name ;
int    flags ;
int    mode ;
SV *   sv ;
char * string ;
{
    SV **	svp;
    HV *	action ;
    union INFO	info ;
    DB_File	RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
    void *	openinfo = NULL ;
    /* DBTYPE	type = DB_HASH ; */

    RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
    RETVAL->type = DB_HASH ;

    if (sv)
    {
        if (! SvROK(sv) )
            croak ("type parameter is not a reference") ;

        action = (HV*)SvRV(sv);
        if (sv_isa(sv, "DB_File::HASHINFO"))
        {
            RETVAL->type = DB_HASH ;
            openinfo = (void*)&info ;
  
            svp = hv_fetch(action, "hash", 4, FALSE); 

            if (svp && SvOK(*svp))
            {
                info.hash.hash = hash_cb ;
		RETVAL->hash = newSVsv(*svp) ;
            }
            else
	        info.hash.hash = NULL ;

           svp = hv_fetch(action, "bsize", 5, FALSE);
           info.hash.bsize = svp ? SvIV(*svp) : 0;
           
           svp = hv_fetch(action, "ffactor", 7, FALSE);
           info.hash.ffactor = svp ? SvIV(*svp) : 0;
         
           svp = hv_fetch(action, "nelem", 5, FALSE);
           info.hash.nelem = svp ? SvIV(*svp) : 0;
         
           svp = hv_fetch(action, "cachesize", 9, FALSE);
           info.hash.cachesize = svp ? SvIV(*svp) : 0;
         
           svp = hv_fetch(action, "lorder", 6, FALSE);
           info.hash.lorder = svp ? SvIV(*svp) : 0;

           PrintHash(info) ; 
        }
        else if (sv_isa(sv, "DB_File::BTREEINFO"))
        {
            RETVAL->type = DB_BTREE ;
            openinfo = (void*)&info ;
   
            svp = hv_fetch(action, "compare", 7, FALSE);
            if (svp && SvOK(*svp))
            {
                info.btree.compare = btree_compare ;
		RETVAL->compare = newSVsv(*svp) ;
            }
            else
                info.btree.compare = NULL ;

            svp = hv_fetch(action, "prefix", 6, FALSE);
            if (svp && SvOK(*svp))
            {
                info.btree.prefix = btree_prefix ;
		RETVAL->prefix = newSVsv(*svp) ;
            }
            else
                info.btree.prefix = NULL ;

            svp = hv_fetch(action, "flags", 5, FALSE);
            info.btree.flags = svp ? SvIV(*svp) : 0;
   
            svp = hv_fetch(action, "cachesize", 9, FALSE);
            info.btree.cachesize = svp ? SvIV(*svp) : 0;
         
            svp = hv_fetch(action, "minkeypage", 10, FALSE);
            info.btree.minkeypage = svp ? SvIV(*svp) : 0;
        
            svp = hv_fetch(action, "maxkeypage", 10, FALSE);
            info.btree.maxkeypage = svp ? SvIV(*svp) : 0;

            svp = hv_fetch(action, "psize", 5, FALSE);
            info.btree.psize = svp ? SvIV(*svp) : 0;
         
            svp = hv_fetch(action, "lorder", 6, FALSE);
            info.btree.lorder = svp ? SvIV(*svp) : 0;

            PrintBtree(info) ;
         
        }
        else if (sv_isa(sv, "DB_File::RECNOINFO"))
        {
            RETVAL->type = DB_RECNO ;
            openinfo = (void *)&info ;

            svp = hv_fetch(action, "flags", 5, FALSE);
            info.recno.flags = (u_long) svp ? SvIV(*svp) : 0;
         
            svp = hv_fetch(action, "cachesize", 9, FALSE);
            info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
         
            svp = hv_fetch(action, "psize", 5, FALSE);
            info.recno.psize = (int) svp ? SvIV(*svp) : 0;
         
            svp = hv_fetch(action, "lorder", 6, FALSE);
            info.recno.lorder = (int) svp ? SvIV(*svp) : 0;
         
            svp = hv_fetch(action, "reclen", 6, FALSE);
            info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
         
	    svp = hv_fetch(action, "bval", 4, FALSE);
            if (svp && SvOK(*svp))
            {
                if (SvPOK(*svp))
		    info.recno.bval = (u_char)*SvPV(*svp, na) ;
		else
		    info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
            }
            else
 	    {
		if (info.recno.flags & R_FIXEDLEN)
                    info.recno.bval = (u_char) ' ' ;
		else
                    info.recno.bval = (u_char) '\n' ;
	    }
         
            svp = hv_fetch(action, "bfname", 6, FALSE); 
            info.recno.bfname = (char *) svp ? SvPV(*svp,na) : 0;

            PrintRecno(info) ;
        }
        else
            croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
    }


    RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; 

#if 0
    /* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE
		       so remember a DB_RECNO by saving the address
		       of one of it's internal routines
    */
    if (RETVAL->dbp && type == DB_RECNO)
        DB_recno_close = RETVAL->dbp->close ;
#endif


    return (RETVAL) ;
}


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;
{
    errno = 0;
    switch (*name) {
    case 'A':
	break;
    case 'B':
	if (strEQ(name, "BTREEMAGIC"))
#ifdef BTREEMAGIC
	    return BTREEMAGIC;
#else
	    goto not_there;
#endif
	if (strEQ(name, "BTREEVERSION"))
#ifdef BTREEVERSION
	    return BTREEVERSION;
#else
	    goto not_there;
#endif
	break;
    case 'C':
	break;
    case 'D':
	if (strEQ(name, "DB_LOCK"))
#ifdef DB_LOCK
	    return DB_LOCK;
#else
	    goto not_there;
#endif
	if (strEQ(name, "DB_SHMEM"))
#ifdef DB_SHMEM
	    return DB_SHMEM;
#else
	    goto not_there;
#endif
	if (strEQ(name, "DB_TXN"))
#ifdef DB_TXN
	    return (U32)DB_TXN;
#else
	    goto not_there;
#endif
	break;
    case 'E':
	break;
    case 'F':
	break;
    case 'G':
	break;
    case 'H':
	if (strEQ(name, "HASHMAGIC"))
#ifdef HASHMAGIC
	    return HASHMAGIC;
#else
	    goto not_there;
#endif
	if (strEQ(name, "HASHVERSION"))
#ifdef HASHVERSION
	    return HASHVERSION;
#else
	    goto not_there;
#endif
	break;
    case 'I':
	break;
    case 'J':
	break;
    case 'K':
	break;
    case 'L':
	break;
    case 'M':
	if (strEQ(name, "MAX_PAGE_NUMBER"))
#ifdef MAX_PAGE_NUMBER
	    return (U32)MAX_PAGE_NUMBER;
#else
	    goto not_there;
#endif
	if (strEQ(name, "MAX_PAGE_OFFSET"))
#ifdef MAX_PAGE_OFFSET
	    return MAX_PAGE_OFFSET;
#else
	    goto not_there;
#endif
	if (strEQ(name, "MAX_REC_NUMBER"))
#ifdef MAX_REC_NUMBER
	    return (U32)MAX_REC_NUMBER;
#else
	    goto not_there;
#endif
	break;
    case 'N':
	break;
    case 'O':
	break;
    case 'P':
	break;
    case 'Q':
	break;
    case 'R':
	if (strEQ(name, "RET_ERROR"))
#ifdef RET_ERROR
	    return RET_ERROR;
#else
	    goto not_there;
#endif
	if (strEQ(name, "RET_SPECIAL"))
#ifdef RET_SPECIAL
	    return RET_SPECIAL;
#else
	    goto not_there;
#endif
	if (strEQ(name, "RET_SUCCESS"))
#ifdef RET_SUCCESS
	    return RET_SUCCESS;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_CURSOR"))
#ifdef R_CURSOR
	    return R_CURSOR;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_DUP"))
#ifdef R_DUP
	    return R_DUP;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_FIRST"))
#ifdef R_FIRST
	    return R_FIRST;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_FIXEDLEN"))
#ifdef R_FIXEDLEN
	    return R_FIXEDLEN;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_IAFTER"))
#ifdef R_IAFTER
	    return R_IAFTER;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_IBEFORE"))
#ifdef R_IBEFORE
	    return R_IBEFORE;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_LAST"))
#ifdef R_LAST
	    return R_LAST;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_NEXT"))
#ifdef R_NEXT
	    return R_NEXT;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_NOKEY"))
#ifdef R_NOKEY
	    return R_NOKEY;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_NOOVERWRITE"))
#ifdef R_NOOVERWRITE
	    return R_NOOVERWRITE;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_PREV"))
#ifdef R_PREV
	    return R_PREV;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_RECNOSYNC"))
#ifdef R_RECNOSYNC
	    return R_RECNOSYNC;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_SETCURSOR"))
#ifdef R_SETCURSOR
	    return R_SETCURSOR;
#else
	    goto not_there;
#endif
	if (strEQ(name, "R_SNAPSHOT"))
#ifdef R_SNAPSHOT
	    return R_SNAPSHOT;
#else
	    goto not_there;
#endif
	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;
    case '_':
	if (strEQ(name, "__R_UNUSED"))
#ifdef __R_UNUSED
	    return __R_UNUSED;
#else
	    goto not_there;
#endif
	break;
    }
    errno = EINVAL;
    return 0;

not_there:
    errno = ENOENT;
    return 0;
}

MODULE = DB_File	PACKAGE = DB_File	PREFIX = db_

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


DB_File
db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH)
	char *		dbtype
	int		flags
	int		mode
	CODE:
	{
	    char *	name = (char *) NULL ; 
	    SV *	sv = (SV *) NULL ; 

	    if (items >= 2 && SvOK(ST(1))) 
	        name = (char*) SvPV(ST(1), na) ; 

            if (items == 5)
	        sv = ST(4) ;

	    RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ;
	}
	OUTPUT:	
	    RETVAL

BOOT:
    newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file);

int
db_DESTROY(db)
	DB_File		db
	INIT:
	  CurrentDB = db ;
	CLEANUP:
	  if (db->hash)
	    SvREFCNT_dec(db->hash) ;
	  if (db->compare)
	    SvREFCNT_dec(db->compare) ;
	  if (db->prefix)
	    SvREFCNT_dec(db->prefix) ;
	  Safefree(db) ;


int
db_DELETE(db, key, flags=0)
	DB_File		db
	DBTKEY		key
	u_int		flags
	INIT:
	  CurrentDB = db ;

int
db_FETCH(db, key, flags=0)
	DB_File		db
	DBTKEY		key
	u_int		flags
	CODE:
	{
	    DBT		value  ;

	    CurrentDB = db ;
	    RETVAL = (db->dbp->get)(db->dbp, &key, &value, flags) ;
	    ST(0) = sv_newmortal();
	    if (RETVAL == 0)
	        sv_setpvn(ST(0), value.data, value.size);
	}

int
db_STORE(db, key, value, flags=0)
	DB_File		db
	DBTKEY		key
	DBT		value
	u_int		flags
	INIT:
	  CurrentDB = db ;


int
db_FIRSTKEY(db)
	DB_File		db
	CODE:
	{
	    DBTKEY		key ;
	    DBT		value ;

	    CurrentDB = db ;
	    RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_FIRST) ;
	    ST(0) = sv_newmortal();
	    if (RETVAL == 0)
	    {
	        if (db->dbp->type != DB_RECNO)
	            sv_setpvn(ST(0), key.data, key.size);
	        else
	            sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
	    }
	}

int
db_NEXTKEY(db, key)
	DB_File		db
	DBTKEY		key
	CODE:
	{
	    DBT		value ;

	    CurrentDB = db ;
	    RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_NEXT) ;
	    ST(0) = sv_newmortal();
	    if (RETVAL == 0)
	    {
	        if (db->dbp->type != DB_RECNO)
	            sv_setpvn(ST(0), key.data, key.size);
	        else
	            sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
	    }
	}

#
# These would be nice for RECNO
#

int
unshift(db, ...)
	DB_File		db
	CODE:
	{
	    DBTKEY	key ;
	    DBT		value ;
	    int		i ;
	    int		One ;

	    CurrentDB = db ;
	    RETVAL = -1 ;
	    for (i = items-1 ; i > 0 ; --i)
	    {
	        value.data = SvPV(ST(i), na) ;
	        value.size = na ;
	        One = 1 ;
	        key.data = &One ;
	        key.size = sizeof(int) ;
	        RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
	        if (RETVAL != 0)
	            break;
	    }
	}
	OUTPUT:
	    RETVAL

I32
pop(db)
	DB_File		db
	CODE:
	{
	    DBTKEY	key ;
	    DBT		value ;

	    CurrentDB = db ;
	    /* First get the final value */
	    RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_LAST) ;	
	    ST(0) = sv_newmortal();
	    /* Now delete it */
	    if (RETVAL == 0)
	    {
	        RETVAL = (db->dbp->del)(db->dbp, &key, R_CURSOR) ;
	        if (RETVAL == 0)
	            sv_setpvn(ST(0), value.data, value.size);
	    }
	}

I32
shift(db)
	DB_File		db
	CODE:
	{
	    DBTKEY	key ;
	    DBT		value ;

	    CurrentDB = db ;
	    /* get the first value */
	    RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_FIRST) ;	
	    ST(0) = sv_newmortal();
	    /* Now delete it */
	    if (RETVAL == 0)
	    {
	        RETVAL = (db->dbp->del)(db->dbp, &key, R_CURSOR) ;
	        if (RETVAL == 0)
	            sv_setpvn(ST(0), value.data, value.size);
	    }
	}


I32
push(db, ...)
	DB_File		db
	CODE:
	{
	    DBTKEY	key ;
	    DBTKEY *	keyptr = &key ; 
	    DBT		value ;
	    int		i ;

	    CurrentDB = db ;
	    /* Set the Cursor to the Last element */
	    RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_LAST) ;
	    if (RETVAL >= 0)
	    {
		if (RETVAL == 1)
		    keyptr = &empty ;
	        for (i = items - 1 ; i > 0 ; --i)
	        {
	            value.data = SvPV(ST(i), na) ;
	            value.size = na ;
	            RETVAL = (db->dbp->put)(db->dbp, keyptr, &value, R_IAFTER) ;
	            if (RETVAL != 0)
	                break;
	        }
	    }
	}
	OUTPUT:
	    RETVAL


I32
length(db)
	DB_File		db
	CODE:
	    CurrentDB = db ;
	    RETVAL = GetArrayLength(db->dbp) ;
	OUTPUT:
	    RETVAL


#
# Now provide an interface to the rest of the DB functionality
#

int
db_del(db, key, flags=0)
	DB_File		db
	DBTKEY		key
	u_int		flags
	INIT:
	  CurrentDB = db ;


int
db_get(db, key, value, flags=0)
	DB_File		db
	DBTKEY		key
	DBT		value
	u_int		flags
	INIT:
	  CurrentDB = db ;
	OUTPUT:
	  value

int
db_put(db, key, value, flags=0)
	DB_File		db
	DBTKEY		key
	DBT		value
	u_int		flags
	INIT:
	  CurrentDB = db ;
	OUTPUT:
	  key		if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);

int
db_fd(db)
	DB_File		db
	INIT:
	  CurrentDB = db ;

int
db_sync(db, flags=0)
	DB_File		db
	u_int		flags
	INIT:
	  CurrentDB = db ;


int
db_seq(db, key, value, flags)
	DB_File		db
	DBTKEY		key 
	DBT		value
	u_int		flags
	INIT:
	  CurrentDB = db ;
	OUTPUT:
	  key
	  value
Commit	Line	Data
a0d0e21e	1	/*
	2
	3	DB_File.xs -- Perl 5 interface to Berkeley DB
	4
	5	written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
8e07c86e	6	last modified 7th October 1995
8e07c86e	7	version 1.0
a0d0e21e	8
	9	All comments/suggestions/problems are welcome
	10
3b35bae3	11	Changes:
	12	0.1 - Initial Release
	13	0.2 - No longer bombs out if dbopen returns an error.
8e07c86e	14	0.3 - Added some support for multiple btree compares
	15	1.0 - Complete support for multiple callbacks added.
	16	Fixed a problem with pushing a value onto an empty list.
a0d0e21e	17	*/
	18
	19	#include "EXTERN.h"
	20	#include "perl.h"
	21	#include "XSUB.h"
	22
	23	#include <db.h>
	24
	25	#include <fcntl.h>
	26
8e07c86e	27	typedef struct {
	28	DBTYPE type ;
	29	DB * dbp ;
	30	SV * compare ;
	31	SV * prefix ;
	32	SV * hash ;
	33	} DB_File_type;
	34
	35	typedef DB_File_type * DB_File ;
a0d0e21e	36	typedef DBT DBTKEY ;
	37
	38	union INFO {
	39	HASHINFO hash ;
	40	RECNOINFO recno ;
	41	BTREEINFO btree ;
	42	} ;
	43
a0d0e21e	44
	45	/* #define TRACE */
	46
8e07c86e	47	#define db_DESTROY(db) (db->dbp->close)(db->dbp)
	48	#define db_DELETE(db, key, flags) (db->dbp->del)(db->dbp, &key, flags)
	49	#define db_STORE(db, key, value, flags) (db->dbp->put)(db->dbp, &key, &value, flags)
	50	#define db_FETCH(db, key, flags) (db->dbp->get)(db->dbp, &key, &value, flags)
a0d0e21e	51
8e07c86e	52	#define db_close(db) (db->dbp->close)(db->dbp)
	53	#define db_del(db, key, flags) (db->dbp->del)(db->dbp, &key, flags)
	54	#define db_fd(db) (db->dbp->fd)(db->dbp)
	55	#define db_put(db, key, value, flags) (db->dbp->put)(db->dbp, &key, &value, flags)
	56	#define db_get(db, key, value, flags) (db->dbp->get)(db->dbp, &key, &value, flags)
	57	#define db_seq(db, key, value, flags) (db->dbp->seq)(db->dbp, &key, &value, flags)
	58	#define db_sync(db, flags) (db->dbp->sync)(db->dbp, flags)
a0d0e21e	59
	60
	61	#define OutputValue(arg, name) \
	62	{ if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; }
	63
	64	#define OutputKey(arg, name) \
	65	{ if (RETVAL == 0) \
	66	{ \
8e07c86e	67	if (db->type != DB_RECNO) \
a0d0e21e	68	sv_setpvn(arg, name.data, name.size); \
	69	else \
	70	sv_setiv(arg, (I32)(I32)name.data - 1); \
	71	} \
	72	}
	73
	74	/* Internal Global Data */
8e07c86e	75	static recno_t Value ;
	76	static DB_File CurrentDB ;
	77	static recno_t zero = 0 ;
	78	static DBTKEY empty = { &zero, sizeof(recno_t) } ;
a0d0e21e	79
	80
	81	static int
	82	btree_compare(key1, key2)
	83	const DBT * key1 ;
	84	const DBT * key2 ;
	85	{
	86	dSP ;
	87	void * data1, * data2 ;
	88	int retval ;
	89	int count ;
	90
	91	data1 = key1->data ;
	92	data2 = key2->data ;
	93
	94	/* As newSVpv will assume that the data pointer is a null terminated C
	95	string if the size parameter is 0, make sure that data points to an
	96	empty string if the length is 0
	97	*/
	98	if (key1->size == 0)
	99	data1 = "" ;
	100	if (key2->size == 0)
	101	data2 = "" ;
	102
	103	ENTER ;
	104	SAVETMPS;
	105
	106	PUSHMARK(sp) ;
	107	EXTEND(sp,2) ;
	108	PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
	109	PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
	110	PUTBACK ;
	111
8e07c86e	112	count = perl_call_sv(CurrentDB->compare, G_SCALAR);
a0d0e21e	113
	114	SPAGAIN ;
	115
	116	if (count != 1)
	117	croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ;
	118
	119	retval = POPi ;
	120
	121	PUTBACK ;
	122	FREETMPS ;
	123	LEAVE ;
	124	return (retval) ;
	125
	126	}
	127
ecfc5424	128	static DB_Prefix_t
a0d0e21e	129	btree_prefix(key1, key2)
	130	const DBT * key1 ;
	131	const DBT * key2 ;
	132	{
	133	dSP ;
	134	void * data1, * data2 ;
	135	int retval ;
	136	int count ;
	137
	138	data1 = key1->data ;
	139	data2 = key2->data ;
	140
	141	/* As newSVpv will assume that the data pointer is a null terminated C
	142	string if the size parameter is 0, make sure that data points to an
	143	empty string if the length is 0
	144	*/
	145	if (key1->size == 0)
	146	data1 = "" ;
	147	if (key2->size == 0)
	148	data2 = "" ;
	149
	150	ENTER ;
	151	SAVETMPS;
	152
	153	PUSHMARK(sp) ;
	154	EXTEND(sp,2) ;
	155	PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
	156	PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
	157	PUTBACK ;
	158
8e07c86e	159	count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
a0d0e21e	160
	161	SPAGAIN ;
	162
	163	if (count != 1)
	164	croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ;
	165
	166	retval = POPi ;
	167
	168	PUTBACK ;
	169	FREETMPS ;
	170	LEAVE ;
	171
	172	return (retval) ;
	173	}
	174
ecfc5424	175	static DB_Hash_t
a0d0e21e	176	hash_cb(data, size)
	177	const void * data ;
	178	size_t size ;
	179	{
	180	dSP ;
	181	int retval ;
	182	int count ;
	183
	184	if (size == 0)
	185	data = "" ;
	186
	187	PUSHMARK(sp) ;
	188	XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
	189	PUTBACK ;
	190
8e07c86e	191	count = perl_call_sv(CurrentDB->hash, G_SCALAR);
a0d0e21e	192
	193	SPAGAIN ;
	194
	195	if (count != 1)
	196	croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ;
	197
	198	retval = POPi ;
	199
	200	PUTBACK ;
	201	FREETMPS ;
	202	LEAVE ;
	203
	204	return (retval) ;
	205	}
	206
	207
	208	#ifdef TRACE
	209
	210	static void
	211	PrintHash(hash)
	212	HASHINFO hash ;
	213	{
	214	printf ("HASH Info\n") ;
	215	printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ;
	216	printf (" bsize = %d\n", hash.bsize) ;
	217	printf (" ffactor = %d\n", hash.ffactor) ;
	218	printf (" nelem = %d\n", hash.nelem) ;
	219	printf (" cachesize = %d\n", hash.cachesize) ;
	220	printf (" lorder = %d\n", hash.lorder) ;
	221
	222	}
	223
	224	static void
	225	PrintRecno(recno)
	226	RECNOINFO recno ;
	227	{
	228	printf ("RECNO Info\n") ;
	229	printf (" flags = %d\n", recno.flags) ;
	230	printf (" cachesize = %d\n", recno.cachesize) ;
	231	printf (" psize = %d\n", recno.psize) ;
	232	printf (" lorder = %d\n", recno.lorder) ;
	233	printf (" reclen = %d\n", recno.reclen) ;
	234	printf (" bval = %d\n", recno.bval) ;
	235	printf (" bfname = %s\n", recno.bfname) ;
	236	}
	237
	238	PrintBtree(btree)
	239	BTREEINFO btree ;
	240	{
	241	printf ("BTREE Info\n") ;
	242	printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ;
	243	printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ;
	244	printf (" flags = %d\n", btree.flags) ;
	245	printf (" cachesize = %d\n", btree.cachesize) ;
	246	printf (" psize = %d\n", btree.psize) ;
	247	printf (" maxkeypage = %d\n", btree.maxkeypage) ;
	248	printf (" minkeypage = %d\n", btree.minkeypage) ;
	249	printf (" lorder = %d\n", btree.lorder) ;
	250	}
	251
	252	#else
	253
	254	#define PrintRecno(recno)
	255	#define PrintHash(hash)
256	#define PrintBtree(btree)
257
258	#endif /* TRACE */
259
260
261	static I32
262	GetArrayLength(db)
8e07c86e	263	DB * db ;
a0d0e21e	264	{
	265	DBT key ;
	266	DBT value ;
	267	int RETVAL ;
	268
	269	RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
	270	if (RETVAL == 0)
	271	RETVAL = (I32 )key.data ;
	272	else if (RETVAL == 1) /* No key means empty file */
	273	RETVAL = 0 ;
	274
	275	return (RETVAL) ;
	276	}
	277
	278	static DB_File
	279	ParseOpenInfo(name, flags, mode, sv, string)
	280	char * name ;
	281	int flags ;
	282	int mode ;
	283	SV * sv ;
	284	char * string ;
	285	{
	286	SV ** svp;
	287	HV * action ;
	288	union INFO info ;
8e07c86e	289	DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
a0d0e21e	290	void * openinfo = NULL ;
8e07c86e	291	/* DBTYPE type = DB_HASH ; */
a0d0e21e	292
8e07c86e	293	RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
8e07c86e	294	RETVAL->type = DB_HASH ;
a0d0e21e	295
	296	if (sv)
	297	{
	298	if (! SvROK(sv) )
	299	croak ("type parameter is not a reference") ;
	300
	301	action = (HV*)SvRV(sv);
	302	if (sv_isa(sv, "DB_File::HASHINFO"))
	303	{
8e07c86e	304	RETVAL->type = DB_HASH ;
a0d0e21e	305	openinfo = (void*)&info ;
	306
	307	svp = hv_fetch(action, "hash", 4, FALSE);
	308
	309	if (svp && SvOK(*svp))
	310	{
	311	info.hash.hash = hash_cb ;
8e07c86e	312	RETVAL->hash = newSVsv(*svp) ;
a0d0e21e	313	}
	314	else
	315	info.hash.hash = NULL ;
	316
	317	svp = hv_fetch(action, "bsize", 5, FALSE);
	318	info.hash.bsize = svp ? SvIV(*svp) : 0;
	319
	320	svp = hv_fetch(action, "ffactor", 7, FALSE);
	321	info.hash.ffactor = svp ? SvIV(*svp) : 0;
	322
	323	svp = hv_fetch(action, "nelem", 5, FALSE);
	324	info.hash.nelem = svp ? SvIV(*svp) : 0;
	325
	326	svp = hv_fetch(action, "cachesize", 9, FALSE);
	327	info.hash.cachesize = svp ? SvIV(*svp) : 0;
	328
	329	svp = hv_fetch(action, "lorder", 6, FALSE);
	330	info.hash.lorder = svp ? SvIV(*svp) : 0;
	331
	332	PrintHash(info) ;
	333	}
	334	else if (sv_isa(sv, "DB_File::BTREEINFO"))
	335	{
8e07c86e	336	RETVAL->type = DB_BTREE ;
a0d0e21e	337	openinfo = (void*)&info ;
	338
	339	svp = hv_fetch(action, "compare", 7, FALSE);
	340	if (svp && SvOK(*svp))
	341	{
	342	info.btree.compare = btree_compare ;
8e07c86e	343	RETVAL->compare = newSVsv(*svp) ;
a0d0e21e	344	}
	345	else
	346	info.btree.compare = NULL ;
	347
	348	svp = hv_fetch(action, "prefix", 6, FALSE);
	349	if (svp && SvOK(*svp))
	350	{
	351	info.btree.prefix = btree_prefix ;
8e07c86e	352	RETVAL->prefix = newSVsv(*svp) ;
a0d0e21e	353	}
	354	else
	355	info.btree.prefix = NULL ;
	356
	357	svp = hv_fetch(action, "flags", 5, FALSE);
	358	info.btree.flags = svp ? SvIV(*svp) : 0;
	359
	360	svp = hv_fetch(action, "cachesize", 9, FALSE);
	361	info.btree.cachesize = svp ? SvIV(*svp) : 0;
	362
	363	svp = hv_fetch(action, "minkeypage", 10, FALSE);
	364	info.btree.minkeypage = svp ? SvIV(*svp) : 0;
	365
	366	svp = hv_fetch(action, "maxkeypage", 10, FALSE);
	367	info.btree.maxkeypage = svp ? SvIV(*svp) : 0;
	368
	369	svp = hv_fetch(action, "psize", 5, FALSE);
	370	info.btree.psize = svp ? SvIV(*svp) : 0;
	371
	372	svp = hv_fetch(action, "lorder", 6, FALSE);
	373	info.btree.lorder = svp ? SvIV(*svp) : 0;
	374
	375	PrintBtree(info) ;
	376
	377	}
	378	else if (sv_isa(sv, "DB_File::RECNOINFO"))
	379	{
8e07c86e	380	RETVAL->type = DB_RECNO ;
a0d0e21e	381	openinfo = (void *)&info ;
	382
	383	svp = hv_fetch(action, "flags", 5, FALSE);
	384	info.recno.flags = (u_long) svp ? SvIV(*svp) : 0;
	385
	386	svp = hv_fetch(action, "cachesize", 9, FALSE);
	387	info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
	388
	389	svp = hv_fetch(action, "psize", 5, FALSE);
	390	info.recno.psize = (int) svp ? SvIV(*svp) : 0;
	391
	392	svp = hv_fetch(action, "lorder", 6, FALSE);
	393	info.recno.lorder = (int) svp ? SvIV(*svp) : 0;
	394
	395	svp = hv_fetch(action, "reclen", 6, FALSE);
	396	info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
	397
	398	svp = hv_fetch(action, "bval", 4, FALSE);
	399	if (svp && SvOK(*svp))
	400	{
	401	if (SvPOK(*svp))
	402	info.recno.bval = (u_char)SvPV(svp, na) ;
	403	else
	404	info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
	405	}
	406	else
	407	{
	408	if (info.recno.flags & R_FIXEDLEN)
	409	info.recno.bval = (u_char) ' ' ;
	410	else
	411	info.recno.bval = (u_char) '\n' ;
	412	}
	413
	414	svp = hv_fetch(action, "bfname", 6, FALSE);
	415	info.recno.bfname = (char ) svp ? SvPV(svp,na) : 0;
	416
	417	PrintRecno(info) ;
	418	}
	419	else
	420	croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
	421	}
	422
	423
8e07c86e	424	RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
a0d0e21e	425
8e07c86e	426	#if 0
a0d0e21e	427	/* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE
	428	so remember a DB_RECNO by saving the address
	429	of one of it's internal routines
	430	*/
8e07c86e	431	if (RETVAL->dbp && type == DB_RECNO)
	432	DB_recno_close = RETVAL->dbp->close ;
	433	#endif
a0d0e21e	434
	435
	436	return (RETVAL) ;
	437	}
	438
	439
	440	static int
	441	not_here(s)
	442	char *s;
	443	{
	444	croak("DB_File::%s not implemented on this architecture", s);
	445	return -1;
	446	}
	447
	448	static double
	449	constant(name, arg)
	450	char *name;
	451	int arg;
	452	{
	453	errno = 0;
	454	switch (*name) {
	455	case 'A':
	456	break;
	457	case 'B':
	458	if (strEQ(name, "BTREEMAGIC"))
	459	#ifdef BTREEMAGIC
	460	return BTREEMAGIC;
	461	#else
	462	goto not_there;
	463	#endif
	464	if (strEQ(name, "BTREEVERSION"))
	465	#ifdef BTREEVERSION
	466	return BTREEVERSION;
	467	#else
	468	goto not_there;
	469	#endif
	470	break;
	471	case 'C':
	472	break;
	473	case 'D':
	474	if (strEQ(name, "DB_LOCK"))
	475	#ifdef DB_LOCK
	476	return DB_LOCK;
	477	#else
	478	goto not_there;
	479	#endif
	480	if (strEQ(name, "DB_SHMEM"))
	481	#ifdef DB_SHMEM
	482	return DB_SHMEM;
	483	#else
	484	goto not_there;
	485	#endif
	486	if (strEQ(name, "DB_TXN"))
	487	#ifdef DB_TXN
	488	return (U32)DB_TXN;
	489	#else
	490	goto not_there;
	491	#endif
	492	break;
	493	case 'E':
	494	break;
	495	case 'F':
	496	break;
	497	case 'G':
498	break;
499	case 'H':
500	if (strEQ(name, "HASHMAGIC"))
501	#ifdef HASHMAGIC
502	return HASHMAGIC;
503	#else
504	goto not_there;
505	#endif
506	if (strEQ(name, "HASHVERSION"))
507	#ifdef HASHVERSION
508	return HASHVERSION;
509	#else
510	goto not_there;
511	#endif
512	break;
513	case 'I':
514	break;
515	case 'J':
516	break;
517	case 'K':
518	break;
519	case 'L':
520	break;
521	case 'M':
522	if (strEQ(name, "MAX_PAGE_NUMBER"))
523	#ifdef MAX_PAGE_NUMBER
524	return (U32)MAX_PAGE_NUMBER;
525	#else
526	goto not_there;
527	#endif
528	if (strEQ(name, "MAX_PAGE_OFFSET"))
529	#ifdef MAX_PAGE_OFFSET
530	return MAX_PAGE_OFFSET;
531	#else
532	goto not_there;
533	#endif
534	if (strEQ(name, "MAX_REC_NUMBER"))
535	#ifdef MAX_REC_NUMBER
536	return (U32)MAX_REC_NUMBER;
537	#else
538	goto not_there;
539	#endif
540	break;
541	case 'N':
542	break;
543	case 'O':
544	break;
545	case 'P':
546	break;
547	case 'Q':
548	break;
549	case 'R':
550	if (strEQ(name, "RET_ERROR"))
551	#ifdef RET_ERROR
552	return RET_ERROR;
553	#else
554	goto not_there;
555	#endif
556	if (strEQ(name, "RET_SPECIAL"))
557	#ifdef RET_SPECIAL
558	return RET_SPECIAL;
559	#else
560	goto not_there;
561	#endif
562	if (strEQ(name, "RET_SUCCESS"))
563	#ifdef RET_SUCCESS
564	return RET_SUCCESS;
565	#else
566	goto not_there;
567	#endif
568	if (strEQ(name, "R_CURSOR"))
569	#ifdef R_CURSOR
570	return R_CURSOR;
571	#else
572	goto not_there;
573	#endif
574	if (strEQ(name, "R_DUP"))
575	#ifdef R_DUP
576	return R_DUP;
577	#else
578	goto not_there;
579	#endif
580	if (strEQ(name, "R_FIRST"))
581	#ifdef R_FIRST
582	return R_FIRST;
583	#else
584	goto not_there;
585	#endif
586	if (strEQ(name, "R_FIXEDLEN"))
587	#ifdef R_FIXEDLEN
588	return R_FIXEDLEN;
589	#else
590	goto not_there;
591	#endif
592	if (strEQ(name, "R_IAFTER"))
593	#ifdef R_IAFTER
594	return R_IAFTER;
595	#else
596	goto not_there;
597	#endif
598	if (strEQ(name, "R_IBEFORE"))
599	#ifdef R_IBEFORE
600	return R_IBEFORE;
601	#else
602	goto not_there;
603	#endif
604	if (strEQ(name, "R_LAST"))
605	#ifdef R_LAST
606	return R_LAST;
607	#else
608	goto not_there;
609	#endif
610	if (strEQ(name, "R_NEXT"))
611	#ifdef R_NEXT
612	return R_NEXT;
613	#else
614	goto not_there;
615	#endif
616	if (strEQ(name, "R_NOKEY"))
617	#ifdef R_NOKEY
618	return R_NOKEY;
619	#else
620	goto not_there;
621	#endif
622	if (strEQ(name, "R_NOOVERWRITE"))
623	#ifdef R_NOOVERWRITE
624	return R_NOOVERWRITE;
625	#else
626	goto not_there;
627	#endif
628	if (strEQ(name, "R_PREV"))
629	#ifdef R_PREV
630	return R_PREV;
631	#else
632	goto not_there;
633	#endif
634	if (strEQ(name, "R_RECNOSYNC"))
635	#ifdef R_RECNOSYNC
636	return R_RECNOSYNC;
637	#else
638	goto not_there;
639	#endif
640	if (strEQ(name, "R_SETCURSOR"))
641	#ifdef R_SETCURSOR
642	return R_SETCURSOR;
643	#else
644	goto not_there;
645	#endif
646	if (strEQ(name, "R_SNAPSHOT"))
647	#ifdef R_SNAPSHOT
648	return R_SNAPSHOT;
649	#else
650	goto not_there;
651	#endif
652	break;
653	case 'S':
654	break;
655	case 'T':
656	break;
657	case 'U':
658	break;
659	case 'V':
660	break;
661	case 'W':
662	break;
663	case 'X':
664	break;
665	case 'Y':
666	break;
667	case 'Z':
668	break;
669	case '_':
670	if (strEQ(name, "__R_UNUSED"))
671	#ifdef __R_UNUSED
672	return __R_UNUSED;
673	#else
674	goto not_there;
675	#endif
676	break;
677	}
678	errno = EINVAL;
679	return 0;
680
681	not_there:
682	errno = ENOENT;
683	return 0;
684	}
685
686	MODULE = DB_File PACKAGE = DB_File PREFIX = db_
687
688	double
689	constant(name,arg)
690	char * name
691	int arg
692
693
694	DB_File
695	db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH)
696	char * dbtype
697	int flags
698	int mode
699	CODE:
700	{
701	char * name = (char *) NULL ;
702	SV * sv = (SV *) NULL ;
703
704	if (items >= 2 && SvOK(ST(1)))
705	name = (char*) SvPV(ST(1), na) ;
706
707	if (items == 5)
708	sv = ST(4) ;
709
710	RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ;
711	}
712	OUTPUT:
713	RETVAL
714
715	BOOT:
716	newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file);
717
718	int
719	db_DESTROY(db)
720	DB_File db
8e07c86e	721	INIT:
	722	CurrentDB = db ;
	723	CLEANUP:
	724	if (db->hash)
	725	SvREFCNT_dec(db->hash) ;
	726	if (db->compare)
	727	SvREFCNT_dec(db->compare) ;
	728	if (db->prefix)
	729	SvREFCNT_dec(db->prefix) ;
	730	Safefree(db) ;
a0d0e21e	731
	732
	733	int
	734	db_DELETE(db, key, flags=0)
	735	DB_File db
	736	DBTKEY key
	737	u_int flags
8e07c86e	738	INIT:
8e07c86e	739	CurrentDB = db ;
a0d0e21e	740
	741	int
	742	db_FETCH(db, key, flags=0)
	743	DB_File db
	744	DBTKEY key
	745	u_int flags
	746	CODE:
	747	{
	748	DBT value ;
	749
8e07c86e	750	CurrentDB = db ;
8e07c86e	751	RETVAL = (db->dbp->get)(db->dbp, &key, &value, flags) ;
a0d0e21e	752	ST(0) = sv_newmortal();
	753	if (RETVAL == 0)
	754	sv_setpvn(ST(0), value.data, value.size);
	755	}
	756
	757	int
	758	db_STORE(db, key, value, flags=0)
	759	DB_File db
	760	DBTKEY key
	761	DBT value
	762	u_int flags
8e07c86e	763	INIT:
8e07c86e	764	CurrentDB = db ;
a0d0e21e	765
	766
	767	int
	768	db_FIRSTKEY(db)
	769	DB_File db
	770	CODE:
	771	{
	772	DBTKEY key ;
	773	DBT value ;
	774
8e07c86e	775	CurrentDB = db ;
8e07c86e	776	RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_FIRST) ;
a0d0e21e	777	ST(0) = sv_newmortal();
	778	if (RETVAL == 0)
	779	{
8e07c86e	780	if (db->dbp->type != DB_RECNO)
a0d0e21e	781	sv_setpvn(ST(0), key.data, key.size);
	782	else
	783	sv_setiv(ST(0), (I32)(I32)key.data - 1);
	784	}
	785	}
	786
	787	int
	788	db_NEXTKEY(db, key)
	789	DB_File db
	790	DBTKEY key
	791	CODE:
	792	{
	793	DBT value ;
	794
8e07c86e	795	CurrentDB = db ;
8e07c86e	796	RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_NEXT) ;
a0d0e21e	797	ST(0) = sv_newmortal();
	798	if (RETVAL == 0)
	799	{
8e07c86e	800	if (db->dbp->type != DB_RECNO)
a0d0e21e	801	sv_setpvn(ST(0), key.data, key.size);
	802	else
	803	sv_setiv(ST(0), (I32)(I32)key.data - 1);
	804	}
	805	}
	806
	807	#
	808	# These would be nice for RECNO
	809	#
	810
	811	int
	812	unshift(db, ...)
	813	DB_File db
	814	CODE:
	815	{
	816	DBTKEY key ;
	817	DBT value ;
	818	int i ;
	819	int One ;
	820
8e07c86e	821	CurrentDB = db ;
a0d0e21e	822	RETVAL = -1 ;
	823	for (i = items-1 ; i > 0 ; --i)
	824	{
	825	value.data = SvPV(ST(i), na) ;
	826	value.size = na ;
	827	One = 1 ;
	828	key.data = &One ;
	829	key.size = sizeof(int) ;
8e07c86e	830	RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
a0d0e21e	831	if (RETVAL != 0)
	832	break;
	833	}
	834	}
	835	OUTPUT:
	836	RETVAL
	837
	838	I32
	839	pop(db)
	840	DB_File db
	841	CODE:
	842	{
	843	DBTKEY key ;
	844	DBT value ;
	845
8e07c86e	846	CurrentDB = db ;
a0d0e21e	847	/* First get the final value */
8e07c86e	848	RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_LAST) ;
a0d0e21e	849	ST(0) = sv_newmortal();
	850	/* Now delete it */
	851	if (RETVAL == 0)
	852	{
8e07c86e	853	RETVAL = (db->dbp->del)(db->dbp, &key, R_CURSOR) ;
a0d0e21e	854	if (RETVAL == 0)
	855	sv_setpvn(ST(0), value.data, value.size);
	856	}
	857	}
	858
	859	I32
	860	shift(db)
	861	DB_File db
	862	CODE:
	863	{
	864	DBTKEY key ;
	865	DBT value ;
	866
8e07c86e	867	CurrentDB = db ;
a0d0e21e	868	/* get the first value */
8e07c86e	869	RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_FIRST) ;
a0d0e21e	870	ST(0) = sv_newmortal();
	871	/* Now delete it */
	872	if (RETVAL == 0)
	873	{
8e07c86e	874	RETVAL = (db->dbp->del)(db->dbp, &key, R_CURSOR) ;
a0d0e21e	875	if (RETVAL == 0)
	876	sv_setpvn(ST(0), value.data, value.size);
	877	}
	878	}
	879
	880
	881	I32
	882	push(db, ...)
	883	DB_File db
	884	CODE:
	885	{
	886	DBTKEY key ;
8e07c86e	887	DBTKEY * keyptr = &key ;
a0d0e21e	888	DBT value ;
	889	int i ;
	890
8e07c86e	891	CurrentDB = db ;
a0d0e21e	892	/* Set the Cursor to the Last element */
8e07c86e	893	RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_LAST) ;
8e07c86e	894	if (RETVAL >= 0)
a0d0e21e	895	{
8e07c86e	896	if (RETVAL == 1)
	897	keyptr = &empty ;
	898	for (i = items - 1 ; i > 0 ; --i)
	899	{
	900	value.data = SvPV(ST(i), na) ;
	901	value.size = na ;
	902	RETVAL = (db->dbp->put)(db->dbp, keyptr, &value, R_IAFTER) ;
	903	if (RETVAL != 0)
	904	break;
	905	}
a0d0e21e	906	}
	907	}
	908	OUTPUT:
	909	RETVAL
	910
	911
	912	I32
	913	length(db)
	914	DB_File db
	915	CODE:
8e07c86e	916	CurrentDB = db ;
8e07c86e	917	RETVAL = GetArrayLength(db->dbp) ;
a0d0e21e	918	OUTPUT:
	919	RETVAL
	920
	921
	922	#
	923	# Now provide an interface to the rest of the DB functionality
	924	#
	925
	926	int
	927	db_del(db, key, flags=0)
	928	DB_File db
	929	DBTKEY key
	930	u_int flags
8e07c86e	931	INIT:
8e07c86e	932	CurrentDB = db ;
a0d0e21e	933
	934
	935	int
	936	db_get(db, key, value, flags=0)
	937	DB_File db
	938	DBTKEY key
	939	DBT value
	940	u_int flags
8e07c86e	941	INIT:
8e07c86e	942	CurrentDB = db ;
a0d0e21e	943	OUTPUT:
	944	value
	945
	946	int
	947	db_put(db, key, value, flags=0)
	948	DB_File db
	949	DBTKEY key
	950	DBT value
	951	u_int flags
8e07c86e	952	INIT:
8e07c86e	953	CurrentDB = db ;
a0d0e21e	954	OUTPUT:
	955	key if (flags & (R_IAFTER\|R_IBEFORE)) OutputKey(ST(1), key);
	956
	957	int
	958	db_fd(db)
	959	DB_File db
8e07c86e	960	INIT:
8e07c86e	961	CurrentDB = db ;
a0d0e21e	962
	963	int
	964	db_sync(db, flags=0)
	965	DB_File db
	966	u_int flags
8e07c86e	967	INIT:
8e07c86e	968	CurrentDB = db ;
a0d0e21e	969
	970
	971	int
	972	db_seq(db, key, value, flags)
	973	DB_File db
	974	DBTKEY key
	975	DBT value
	976	u_int flags
8e07c86e	977	INIT:
8e07c86e	978	CurrentDB = db ;
a0d0e21e	979	OUTPUT:
	980	key
	981	value