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