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