This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate cfgperl contents into mainline, update Changes
[perl5.git] / ext / DB_File / DB_File.xs
CommitLineData
a0d0e21e
LW
1/*
2
3 DB_File.xs -- Perl 5 interface to Berkeley DB
4
6ca2e664 5 written by Paul Marquess <Paul.Marquess@btinternet.com>
e07e3419
PM
6 last modified 4th August 1999
7 version 1.70
a0d0e21e
LW
8
9 All comments/suggestions/problems are welcome
10
20896112 11 Copyright (c) 1995-9 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
1f70e1ea
PM
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.50 - Make work with both DB 1.x or DB 2.x
46 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
47 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
a6ed719b 48 undefined value" warning with db_get and db_seq.
1f70e1ea
PM
49 1.53 - Added DB_RENUMBER to flags for recno.
50 1.54 - Fixed bug in the fd method
51 1.55 - Fix for AIX from Jarkko Hietaniemi
52 1.56 - No change to DB_File.xs
045291aa
PM
53 1.57 - added the #undef op to allow building with Threads support.
54 1.58 - Fixed a problem with the use of sv_setpvn. When the
55 size is specified as 0, it does a strlen on the data.
56 This was ok for DB 1.x, but isn't for DB 2.x.
a9fd575d
PM
57 1.59 - No change to DB_File.xs
58 1.60 - Some code tidy up
9d9477b1
PM
59 1.61 - added flagSet macro for DB 2.5.x
60 fixed typo in O_RDONLY test.
6ca2e664
PM
61 1.62 - No change to DB_File.xs
62 1.63 - Fix to alllow DB 2.6.x to build.
20896112
PM
63 1.64 - Tidied up the 1.x to 2.x flags mapping code.
64 Added a patch from Mark Kettenis <kettenis@wins.uva.nl>
65 to fix a flag mapping problem with O_RDONLY on the Hurd
ca63f0d2
GS
66 1.65 - Fixed a bug in the PUSH logic.
67 Added BOOT check that using 2.3.4 or greater
9fe6733a 68 1.66 - Added DBM filter code
cad2e5aa
JH
69 1.67 - Backed off the use of newSVpvn.
70 Fixed DBM Filter code for Perl 5.004.
71 Fixed a small memory leak in the filter code.
2c2d71f5
JH
72 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE
73 merged in the 5.005_58 changes
a62982a8
PM
74 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly.
75 Fixed the R_SETCURSOR bug introduced in 1.68
76 Added a new Perl variable $DB_File::db_ver
e07e3419
PM
77 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with
78 GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons.
79 Added a BOOT check to test for equivalent versions of db.h &
80 libdb.a/so.
f6b705ef 81
a0d0e21e
LW
82*/
83
84#include "EXTERN.h"
85#include "perl.h"
86#include "XSUB.h"
87
cceca5ed 88#ifndef PERL_VERSION
2c2d71f5
JH
89# include "patchlevel.h"
90# define PERL_REVISION 5
91# define PERL_VERSION PATCHLEVEL
92# define PERL_SUBVERSION SUBVERSION
20896112
PM
93#endif
94
95#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 ))
96
97# define PL_sv_undef sv_undef
98# define PL_na na
99
cceca5ed
GS
100#endif
101
cad2e5aa
JH
102/* DEFSV appears first in 5.004_56 */
103#ifndef DEFSV
2c2d71f5 104# define DEFSV GvSV(defgv)
cad2e5aa
JH
105#endif
106
52e1cb5e
JH
107/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
108 * shortly #included by the <db.h>) __attribute__ to the possibly
109 * already defined __attribute__, for example by GNUC or by Perl. */
1f70e1ea 110
52e1cb5e
JH
111#undef __attribute__
112
045291aa
PM
113/* If Perl has been compiled with Threads support,the symbol op will
114 be defined here. This clashes with a field name in db.h, so get rid of it.
115 */
116#ifdef op
2c2d71f5 117# undef op
045291aa 118#endif
a0d0e21e
LW
119#include <db.h>
120
2c2d71f5
JH
121#ifndef pTHX
122# define pTHX
123# define pTHX_
124# define aTHX
125# define aTHX_
126#endif
127
128#ifndef newSVpvn
129# define newSVpvn(a,b) newSVpv(a,b)
130#endif
131
a0d0e21e
LW
132#include <fcntl.h>
133
1f70e1ea 134/* #define TRACE */
9fe6733a 135#define DBM_FILTERING
1f70e1ea
PM
136
137
138
139#ifdef DB_VERSION_MAJOR
140
141/* map version 2 features & constants onto their version 1 equivalent */
142
143#ifdef DB_Prefix_t
2c2d71f5 144# undef DB_Prefix_t
1f70e1ea
PM
145#endif
146#define DB_Prefix_t size_t
147
148#ifdef DB_Hash_t
2c2d71f5 149# undef DB_Hash_t
1f70e1ea
PM
150#endif
151#define DB_Hash_t u_int32_t
152
153/* DBTYPE stays the same */
154/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */
155typedef DB_INFO INFO ;
156
157/* version 2 has db_recno_t in place of recno_t */
158typedef db_recno_t recno_t;
159
160
161#define R_CURSOR DB_SET_RANGE
162#define R_FIRST DB_FIRST
163#define R_IAFTER DB_AFTER
164#define R_IBEFORE DB_BEFORE
165#define R_LAST DB_LAST
166#define R_NEXT DB_NEXT
167#define R_NOOVERWRITE DB_NOOVERWRITE
168#define R_PREV DB_PREV
a62982a8
PM
169#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
170#define R_SETCURSOR 0x800000
171#else
172#define R_SETCURSOR (-100)
173#endif
1f70e1ea
PM
174#define R_RECNOSYNC 0
175#define R_FIXEDLEN DB_FIXEDLEN
176#define R_DUP DB_DUP
177
178#define db_HA_hash h_hash
179#define db_HA_ffactor h_ffactor
180#define db_HA_nelem h_nelem
181#define db_HA_bsize db_pagesize
182#define db_HA_cachesize db_cachesize
183#define db_HA_lorder db_lorder
184
185#define db_BT_compare bt_compare
186#define db_BT_prefix bt_prefix
187#define db_BT_flags flags
188#define db_BT_psize db_pagesize
189#define db_BT_cachesize db_cachesize
190#define db_BT_lorder db_lorder
191#define db_BT_maxkeypage
192#define db_BT_minkeypage
193
194
195#define db_RE_reclen re_len
196#define db_RE_flags flags
197#define db_RE_bval re_pad
198#define db_RE_bfname re_source
199#define db_RE_psize db_pagesize
200#define db_RE_cachesize db_cachesize
201#define db_RE_lorder db_lorder
202
203#define TXN NULL,
204
205#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag)
206
207
208#define DBT_flags(x) x.flags = 0
209#define DB_flags(x, v) x |= v
210
9d9477b1
PM
211#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
212#define flagSet(flags, bitmask) ((flags) & (bitmask))
213#else
214#define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask))
215#endif
216
1f70e1ea
PM
217#else /* db version 1.x */
218
219typedef union INFO {
220 HASHINFO hash ;
221 RECNOINFO recno ;
222 BTREEINFO btree ;
223 } INFO ;
224
225
610ab055
PM
226#ifdef mDB_Prefix_t
227#ifdef DB_Prefix_t
228#undef DB_Prefix_t
229#endif
230#define DB_Prefix_t mDB_Prefix_t
231#endif
232
233#ifdef mDB_Hash_t
234#ifdef DB_Hash_t
235#undef DB_Hash_t
236#endif
237#define DB_Hash_t mDB_Hash_t
238#endif
239
1f70e1ea
PM
240#define db_HA_hash hash.hash
241#define db_HA_ffactor hash.ffactor
242#define db_HA_nelem hash.nelem
243#define db_HA_bsize hash.bsize
244#define db_HA_cachesize hash.cachesize
245#define db_HA_lorder hash.lorder
246
247#define db_BT_compare btree.compare
248#define db_BT_prefix btree.prefix
249#define db_BT_flags btree.flags
250#define db_BT_psize btree.psize
251#define db_BT_cachesize btree.cachesize
252#define db_BT_lorder btree.lorder
253#define db_BT_maxkeypage btree.maxkeypage
254#define db_BT_minkeypage btree.minkeypage
255
256#define db_RE_reclen recno.reclen
257#define db_RE_flags recno.flags
258#define db_RE_bval recno.bval
259#define db_RE_bfname recno.bfname
260#define db_RE_psize recno.psize
261#define db_RE_cachesize recno.cachesize
262#define db_RE_lorder recno.lorder
263
264#define TXN
265
266#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
267#define DBT_flags(x)
268#define DB_flags(x, v)
9d9477b1 269#define flagSet(flags, bitmask) ((flags) & (bitmask))
1f70e1ea
PM
270
271#endif /* db version 1 */
272
273
274
275#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, flags)
276#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, flags)
277#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
278
279#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
280#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
9d9477b1 281
1f70e1ea 282#ifdef DB_VERSION_MAJOR
a62982a8
PM
283#define db_DESTROY(db) ( db->cursor->c_close(db->cursor),\
284 db->dbp->close(db->dbp, 0) )
1f70e1ea 285#define db_close(db) ((db->dbp)->close)(db->dbp, 0)
9d9477b1 286#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
1f70e1ea
PM
287 ? ((db->cursor)->c_del)(db->cursor, 0) \
288 : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
289
290#else
291
292#define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
293#define db_close(db) ((db->dbp)->close)(db->dbp)
294#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
295#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
296
297#endif
298
9d9477b1 299
1f70e1ea 300#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
610ab055 301
8e07c86e
AD
302typedef struct {
303 DBTYPE type ;
304 DB * dbp ;
305 SV * compare ;
306 SV * prefix ;
307 SV * hash ;
a0b8c8c1 308 int in_memory ;
1f70e1ea
PM
309 INFO info ;
310#ifdef DB_VERSION_MAJOR
311 DBC * cursor ;
312#endif
9fe6733a
PM
313#ifdef DBM_FILTERING
314 SV * filter_fetch_key ;
315 SV * filter_store_key ;
316 SV * filter_fetch_value ;
317 SV * filter_store_value ;
318 int filtering ;
319#endif /* DBM_FILTERING */
320
8e07c86e
AD
321 } DB_File_type;
322
323typedef DB_File_type * DB_File ;
a0d0e21e
LW
324typedef DBT DBTKEY ;
325
9fe6733a
PM
326#ifdef DBM_FILTERING
327
328#define ckFilter(arg,type,name) \
329 if (db->type) { \
330 SV * save_defsv ; \
331 /* printf("filtering %s\n", name) ;*/ \
332 if (db->filtering) \
333 croak("recursion detected in %s", name) ; \
334 db->filtering = TRUE ; \
9fe6733a
PM
335 save_defsv = newSVsv(DEFSV) ; \
336 sv_setsv(DEFSV, arg) ; \
337 PUSHMARK(sp) ; \
338 (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \
9fe6733a 339 sv_setsv(arg, DEFSV) ; \
cad2e5aa 340 sv_setsv(DEFSV, save_defsv) ; \
9fe6733a 341 SvREFCNT_dec(save_defsv) ; \
9fe6733a
PM
342 db->filtering = FALSE ; \
343 /*printf("end of filtering %s\n", name) ;*/ \
344 }
345
346#else
347
348#define ckFilter(arg,type, name)
349
350#endif /* DBM_FILTERING */
351
045291aa 352#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
a0d0e21e 353
9fe6733a
PM
354#define OutputValue(arg, name) \
355 { if (RETVAL == 0) { \
356 my_sv_setpvn(arg, name.data, name.size) ; \
357 ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
358 } \
88108326 359 }
a0d0e21e 360
9fe6733a
PM
361#define OutputKey(arg, name) \
362 { if (RETVAL == 0) \
363 { \
364 if (db->type != DB_RECNO) { \
365 my_sv_setpvn(arg, name.data, name.size); \
366 } \
367 else \
368 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
369 ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
370 } \
a0d0e21e
LW
371 }
372
045291aa 373
a0d0e21e 374/* Internal Global Data */
8e07c86e 375static recno_t Value ;
8e07c86e 376static recno_t zero = 0 ;
1f70e1ea
PM
377static DB_File CurrentDB ;
378static DBTKEY empty ;
379
380#ifdef DB_VERSION_MAJOR
381
382static int
2c2d71f5 383#ifdef CAN_PROTOTYPE
b76802f5 384db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
2c2d71f5
JH
385#else
386db_put(db, key, value, flags)
387DB_File db ;
388DBTKEY key ;
389DBT value ;
390u_int flags ;
391#endif
1f70e1ea
PM
392{
393 int status ;
394
2c2d71f5
JH
395 if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
396 DBC * temp_cursor ;
397 DBT l_key, l_value;
398
399#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
400 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
9d9477b1 401#else
2c2d71f5 402 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
9d9477b1 403#endif
2c2d71f5
JH
404 return (-1) ;
405
406 memset(&l_key, 0, sizeof(l_key));
407 l_key.data = key.data;
408 l_key.size = key.size;
409 memset(&l_value, 0, sizeof(l_value));
410 l_value.data = value.data;
411 l_value.size = value.size;
412
413 if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
414 (void)temp_cursor->c_close(temp_cursor);
415 return (-1);
416 }
417
418 status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
419 (void)temp_cursor->c_close(temp_cursor);
420
421 return (status) ;
422 }
423
424
425 if (flagSet(flags, R_CURSOR)) {
426 return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
427 }
9d9477b1 428
2c2d71f5
JH
429 if (flagSet(flags, R_SETCURSOR)) {
430 if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
431 return -1 ;
432 return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
433
1f70e1ea
PM
434 }
435
436 return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
437
438}
439
440#endif /* DB_VERSION_MAJOR */
441
442static void
b76802f5 443GetVersionInfo(pTHX)
1f70e1ea 444{
e07e3419
PM
445 SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ;
446 SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ;
1f70e1ea
PM
447#ifdef DB_VERSION_MAJOR
448 int Major, Minor, Patch ;
449
450 (void)db_version(&Major, &Minor, &Patch) ;
451
e07e3419
PM
452 /* Check that the versions of db.h and libdb.a are the same */
453 if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR
454 || Patch != DB_VERSION_PATCH)
455 croak("\nDB_File needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n",
456 DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH,
457 Major, Minor, Patch) ;
458
ca63f0d2
GS
459 /* check that libdb is recent enough -- we need 2.3.4 or greater */
460 if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4)))
461 croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n",
1f70e1ea
PM
462 Major, Minor, Patch) ;
463
cceca5ed 464#if PERL_VERSION > 3
a62982a8
PM
465 sv_setpvf(version_sv, "%d.%d", Major, Minor) ;
466 sv_setpvf(ver_sv, "%d.%03d%03d", Major, Minor, Patch) ;
1f70e1ea
PM
467#else
468 {
469 char buffer[40] ;
470 sprintf(buffer, "%d.%d", Major, Minor) ;
a62982a8
PM
471 sv_setpv(version_sv, buffer) ;
472 sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ;
1f70e1ea
PM
473 sv_setpv(ver_sv, buffer) ;
474 }
475#endif
476
477#else
a62982a8 478 sv_setiv(version_sv, 1) ;
1f70e1ea
PM
479 sv_setiv(ver_sv, 1) ;
480#endif
481
482}
a0d0e21e
LW
483
484
485static int
2c2d71f5 486#ifdef CAN_PROTOTYPE
b76802f5 487btree_compare(const DBT *key1, const DBT *key2)
2c2d71f5
JH
488#else
489btree_compare(key1, key2)
490const DBT * key1 ;
491const DBT * key2 ;
492#endif
a0d0e21e 493{
2c2d71f5 494#ifdef dTHX
b76802f5 495 dTHX;
2c2d71f5 496#endif
a0d0e21e
LW
497 dSP ;
498 void * data1, * data2 ;
499 int retval ;
500 int count ;
501
502 data1 = key1->data ;
503 data2 = key2->data ;
cad2e5aa 504
2c2d71f5 505#ifndef newSVpvn
a0d0e21e
LW
506 /* As newSVpv will assume that the data pointer is a null terminated C
507 string if the size parameter is 0, make sure that data points to an
508 empty string if the length is 0
509 */
510 if (key1->size == 0)
511 data1 = "" ;
512 if (key2->size == 0)
513 data2 = "" ;
2c2d71f5 514#endif
cad2e5aa 515
a0d0e21e
LW
516 ENTER ;
517 SAVETMPS;
518
924508f0
GS
519 PUSHMARK(SP) ;
520 EXTEND(SP,2) ;
2c2d71f5
JH
521 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
522 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
a0d0e21e
LW
523 PUTBACK ;
524
8e07c86e 525 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
a0d0e21e
LW
526
527 SPAGAIN ;
528
529 if (count != 1)
ff0cee69 530 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
a0d0e21e
LW
531
532 retval = POPi ;
533
534 PUTBACK ;
535 FREETMPS ;
536 LEAVE ;
537 return (retval) ;
538
539}
540
ecfc5424 541static DB_Prefix_t
2c2d71f5 542#ifdef CAN_PROTOTYPE
b76802f5 543btree_prefix(const DBT *key1, const DBT *key2)
2c2d71f5
JH
544#else
545btree_prefix(key1, key2)
546const DBT * key1 ;
547const DBT * key2 ;
548#endif
a0d0e21e 549{
2c2d71f5 550#ifdef dTHX
b76802f5 551 dTHX;
2c2d71f5 552#endif
a0d0e21e
LW
553 dSP ;
554 void * data1, * data2 ;
555 int retval ;
556 int count ;
557
558 data1 = key1->data ;
559 data2 = key2->data ;
cad2e5aa 560
2c2d71f5 561#ifndef newSVpvn
a0d0e21e
LW
562 /* As newSVpv will assume that the data pointer is a null terminated C
563 string if the size parameter is 0, make sure that data points to an
564 empty string if the length is 0
565 */
566 if (key1->size == 0)
567 data1 = "" ;
568 if (key2->size == 0)
569 data2 = "" ;
2c2d71f5 570#endif
cad2e5aa 571
a0d0e21e
LW
572 ENTER ;
573 SAVETMPS;
574
924508f0
GS
575 PUSHMARK(SP) ;
576 EXTEND(SP,2) ;
2c2d71f5
JH
577 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
578 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
a0d0e21e
LW
579 PUTBACK ;
580
8e07c86e 581 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
a0d0e21e
LW
582
583 SPAGAIN ;
584
585 if (count != 1)
ff0cee69 586 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
a0d0e21e
LW
587
588 retval = POPi ;
589
590 PUTBACK ;
591 FREETMPS ;
592 LEAVE ;
593
594 return (retval) ;
595}
596
ecfc5424 597static DB_Hash_t
2c2d71f5 598#ifdef CAN_PROTOTYPE
b76802f5 599hash_cb(const void *data, size_t size)
2c2d71f5
JH
600#else
601hash_cb(data, size)
602const void * data ;
603size_t size ;
604#endif
a0d0e21e 605{
2c2d71f5 606#ifdef dTHX
b76802f5 607 dTHX;
2c2d71f5 608#endif
a0d0e21e
LW
609 dSP ;
610 int retval ;
611 int count ;
cad2e5aa 612
2c2d71f5 613#ifndef newSVpvn
a0d0e21e
LW
614 if (size == 0)
615 data = "" ;
2c2d71f5 616#endif
cad2e5aa 617
610ab055
PM
618 /* DGH - Next two lines added to fix corrupted stack problem */
619 ENTER ;
620 SAVETMPS;
621
924508f0 622 PUSHMARK(SP) ;
610ab055 623
2c2d71f5 624 XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
a0d0e21e
LW
625 PUTBACK ;
626
8e07c86e 627 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
a0d0e21e
LW
628
629 SPAGAIN ;
630
631 if (count != 1)
ff0cee69 632 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
a0d0e21e
LW
633
634 retval = POPi ;
635
636 PUTBACK ;
637 FREETMPS ;
638 LEAVE ;
639
640 return (retval) ;
641}
642
643
644#ifdef TRACE
645
646static void
2c2d71f5 647#ifdef CAN_PROTOTYPE
b76802f5 648PrintHash(INFO *hash)
2c2d71f5
JH
649#else
650PrintHash(hash)
651INFO * hash ;
652#endif
a0d0e21e
LW
653{
654 printf ("HASH Info\n") ;
1f70e1ea
PM
655 printf (" hash = %s\n",
656 (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
657 printf (" bsize = %d\n", hash->db_HA_bsize) ;
658 printf (" ffactor = %d\n", hash->db_HA_ffactor) ;
659 printf (" nelem = %d\n", hash->db_HA_nelem) ;
660 printf (" cachesize = %d\n", hash->db_HA_cachesize) ;
661 printf (" lorder = %d\n", hash->db_HA_lorder) ;
a0d0e21e
LW
662
663}
664
665static void
2c2d71f5 666#ifdef CAN_PROTOTYPE
b76802f5 667PrintRecno(INFO *recno)
2c2d71f5
JH
668#else
669PrintRecno(recno)
670INFO * recno ;
671#endif
a0d0e21e
LW
672{
673 printf ("RECNO Info\n") ;
1f70e1ea
PM
674 printf (" flags = %d\n", recno->db_RE_flags) ;
675 printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
676 printf (" psize = %d\n", recno->db_RE_psize) ;
677 printf (" lorder = %d\n", recno->db_RE_lorder) ;
678 printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ;
679 printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
680 printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
a0d0e21e
LW
681}
682
ff68c719 683static void
2c2d71f5 684#ifdef CAN_PROTOTYPE
b76802f5 685PrintBtree(INFO *btree)
2c2d71f5
JH
686#else
687PrintBtree(btree)
688INFO * btree ;
689#endif
a0d0e21e
LW
690{
691 printf ("BTREE Info\n") ;
1f70e1ea
PM
692 printf (" compare = %s\n",
693 (btree->db_BT_compare ? "redefined" : "default")) ;
694 printf (" prefix = %s\n",
695 (btree->db_BT_prefix ? "redefined" : "default")) ;
696 printf (" flags = %d\n", btree->db_BT_flags) ;
697 printf (" cachesize = %d\n", btree->db_BT_cachesize) ;
698 printf (" psize = %d\n", btree->db_BT_psize) ;
699#ifndef DB_VERSION_MAJOR
700 printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
701 printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ;
702#endif
703 printf (" lorder = %d\n", btree->db_BT_lorder) ;
a0d0e21e
LW
704}
705
706#else
707
708#define PrintRecno(recno)
709#define PrintHash(hash)
710#define PrintBtree(btree)
711
712#endif /* TRACE */
713
714
715static I32
2c2d71f5 716#ifdef CAN_PROTOTYPE
b76802f5 717GetArrayLength(pTHX_ DB_File db)
2c2d71f5
JH
718#else
719GetArrayLength(db)
720DB_File db ;
721#endif
a0d0e21e
LW
722{
723 DBT key ;
724 DBT value ;
725 int RETVAL ;
726
1f70e1ea
PM
727 DBT_flags(key) ;
728 DBT_flags(value) ;
729 RETVAL = do_SEQ(db, key, value, R_LAST) ;
a0d0e21e
LW
730 if (RETVAL == 0)
731 RETVAL = *(I32 *)key.data ;
1f70e1ea 732 else /* No key means empty file */
a0d0e21e
LW
733 RETVAL = 0 ;
734
a0b8c8c1 735 return ((I32)RETVAL) ;
a0d0e21e
LW
736}
737
88108326 738static recno_t
2c2d71f5 739#ifdef CAN_PROTOTYPE
b76802f5 740GetRecnoKey(pTHX_ DB_File db, I32 value)
2c2d71f5
JH
741#else
742GetRecnoKey(db, value)
743DB_File db ;
744I32 value ;
745#endif
88108326
PP
746{
747 if (value < 0) {
748 /* Get the length of the array */
b76802f5 749 I32 length = GetArrayLength(aTHX_ db) ;
88108326
PP
750
751 /* check for attempt to write before start of array */
752 if (length + value + 1 <= 0)
ff0cee69 753 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
88108326
PP
754
755 value = length + value + 1 ;
756 }
757 else
758 ++ value ;
759
760 return value ;
a0d0e21e
LW
761}
762
763static DB_File
2c2d71f5 764#ifdef CAN_PROTOTYPE
b76802f5 765ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
2c2d71f5
JH
766#else
767ParseOpenInfo(isHASH, name, flags, mode, sv)
768int isHASH ;
769char * name ;
770int flags ;
771int mode ;
772SV * sv ;
773#endif
a0d0e21e
LW
774{
775 SV ** svp;
776 HV * action ;
045291aa 777 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
a0d0e21e 778 void * openinfo = NULL ;
045291aa 779 INFO * info = &RETVAL->info ;
2d8e6c8d 780 STRLEN n_a;
1f70e1ea
PM
781
782/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
045291aa 783 Zero(RETVAL, 1, DB_File_type) ;
a0d0e21e 784
88108326 785 /* Default to HASH */
9fe6733a
PM
786#ifdef DBM_FILTERING
787 RETVAL->filtering = 0 ;
788 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
789 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
790#endif /* DBM_FILTERING */
8e07c86e
AD
791 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
792 RETVAL->type = DB_HASH ;
a0d0e21e 793
610ab055
PM
794 /* DGH - Next line added to avoid SEGV on existing hash DB */
795 CurrentDB = RETVAL;
796
a0b8c8c1
PM
797 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
798 RETVAL->in_memory = (name == NULL) ;
799
a0d0e21e
LW
800 if (sv)
801 {
802 if (! SvROK(sv) )
803 croak ("type parameter is not a reference") ;
804
36477c24
PP
805 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
806 if (svp && SvOK(*svp))
807 action = (HV*) SvRV(*svp) ;
808 else
809 croak("internal error") ;
610ab055 810
a0d0e21e
LW
811 if (sv_isa(sv, "DB_File::HASHINFO"))
812 {
05475680
PM
813
814 if (!isHASH)
815 croak("DB_File can only tie an associative array to a DB_HASH database") ;
816
8e07c86e 817 RETVAL->type = DB_HASH ;
610ab055 818 openinfo = (void*)info ;
a0d0e21e
LW
819
820 svp = hv_fetch(action, "hash", 4, FALSE);
821
822 if (svp && SvOK(*svp))
823 {
1f70e1ea 824 info->db_HA_hash = hash_cb ;
8e07c86e 825 RETVAL->hash = newSVsv(*svp) ;
a0d0e21e
LW
826 }
827 else
1f70e1ea 828 info->db_HA_hash = NULL ;
a0d0e21e 829
a0d0e21e 830 svp = hv_fetch(action, "ffactor", 7, FALSE);
1f70e1ea 831 info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
832
833 svp = hv_fetch(action, "nelem", 5, FALSE);
1f70e1ea 834 info->db_HA_nelem = svp ? SvIV(*svp) : 0;
a0d0e21e 835
1f70e1ea
PM
836 svp = hv_fetch(action, "bsize", 5, FALSE);
837 info->db_HA_bsize = svp ? SvIV(*svp) : 0;
838
a0d0e21e 839 svp = hv_fetch(action, "cachesize", 9, FALSE);
1f70e1ea 840 info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
841
842 svp = hv_fetch(action, "lorder", 6, FALSE);
1f70e1ea 843 info->db_HA_lorder = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
844
845 PrintHash(info) ;
846 }
847 else if (sv_isa(sv, "DB_File::BTREEINFO"))
848 {
05475680
PM
849 if (!isHASH)
850 croak("DB_File can only tie an associative array to a DB_BTREE database");
851
8e07c86e 852 RETVAL->type = DB_BTREE ;
610ab055 853 openinfo = (void*)info ;
a0d0e21e
LW
854
855 svp = hv_fetch(action, "compare", 7, FALSE);
856 if (svp && SvOK(*svp))
857 {
1f70e1ea 858 info->db_BT_compare = btree_compare ;
8e07c86e 859 RETVAL->compare = newSVsv(*svp) ;
a0d0e21e
LW
860 }
861 else
1f70e1ea 862 info->db_BT_compare = NULL ;
a0d0e21e
LW
863
864 svp = hv_fetch(action, "prefix", 6, FALSE);
865 if (svp && SvOK(*svp))
866 {
1f70e1ea 867 info->db_BT_prefix = btree_prefix ;
8e07c86e 868 RETVAL->prefix = newSVsv(*svp) ;
a0d0e21e
LW
869 }
870 else
1f70e1ea 871 info->db_BT_prefix = NULL ;
a0d0e21e
LW
872
873 svp = hv_fetch(action, "flags", 5, FALSE);
1f70e1ea 874 info->db_BT_flags = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
875
876 svp = hv_fetch(action, "cachesize", 9, FALSE);
1f70e1ea 877 info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
a0d0e21e 878
1f70e1ea 879#ifndef DB_VERSION_MAJOR
a0d0e21e 880 svp = hv_fetch(action, "minkeypage", 10, FALSE);
610ab055 881 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
882
883 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
610ab055 884 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
1f70e1ea 885#endif
a0d0e21e
LW
886
887 svp = hv_fetch(action, "psize", 5, FALSE);
1f70e1ea 888 info->db_BT_psize = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
889
890 svp = hv_fetch(action, "lorder", 6, FALSE);
1f70e1ea 891 info->db_BT_lorder = svp ? SvIV(*svp) : 0;
a0d0e21e
LW
892
893 PrintBtree(info) ;
894
895 }
896 else if (sv_isa(sv, "DB_File::RECNOINFO"))
897 {
05475680
PM
898 if (isHASH)
899 croak("DB_File can only tie an array to a DB_RECNO database");
900
8e07c86e 901 RETVAL->type = DB_RECNO ;
610ab055 902 openinfo = (void *)info ;
a0d0e21e 903
1f70e1ea
PM
904 info->db_RE_flags = 0 ;
905
a0d0e21e 906 svp = hv_fetch(action, "flags", 5, FALSE);
1f70e1ea
PM
907 info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
908
909 svp = hv_fetch(action, "reclen", 6, FALSE);
910 info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
a0d0e21e
LW
911
912 svp = hv_fetch(action, "cachesize", 9, FALSE);
1f70e1ea 913 info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
a0d0e21e
LW
914
915 svp = hv_fetch(action, "psize", 5, FALSE);
1f70e1ea 916 info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
a0d0e21e
LW
917
918 svp = hv_fetch(action, "lorder", 6, FALSE);
1f70e1ea
PM
919 info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
920
921#ifdef DB_VERSION_MAJOR
922 info->re_source = name ;
923 name = NULL ;
924#endif
925 svp = hv_fetch(action, "bfname", 6, FALSE);
926 if (svp && SvOK(*svp)) {
2d8e6c8d 927 char * ptr = SvPV(*svp,n_a) ;
1f70e1ea 928#ifdef DB_VERSION_MAJOR
2d8e6c8d 929 name = (char*) n_a ? ptr : NULL ;
1f70e1ea 930#else
2d8e6c8d 931 info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
1f70e1ea
PM
932#endif
933 }
934 else
935#ifdef DB_VERSION_MAJOR
936 name = NULL ;
937#else
938 info->db_RE_bfname = NULL ;
939#endif
a0d0e21e
LW
940
941 svp = hv_fetch(action, "bval", 4, FALSE);
1f70e1ea 942#ifdef DB_VERSION_MAJOR
a0d0e21e
LW
943 if (svp && SvOK(*svp))
944 {
1f70e1ea 945 int value ;
a0d0e21e 946 if (SvPOK(*svp))
2d8e6c8d 947 value = (int)*SvPV(*svp, n_a) ;
a0d0e21e 948 else
1f70e1ea
PM
949 value = SvIV(*svp) ;
950
951 if (info->flags & DB_FIXEDLEN) {
952 info->re_pad = value ;
953 info->flags |= DB_PAD ;
954 }
955 else {
956 info->re_delim = value ;
957 info->flags |= DB_DELIMITER ;
958 }
959
960 }
961#else
962 if (svp && SvOK(*svp))
963 {
964 if (SvPOK(*svp))
2d8e6c8d 965 info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
1f70e1ea
PM
966 else
967 info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
968 DB_flags(info->flags, DB_DELIMITER) ;
969
a0d0e21e
LW
970 }
971 else
972 {
1f70e1ea
PM
973 if (info->db_RE_flags & R_FIXEDLEN)
974 info->db_RE_bval = (u_char) ' ' ;
a0d0e21e 975 else
1f70e1ea
PM
976 info->db_RE_bval = (u_char) '\n' ;
977 DB_flags(info->flags, DB_DELIMITER) ;
a0d0e21e 978 }
1f70e1ea 979#endif
a0d0e21e 980
1f70e1ea
PM
981#ifdef DB_RENUMBER
982 info->flags |= DB_RENUMBER ;
983#endif
984
a0d0e21e
LW
985 PrintRecno(info) ;
986 }
987 else
988 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
989 }
990
991
88108326
PP
992 /* OS2 Specific Code */
993#ifdef OS2
994#ifdef __EMX__
995 flags |= O_BINARY;
996#endif /* __EMX__ */
997#endif /* OS2 */
a0d0e21e 998
1f70e1ea
PM
999#ifdef DB_VERSION_MAJOR
1000
1001 {
1002 int Flags = 0 ;
1003 int status ;
1004
1005 /* Map 1.x flags to 2.x flags */
1006 if ((flags & O_CREAT) == O_CREAT)
1007 Flags |= DB_CREATE ;
1008
1f70e1ea
PM
1009#if O_RDONLY == 0
1010 if (flags == O_RDONLY)
1011#else
20896112 1012 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1f70e1ea
PM
1013#endif
1014 Flags |= DB_RDONLY ;
1015
20896112 1016#ifdef O_TRUNC
1f70e1ea
PM
1017 if ((flags & O_TRUNC) == O_TRUNC)
1018 Flags |= DB_TRUNCATE ;
1019#endif
1020
1021 status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
1022 if (status == 0)
6ca2e664 1023#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
1f70e1ea 1024 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
6ca2e664
PM
1025#else
1026 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1027 0) ;
1028#endif
1f70e1ea
PM
1029
1030 if (status)
1031 RETVAL->dbp = NULL ;
1032
1033 }
1034#else
88108326 1035 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
1f70e1ea 1036#endif
a0d0e21e
LW
1037
1038 return (RETVAL) ;
1039}
1040
1041
a0d0e21e 1042static double
2c2d71f5 1043#ifdef CAN_PROTOTYPE
b76802f5 1044constant(char *name, int arg)
2c2d71f5
JH
1045#else
1046constant(name, arg)
1047char *name;
1048int arg;
1049#endif
a0d0e21e
LW
1050{
1051 errno = 0;
1052 switch (*name) {
1053 case 'A':
1054 break;
1055 case 'B':
1056 if (strEQ(name, "BTREEMAGIC"))
1057#ifdef BTREEMAGIC
1058 return BTREEMAGIC;
1059#else
1060 goto not_there;
1061#endif
1062 if (strEQ(name, "BTREEVERSION"))
1063#ifdef BTREEVERSION
1064 return BTREEVERSION;
1065#else
1066 goto not_there;
1067#endif
1068 break;
1069 case 'C':
1070 break;
1071 case 'D':
1072 if (strEQ(name, "DB_LOCK"))
1073#ifdef DB_LOCK
1074 return DB_LOCK;
1075#else
1076 goto not_there;
1077#endif
1078 if (strEQ(name, "DB_SHMEM"))
1079#ifdef DB_SHMEM
1080 return DB_SHMEM;
1081#else
1082 goto not_there;
1083#endif
1084 if (strEQ(name, "DB_TXN"))
1085#ifdef DB_TXN
1086 return (U32)DB_TXN;
1087#else
1088 goto not_there;
1089#endif
1090 break;
1091 case 'E':
1092 break;
1093 case 'F':
1094 break;
1095 case 'G':
1096 break;
1097 case 'H':
1098 if (strEQ(name, "HASHMAGIC"))
1099#ifdef HASHMAGIC
1100 return HASHMAGIC;
1101#else
1102 goto not_there;
1103#endif
1104 if (strEQ(name, "HASHVERSION"))
1105#ifdef HASHVERSION
1106 return HASHVERSION;
1107#else
1108 goto not_there;
1109#endif
1110 break;
1111 case 'I':
1112 break;
1113 case 'J':
1114 break;
1115 case 'K':
1116 break;
1117 case 'L':
1118 break;
1119 case 'M':
1120 if (strEQ(name, "MAX_PAGE_NUMBER"))
1121#ifdef MAX_PAGE_NUMBER
1122 return (U32)MAX_PAGE_NUMBER;
1123#else
1124 goto not_there;
1125#endif
1126 if (strEQ(name, "MAX_PAGE_OFFSET"))
1127#ifdef MAX_PAGE_OFFSET
1128 return MAX_PAGE_OFFSET;
1129#else
1130 goto not_there;
1131#endif
1132 if (strEQ(name, "MAX_REC_NUMBER"))
1133#ifdef MAX_REC_NUMBER
1134 return (U32)MAX_REC_NUMBER;
1135#else
1136 goto not_there;
1137#endif
1138 break;
1139 case 'N':
1140 break;
1141 case 'O':
1142 break;
1143 case 'P':
1144 break;
1145 case 'Q':
1146 break;
1147 case 'R':
1148 if (strEQ(name, "RET_ERROR"))
1149#ifdef RET_ERROR
1150 return RET_ERROR;
1151#else
1152 goto not_there;
1153#endif
1154 if (strEQ(name, "RET_SPECIAL"))
1155#ifdef RET_SPECIAL
1156 return RET_SPECIAL;
1157#else
1158 goto not_there;
1159#endif
1160 if (strEQ(name, "RET_SUCCESS"))
1161#ifdef RET_SUCCESS
1162 return RET_SUCCESS;
1163#else
1164 goto not_there;
1165#endif
1166 if (strEQ(name, "R_CURSOR"))
1167#ifdef R_CURSOR
1168 return R_CURSOR;
1169#else
1170 goto not_there;
1171#endif
1172 if (strEQ(name, "R_DUP"))
1173#ifdef R_DUP
1174 return R_DUP;
1175#else
1176 goto not_there;
1177#endif
1178 if (strEQ(name, "R_FIRST"))
1179#ifdef R_FIRST
1180 return R_FIRST;
1181#else
1182 goto not_there;
1183#endif
1184 if (strEQ(name, "R_FIXEDLEN"))
1185#ifdef R_FIXEDLEN
1186 return R_FIXEDLEN;
1187#else
1188 goto not_there;
1189#endif
1190 if (strEQ(name, "R_IAFTER"))
1191#ifdef R_IAFTER
1192 return R_IAFTER;
1193#else
1194 goto not_there;
1195#endif
1196 if (strEQ(name, "R_IBEFORE"))
1197#ifdef R_IBEFORE
1198 return R_IBEFORE;
1199#else
1200 goto not_there;
1201#endif
1202 if (strEQ(name, "R_LAST"))
1203#ifdef R_LAST
1204 return R_LAST;
1205#else
1206 goto not_there;
1207#endif
1208 if (strEQ(name, "R_NEXT"))
1209#ifdef R_NEXT
1210 return R_NEXT;
1211#else
1212 goto not_there;
1213#endif
1214 if (strEQ(name, "R_NOKEY"))
1215#ifdef R_NOKEY
1216 return R_NOKEY;
1217#else
1218 goto not_there;
1219#endif
1220 if (strEQ(name, "R_NOOVERWRITE"))
1221#ifdef R_NOOVERWRITE
1222 return R_NOOVERWRITE;
1223#else
1224 goto not_there;
1225#endif
1226 if (strEQ(name, "R_PREV"))
1227#ifdef R_PREV
1228 return R_PREV;
1229#else
1230 goto not_there;
1231#endif
1232 if (strEQ(name, "R_RECNOSYNC"))
1233#ifdef R_RECNOSYNC
1234 return R_RECNOSYNC;
1235#else
1236 goto not_there;
1237#endif
1238 if (strEQ(name, "R_SETCURSOR"))
1239#ifdef R_SETCURSOR
1240 return R_SETCURSOR;
1241#else
1242 goto not_there;
1243#endif
1244 if (strEQ(name, "R_SNAPSHOT"))
1245#ifdef R_SNAPSHOT
1246 return R_SNAPSHOT;
1247#else
1248 goto not_there;
1249#endif
1250 break;
1251 case 'S':
1252 break;
1253 case 'T':
1254 break;
1255 case 'U':
1256 break;
1257 case 'V':
1258 break;
1259 case 'W':
1260 break;
1261 case 'X':
1262 break;
1263 case 'Y':
1264 break;
1265 case 'Z':
1266 break;
1267 case '_':
a0d0e21e
LW
1268 break;
1269 }
1270 errno = EINVAL;
1271 return 0;
1272
1273not_there:
1274 errno = ENOENT;
1275 return 0;
1276}
1277
1278MODULE = DB_File PACKAGE = DB_File PREFIX = db_
1279
1f70e1ea
PM
1280BOOT:
1281 {
b76802f5 1282 GetVersionInfo(aTHX) ;
1f70e1ea
PM
1283
1284 empty.data = &zero ;
1285 empty.size = sizeof(recno_t) ;
1286 DBT_flags(empty) ;
1287 }
1288
a0d0e21e
LW
1289double
1290constant(name,arg)
1291 char * name
1292 int arg
1293
1294
1295DB_File
05475680
PM
1296db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1297 int isHASH
a0d0e21e
LW
1298 char * dbtype
1299 int flags
1300 int mode
1301 CODE:
1302 {
1303 char * name = (char *) NULL ;
1304 SV * sv = (SV *) NULL ;
2d8e6c8d 1305 STRLEN n_a;
a0d0e21e 1306
05475680 1307 if (items >= 3 && SvOK(ST(2)))
2d8e6c8d 1308 name = (char*) SvPV(ST(2), n_a) ;
a0d0e21e 1309
05475680
PM
1310 if (items == 6)
1311 sv = ST(5) ;
a0d0e21e 1312
b76802f5 1313 RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
4633a7c4
LW
1314 if (RETVAL->dbp == NULL)
1315 RETVAL = NULL ;
a0d0e21e
LW
1316 }
1317 OUTPUT:
1318 RETVAL
1319
a0d0e21e
LW
1320int
1321db_DESTROY(db)
1322 DB_File db
8e07c86e
AD
1323 INIT:
1324 CurrentDB = db ;
1325 CLEANUP:
1326 if (db->hash)
1327 SvREFCNT_dec(db->hash) ;
1328 if (db->compare)
1329 SvREFCNT_dec(db->compare) ;
1330 if (db->prefix)
1331 SvREFCNT_dec(db->prefix) ;
9fe6733a
PM
1332#ifdef DBM_FILTERING
1333 if (db->filter_fetch_key)
1334 SvREFCNT_dec(db->filter_fetch_key) ;
1335 if (db->filter_store_key)
1336 SvREFCNT_dec(db->filter_store_key) ;
1337 if (db->filter_fetch_value)
1338 SvREFCNT_dec(db->filter_fetch_value) ;
1339 if (db->filter_store_value)
1340 SvREFCNT_dec(db->filter_store_value) ;
1341#endif /* DBM_FILTERING */
8e07c86e 1342 Safefree(db) ;
1f70e1ea
PM
1343#ifdef DB_VERSION_MAJOR
1344 if (RETVAL > 0)
1345 RETVAL = -1 ;
1346#endif
a0d0e21e
LW
1347
1348
1349int
1350db_DELETE(db, key, flags=0)
1351 DB_File db
1352 DBTKEY key
1353 u_int flags
8e07c86e
AD
1354 INIT:
1355 CurrentDB = db ;
a0d0e21e 1356
f6b705ef
PP
1357
1358int
1359db_EXISTS(db, key)
1360 DB_File db
1361 DBTKEY key
1362 CODE:
1363 {
1364 DBT value ;
1365
1f70e1ea 1366 DBT_flags(value) ;
f6b705ef 1367 CurrentDB = db ;
1f70e1ea 1368 RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
f6b705ef
PP
1369 }
1370 OUTPUT:
1371 RETVAL
1372
a0d0e21e
LW
1373int
1374db_FETCH(db, key, flags=0)
1375 DB_File db
1376 DBTKEY key
1377 u_int flags
1378 CODE:
1379 {
1f70e1ea 1380 DBT value ;
a0d0e21e 1381
1f70e1ea 1382 DBT_flags(value) ;
8e07c86e 1383 CurrentDB = db ;
1f70e1ea
PM
1384 /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */
1385 RETVAL = db_get(db, key, value, flags) ;
a0d0e21e 1386 ST(0) = sv_newmortal();
a9fd575d 1387 OutputValue(ST(0), value)
a0d0e21e
LW
1388 }
1389
1390int
1391db_STORE(db, key, value, flags=0)
1392 DB_File db
1393 DBTKEY key
1394 DBT value
1395 u_int flags
8e07c86e
AD
1396 INIT:
1397 CurrentDB = db ;
a0d0e21e
LW
1398
1399
1400int
1401db_FIRSTKEY(db)
1402 DB_File db
1403 CODE:
1404 {
1f70e1ea 1405 DBTKEY key ;
a0d0e21e
LW
1406 DBT value ;
1407
1f70e1ea
PM
1408 DBT_flags(key) ;
1409 DBT_flags(value) ;
8e07c86e 1410 CurrentDB = db ;
1f70e1ea 1411 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
a0d0e21e 1412 ST(0) = sv_newmortal();
a9fd575d 1413 OutputKey(ST(0), key) ;
a0d0e21e
LW
1414 }
1415
1416int
1417db_NEXTKEY(db, key)
1418 DB_File db
1419 DBTKEY key
1420 CODE:
1421 {
1422 DBT value ;
1423
1f70e1ea 1424 DBT_flags(value) ;
8e07c86e 1425 CurrentDB = db ;
1f70e1ea 1426 RETVAL = do_SEQ(db, key, value, R_NEXT) ;
a0d0e21e 1427 ST(0) = sv_newmortal();
a9fd575d 1428 OutputKey(ST(0), key) ;
a0d0e21e
LW
1429 }
1430
1431#
1432# These would be nice for RECNO
1433#
1434
1435int
1436unshift(db, ...)
1437 DB_File db
045291aa 1438 ALIAS: UNSHIFT = 1
a0d0e21e
LW
1439 CODE:
1440 {
1441 DBTKEY key ;
1442 DBT value ;
1443 int i ;
1444 int One ;
4633a7c4 1445 DB * Db = db->dbp ;
2d8e6c8d 1446 STRLEN n_a;
a0d0e21e 1447
1f70e1ea
PM
1448 DBT_flags(key) ;
1449 DBT_flags(value) ;
8e07c86e 1450 CurrentDB = db ;
1f70e1ea
PM
1451#ifdef DB_VERSION_MAJOR
1452 /* get the first value */
1453 RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
1454 RETVAL = 0 ;
1455#else
a0d0e21e 1456 RETVAL = -1 ;
1f70e1ea 1457#endif
a0d0e21e
LW
1458 for (i = items-1 ; i > 0 ; --i)
1459 {
2d8e6c8d
GS
1460 value.data = SvPV(ST(i), n_a) ;
1461 value.size = n_a ;
a0d0e21e
LW
1462 One = 1 ;
1463 key.data = &One ;
1464 key.size = sizeof(int) ;
1f70e1ea
PM
1465#ifdef DB_VERSION_MAJOR
1466 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1467#else
4633a7c4 1468 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
1f70e1ea 1469#endif
a0d0e21e
LW
1470 if (RETVAL != 0)
1471 break;
1472 }
1473 }
1474 OUTPUT:
1475 RETVAL
1476
1477I32
1478pop(db)
1479 DB_File db
045291aa 1480 ALIAS: POP = 1
a0d0e21e
LW
1481 CODE:
1482 {
1483 DBTKEY key ;
1484 DBT value ;
1485
1f70e1ea
PM
1486 DBT_flags(key) ;
1487 DBT_flags(value) ;
8e07c86e 1488 CurrentDB = db ;
1f70e1ea 1489
a0d0e21e 1490 /* First get the final value */
1f70e1ea 1491 RETVAL = do_SEQ(db, key, value, R_LAST) ;
a0d0e21e
LW
1492 ST(0) = sv_newmortal();
1493 /* Now delete it */
1494 if (RETVAL == 0)
1495 {
f6b705ef 1496 /* the call to del will trash value, so take a copy now */
a9fd575d 1497 OutputValue(ST(0), value) ;
1f70e1ea 1498 RETVAL = db_del(db, key, R_CURSOR) ;
f6b705ef 1499 if (RETVAL != 0)
6b88bc9c 1500 sv_setsv(ST(0), &PL_sv_undef);
a0d0e21e
LW
1501 }
1502 }
1503
1504I32
1505shift(db)
1506 DB_File db
045291aa 1507 ALIAS: SHIFT = 1
a0d0e21e
LW
1508 CODE:
1509 {
a0d0e21e 1510 DBT value ;
f6b705ef 1511 DBTKEY key ;
a0d0e21e 1512
1f70e1ea
PM
1513 DBT_flags(key) ;
1514 DBT_flags(value) ;
8e07c86e 1515 CurrentDB = db ;
a0d0e21e 1516 /* get the first value */
1f70e1ea 1517 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
a0d0e21e
LW
1518 ST(0) = sv_newmortal();
1519 /* Now delete it */
1520 if (RETVAL == 0)
1521 {
f6b705ef 1522 /* the call to del will trash value, so take a copy now */
a9fd575d 1523 OutputValue(ST(0), value) ;
1f70e1ea 1524 RETVAL = db_del(db, key, R_CURSOR) ;
f6b705ef 1525 if (RETVAL != 0)
6b88bc9c 1526 sv_setsv (ST(0), &PL_sv_undef) ;
a0d0e21e
LW
1527 }
1528 }
1529
1530
1531I32
1532push(db, ...)
1533 DB_File db
045291aa 1534 ALIAS: PUSH = 1
a0d0e21e
LW
1535 CODE:
1536 {
1537 DBTKEY key ;
1538 DBT value ;
4633a7c4 1539 DB * Db = db->dbp ;
a0d0e21e 1540 int i ;
2d8e6c8d 1541 STRLEN n_a;
a0d0e21e 1542
1f70e1ea
PM
1543 DBT_flags(key) ;
1544 DBT_flags(value) ;
8e07c86e 1545 CurrentDB = db ;
1f70e1ea 1546#ifdef DB_VERSION_MAJOR
a62982a8 1547 RETVAL = do_SEQ(db, key, value, DB_LAST) ;
ca63f0d2
GS
1548 RETVAL = 0 ;
1549 key = empty ;
1f70e1ea
PM
1550 for (i = 1 ; i < items ; ++i)
1551 {
2d8e6c8d
GS
1552 value.data = SvPV(ST(i), n_a) ;
1553 value.size = n_a ;
ca63f0d2 1554 RETVAL = (Db->put)(Db, NULL, &key, &value, DB_APPEND) ;
1f70e1ea
PM
1555 if (RETVAL != 0)
1556 break;
1557 }
9fe6733a
PM
1558#else
1559
ca63f0d2
GS
1560 /* Set the Cursor to the Last element */
1561 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1562 if (RETVAL >= 0)
1563 {
1564 if (RETVAL == 1)
1565 key = empty ;
8e07c86e
AD
1566 for (i = items - 1 ; i > 0 ; --i)
1567 {
2d8e6c8d
GS
1568 value.data = SvPV(ST(i), n_a) ;
1569 value.size = n_a ;
ca63f0d2 1570 RETVAL = (Db->put)(Db, &key, &value, R_IAFTER) ;
8e07c86e
AD
1571 if (RETVAL != 0)
1572 break;
1573 }
a0d0e21e 1574 }
ca63f0d2 1575#endif
a0d0e21e
LW
1576 }
1577 OUTPUT:
1578 RETVAL
1579
1580
1581I32
1582length(db)
1583 DB_File db
045291aa 1584 ALIAS: FETCHSIZE = 1
a0d0e21e 1585 CODE:
8e07c86e 1586 CurrentDB = db ;
b76802f5 1587 RETVAL = GetArrayLength(aTHX_ db) ;
a0d0e21e
LW
1588 OUTPUT:
1589 RETVAL
1590
1591
1592#
1593# Now provide an interface to the rest of the DB functionality
1594#
1595
1596int
1597db_del(db, key, flags=0)
1598 DB_File db
1599 DBTKEY key
1600 u_int flags
1f70e1ea 1601 CODE:
8e07c86e 1602 CurrentDB = db ;
1f70e1ea
PM
1603 RETVAL = db_del(db, key, flags) ;
1604#ifdef DB_VERSION_MAJOR
1605 if (RETVAL > 0)
1606 RETVAL = -1 ;
1607 else if (RETVAL == DB_NOTFOUND)
1608 RETVAL = 1 ;
1609#endif
1610 OUTPUT:
1611 RETVAL
a0d0e21e
LW
1612
1613
1614int
1615db_get(db, key, value, flags=0)
1616 DB_File db
1617 DBTKEY key
a6ed719b 1618 DBT value = NO_INIT
a0d0e21e 1619 u_int flags
1f70e1ea 1620 CODE:
8e07c86e 1621 CurrentDB = db ;
1f70e1ea
PM
1622 DBT_flags(value) ;
1623 RETVAL = db_get(db, key, value, flags) ;
1624#ifdef DB_VERSION_MAJOR
1625 if (RETVAL > 0)
1626 RETVAL = -1 ;
1627 else if (RETVAL == DB_NOTFOUND)
1628 RETVAL = 1 ;
1629#endif
a0d0e21e 1630 OUTPUT:
1f70e1ea 1631 RETVAL
a0d0e21e
LW
1632 value
1633
1634int
1635db_put(db, key, value, flags=0)
1636 DB_File db
1637 DBTKEY key
1638 DBT value
1639 u_int flags
1f70e1ea 1640 CODE:
8e07c86e 1641 CurrentDB = db ;
1f70e1ea
PM
1642 RETVAL = db_put(db, key, value, flags) ;
1643#ifdef DB_VERSION_MAJOR
1644 if (RETVAL > 0)
1645 RETVAL = -1 ;
1646 else if (RETVAL == DB_KEYEXIST)
1647 RETVAL = 1 ;
1648#endif
a0d0e21e 1649 OUTPUT:
1f70e1ea 1650 RETVAL
9d9477b1 1651 key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
a0d0e21e
LW
1652
1653int
1654db_fd(db)
1655 DB_File db
1f70e1ea
PM
1656 int status = 0 ;
1657 CODE:
8e07c86e 1658 CurrentDB = db ;
1f70e1ea
PM
1659#ifdef DB_VERSION_MAJOR
1660 RETVAL = -1 ;
1661 status = (db->in_memory
1662 ? -1
1663 : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1664 if (status != 0)
1665 RETVAL = -1 ;
1666#else
1667 RETVAL = (db->in_memory
1668 ? -1
1669 : ((db->dbp)->fd)(db->dbp) ) ;
1670#endif
1671 OUTPUT:
1672 RETVAL
a0d0e21e
LW
1673
1674int
1675db_sync(db, flags=0)
1676 DB_File db
1677 u_int flags
1f70e1ea 1678 CODE:
8e07c86e 1679 CurrentDB = db ;
1f70e1ea
PM
1680 RETVAL = db_sync(db, flags) ;
1681#ifdef DB_VERSION_MAJOR
1682 if (RETVAL > 0)
1683 RETVAL = -1 ;
1684#endif
1685 OUTPUT:
1686 RETVAL
a0d0e21e
LW
1687
1688
1689int
1690db_seq(db, key, value, flags)
1691 DB_File db
1692 DBTKEY key
a6ed719b 1693 DBT value = NO_INIT
a0d0e21e 1694 u_int flags
1f70e1ea 1695 CODE:
8e07c86e 1696 CurrentDB = db ;
1f70e1ea
PM
1697 DBT_flags(value) ;
1698 RETVAL = db_seq(db, key, value, flags);
1699#ifdef DB_VERSION_MAJOR
1700 if (RETVAL > 0)
1701 RETVAL = -1 ;
1702 else if (RETVAL == DB_NOTFOUND)
1703 RETVAL = 1 ;
1704#endif
a0d0e21e 1705 OUTPUT:
1f70e1ea 1706 RETVAL
a0d0e21e
LW
1707 key
1708 value
610ab055 1709
9fe6733a
PM
1710#ifdef DBM_FILTERING
1711
1712#define setFilter(type) \
1713 { \
1714 if (db->type) \
cad2e5aa
JH
1715 RETVAL = sv_mortalcopy(db->type) ; \
1716 ST(0) = RETVAL ; \
9fe6733a
PM
1717 if (db->type && (code == &PL_sv_undef)) { \
1718 SvREFCNT_dec(db->type) ; \
1719 db->type = NULL ; \
1720 } \
1721 else if (code) { \
1722 if (db->type) \
1723 sv_setsv(db->type, code) ; \
1724 else \
1725 db->type = newSVsv(code) ; \
1726 } \
1727 }
1728
1729
1730SV *
1731filter_fetch_key(db, code)
1732 DB_File db
1733 SV * code
1734 SV * RETVAL = &PL_sv_undef ;
1735 CODE:
1736 setFilter(filter_fetch_key) ;
9fe6733a
PM
1737
1738SV *
1739filter_store_key(db, code)
1740 DB_File db
1741 SV * code
1742 SV * RETVAL = &PL_sv_undef ;
1743 CODE:
1744 setFilter(filter_store_key) ;
9fe6733a
PM
1745
1746SV *
1747filter_fetch_value(db, code)
1748 DB_File db
1749 SV * code
1750 SV * RETVAL = &PL_sv_undef ;
1751 CODE:
1752 setFilter(filter_fetch_value) ;
9fe6733a
PM
1753
1754SV *
1755filter_store_value(db, code)
1756 DB_File db
1757 SV * code
1758 SV * RETVAL = &PL_sv_undef ;
1759 CODE:
1760 setFilter(filter_store_value) ;
9fe6733a
PM
1761
1762#endif /* DBM_FILTERING */