[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 23rd June 1994
 version 0.1

 All comments/suggestions/problems are welcome

*/

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

#include <db.h>

#include <fcntl.h> 

#ifndef DBXS_HASH_TYPE
#define DBXS_HASH_TYPE u_int32_t
#endif

#ifndef DBXS_PREFIX_TYPE
#define DBXS_PREFIX_TYPE size_t
#endif

typedef DB * DB_File;
typedef DBT DBTKEY ;

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

typedef struct {
	    SV *	sub ;
	} CallBackInfo ;


/* #define TRACE  */

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

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


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

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

/* Internal Global Data */

static recno_t Value ;
static int (*DB_recno_close)() = NULL ;

static CallBackInfo hash_callback 	= { 0 } ;
static CallBackInfo compare_callback 	= { 0 } ;
static CallBackInfo prefix_callback 	= { 0 } ;


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(compare_callback.sub, 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 DBXS_PREFIX_TYPE
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(prefix_callback.sub, 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 DBXS_HASH_TYPE
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(hash_callback.sub, 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_File 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 ;
    void *	openinfo = NULL ;
    DBTYPE	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"))
        {
            type = DB_HASH ;
            openinfo = (void*)&info ;
  
            svp = hv_fetch(action, "hash", 4, FALSE); 

            if (svp && SvOK(*svp))
            {
                info.hash.hash = hash_cb ;
		hash_callback.sub = *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"))
        {
            type = DB_BTREE ;
            openinfo = (void*)&info ;
   
            svp = hv_fetch(action, "compare", 7, FALSE);
            if (svp && SvOK(*svp))
            {
                info.btree.compare = btree_compare ;
                compare_callback.sub = *svp ;
            }
            else
                info.btree.compare = NULL ;

            svp = hv_fetch(action, "prefix", 6, FALSE);
            if (svp && SvOK(*svp))
            {
                info.btree.prefix = btree_prefix ;
                prefix_callback.sub = *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"))
        {
            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 = dbopen(name, flags, mode, type, openinfo) ; 

    if (RETVAL == 0)
        croak("DB_File::%s failed, reason: %s", string, Strerror(errno)) ;

    /* 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 (type == DB_RECNO)
        DB_recno_close = RETVAL->close ;


    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


int
db_DELETE(db, key, flags=0)
	DB_File		db
	DBTKEY		key
	u_int		flags

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

	    RETVAL = (db->get)(db, &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


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

	    RETVAL = (db->seq)(db, &key, &value, R_FIRST) ;
	    ST(0) = sv_newmortal();
	    if (RETVAL == 0)
	    {
	        if (db->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 ;

	    RETVAL = (db->seq)(db, &key, &value, R_NEXT) ;
	    ST(0) = sv_newmortal();
	    if (RETVAL == 0)
	    {
	        if (db->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 ;

	    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->put)(db, &key, &value, R_IBEFORE) ;
	        if (RETVAL != 0)
	            break;
	    }
	}
	OUTPUT:
	    RETVAL

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

	    /* First get the final value */
	    RETVAL = (db->seq)(db, &key, &value, R_LAST) ;	
	    ST(0) = sv_newmortal();
	    /* Now delete it */
	    if (RETVAL == 0)
	    {
	        RETVAL = (db->del)(db, &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 ;

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


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

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


I32
length(db)
	DB_File		db
	CODE:
	    RETVAL = GetArrayLength(db) ;
	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


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

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

int
db_fd(db)
	DB_File		db

int
db_sync(db, flags=0)
	DB_File		db
	u_int		flags


int
db_seq(db, key, value, flags)
	DB_File		db
	DBTKEY		key 
	DBT		value
	u_int		flags
	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)
	6	last modified 23rd June 1994
	7	version 0.1
	8
	9	All comments/suggestions/problems are welcome
	10
	11	*/
	12
	13	#include "EXTERN.h"
	14	#include "perl.h"
	15	#include "XSUB.h"
	16
	17	#include <db.h>
	18
	19	#include <fcntl.h>
	20
	21	#ifndef DBXS_HASH_TYPE
	22	#define DBXS_HASH_TYPE u_int32_t
	23	#endif
	24
	25	#ifndef DBXS_PREFIX_TYPE
	26	#define DBXS_PREFIX_TYPE size_t
	27	#endif
	28
	29	typedef DB * DB_File;
	30	typedef DBT DBTKEY ;
	31
	32	union INFO {
	33	HASHINFO hash ;
	34	RECNOINFO recno ;
	35	BTREEINFO btree ;
	36	} ;
	37
	38	typedef struct {
	39	SV * sub ;
	40	} CallBackInfo ;
	41
	42
	43	/* #define TRACE */
	44
	45	#define db_DESTROY(db) (db->close)(db)
	46	#define db_DELETE(db, key, flags) (db->del)(db, &key, flags)
	47	#define db_STORE(db, key, value, flags) (db->put)(db, &key, &value, flags)
	48	#define db_FETCH(db, key, flags) (db->get)(db, &key, &value, flags)
	49
	50	#define db_close(db) (db->close)(db)
	51	#define db_del(db, key, flags) (db->del)(db, &key, flags)
	52	#define db_fd(db) (db->fd)(db)
	53	#define db_put(db, key, value, flags) (db->put)(db, &key, &value, flags)
	54	#define db_get(db, key, value, flags) (db->get)(db, &key, &value, flags)
	55	#define db_seq(db, key, value, flags) (db->seq)(db, &key, &value, flags)
	56	#define db_sync(db, flags) (db->sync)(db, flags)
	57
	58
	59	#define OutputValue(arg, name) \
	60	{ if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; }
	61
	62	#define OutputKey(arg, name) \
	63	{ if (RETVAL == 0) \
	64	{ \
65	if (db->close != DB_recno_close) \
66	sv_setpvn(arg, name.data, name.size); \
67	else \
68	sv_setiv(arg, (I32)(I32)name.data - 1); \
69	} \
70	}
71
72	/* Internal Global Data */
73
74	static recno_t Value ;
75	static int (*DB_recno_close)() = NULL ;
76
77	static CallBackInfo hash_callback = { 0 } ;
78	static CallBackInfo compare_callback = { 0 } ;
79	static CallBackInfo prefix_callback = { 0 } ;
80
81
82	static int
83	btree_compare(key1, key2)
84	const DBT * key1 ;
85	const DBT * key2 ;
86	{
87	dSP ;
88	void * data1, * data2 ;
89	int retval ;
90	int count ;
91
92	data1 = key1->data ;
93	data2 = key2->data ;
94
95	/* As newSVpv will assume that the data pointer is a null terminated C
96	string if the size parameter is 0, make sure that data points to an
97	empty string if the length is 0
98	*/
99	if (key1->size == 0)
100	data1 = "" ;
101	if (key2->size == 0)
102	data2 = "" ;
103
104	ENTER ;
105	SAVETMPS;
106
107	PUSHMARK(sp) ;
108	EXTEND(sp,2) ;
109	PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
110	PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
111	PUTBACK ;
112
113	count = perl_call_sv(compare_callback.sub, G_SCALAR);
114
115	SPAGAIN ;
116
117	if (count != 1)
118	croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ;
119
120	retval = POPi ;
121
122	PUTBACK ;
123	FREETMPS ;
124	LEAVE ;
125	return (retval) ;
126
127	}
128
129	static DBXS_PREFIX_TYPE
130	btree_prefix(key1, key2)
131	const DBT * key1 ;
132	const DBT * key2 ;
133	{
134	dSP ;
135	void * data1, * data2 ;
136	int retval ;
137	int count ;
138
139	data1 = key1->data ;
140	data2 = key2->data ;
141
142	/* As newSVpv will assume that the data pointer is a null terminated C
143	string if the size parameter is 0, make sure that data points to an
144	empty string if the length is 0
145	*/
146	if (key1->size == 0)
147	data1 = "" ;
148	if (key2->size == 0)
149	data2 = "" ;
150
151	ENTER ;
152	SAVETMPS;
153
154	PUSHMARK(sp) ;
155	EXTEND(sp,2) ;
156	PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
157	PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
158	PUTBACK ;
159
160	count = perl_call_sv(prefix_callback.sub, G_SCALAR);
161
162	SPAGAIN ;
163
164	if (count != 1)
165	croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ;
166
167	retval = POPi ;
168
169	PUTBACK ;
170	FREETMPS ;
171	LEAVE ;
172
173	return (retval) ;
174	}
175
176	static DBXS_HASH_TYPE
177	hash_cb(data, size)
178	const void * data ;
179	size_t size ;
180	{
181	dSP ;
182	int retval ;
183	int count ;
184
185	if (size == 0)
186	data = "" ;
187
188	PUSHMARK(sp) ;
189	XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
190	PUTBACK ;
191
192	count = perl_call_sv(hash_callback.sub, G_SCALAR);
193
194	SPAGAIN ;
195
196	if (count != 1)
197	croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ;
198
199	retval = POPi ;
200
201	PUTBACK ;
202	FREETMPS ;
203	LEAVE ;
204
205	return (retval) ;
206	}
207
208
209	#ifdef TRACE
210
211	static void
212	PrintHash(hash)
213	HASHINFO hash ;
214	{
215	printf ("HASH Info\n") ;
216	printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ;
217	printf (" bsize = %d\n", hash.bsize) ;
218	printf (" ffactor = %d\n", hash.ffactor) ;
219	printf (" nelem = %d\n", hash.nelem) ;
220	printf (" cachesize = %d\n", hash.cachesize) ;
221	printf (" lorder = %d\n", hash.lorder) ;
222
223	}
224
225	static void
226	PrintRecno(recno)
227	RECNOINFO recno ;
228	{
229	printf ("RECNO Info\n") ;
230	printf (" flags = %d\n", recno.flags) ;
231	printf (" cachesize = %d\n", recno.cachesize) ;
232	printf (" psize = %d\n", recno.psize) ;
233	printf (" lorder = %d\n", recno.lorder) ;
234	printf (" reclen = %d\n", recno.reclen) ;
235	printf (" bval = %d\n", recno.bval) ;
236	printf (" bfname = %s\n", recno.bfname) ;
237	}
238
239	PrintBtree(btree)
240	BTREEINFO btree ;
241	{
242	printf ("BTREE Info\n") ;
243	printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ;
244	printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ;
245	printf (" flags = %d\n", btree.flags) ;
246	printf (" cachesize = %d\n", btree.cachesize) ;
247	printf (" psize = %d\n", btree.psize) ;
248	printf (" maxkeypage = %d\n", btree.maxkeypage) ;
249	printf (" minkeypage = %d\n", btree.minkeypage) ;
250	printf (" lorder = %d\n", btree.lorder) ;
251	}
252
253	#else
254
255	#define PrintRecno(recno)
256	#define PrintHash(hash)
257	#define PrintBtree(btree)
258
259	#endif /* TRACE */
260
261
262	static I32
263	GetArrayLength(db)
264	DB_File db ;
265	{
266	DBT key ;
267	DBT value ;
268	int RETVAL ;
269
270	RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
271	if (RETVAL == 0)
272	RETVAL = (I32 )key.data ;
273	else if (RETVAL == 1) /* No key means empty file */
274	RETVAL = 0 ;
275
276	return (RETVAL) ;
277	}
278
279	static DB_File
280	ParseOpenInfo(name, flags, mode, sv, string)
281	char * name ;
282	int flags ;
283	int mode ;
284	SV * sv ;
285	char * string ;
286	{
287	SV ** svp;
288	HV * action ;
289	union INFO info ;
290	DB_File RETVAL ;
291	void * openinfo = NULL ;
292	DBTYPE type = DB_HASH ;
293
294
295	if (sv)
296	{
297	if (! SvROK(sv) )
298	croak ("type parameter is not a reference") ;
299
300	action = (HV*)SvRV(sv);
301	if (sv_isa(sv, "DB_File::HASHINFO"))
302	{
303	type = DB_HASH ;
304	openinfo = (void*)&info ;
305
306	svp = hv_fetch(action, "hash", 4, FALSE);
307
308	if (svp && SvOK(*svp))
309	{
310	info.hash.hash = hash_cb ;
311	hash_callback.sub = *svp ;
312	}
313	else
314	info.hash.hash = NULL ;
315
316	svp = hv_fetch(action, "bsize", 5, FALSE);
317	info.hash.bsize = svp ? SvIV(*svp) : 0;
318
319	svp = hv_fetch(action, "ffactor", 7, FALSE);
320	info.hash.ffactor = svp ? SvIV(*svp) : 0;
321
322	svp = hv_fetch(action, "nelem", 5, FALSE);
323	info.hash.nelem = svp ? SvIV(*svp) : 0;
324
325	svp = hv_fetch(action, "cachesize", 9, FALSE);
326	info.hash.cachesize = svp ? SvIV(*svp) : 0;
327
328	svp = hv_fetch(action, "lorder", 6, FALSE);
329	info.hash.lorder = svp ? SvIV(*svp) : 0;
330
331	PrintHash(info) ;
332	}
333	else if (sv_isa(sv, "DB_File::BTREEINFO"))
334	{
335	type = DB_BTREE ;
336	openinfo = (void*)&info ;
337
338	svp = hv_fetch(action, "compare", 7, FALSE);
339	if (svp && SvOK(*svp))
340	{
341	info.btree.compare = btree_compare ;
342	compare_callback.sub = *svp ;
343	}
344	else
345	info.btree.compare = NULL ;
346
347	svp = hv_fetch(action, "prefix", 6, FALSE);
348	if (svp && SvOK(*svp))
349	{
350	info.btree.prefix = btree_prefix ;
351	prefix_callback.sub = *svp ;
352	}
353	else
354	info.btree.prefix = NULL ;
355
356	svp = hv_fetch(action, "flags", 5, FALSE);
357	info.btree.flags = svp ? SvIV(*svp) : 0;
358
359	svp = hv_fetch(action, "cachesize", 9, FALSE);
360	info.btree.cachesize = svp ? SvIV(*svp) : 0;
361
362	svp = hv_fetch(action, "minkeypage", 10, FALSE);
363	info.btree.minkeypage = svp ? SvIV(*svp) : 0;
364
365	svp = hv_fetch(action, "maxkeypage", 10, FALSE);
366	info.btree.maxkeypage = svp ? SvIV(*svp) : 0;
367
368	svp = hv_fetch(action, "psize", 5, FALSE);
369	info.btree.psize = svp ? SvIV(*svp) : 0;
370
371	svp = hv_fetch(action, "lorder", 6, FALSE);
372	info.btree.lorder = svp ? SvIV(*svp) : 0;
373
374	PrintBtree(info) ;
375
376	}
377	else if (sv_isa(sv, "DB_File::RECNOINFO"))
378	{
379	type = DB_RECNO ;
380	openinfo = (void *)&info ;
381
382	svp = hv_fetch(action, "flags", 5, FALSE);
383	info.recno.flags = (u_long) svp ? SvIV(*svp) : 0;
384
385	svp = hv_fetch(action, "cachesize", 9, FALSE);
386	info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
387
388	svp = hv_fetch(action, "psize", 5, FALSE);
389	info.recno.psize = (int) svp ? SvIV(*svp) : 0;
390
391	svp = hv_fetch(action, "lorder", 6, FALSE);
392	info.recno.lorder = (int) svp ? SvIV(*svp) : 0;
393
394	svp = hv_fetch(action, "reclen", 6, FALSE);
395	info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
396
397	svp = hv_fetch(action, "bval", 4, FALSE);
398	if (svp && SvOK(*svp))
399	{
400	if (SvPOK(*svp))
401	info.recno.bval = (u_char)SvPV(svp, na) ;
402	else
403	info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
404	}
405	else
406	{
407	if (info.recno.flags & R_FIXEDLEN)
408	info.recno.bval = (u_char) ' ' ;
409	else
410	info.recno.bval = (u_char) '\n' ;
411	}
412
413	svp = hv_fetch(action, "bfname", 6, FALSE);
414	info.recno.bfname = (char ) svp ? SvPV(svp,na) : 0;
415
416	PrintRecno(info) ;
417	}
418	else
419	croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
420	}
421
422
423	RETVAL = dbopen(name, flags, mode, type, openinfo) ;
424
425	if (RETVAL == 0)
426	croak("DB_File::%s failed, reason: %s", string, Strerror(errno)) ;
427
428	/* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE
429	so remember a DB_RECNO by saving the address
430	of one of it's internal routines
431	*/
432	if (type == DB_RECNO)
433	DB_recno_close = RETVAL->close ;
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
721
722
723	int
724	db_DELETE(db, key, flags=0)
725	DB_File db
726	DBTKEY key
727	u_int flags
728
729	int
730	db_FETCH(db, key, flags=0)
731	DB_File db
732	DBTKEY key
733	u_int flags
734	CODE:
735	{
736	DBT value ;
737
738	RETVAL = (db->get)(db, &key, &value, flags) ;
739	ST(0) = sv_newmortal();
740	if (RETVAL == 0)
741	sv_setpvn(ST(0), value.data, value.size);
742	}
743
744	int
745	db_STORE(db, key, value, flags=0)
746	DB_File db
747	DBTKEY key
748	DBT value
749	u_int flags
750
751
752	int
753	db_FIRSTKEY(db)
754	DB_File db
755	CODE:
756	{
757	DBTKEY key ;
758	DBT value ;
759
760	RETVAL = (db->seq)(db, &key, &value, R_FIRST) ;
761	ST(0) = sv_newmortal();
762	if (RETVAL == 0)
763	{
764	if (db->type != DB_RECNO)
765	sv_setpvn(ST(0), key.data, key.size);
766	else
767	sv_setiv(ST(0), (I32)(I32)key.data - 1);
768	}
769	}
770
771	int
772	db_NEXTKEY(db, key)
773	DB_File db
774	DBTKEY key
775	CODE:
776	{
777	DBT value ;
778
779	RETVAL = (db->seq)(db, &key, &value, R_NEXT) ;
780	ST(0) = sv_newmortal();
781	if (RETVAL == 0)
782	{
783	if (db->type != DB_RECNO)
784	sv_setpvn(ST(0), key.data, key.size);
785	else
786	sv_setiv(ST(0), (I32)(I32)key.data - 1);
787	}
788	}
789
790	#
791	# These would be nice for RECNO
792	#
793
794	int
795	unshift(db, ...)
796	DB_File db
797	CODE:
798	{
799	DBTKEY key ;
800	DBT value ;
801	int i ;
802	int One ;
803
804	RETVAL = -1 ;
805	for (i = items-1 ; i > 0 ; --i)
806	{
807	value.data = SvPV(ST(i), na) ;
808	value.size = na ;
809	One = 1 ;
810	key.data = &One ;
811	key.size = sizeof(int) ;
812	RETVAL = (db->put)(db, &key, &value, R_IBEFORE) ;
813	if (RETVAL != 0)
814	break;
815	}
816	}
817	OUTPUT:
818	RETVAL
819
820	I32
821	pop(db)
822	DB_File db
823	CODE:
824	{
825	DBTKEY key ;
826	DBT value ;
827
828	/* First get the final value */
829	RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
830	ST(0) = sv_newmortal();
831	/* Now delete it */
832	if (RETVAL == 0)
833	{
834	RETVAL = (db->del)(db, &key, R_CURSOR) ;
835	if (RETVAL == 0)
836	sv_setpvn(ST(0), value.data, value.size);
837	}
838	}
839
840	I32
841	shift(db)
842	DB_File db
843	CODE:
844	{
845	DBTKEY key ;
846	DBT value ;
847
848	/* get the first value */
849	RETVAL = (db->seq)(db, &key, &value, R_FIRST) ;
850	ST(0) = sv_newmortal();
851	/* Now delete it */
852	if (RETVAL == 0)
853	{
854	RETVAL = (db->del)(db, &key, R_CURSOR) ;
855	if (RETVAL == 0)
856	sv_setpvn(ST(0), value.data, value.size);
857	}
858	}
859
860
861	I32
862	push(db, ...)
863	DB_File db
864	CODE:
865	{
866	DBTKEY key ;
867	DBT value ;
868	int i ;
869
870	/* Set the Cursor to the Last element */
871	RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
872	if (RETVAL == 0)
873	{
874	/* for (i = 1 ; i < items ; ++i) */
875	for (i = items - 1 ; i > 0 ; --i)
876	{
877	value.data = SvPV(ST(i), na) ;
878	value.size = na ;
879	RETVAL = (db->put)(db, &key, &value, R_IAFTER) ;
880	if (RETVAL != 0)
881	break;
882	}
883	}
884	}
885	OUTPUT:
886	RETVAL
887
888
889	I32
890	length(db)
891	DB_File db
892	CODE:
893	RETVAL = GetArrayLength(db) ;
894	OUTPUT:
895	RETVAL
896
897
898	#
899	# Now provide an interface to the rest of the DB functionality
900	#
901
902	int
903	db_del(db, key, flags=0)
904	DB_File db
905	DBTKEY key
906	u_int flags
907
908
909	int
910	db_get(db, key, value, flags=0)
911	DB_File db
912	DBTKEY key
913	DBT value
914	u_int flags
915	OUTPUT:
916	value
917
918	int
919	db_put(db, key, value, flags=0)
920	DB_File db
921	DBTKEY key
922	DBT value
923	u_int flags
924	OUTPUT:
925	key if (flags & (R_IAFTER\|R_IBEFORE)) OutputKey(ST(1), key);
926
927	int
928	db_fd(db)
929	DB_File db
930
931	int
932	db_sync(db, flags=0)
933	DB_File db
934	u_int flags
935
936
937	int
938	db_seq(db, key, value, flags)
939	DB_File db
940	DBTKEY key
941	DBT value
942	u_int flags
943	OUTPUT:
944	key
945	value