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