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