ext/DB_File/DB_File.xs

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