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