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