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