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