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