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