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