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 >>>> ORIGINAL VERSION
 820 BOOT:
 821     newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file);
 822
 823 ==== THEIR VERSION
 824 ==== YOUR VERSION
 825 BOOT:
 826     newXS("DB_File::TIEARRAY", XS_DB_File_TIEHASH, file);
 827
 828 <<<<
 829 int
 830 db_DESTROY(db)
 831         DB_File         db
 832         INIT:
 833           CurrentDB = db ;
 834         CLEANUP:
 835           if (db->hash)
 836             SvREFCNT_dec(db->hash) ;
 837           if (db->compare)
 838             SvREFCNT_dec(db->compare) ;
 839           if (db->prefix)
 840             SvREFCNT_dec(db->prefix) ;
 841           Safefree(db) ;
 842
 843
 844 int
 845 db_DELETE(db, key, flags=0)
 846         DB_File         db
 847         DBTKEY          key
 848         u_int           flags
 849         INIT:
 850           CurrentDB = db ;
 851
 852
 853 int
 854 db_EXISTS(db, key)
 855         DB_File         db
 856         DBTKEY          key
 857         CODE:
 858         {
 859           DBT           value ;
 860
 861           CurrentDB = db ;
 862           RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
 863         }
 864         OUTPUT:
 865           RETVAL
 866
 867 int
 868 db_FETCH(db, key, flags=0)
 869         DB_File         db
 870         DBTKEY          key
 871         u_int           flags
 872         CODE:
 873         {
 874             DBT         value  ;
 875
 876             CurrentDB = db ;
 877             RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
 878             ST(0) = sv_newmortal();
 879             if (RETVAL == 0)
 880                 sv_setpvn(ST(0), value.data, value.size);
 881         }
 882
 883 int
 884 db_STORE(db, key, value, flags=0)
 885         DB_File         db
 886         DBTKEY          key
 887         DBT             value
 888         u_int           flags
 889         INIT:
 890           CurrentDB = db ;
 891
 892
 893 int
 894 db_FIRSTKEY(db)
 895         DB_File         db
 896         CODE:
 897         {
 898             DBTKEY              key ;
 899             DBT         value ;
 900             DB *        Db = db->dbp ;
 901
 902             CurrentDB = db ;
 903             RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
 904             ST(0) = sv_newmortal();
 905             if (RETVAL == 0)
 906             {
 907                 if (db->type != DB_RECNO)
 908                     sv_setpvn(ST(0), key.data, key.size);
 909                 else
 910                     sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
 911             }
 912         }
 913
 914 int
 915 db_NEXTKEY(db, key)
 916         DB_File         db
 917         DBTKEY          key
 918         CODE:
 919         {
 920             DBT         value ;
 921             DB *        Db = db->dbp ;
 922
 923             CurrentDB = db ;
 924             RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
 925             ST(0) = sv_newmortal();
 926             if (RETVAL == 0)
 927             {
 928                 if (db->type != DB_RECNO)
 929                     sv_setpvn(ST(0), key.data, key.size);
 930                 else
 931                     sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
 932             }
 933         }
 934
 935 #
 936 # These would be nice for RECNO
 937 #
 938
 939 int
 940 unshift(db, ...)
 941         DB_File         db
 942         CODE:
 943         {
 944             DBTKEY      key ;
 945             DBT         value ;
 946             int         i ;
 947             int         One ;
 948             DB *        Db = db->dbp ;
 949
 950             CurrentDB = db ;
 951             RETVAL = -1 ;
 952             for (i = items-1 ; i > 0 ; --i)
 953             {
 954                 value.data = SvPV(ST(i), na) ;
 955                 value.size = na ;
 956                 One = 1 ;
 957                 key.data = &One ;
 958                 key.size = sizeof(int) ;
 959                 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
 960                 if (RETVAL != 0)
 961                     break;
 962             }
 963         }
 964         OUTPUT:
 965             RETVAL
 966
 967 I32
 968 pop(db)
 969         DB_File         db
 970         CODE:
 971         {
 972             DBTKEY      key ;
 973             DBT         value ;
 974             DB *        Db = db->dbp ;
 975
 976             CurrentDB = db ;
 977             /* First get the final value */
 978             RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
 979             ST(0) = sv_newmortal();
 980             /* Now delete it */
 981             if (RETVAL == 0)
 982             {
 983                 /* the call to del will trash value, so take a copy now */
 984                 sv_setpvn(ST(0), value.data, value.size);
 985                 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
 986                 if (RETVAL != 0)
 987                     sv_setsv(ST(0), &sv_undef);
 988             }
 989         }
 990
 991 I32
 992 shift(db)
 993         DB_File         db
 994         CODE:
 995         {
 996             DBT         value ;
 997             DBTKEY      key ;
 998             DB *        Db = db->dbp ;
 999
1000             CurrentDB = db ;
1001             /* get the first value */
1002             RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
1003             ST(0) = sv_newmortal();
1004             /* Now delete it */
1005             if (RETVAL == 0)
1006             {
1007                 /* the call to del will trash value, so take a copy now */
1008                 sv_setpvn(ST(0), value.data, value.size);
1009                 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
1010                 if (RETVAL != 0)
1011                     sv_setsv (ST(0), &sv_undef) ;
1012             }
1013         }
1014
1015
1016 I32
1017 push(db, ...)
1018         DB_File         db
1019         CODE:
1020         {
1021             DBTKEY      key ;
1022             DBTKEY *    keyptr = &key ;
1023             DBT         value ;
1024             DB *        Db = db->dbp ;
1025             int         i ;
1026
1027             CurrentDB = db ;
1028             /* Set the Cursor to the Last element */
1029             RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
1030             if (RETVAL >= 0)
1031             {
1032                 if (RETVAL == 1)
1033                     keyptr = &empty ;
1034                 for (i = items - 1 ; i > 0 ; --i)
1035                 {
1036                     value.data = SvPV(ST(i), na) ;
1037                     value.size = na ;
1038                     RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1039                     if (RETVAL != 0)
1040                         break;
1041                 }
1042             }
1043         }
1044         OUTPUT:
1045             RETVAL
1046
1047
1048 I32
1049 length(db)
1050         DB_File         db
1051         CODE:
1052             CurrentDB = db ;
1053             RETVAL = GetArrayLength(db->dbp) ;
1054         OUTPUT:
1055             RETVAL
1056
1057
1058 #
1059 # Now provide an interface to the rest of the DB functionality
1060 #
1061
1062 int
1063 db_del(db, key, flags=0)
1064         DB_File         db
1065         DBTKEY          key
1066         u_int           flags
1067         INIT:
1068           CurrentDB = db ;
1069
1070
1071 int
1072 db_get(db, key, value, flags=0)
1073         DB_File         db
1074         DBTKEY          key
1075         DBT             value
1076         u_int           flags
1077         INIT:
1078           CurrentDB = db ;
1079         OUTPUT:
1080           value
1081
1082 int
1083 db_put(db, key, value, flags=0)
1084         DB_File         db
1085         DBTKEY          key
1086         DBT             value
1087         u_int           flags
1088         INIT:
1089           CurrentDB = db ;
1090         OUTPUT:
1091           key           if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1092
1093 int
1094 db_fd(db)
1095         DB_File         db
1096         INIT:
1097           CurrentDB = db ;
1098
1099 int
1100 db_sync(db, flags=0)
1101         DB_File         db
1102         u_int           flags
1103         INIT:
1104           CurrentDB = db ;
1105
1106
1107 int
1108 db_seq(db, key, value, flags)
1109         DB_File         db
1110         DBTKEY          key
1111         DBT             value
1112         u_int           flags
1113         INIT:
1114           CurrentDB = db ;
1115         OUTPUT:
1116           key
1117           value
1118