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