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