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