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