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