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
CommitLineData
a0d0e21e
LW
1/*
2
3 DB_File.xs -- Perl 5 interface to Berkeley DB
4
5 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
93af7a87
MB
6 last modified 8th Oct 1997
7 version 1.16
a0d0e21e
LW
8
9 All comments/suggestions/problems are welcome
10
a0b8c8c1 11 Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved.
36477c24
PP
12 This program is free software; you can redistribute it and/or
13 modify it under the same terms as Perl itself.
14
3b35bae3 15 Changes:
4633a7c4
LW
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.
88108326
PP
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
f6b705ef 29 1.03 - Added EXISTS
610ab055
PM
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
ff68c719 34 1.06 - Minor namespace cleanup: Localized PrintBtree.
36477c24
PP
35 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n".
36 1.08 - No change to DB_File.xs
18d2dc8c 37 1.09 - Default mode for dbopen changed to 0666
a0b8c8c1
PM
38 1.10 - Fixed fd method so that it still returns -1 for
39 in-memory files when db 1.86 is used.
778183f3 40 1.11 - No change to DB_File.xs
68dc0745 41 1.12 - No change to DB_File.xs
d3ef3b8a 42 1.13 - Tidied up a few casts.
05475680
PM
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.
a6ed719b
PM
45 1.15 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
46 undefined value" warning with db_get and db_seq.
93af7a87 47 1.16 - Minor additions to DB_File.xs to support multithreaded perl.
f6b705ef 48
a0d0e21e
LW
49*/
50
51#include "EXTERN.h"
52#include "perl.h"
53#include "XSUB.h"
54
52e1cb5e
JH
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
a0d0e21e 60#include <db.h>
a6ed719b
PM
61/* #ifdef DB_VERSION_MAJOR */
62/* #include <db_185.h> */
63/* #endif */
a0d0e21e
LW
64
65#include <fcntl.h>
66
610ab055
PM
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
81union INFO {
82 HASHINFO hash ;
83 RECNOINFO recno ;
84 BTREEINFO btree ;
85 } ;
86
8e07c86e
AD
87typedef struct {
88 DBTYPE type ;
89 DB * dbp ;
90 SV * compare ;
91 SV * prefix ;
92 SV * hash ;
a0b8c8c1 93 int in_memory ;
610ab055 94 union INFO info ;
8e07c86e
AD
95 } DB_File_type;
96
97typedef DB_File_type * DB_File ;
a0d0e21e
LW
98typedef DBT DBTKEY ;
99
a0d0e21e 100
a6ed719b 101/* #define TRACE */
a0d0e21e 102
4633a7c4
LW
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)
a0d0e21e 107
4633a7c4
LW
108#define db_close(db) ((db->dbp)->close)(db->dbp)
109#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
a0b8c8c1
PM
110#define db_fd(db) (db->in_memory \
111 ? -1 \
112 : ((db->dbp)->fd)(db->dbp) )
4633a7c4
LW
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)
a0d0e21e
LW
117
118
88108326
PP
119#define OutputValue(arg, name) \
120 { if (RETVAL == 0) { \
121 sv_setpvn(arg, name.data, name.size) ; \
122 } \
123 }
a0d0e21e
LW
124
125#define OutputKey(arg, name) \
126 { if (RETVAL == 0) \
127 { \
88108326 128 if (db->type != DB_RECNO) { \
a0d0e21e 129 sv_setpvn(arg, name.data, name.size); \
88108326 130 } \
a0d0e21e
LW
131 else \
132 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
133 } \
134 }
135
136/* Internal Global Data */
8e07c86e
AD
137static recno_t Value ;
138static DB_File CurrentDB ;
139static recno_t zero = 0 ;
140static DBTKEY empty = { &zero, sizeof(recno_t) } ;
a0d0e21e
LW
141
142
143static int
144btree_compare(key1, key2)
145const DBT * key1 ;
146const 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
8e07c86e 174 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
a0d0e21e
LW
175
176 SPAGAIN ;
177
178 if (count != 1)
ff0cee69 179 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
a0d0e21e
LW
180
181 retval = POPi ;
182
183 PUTBACK ;
184 FREETMPS ;
185 LEAVE ;
186 return (retval) ;
187
188}
189
ecfc5424 190static DB_Prefix_t
a0d0e21e
LW
191btree_prefix(key1, key2)
192const DBT * key1 ;
193const 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
8e07c86e 221 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
a0d0e21e
LW
222
223 SPAGAIN ;
224
225 if (count != 1)
ff0cee69 226 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
a0d0e21e
LW
227
228 retval = POPi ;
229
230 PUTBACK ;
231 FREETMPS ;
232 LEAVE ;
233
234 return (retval) ;
235}
236
ecfc5424 237static DB_Hash_t
a0d0e21e
LW
238hash_cb(data, size)
239const void * data ;
240size_t size ;
241{
242 dSP ;
243 int retval ;
244 int count ;
245
246 if (size == 0)
247 data = "" ;
248
610ab055
PM
249 /* DGH - Next two lines added to fix corrupted stack problem */
250 ENTER ;
251 SAVETMPS;
252
a0d0e21e 253 PUSHMARK(sp) ;
610ab055 254
a0d0e21e
LW
255 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
256 PUTBACK ;
257
8e07c86e 258 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
a0d0e21e
LW
259
260 SPAGAIN ;
261
262 if (count != 1)
ff0cee69 263 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
a0d0e21e
LW
264
265 retval = POPi ;
266
267 PUTBACK ;
268 FREETMPS ;
269 LEAVE ;
270
271 return (retval) ;
272}
273
274
275#ifdef TRACE
276
277static void
278PrintHash(hash)
610ab055 279HASHINFO * hash ;
a0d0e21e
LW
280{
281 printf ("HASH Info\n") ;
610ab055
PM
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) ;
a0d0e21e
LW
288
289}
290
291static void
292PrintRecno(recno)
610ab055 293RECNOINFO * recno ;
a0d0e21e
LW
294{
295 printf ("RECNO Info\n") ;
610ab055
PM
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) ;
d3ef3b8a 300 printf (" reclen = %lu\n", (unsigned long)recno->reclen) ;
36477c24 301 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
610ab055 302 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
a0d0e21e
LW
303}
304
ff68c719 305static void
a0d0e21e 306PrintBtree(btree)
610ab055 307BTREEINFO * btree ;
a0d0e21e
LW
308{
309 printf ("BTREE Info\n") ;
610ab055
PM
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) ;
a0d0e21e
LW
318}
319
320#else
321
322#define PrintRecno(recno)
323#define PrintHash(hash)
324#define PrintBtree(btree)
325
326#endif /* TRACE */
327
328
329static I32
330GetArrayLength(db)
8e07c86e 331DB * db ;
a0d0e21e
LW
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
a0b8c8c1 343 return ((I32)RETVAL) ;
a0d0e21e
LW
344}
345
88108326
PP
346static recno_t
347GetRecnoKey(db, value)
348DB_File db ;
349I32 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)
ff0cee69 357 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
88108326
PP
358
359 value = length + value + 1 ;
360 }
361 else
362 ++ value ;
363
364 return value ;
a0d0e21e
LW
365}
366
367static DB_File
05475680
PM
368ParseOpenInfo(isHASH, name, flags, mode, sv)
369int isHASH ;
a0d0e21e
LW
370char * name ;
371int flags ;
372int mode ;
373SV * sv ;
a0d0e21e
LW
374{
375 SV ** svp;
376 HV * action ;
8e07c86e 377 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
a0d0e21e 378 void * openinfo = NULL ;
610ab055 379 union INFO * info = &RETVAL->info ;
a0d0e21e 380
88108326 381 /* Default to HASH */
8e07c86e
AD
382 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
383 RETVAL->type = DB_HASH ;
a0d0e21e 384
610ab055
PM
385 /* DGH - Next line added to avoid SEGV on existing hash DB */
386 CurrentDB = RETVAL;
387
a0b8c8c1
PM
388 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
389 RETVAL->in_memory = (name == NULL) ;
390
a0d0e21e
LW
391 if (sv)
392 {
393 if (! SvROK(sv) )
394 croak ("type parameter is not a reference") ;
395
36477c24
PP
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") ;
610ab055 401
a0d0e21e
LW
402 if (sv_isa(sv, "DB_File::HASHINFO"))
403 {
05475680
PM
404
405 if (!isHASH)
406 croak("DB_File can only tie an associative array to a DB_HASH database") ;
407
8e07c86e 408 RETVAL->type = DB_HASH ;
610ab055 409 openinfo = (void*)info ;
a0d0e21e
LW
410
411 svp = hv_fetch(action, "hash", 4, FALSE);
412
413 if (svp && SvOK(*svp))
414 {
610ab055 415 info->hash.hash = hash_cb ;
8e07c86e 416 RETVAL->hash = newSVsv(*svp) ;
a0d0e21e
LW
417 }
418 else
610ab055 419 info->hash.hash = NULL ;
a0d0e21e
LW
420
421 svp = hv_fetch(action, "bsize", 5, FALSE);
610ab055 422 info->hash.bsize = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
423
424 svp = hv_fetch(action, "ffactor", 7, FALSE);
610ab055 425 info->hash.ffactor = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
426
427 svp = hv_fetch(action, "nelem", 5, FALSE);
610ab055 428 info->hash.nelem = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
429
430 svp = hv_fetch(action, "cachesize", 9, FALSE);
610ab055 431 info->hash.cachesize = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
432
433 svp = hv_fetch(action, "lorder", 6, FALSE);
610ab055 434 info->hash.lorder = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
435
436 PrintHash(info) ;
437 }
438 else if (sv_isa(sv, "DB_File::BTREEINFO"))
439 {
05475680
PM
440 if (!isHASH)
441 croak("DB_File can only tie an associative array to a DB_BTREE database");
442
8e07c86e 443 RETVAL->type = DB_BTREE ;
610ab055 444 openinfo = (void*)info ;
a0d0e21e
LW
445
446 svp = hv_fetch(action, "compare", 7, FALSE);
447 if (svp && SvOK(*svp))
448 {
610ab055 449 info->btree.compare = btree_compare ;
8e07c86e 450 RETVAL->compare = newSVsv(*svp) ;
a0d0e21e
LW
451 }
452 else
610ab055 453 info->btree.compare = NULL ;
a0d0e21e
LW
454
455 svp = hv_fetch(action, "prefix", 6, FALSE);
456 if (svp && SvOK(*svp))
457 {
610ab055 458 info->btree.prefix = btree_prefix ;
8e07c86e 459 RETVAL->prefix = newSVsv(*svp) ;
a0d0e21e
LW
460 }
461 else
610ab055 462 info->btree.prefix = NULL ;
a0d0e21e
LW
463
464 svp = hv_fetch(action, "flags", 5, FALSE);
610ab055 465 info->btree.flags = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
466
467 svp = hv_fetch(action, "cachesize", 9, FALSE);
610ab055 468 info->btree.cachesize = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
469
470 svp = hv_fetch(action, "minkeypage", 10, FALSE);
610ab055 471 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
472
473 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
610ab055 474 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
475
476 svp = hv_fetch(action, "psize", 5, FALSE);
610ab055 477 info->btree.psize = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
478
479 svp = hv_fetch(action, "lorder", 6, FALSE);
610ab055 480 info->btree.lorder = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
481
482 PrintBtree(info) ;
483
484 }
485 else if (sv_isa(sv, "DB_File::RECNOINFO"))
486 {
05475680
PM
487 if (isHASH)
488 croak("DB_File can only tie an array to a DB_RECNO database");
489
8e07c86e 490 RETVAL->type = DB_RECNO ;
610ab055 491 openinfo = (void *)info ;
a0d0e21e
LW
492
493 svp = hv_fetch(action, "flags", 5, FALSE);
d3ef3b8a 494 info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0);
a0d0e21e
LW
495
496 svp = hv_fetch(action, "cachesize", 9, FALSE);
d3ef3b8a 497 info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0);
a0d0e21e
LW
498
499 svp = hv_fetch(action, "psize", 5, FALSE);
d3ef3b8a 500 info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0);
a0d0e21e
LW
501
502 svp = hv_fetch(action, "lorder", 6, FALSE);
d3ef3b8a 503 info->recno.lorder = (int) (svp ? SvIV(*svp) : 0);
a0d0e21e
LW
504
505 svp = hv_fetch(action, "reclen", 6, FALSE);
d3ef3b8a 506 info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0);
a0d0e21e
LW
507
508 svp = hv_fetch(action, "bval", 4, FALSE);
509 if (svp && SvOK(*svp))
510 {
511 if (SvPOK(*svp))
610ab055 512 info->recno.bval = (u_char)*SvPV(*svp, na) ;
a0d0e21e 513 else
610ab055 514 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
a0d0e21e
LW
515 }
516 else
517 {
610ab055
PM
518 if (info->recno.flags & R_FIXEDLEN)
519 info->recno.bval = (u_char) ' ' ;
a0d0e21e 520 else
610ab055 521 info->recno.bval = (u_char) '\n' ;
a0d0e21e
LW
522 }
523
524 svp = hv_fetch(action, "bfname", 6, FALSE);
36477c24 525 if (svp && SvOK(*svp)) {
88108326 526 char * ptr = SvPV(*svp,na) ;
d3ef3b8a 527 info->recno.bfname = (char*) (na ? ptr : NULL) ;
88108326 528 }
36477c24
PP
529 else
530 info->recno.bfname = NULL ;
a0d0e21e
LW
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
88108326
PP
539 /* OS2 Specific Code */
540#ifdef OS2
541#ifdef __EMX__
542 flags |= O_BINARY;
543#endif /* __EMX__ */
544#endif /* OS2 */
a0d0e21e 545
88108326 546 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
a0d0e21e
LW
547
548 return (RETVAL) ;
549}
550
551
552static int
553not_here(s)
554char *s;
555{
556 croak("DB_File::%s not implemented on this architecture", s);
557 return -1;
558}
559
560static double
561constant(name, arg)
562char *name;
563int 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
793not_there:
794 errno = ENOENT;
795 return 0;
796}
797
798MODULE = DB_File PACKAGE = DB_File PREFIX = db_
799
800double
801constant(name,arg)
802 char * name
803 int arg
804
805
806DB_File
05475680
PM
807db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
808 int isHASH
a0d0e21e
LW
809 char * dbtype
810 int flags
811 int mode
812 CODE:
813 {
814 char * name = (char *) NULL ;
815 SV * sv = (SV *) NULL ;
816
05475680
PM
817 if (items >= 3 && SvOK(ST(2)))
818 name = (char*) SvPV(ST(2), na) ;
a0d0e21e 819
05475680
PM
820 if (items == 6)
821 sv = ST(5) ;
a0d0e21e 822
05475680 823 RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
4633a7c4
LW
824 if (RETVAL->dbp == NULL)
825 RETVAL = NULL ;
a0d0e21e
LW
826 }
827 OUTPUT:
828 RETVAL
829
a0d0e21e
LW
830int
831db_DESTROY(db)
832 DB_File db
8e07c86e
AD
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) ;
a0d0e21e
LW
843
844
845int
846db_DELETE(db, key, flags=0)
847 DB_File db
848 DBTKEY key
849 u_int flags
8e07c86e
AD
850 INIT:
851 CurrentDB = db ;
a0d0e21e 852
f6b705ef
PP
853
854int
855db_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
a0d0e21e
LW
868int
869db_FETCH(db, key, flags=0)
870 DB_File db
871 DBTKEY key
872 u_int flags
873 CODE:
874 {
875 DBT value ;
876
8e07c86e 877 CurrentDB = db ;
4633a7c4 878 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
a0d0e21e
LW
879 ST(0) = sv_newmortal();
880 if (RETVAL == 0)
881 sv_setpvn(ST(0), value.data, value.size);
882 }
883
884int
885db_STORE(db, key, value, flags=0)
886 DB_File db
887 DBTKEY key
888 DBT value
889 u_int flags
8e07c86e
AD
890 INIT:
891 CurrentDB = db ;
a0d0e21e
LW
892
893
894int
895db_FIRSTKEY(db)
896 DB_File db
897 CODE:
898 {
899 DBTKEY key ;
900 DBT value ;
4633a7c4 901 DB * Db = db->dbp ;
a0d0e21e 902
8e07c86e 903 CurrentDB = db ;
4633a7c4 904 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
a0d0e21e
LW
905 ST(0) = sv_newmortal();
906 if (RETVAL == 0)
907 {
05475680 908 if (db->type != DB_RECNO)
a0d0e21e
LW
909 sv_setpvn(ST(0), key.data, key.size);
910 else
911 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
912 }
913 }
914
915int
916db_NEXTKEY(db, key)
917 DB_File db
918 DBTKEY key
919 CODE:
920 {
921 DBT value ;
4633a7c4 922 DB * Db = db->dbp ;
a0d0e21e 923
8e07c86e 924 CurrentDB = db ;
4633a7c4 925 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
a0d0e21e
LW
926 ST(0) = sv_newmortal();
927 if (RETVAL == 0)
928 {
05475680 929 if (db->type != DB_RECNO)
a0d0e21e
LW
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
940int
941unshift(db, ...)
942 DB_File db
943 CODE:
944 {
945 DBTKEY key ;
946 DBT value ;
947 int i ;
948 int One ;
4633a7c4 949 DB * Db = db->dbp ;
a0d0e21e 950
8e07c86e 951 CurrentDB = db ;
a0d0e21e
LW
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) ;
4633a7c4 960 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
a0d0e21e
LW
961 if (RETVAL != 0)
962 break;
963 }
964 }
965 OUTPUT:
966 RETVAL
967
968I32
969pop(db)
970 DB_File db
971 CODE:
972 {
973 DBTKEY key ;
974 DBT value ;
4633a7c4 975 DB * Db = db->dbp ;
a0d0e21e 976
8e07c86e 977 CurrentDB = db ;
a0d0e21e 978 /* First get the final value */
4633a7c4 979 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
a0d0e21e
LW
980 ST(0) = sv_newmortal();
981 /* Now delete it */
982 if (RETVAL == 0)
983 {
f6b705ef
PP
984 /* the call to del will trash value, so take a copy now */
985 sv_setpvn(ST(0), value.data, value.size);
4633a7c4 986 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
f6b705ef
PP
987 if (RETVAL != 0)
988 sv_setsv(ST(0), &sv_undef);
a0d0e21e
LW
989 }
990 }
991
992I32
993shift(db)
994 DB_File db
995 CODE:
996 {
a0d0e21e 997 DBT value ;
f6b705ef 998 DBTKEY key ;
4633a7c4 999 DB * Db = db->dbp ;
a0d0e21e 1000
8e07c86e 1001 CurrentDB = db ;
a0d0e21e 1002 /* get the first value */
f6b705ef 1003 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
a0d0e21e
LW
1004 ST(0) = sv_newmortal();
1005 /* Now delete it */
1006 if (RETVAL == 0)
1007 {
f6b705ef
PP
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) ;
a0d0e21e
LW
1013 }
1014 }
1015
1016
1017I32
1018push(db, ...)
1019 DB_File db
1020 CODE:
1021 {
1022 DBTKEY key ;
8e07c86e 1023 DBTKEY * keyptr = &key ;
a0d0e21e 1024 DBT value ;
4633a7c4 1025 DB * Db = db->dbp ;
a0d0e21e
LW
1026 int i ;
1027
8e07c86e 1028 CurrentDB = db ;
a0d0e21e 1029 /* Set the Cursor to the Last element */
4633a7c4 1030 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
8e07c86e 1031 if (RETVAL >= 0)
a0d0e21e 1032 {
8e07c86e
AD
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 ;
4633a7c4 1039 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
8e07c86e
AD
1040 if (RETVAL != 0)
1041 break;
1042 }
a0d0e21e
LW
1043 }
1044 }
1045 OUTPUT:
1046 RETVAL
1047
1048
1049I32
1050length(db)
1051 DB_File db
1052 CODE:
8e07c86e
AD
1053 CurrentDB = db ;
1054 RETVAL = GetArrayLength(db->dbp) ;
a0d0e21e
LW
1055 OUTPUT:
1056 RETVAL
1057
1058
1059#
1060# Now provide an interface to the rest of the DB functionality
1061#
1062
1063int
1064db_del(db, key, flags=0)
1065 DB_File db
1066 DBTKEY key
1067 u_int flags
8e07c86e
AD
1068 INIT:
1069 CurrentDB = db ;
a0d0e21e
LW
1070
1071
1072int
1073db_get(db, key, value, flags=0)
1074 DB_File db
1075 DBTKEY key
a6ed719b 1076 DBT value = NO_INIT
a0d0e21e 1077 u_int flags
8e07c86e
AD
1078 INIT:
1079 CurrentDB = db ;
a0d0e21e
LW
1080 OUTPUT:
1081 value
1082
1083int
1084db_put(db, key, value, flags=0)
1085 DB_File db
1086 DBTKEY key
1087 DBT value
1088 u_int flags
8e07c86e
AD
1089 INIT:
1090 CurrentDB = db ;
a0d0e21e
LW
1091 OUTPUT:
1092 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1093
1094int
1095db_fd(db)
1096 DB_File db
8e07c86e
AD
1097 INIT:
1098 CurrentDB = db ;
a0d0e21e
LW
1099
1100int
1101db_sync(db, flags=0)
1102 DB_File db
1103 u_int flags
8e07c86e
AD
1104 INIT:
1105 CurrentDB = db ;
a0d0e21e
LW
1106
1107
1108int
1109db_seq(db, key, value, flags)
1110 DB_File db
1111 DBTKEY key
a6ed719b 1112 DBT value = NO_INIT
a0d0e21e 1113 u_int flags
8e07c86e
AD
1114 INIT:
1115 CurrentDB = db ;
a0d0e21e
LW
1116 OUTPUT:
1117 key
1118 value
610ab055 1119