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