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