-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathDB_File.xs
executable file
·2068 lines (1716 loc) · 52.4 KB
/
DB_File.xs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/*
DB_File.xs -- Perl 5 interface to Berkeley DB
Written by Paul Marquess <pmqs@cpan.org>
All comments/suggestions/problems are welcome
Copyright (c) 1995-2023 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
Changes:
0.1 - Initial Release
0.2 - No longer bombs out if dbopen returns an error.
0.3 - Added some support for multiple btree compares
1.0 - Complete support for multiple callbacks added.
Fixed a problem with pushing a value onto an empty list.
1.01 - Fixed a SunOS core dump problem.
The return value from TIEHASH wasn't set to NULL when
dbopen returned an error.
1.02 - Use ALIAS to define TIEARRAY.
Removed some redundant commented code.
Merged OS2 code into the main distribution.
Allow negative subscripts with RECNO interface.
Changed the default flags to O_CREAT|O_RDWR
1.03 - Added EXISTS
1.04 - fixed a couple of bugs in hash_cb. Patches supplied by
Dave Hammen, hammen@gothamcity.jsc.nasa.gov
1.05 - Added logic to allow prefix & hash types to be specified via
Makefile.PL
1.06 - Minor namespace cleanup: Localized PrintBtree.
1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n".
1.08 - No change to DB_File.xs
1.09 - Default mode for dbopen changed to 0666
1.10 - Fixed fd method so that it still returns -1 for
in-memory files when db 1.86 is used.
1.11 - No change to DB_File.xs
1.12 - No change to DB_File.xs
1.13 - Tidied up a few casts.
1.14 - Made it illegal to tie an associative array to a RECNO
database and an ordinary array to a HASH or BTREE database.
1.50 - Make work with both DB 1.x or DB 2.x
1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
undefined value" warning with db_get and db_seq.
1.53 - Added DB_RENUMBER to flags for recno.
1.54 - Fixed bug in the fd method
1.55 - Fix for AIX from Jarkko Hietaniemi
1.56 - No change to DB_File.xs
1.57 - added the #undef op to allow building with Threads support.
1.58 - Fixed a problem with the use of sv_setpvn. When the
size is specified as 0, it does a strlen on the data.
This was ok for DB 1.x, but isn't for DB 2.x.
1.59 - No change to DB_File.xs
1.60 - Some code tidy up
1.61 - added flagSet macro for DB 2.5.x
fixed typo in O_RDONLY test.
1.62 - No change to DB_File.xs
1.63 - Fix to alllow DB 2.6.x to build.
1.64 - Tidied up the 1.x to 2.x flags mapping code.
Added a patch from Mark Kettenis <kettenis@wins.uva.nl>
to fix a flag mapping problem with O_RDONLY on the Hurd
1.65 - Fixed a bug in the PUSH logic.
Added BOOT check that using 2.3.4 or greater
1.66 - Added DBM filter code
1.67 - Backed off the use of newSVpvn.
Fixed DBM Filter code for Perl 5.004.
Fixed a small memory leak in the filter code.
1.68 - fixed backward compatibility bug with R_IAFTER & R_IBEFORE
merged in the 5.005_58 changes
1.69 - fixed a bug in push -- DB_APPEND wasn't working properly.
Fixed the R_SETCURSOR bug introduced in 1.68
Added a new Perl variable $DB_File::db_ver
1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with
GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons.
Added a BOOT check to test for equivalent versions of db.h &
libdb.a/so.
1.71 - Support for Berkeley DB version 3.
Support for Berkeley DB 2/3's backward compatibility mode.
Rewrote push
1.72 - No change to DB_File.xs
1.73 - No change to DB_File.xs
1.74 - A call to open needed parenthesised to stop it clashing
with a win32 macro.
Added Perl core patches 7703 & 7801.
1.75 - Fixed Perl core patch 7703.
Added support to allow DB_File to be built with
Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb
needed to be changed.
1.76 - No change to DB_File.xs
1.77 - Tidied up a few types used in calling newSVpvn.
1.78 - Core patch 10335, 10372, 10534, 10549, 11051 included.
1.79 - NEXTKEY ignores the input key.
Added lots of casts
1.800 - Moved backward compatibility code into ppport.h.
Use the new constants code.
1.801 - No change to DB_File.xs
1.802 - No change to DB_File.xs
1.803 - FETCH, STORE & DELETE don't map the flags parameter
into the equivalent Berkeley DB function anymore.
1.804 - no change.
1.805 - recursion detection added to the callbacks
Support for 4.1.X added.
Filter code can now cope with read-only $_
1.806 - recursion detection beefed up.
1.807 - no change
1.808 - leak fixed in ParseOpenInfo
1.809 - no change
1.810 - no change
1.811 - no change
1.812 - no change
1.813 - no change
1.814 - no change
1.814 - C++ casting fixes
*/
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef _NOT_CORE
# include "ppport.h"
#endif
int DB_File___unused() { return 0; }
/* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
* shortly #included by the <db.h>) __attribute__ to the possibly
* already defined __attribute__, for example by GNUC or by Perl. */
/* #if DB_VERSION_MAJOR_CFG < 2 */
#ifndef DB_VERSION_MAJOR
# undef __attribute__
#endif
#ifdef COMPAT185
# include <db_185.h>
#else
/* Uncomment one of the lines below */
/* See the section "At least one secondary cursor must be specified to DB->join"
in the README file for the circumstances where you need to uncomment one
of the two lines below.
*/
/* #define time_t __time64_t */
/* #define time_t __time32_t */
# include <db.h>
#endif
#ifndef PERL_UNUSED_ARG
# define PERL_UNUSED_ARG(x) ((void)x)
#endif
/* Wall starts with 5.7.x */
#if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
/* Since we dropped the gccish definition of __attribute__ we will want
* to redefine dNOOP, however (so that dTHX continues to work). Yes,
* all this means that we can't do attribute checking on the DB_File,
* boo, hiss. */
# ifndef DB_VERSION_MAJOR
# undef dNOOP
# ifdef __cplusplus
# define dNOOP (void)0
# else
# define dNOOP extern int DB_File___notused()
# endif
/* Ditto for dXSARGS. */
# undef dXSARGS
# define dXSARGS \
dSP; dMARK; \
I32 ax = mark - PL_stack_base + 1; \
I32 items = sp - mark
# endif
/* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
# undef dXSI32
# define dXSI32 dNOOP
#endif /* Perl >= 5.7 */
#include <fcntl.h>
/* #define TRACE */
#ifdef TRACE
# define Trace(x) printf x
#else
# define Trace(x)
#endif
#define DBT_clear(x) Zero(&x, 1, DBT) ;
#ifdef DB_VERSION_MAJOR
#if DB_VERSION_MAJOR == 2
# define BERKELEY_DB_1_OR_2
#endif
#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
# define AT_LEAST_DB_3_2
#endif
#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3)
# define AT_LEAST_DB_3_3
#endif
#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
# define AT_LEAST_DB_4_1
#endif
#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 3)
# define AT_LEAST_DB_4_3
#endif
#if DB_VERSION_MAJOR >= 6
# define AT_LEAST_DB_6_0
#endif
#ifdef AT_LEAST_DB_3_3
# define WANT_ERROR
#endif
/* map version 2 features & constants onto their version 1 equivalent */
#ifdef DB_Prefix_t
# undef DB_Prefix_t
#endif
#define DB_Prefix_t size_t
#ifdef DB_Hash_t
# undef DB_Hash_t
#endif
#define DB_Hash_t u_int32_t
/* DBTYPE stays the same */
/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */
#if DB_VERSION_MAJOR == 2
typedef DB_INFO INFO ;
#else /* DB_VERSION_MAJOR > 2 */
# define DB_FIXEDLEN (0x8000)
#endif /* DB_VERSION_MAJOR == 2 */
/* version 2 has db_recno_t in place of recno_t */
typedef db_recno_t recno_t;
#define R_CURSOR DB_SET_RANGE
#define R_FIRST DB_FIRST
#define R_IAFTER DB_AFTER
#define R_IBEFORE DB_BEFORE
#define R_LAST DB_LAST
#define R_NEXT DB_NEXT
#define R_NOOVERWRITE DB_NOOVERWRITE
#define R_PREV DB_PREV
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
# define R_SETCURSOR 0x800000
#else
# define R_SETCURSOR (DB_OPFLAGS_MASK)
#endif
#define R_RECNOSYNC 0
#define R_FIXEDLEN DB_FIXEDLEN
#define R_DUP DB_DUP
#define db_HA_hash h_hash
#define db_HA_ffactor h_ffactor
#define db_HA_nelem h_nelem
#define db_HA_bsize db_pagesize
#define db_HA_cachesize db_cachesize
#define db_HA_lorder db_lorder
#define db_BT_compare bt_compare
#define db_BT_prefix bt_prefix
#define db_BT_flags flags
#define db_BT_psize db_pagesize
#define db_BT_cachesize db_cachesize
#define db_BT_lorder db_lorder
#define db_BT_maxkeypage
#define db_BT_minkeypage
#define db_RE_reclen re_len
#define db_RE_flags flags
#define db_RE_bval re_pad
#define db_RE_bfname re_source
#define db_RE_psize db_pagesize
#define db_RE_cachesize db_cachesize
#define db_RE_lorder db_lorder
#define TXN NULL,
#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag)
#define DBT_flags(x) x.flags = 0
#define DB_flags(x, v) x |= v
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
# define flagSet(flags, bitmask) ((flags) & (bitmask))
#else
# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (u_int)(bitmask))
#endif
#else /* db version 1.x */
#define BERKELEY_DB_1
#define BERKELEY_DB_1_OR_2
typedef union INFO {
HASHINFO hash ;
RECNOINFO recno ;
BTREEINFO btree ;
} INFO ;
#ifdef mDB_Prefix_t
# ifdef DB_Prefix_t
# undef DB_Prefix_t
# endif
# define DB_Prefix_t mDB_Prefix_t
#endif
#ifdef mDB_Hash_t
# ifdef DB_Hash_t
# undef DB_Hash_t
# endif
# define DB_Hash_t mDB_Hash_t
#endif
#define db_HA_hash hash.hash
#define db_HA_ffactor hash.ffactor
#define db_HA_nelem hash.nelem
#define db_HA_bsize hash.bsize
#define db_HA_cachesize hash.cachesize
#define db_HA_lorder hash.lorder
#define db_BT_compare btree.compare
#define db_BT_prefix btree.prefix
#define db_BT_flags btree.flags
#define db_BT_psize btree.psize
#define db_BT_cachesize btree.cachesize
#define db_BT_lorder btree.lorder
#define db_BT_maxkeypage btree.maxkeypage
#define db_BT_minkeypage btree.minkeypage
#define db_RE_reclen recno.reclen
#define db_RE_flags recno.flags
#define db_RE_bval recno.bval
#define db_RE_bfname recno.bfname
#define db_RE_psize recno.psize
#define db_RE_cachesize recno.cachesize
#define db_RE_lorder recno.lorder
#define TXN
#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
#define DBT_flags(x)
#define DB_flags(x, v)
#define flagSet(flags, bitmask) ((flags) & (bitmask))
#endif /* db version 1 */
#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0)
#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
#ifdef DB_VERSION_MAJOR
#define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\
(db->dbp->close)(db->dbp, 0) ))
#define db_close(db) ((db->dbp)->close)(db->dbp, 0)
#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
? ((db->cursor)->c_del)(db->cursor, 0) \
: ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
#else /* ! DB_VERSION_MAJOR */
#define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp))
#define db_close(db) ((db->dbp)->close)(db->dbp)
#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
#endif /* ! DB_VERSION_MAJOR */
#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
typedef struct {
DBTYPE type ;
DB * dbp ;
SV * compare ;
bool in_compare ;
SV * prefix ;
bool in_prefix ;
SV * hash ;
bool in_hash ;
bool aborted ;
int in_memory ;
#ifdef BERKELEY_DB_1_OR_2
INFO info ;
#endif
#ifdef DB_VERSION_MAJOR
DBC * cursor ;
#endif
SV * filter_fetch_key ;
SV * filter_store_key ;
SV * filter_fetch_value ;
SV * filter_store_value ;
int filtering ;
} DB_File_type;
typedef DB_File_type * DB_File ;
typedef DBT DBTKEY ;
#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (const char *)""), s)
#define OutputValue(arg, name) \
{ if (RETVAL == 0) { \
SvGETMAGIC(arg) ; \
my_sv_setpvn(arg, (const char *)name.data, name.size) ; \
TAINT; \
SvTAINTED_on(arg); \
SvUTF8_off(arg); \
DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
} \
}
#define OutputKey(arg, name) \
{ if (RETVAL == 0) \
{ \
SvGETMAGIC(arg) ; \
if (db->type != DB_RECNO) { \
my_sv_setpvn(arg, (const char *)name.data, name.size); \
} \
else \
sv_setiv(arg, (I32)*(I32*)name.data - 1); \
TAINT; \
SvTAINTED_on(arg); \
SvUTF8_off(arg); \
DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
} \
}
/* Macro err_close only for use in croak_and_free */
#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */
# define err_close(r)
#else
# define err_close(r) db_close(r)
#endif
/* Macro croak_and_free only for use in ParseOpenInfo */
#define croak_and_free(x) \
do \
{ \
if (RETVAL->dbp) { err_close(RETVAL) ; } \
Safefree(RETVAL); \
croak(x); \
} while (0)
#define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
#ifdef CAN_PROTOTYPE
extern void __getBerkeleyDBInfo(void);
#endif
/* Internal Global Data */
#define MY_CXT_KEY "DB_File::_guts" XS_VERSION
typedef struct {
recno_t x_Value;
recno_t x_zero;
DB_File x_CurrentDB;
DBTKEY x_empty;
} my_cxt_t;
START_MY_CXT
#define Value (MY_CXT.x_Value)
#define zero (MY_CXT.x_zero)
#define CurrentDB (MY_CXT.x_CurrentDB)
#define empty (MY_CXT.x_empty)
#define ERR_BUFF "DB_File::Error"
#ifdef DB_VERSION_MAJOR
static int
#ifdef CAN_PROTOTYPE
db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
#else
db_put(db, key, value, flags)
DB_File db ;
DBTKEY key ;
DBT value ;
u_int flags ;
#endif
{
int status ;
if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
DBC * temp_cursor ;
DBT l_key, l_value;
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
#else
if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
#endif
return (-1) ;
memset(&l_key, 0, sizeof(l_key));
l_key.data = key.data;
l_key.size = key.size;
memset(&l_value, 0, sizeof(l_value));
l_value.data = value.data;
l_value.size = value.size;
if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
(void)temp_cursor->c_close(temp_cursor);
return (-1);
}
status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
(void)temp_cursor->c_close(temp_cursor);
return (status) ;
}
if (flagSet(flags, R_CURSOR)) {
return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
}
if (flagSet(flags, R_SETCURSOR)) {
if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
return -1 ;
return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
}
return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
}
#endif /* DB_VERSION_MAJOR */
static void
tidyUp(DB_File db)
{
db->aborted = TRUE ;
}
static int
#ifdef AT_LEAST_DB_6_0
#ifdef CAN_PROTOTYPE
btree_compare(DB * db, const DBT *key1, const DBT *key2, size_t* locp)
#else
btree_compare(db, key1, key2, locp)
DB * db ;
const DBT * key1 ;
const DBT * key2 ;
size_t* locp;
#endif /* CAN_PROTOTYPE */
#else /* Berkeley DB < 6.0 */
#ifdef AT_LEAST_DB_3_2
#ifdef CAN_PROTOTYPE
btree_compare(DB * db, const DBT *key1, const DBT *key2)
#else
btree_compare(db, key1, key2)
DB * db ;
const DBT * key1 ;
const DBT * key2 ;
#endif /* CAN_PROTOTYPE */
#else /* Berkeley DB < 3.2 */
#ifdef CAN_PROTOTYPE
btree_compare(const DBT *key1, const DBT *key2)
#else
btree_compare(key1, key2)
const DBT * key1 ;
const DBT * key2 ;
#endif
#endif
#endif
{
#ifdef dTHX
dTHX;
#endif
dSP ;
dMY_CXT ;
void * data1, * data2 ;
int retval ;
int count ;
#ifdef AT_LEAST_DB_3_2
PERL_UNUSED_ARG(db);
#endif
#ifdef AT_LEAST_DB_6_0
PERL_UNUSED_ARG(locp);
#endif
if (CurrentDB->in_compare) {
tidyUp(CurrentDB);
croak ("DB_File btree_compare: recursion detected\n") ;
}
data1 = (char *) key1->data ;
data2 = (char *) key2->data ;
#ifndef newSVpvn
/* As newSVpv will assume that the data pointer is a null terminated C
string if the size parameter is 0, make sure that data points to an
empty string if the length is 0
*/
if (key1->size == 0)
data1 = "" ;
if (key2->size == 0)
data2 = "" ;
#endif
ENTER ;
SAVETMPS;
SAVESPTR(CurrentDB);
CurrentDB->in_compare = FALSE;
SAVEINT(CurrentDB->in_compare);
CurrentDB->in_compare = TRUE;
PUSHMARK(SP) ;
EXTEND(SP,2) ;
PUSHs(sv_2mortal(newSVpvn((const char*)data1,key1->size)));
PUSHs(sv_2mortal(newSVpvn((const char*)data2,key2->size)));
PUTBACK ;
count = perl_call_sv(CurrentDB->compare, G_SCALAR);
SPAGAIN ;
if (count != 1){
tidyUp(CurrentDB);
croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
}
retval = POPi ;
PUTBACK ;
FREETMPS ;
LEAVE ;
return (retval) ;
}
static DB_Prefix_t
#ifdef AT_LEAST_DB_3_2
#ifdef CAN_PROTOTYPE
btree_prefix(DB * db, const DBT *key1, const DBT *key2)
#else
btree_prefix(db, key1, key2)
Db * db ;
const DBT * key1 ;
const DBT * key2 ;
#endif
#else /* Berkeley DB < 3.2 */
#ifdef CAN_PROTOTYPE
btree_prefix(const DBT *key1, const DBT *key2)
#else
btree_prefix(key1, key2)
const DBT * key1 ;
const DBT * key2 ;
#endif
#endif
{
#ifdef dTHX
dTHX;
#endif
dSP ;
dMY_CXT ;
char * data1, * data2 ;
int retval ;
int count ;
#ifdef AT_LEAST_DB_3_2
PERL_UNUSED_ARG(db);
#endif
if (CurrentDB->in_prefix){
tidyUp(CurrentDB);
croak ("DB_File btree_prefix: recursion detected\n") ;
}
data1 = (char *) key1->data ;
data2 = (char *) key2->data ;
#ifndef newSVpvn
/* As newSVpv will assume that the data pointer is a null terminated C
string if the size parameter is 0, make sure that data points to an
empty string if the length is 0
*/
if (key1->size == 0)
data1 = "" ;
if (key2->size == 0)
data2 = "" ;
#endif
ENTER ;
SAVETMPS;
SAVESPTR(CurrentDB);
CurrentDB->in_prefix = FALSE;
SAVEINT(CurrentDB->in_prefix);
CurrentDB->in_prefix = TRUE;
PUSHMARK(SP) ;
EXTEND(SP,2) ;
PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
PUTBACK ;
count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
SPAGAIN ;
if (count != 1){
tidyUp(CurrentDB);
croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
}
retval = POPi ;
PUTBACK ;
FREETMPS ;
LEAVE ;
return (retval) ;
}
#ifdef BERKELEY_DB_1
# define HASH_CB_SIZE_TYPE size_t
#else
# define HASH_CB_SIZE_TYPE u_int32_t
#endif
static DB_Hash_t
#ifdef AT_LEAST_DB_3_2
#ifdef CAN_PROTOTYPE
hash_cb(DB * db, const void *data, u_int32_t size)
#else
hash_cb(db, data, size)
DB * db ;
const void * data ;
HASH_CB_SIZE_TYPE size ;
#endif
#else /* Berkeley DB < 3.2 */
#ifdef CAN_PROTOTYPE
hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
#else
hash_cb(data, size)
const void * data ;
HASH_CB_SIZE_TYPE size ;
#endif
#endif
{
#ifdef dTHX
dTHX;
#endif
dSP ;
dMY_CXT;
int retval = 0;
int count ;
#ifdef AT_LEAST_DB_3_2
PERL_UNUSED_ARG(db);
#endif
if (CurrentDB->in_hash){
tidyUp(CurrentDB);
croak ("DB_File hash callback: recursion detected\n") ;
}
#ifndef newSVpvn
if (size == 0)
data = "" ;
#endif
/* DGH - Next two lines added to fix corrupted stack problem */
ENTER ;
SAVETMPS;
SAVESPTR(CurrentDB);
CurrentDB->in_hash = FALSE;
SAVEINT(CurrentDB->in_hash);
CurrentDB->in_hash = TRUE;
PUSHMARK(SP) ;
XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
PUTBACK ;
count = perl_call_sv(CurrentDB->hash, G_SCALAR);
SPAGAIN ;
if (count != 1){
tidyUp(CurrentDB);
croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
}
retval = POPi ;
PUTBACK ;
FREETMPS ;
LEAVE ;
return (retval) ;
}
#ifdef WANT_ERROR
static void
#ifdef AT_LEAST_DB_4_3
db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer)
#else
db_errcall_cb(const char * db_errpfx, char * buffer)
#endif
{
#ifdef dTHX
dTHX;
#endif
SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
#ifdef AT_LEAST_DB_4_3
PERL_UNUSED_ARG(dbenv);
#endif
if (sv) {
if (db_errpfx)
sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
else
sv_setpv(sv, buffer) ;
}
}
#endif
#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
static void
#ifdef CAN_PROTOTYPE
PrintHash(INFO *hash)
#else
PrintHash(hash)
INFO * hash ;
#endif
{
printf ("HASH Info\n") ;
printf (" hash = %s\n",
(hash->db_HA_hash != NULL ? "redefined" : "default")) ;
printf (" bsize = %d\n", hash->db_HA_bsize) ;
printf (" ffactor = %d\n", hash->db_HA_ffactor) ;
printf (" nelem = %d\n", hash->db_HA_nelem) ;
printf (" cachesize = %d\n", hash->db_HA_cachesize) ;
printf (" lorder = %d\n", hash->db_HA_lorder) ;
}
static void
#ifdef CAN_PROTOTYPE
PrintRecno(INFO *recno)
#else
PrintRecno(recno)
INFO * recno ;
#endif
{
printf ("RECNO Info\n") ;
printf (" flags = %d\n", recno->db_RE_flags) ;
printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
printf (" psize = %d\n", recno->db_RE_psize) ;
printf (" lorder = %d\n", recno->db_RE_lorder) ;
printf (" reclen = %lu\n", (unsigned long)recno->db_RE_reclen) ;
printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
}
static void
#ifdef CAN_PROTOTYPE
PrintBtree(INFO *btree)
#else
PrintBtree(btree)
INFO * btree ;
#endif
{
printf ("BTREE Info\n") ;
printf (" compare = %s\n",
(btree->db_BT_compare ? "redefined" : "default")) ;
printf (" prefix = %s\n",
(btree->db_BT_prefix ? "redefined" : "default")) ;
printf (" flags = %d\n", btree->db_BT_flags) ;
printf (" cachesize = %d\n", btree->db_BT_cachesize) ;
printf (" psize = %d\n", btree->db_BT_psize) ;
#ifndef DB_VERSION_MAJOR
printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ;
#endif
printf (" lorder = %d\n", btree->db_BT_lorder) ;
}
#else
#define PrintRecno(recno)
#define PrintHash(hash)
#define PrintBtree(btree)
#endif /* TRACE */
static I32
#ifdef CAN_PROTOTYPE
GetArrayLength(pTHX_ DB_File db)
#else
GetArrayLength(db)
DB_File db ;
#endif
{
DBT key ;
DBT value ;
int RETVAL ;
DBT_clear(key) ;
DBT_clear(value) ;
RETVAL = do_SEQ(db, key, value, R_LAST) ;
if (RETVAL == 0)
RETVAL = *(I32 *)key.data ;
else /* No key means empty file */
RETVAL = 0 ;
return ((I32)RETVAL) ;
}
static recno_t
#ifdef CAN_PROTOTYPE
GetRecnoKey(pTHX_ DB_File db, I32 value)
#else
GetRecnoKey(db, value)
DB_File db ;
I32 value ;
#endif
{
if (value < 0) {
/* Get the length of the array */
I32 length = GetArrayLength(aTHX_ db) ;
/* check for attempt to write before start of array */
if (length + value + 1 <= 0) {
tidyUp(db);
croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
}
value = length + value + 1 ;
}
else
++ value ;
return value ;
}
static DB_File
#ifdef CAN_PROTOTYPE