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