line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
#!perl |
2
|
1
|
|
|
1
|
111625
|
BEGIN { |
3
|
|
|
|
|
|
} |
4
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
9
|
use strict; |
|
1
|
|
|
|
3
|
|
|
1
|
|
|
|
40
|
|
6
|
1
|
|
|
1
|
6
|
use warnings; |
|
1
|
|
|
|
3
|
|
|
1
|
|
|
|
36
|
|
7
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
472
|
use Test::More; |
|
1
|
|
|
|
21434
|
|
|
1
|
|
|
|
11
|
|
9
|
1
|
|
|
1
|
373
|
use Config; |
|
1
|
|
|
|
3
|
|
|
1
|
|
|
|
311
|
|
10
|
|
|
|
|
|
|
11
|
|
|
|
|
|
our $DBM_Class; |
12
|
|
|
|
|
|
|
13
|
|
|
|
|
|
my ($create, $write); |
14
|
|
|
|
|
|
BEGIN { |
15
|
1
|
50
|
|
1
|
15
|
plan(skip_all => "$DBM_Class was not built") |
16
|
|
|
|
|
|
unless $Config{extensions} =~ /\b$DBM_Class\b/; |
17
|
1
|
50
|
33
|
|
8
|
plan(skip_all => "$DBM_Class not compatible with C++") |
18
|
|
|
|
|
|
if $DBM_Class eq 'ODBM_File' && $Config{d_cplusplus}; |
19
|
|
|
|
|
|
|
20
|
1
|
|
|
|
4
|
use_ok($DBM_Class); |
21
|
|
|
|
|
|
|
22
|
1
|
50
|
|
|
2974
|
if ($::Create_and_Write) { |
23
|
0
|
|
|
|
0
|
($create, $write) = eval $::Create_and_Write; |
24
|
0
|
|
|
|
0
|
isnt($create, undef, "(eval q{$::Create_and_Write})[0]"); |
25
|
0
|
|
|
|
0
|
isnt($write, undef, "(eval q{$::Create_and_Write})[1]"); |
26
|
|
|
|
|
|
} else { |
27
|
|
|
|
|
|
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT |
28
|
1
|
|
|
|
6
|
use_ok('Fcntl'); |
29
|
1
|
|
|
|
967
|
$create = O_RDWR()|O_CREAT(); |
30
|
1
|
|
|
|
1425
|
$write = O_RDWR(); |
31
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
34
|
|
|
|
|
|
unlink ; |
35
|
|
|
|
|
|
|
36
|
|
|
|
|
|
umask(0); |
37
|
|
|
|
|
|
my %h; |
38
|
|
|
|
|
|
isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class); |
39
|
|
|
|
|
|
|
40
|
|
|
|
|
|
my $Dfile = "Op_dbmx.pag"; |
41
|
|
|
|
|
|
if (! -e $Dfile) { |
42
|
|
|
|
|
|
($Dfile) = ; |
43
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
SKIP: { |
45
|
|
|
|
|
|
skip "different file permission semantics on $^O", 1 |
46
|
|
|
|
|
|
if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || $^O eq 'vos'; |
47
|
|
|
|
|
|
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
48
|
|
|
|
|
|
$blksize,$blocks) = stat($Dfile); |
49
|
|
|
|
|
|
is($mode & 0777, 0640); |
50
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
my $i = 0; |
52
|
|
|
|
|
|
while (my ($key,$value) = each(%h)) { |
53
|
|
|
|
|
|
$i++; |
54
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
is($i, 0); |
56
|
|
|
|
|
|
|
57
|
|
|
|
|
|
$h{'goner1'} = 'snork'; |
58
|
|
|
|
|
|
|
59
|
|
|
|
|
|
$h{'abc'} = 'ABC'; |
60
|
|
|
|
|
|
$h{'def'} = 'DEF'; |
61
|
|
|
|
|
|
$h{'jkl','mno'} = "JKL\034MNO"; |
62
|
|
|
|
|
|
$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); |
63
|
|
|
|
|
|
$h{'a'} = 'A'; |
64
|
|
|
|
|
|
$h{'b'} = 'B'; |
65
|
|
|
|
|
|
$h{'c'} = 'C'; |
66
|
|
|
|
|
|
$h{'d'} = 'D'; |
67
|
|
|
|
|
|
$h{'e'} = 'E'; |
68
|
|
|
|
|
|
$h{'f'} = 'F'; |
69
|
|
|
|
|
|
$h{'g'} = 'G'; |
70
|
|
|
|
|
|
$h{'h'} = 'H'; |
71
|
|
|
|
|
|
$h{'i'} = 'I'; |
72
|
|
|
|
|
|
|
73
|
|
|
|
|
|
$h{'goner2'} = 'snork'; |
74
|
|
|
|
|
|
delete $h{'goner2'}; |
75
|
|
|
|
|
|
|
76
|
|
|
|
|
|
untie(%h); |
77
|
|
|
|
|
|
isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $write, 0640), $DBM_Class); |
78
|
|
|
|
|
|
|
79
|
|
|
|
|
|
$h{'j'} = 'J'; |
80
|
|
|
|
|
|
$h{'k'} = 'K'; |
81
|
|
|
|
|
|
$h{'l'} = 'L'; |
82
|
|
|
|
|
|
$h{'m'} = 'M'; |
83
|
|
|
|
|
|
$h{'n'} = 'N'; |
84
|
|
|
|
|
|
$h{'o'} = 'O'; |
85
|
|
|
|
|
|
$h{'p'} = 'P'; |
86
|
|
|
|
|
|
$h{'q'} = 'Q'; |
87
|
|
|
|
|
|
$h{'r'} = 'R'; |
88
|
|
|
|
|
|
$h{'s'} = 'S'; |
89
|
|
|
|
|
|
$h{'t'} = 'T'; |
90
|
|
|
|
|
|
$h{'u'} = 'U'; |
91
|
|
|
|
|
|
$h{'v'} = 'V'; |
92
|
|
|
|
|
|
$h{'w'} = 'W'; |
93
|
|
|
|
|
|
$h{'x'} = 'X'; |
94
|
|
|
|
|
|
$h{'y'} = 'Y'; |
95
|
|
|
|
|
|
$h{'z'} = 'Z'; |
96
|
|
|
|
|
|
|
97
|
|
|
|
|
|
$h{'goner3'} = 'snork'; |
98
|
|
|
|
|
|
|
99
|
|
|
|
|
|
delete $h{'goner1'}; |
100
|
|
|
|
|
|
delete $h{'goner3'}; |
101
|
|
|
|
|
|
|
102
|
|
|
|
|
|
my @keys = keys(%h); |
103
|
|
|
|
|
|
my @values = values(%h); |
104
|
|
|
|
|
|
|
105
|
|
|
|
|
|
is($#keys, 29); |
106
|
|
|
|
|
|
is($#values, 29); |
107
|
|
|
|
|
|
|
108
|
|
|
|
|
|
while (my ($key, $value) = each(%h)) { |
109
|
|
|
|
|
|
if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { |
110
|
|
|
|
|
|
$key =~ y/a-z/A-Z/; |
111
|
|
|
|
|
|
$i++ if $key eq $value; |
112
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
115
|
|
|
|
|
|
is($i, 30); |
116
|
|
|
|
|
|
|
117
|
|
|
|
|
|
@keys = ('blurfl', keys(%h), 'dyick'); |
118
|
|
|
|
|
|
is($#keys, 31); |
119
|
|
|
|
|
|
|
120
|
|
|
|
|
|
$h{'foo'} = ''; |
121
|
|
|
|
|
|
$h{''} = 'bar'; |
122
|
|
|
|
|
|
|
123
|
|
|
|
|
|
my $ok = 1; |
124
|
|
|
|
|
|
for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } |
125
|
|
|
|
|
|
for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } |
126
|
|
|
|
|
|
is($ok, 1, 'check cache overflow and numeric keys and contents'); |
127
|
|
|
|
|
|
|
128
|
|
|
|
|
|
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
129
|
|
|
|
|
|
$blksize,$blocks) = stat($Dfile); |
130
|
|
|
|
|
|
cmp_ok($size, '>', 0); |
131
|
|
|
|
|
|
|
132
|
|
|
|
|
|
@h{0..200} = 200..400; |
133
|
|
|
|
|
|
my @foo = @h{0..200}; |
134
|
|
|
|
|
|
is(join(':',200..400), join(':',@foo)); |
135
|
|
|
|
|
|
|
136
|
|
|
|
|
|
is($h{'foo'}, ''); |
137
|
|
|
|
|
|
is($h{''}, 'bar'); |
138
|
|
|
|
|
|
|
139
|
|
|
|
|
|
if($DBM_Class eq 'SDBM_File') { |
140
|
|
|
|
|
|
is(exists $h{goner1}, ''); |
141
|
|
|
|
|
|
is(exists $h{foo}, 1); |
142
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
144
|
|
|
|
|
|
untie %h; |
145
|
|
|
|
|
|
unlink , $Dfile; |
146
|
|
|
|
|
|
|
147
|
|
|
|
|
|
{ |
148
|
|
|
|
|
|
# sub-class test |
149
|
|
|
|
|
|
|
150
|
|
|
|
|
|
package Another; |
151
|
|
|
|
|
|
|
152
|
|
|
|
|
|
open my $file, '>', 'SubDB.pm' or die "Cannot open SubDB.pm: $!\n"; |
153
|
|
|
|
|
|
printf $file <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class; |
154
|
|
|
|
|
|
|
155
|
|
|
|
|
|
package SubDB; |
156
|
|
|
|
|
|
|
157
|
|
|
|
|
|
use strict; |
158
|
|
|
|
|
|
use warnings; |
159
|
|
|
|
|
|
use vars qw(@ISA @EXPORT); |
160
|
|
|
|
|
|
|
161
|
|
|
|
|
|
require Exporter; |
162
|
|
|
|
|
|
use %s; |
163
|
|
|
|
|
|
@ISA=qw(%s); |
164
|
|
|
|
|
|
@EXPORT = @%s::EXPORT; |
165
|
|
|
|
|
|
|
166
|
|
|
|
|
|
sub STORE { |
167
|
|
|
|
|
|
my $self = shift; |
168
|
|
|
|
|
|
my $key = shift; |
169
|
|
|
|
|
|
my $value = shift; |
170
|
|
|
|
|
|
$self->SUPER::STORE($key, $value * 2); |
171
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
173
|
|
|
|
|
|
sub FETCH { |
174
|
|
|
|
|
|
my $self = shift; |
175
|
|
|
|
|
|
my $key = shift; |
176
|
|
|
|
|
|
$self->SUPER::FETCH($key) - 1; |
177
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
179
|
|
|
|
|
|
sub A_new_method |
180
|
|
|
|
|
|
{ |
181
|
|
|
|
|
|
my $self = shift; |
182
|
|
|
|
|
|
my $key = shift; |
183
|
|
|
|
|
|
my $value = $self->FETCH($key); |
184
|
|
|
|
|
|
return "[[$value]]"; |
185
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
187
|
|
|
|
|
|
1; |
188
|
|
|
|
|
|
EOM |
189
|
|
|
|
|
|
|
190
|
|
|
|
|
|
close $file or die "Could not close: $!"; |
191
|
|
|
|
|
|
|
192
|
1
|
|
|
1
|
3927
|
BEGIN { push @INC, '.'; } |
193
|
|
|
|
|
|
unlink ; |
194
|
|
|
|
|
|
|
195
|
|
|
|
|
|
main::use_ok('SubDB'); |
196
|
|
|
|
|
|
my %h; |
197
|
|
|
|
|
|
my $X; |
198
|
|
|
|
|
|
eval ' |
199
|
|
|
|
|
|
$X = tie(%h, "SubDB", "dbhash_tmp", $create, 0640 ); |
200
|
|
|
|
|
|
'; |
201
|
|
|
|
|
|
|
202
|
|
|
|
|
|
main::is($@, ""); |
203
|
|
|
|
|
|
|
204
|
|
|
|
|
|
my $ret = eval '$h{"fred"} = 3; return $h{"fred"} '; |
205
|
|
|
|
|
|
main::is($@, ""); |
206
|
|
|
|
|
|
main::is($ret, 5); |
207
|
|
|
|
|
|
|
208
|
|
|
|
|
|
$ret = eval '$X->A_new_method("fred") '; |
209
|
|
|
|
|
|
main::is($@, ""); |
210
|
|
|
|
|
|
main::is($ret, "[[5]]"); |
211
|
|
|
|
|
|
|
212
|
|
|
|
|
|
if ($DBM_Class eq 'GDBM_File') { |
213
|
|
|
|
|
|
$ret = eval 'GDBM_WRCREAT eq main::GDBM_WRCREAT'; |
214
|
|
|
|
|
|
main::is($@, ""); |
215
|
|
|
|
|
|
main::is($ret, 1); |
216
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
218
|
|
|
|
|
|
undef $X; |
219
|
|
|
|
|
|
untie(%h); |
220
|
|
|
|
|
|
unlink "SubDB.pm", ; |
221
|
|
|
|
|
|
|
222
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
224
|
|
|
|
|
|
untie %h; |
225
|
|
|
|
|
|
unlink , $Dfile; |
226
|
|
|
|
|
|
|
227
|
|
|
|
|
|
{ |
228
|
|
|
|
|
|
# DBM Filter tests |
229
|
|
|
|
|
|
my (%h, $db); |
230
|
|
|
|
|
|
my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
231
|
|
|
|
|
|
|
232
|
|
|
|
|
|
sub checkOutput |
233
|
|
|
|
|
|
{ |
234
|
12
|
|
|
12
|
35
|
my($fk, $sk, $fv, $sv) = @_; |
235
|
12
|
|
|
|
26
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
236
|
12
|
|
|
|
35
|
is($fetch_key, $fk); |
237
|
12
|
|
|
|
4035
|
is($store_key, $sk); |
238
|
12
|
|
|
|
4054
|
is($fetch_value, $fv); |
239
|
12
|
|
|
|
4058
|
is($store_value, $sv); |
240
|
12
|
|
|
|
4032
|
is($_, 'original'); |
241
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
243
|
|
|
|
|
|
unlink ; |
244
|
|
|
|
|
|
$db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640; |
245
|
|
|
|
|
|
isa_ok($db, $DBM_Class); |
246
|
|
|
|
|
|
|
247
|
|
|
|
|
|
$db->filter_fetch_key (sub { $fetch_key = $_ }); |
248
|
|
|
|
|
|
$db->filter_store_key (sub { $store_key = $_ }); |
249
|
|
|
|
|
|
$db->filter_fetch_value (sub { $fetch_value = $_}); |
250
|
|
|
|
|
|
$db->filter_store_value (sub { $store_value = $_ }); |
251
|
|
|
|
|
|
|
252
|
|
|
|
|
|
$_ = "original"; |
253
|
|
|
|
|
|
|
254
|
|
|
|
|
|
$h{"fred"} = "joe"; |
255
|
|
|
|
|
|
# fk sk fv sv |
256
|
|
|
|
|
|
checkOutput("", "fred", "", "joe"); |
257
|
|
|
|
|
|
|
258
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
259
|
|
|
|
|
|
is($h{"fred"}, "joe"); |
260
|
|
|
|
|
|
# fk sk fv sv |
261
|
|
|
|
|
|
checkOutput("", "fred", "joe", ""); |
262
|
|
|
|
|
|
|
263
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
264
|
|
|
|
|
|
is($db->FIRSTKEY(), "fred"); |
265
|
|
|
|
|
|
# fk sk fv sv |
266
|
|
|
|
|
|
checkOutput("fred", "", "", ""); |
267
|
|
|
|
|
|
|
268
|
|
|
|
|
|
# replace the filters, but remember the previous set |
269
|
|
|
|
|
|
my ($old_fk) = $db->filter_fetch_key |
270
|
|
|
|
|
|
(sub { $_ = uc $_; $fetch_key = $_ }); |
271
|
|
|
|
|
|
my ($old_sk) = $db->filter_store_key |
272
|
|
|
|
|
|
(sub { $_ = lc $_; $store_key = $_ }); |
273
|
|
|
|
|
|
my ($old_fv) = $db->filter_fetch_value |
274
|
|
|
|
|
|
(sub { $_ = "[$_]"; $fetch_value = $_ }); |
275
|
|
|
|
|
|
my ($old_sv) = $db->filter_store_value |
276
|
|
|
|
|
|
(sub { s/o/x/g; $store_value = $_ }); |
277
|
|
|
|
|
|
|
278
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
279
|
|
|
|
|
|
$h{"Fred"} = "Joe"; |
280
|
|
|
|
|
|
# fk sk fv sv |
281
|
|
|
|
|
|
checkOutput("", "fred", "", "Jxe"); |
282
|
|
|
|
|
|
|
283
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
284
|
|
|
|
|
|
is($h{"Fred"}, "[Jxe]"); |
285
|
|
|
|
|
|
# fk sk fv sv |
286
|
|
|
|
|
|
checkOutput("", "fred", "[Jxe]", ""); |
287
|
|
|
|
|
|
|
288
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
289
|
|
|
|
|
|
is($db->FIRSTKEY(), "FRED"); |
290
|
|
|
|
|
|
# fk sk fv sv |
291
|
|
|
|
|
|
checkOutput("FRED", "", "", ""); |
292
|
|
|
|
|
|
|
293
|
|
|
|
|
|
# put the original filters back |
294
|
|
|
|
|
|
$db->filter_fetch_key ($old_fk); |
295
|
|
|
|
|
|
$db->filter_store_key ($old_sk); |
296
|
|
|
|
|
|
$db->filter_fetch_value ($old_fv); |
297
|
|
|
|
|
|
$db->filter_store_value ($old_sv); |
298
|
|
|
|
|
|
|
299
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
300
|
|
|
|
|
|
$h{"fred"} = "joe"; |
301
|
|
|
|
|
|
checkOutput("", "fred", "", "joe"); |
302
|
|
|
|
|
|
|
303
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
304
|
|
|
|
|
|
is($h{"fred"}, "joe"); |
305
|
|
|
|
|
|
checkOutput("", "fred", "joe", ""); |
306
|
|
|
|
|
|
|
307
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
308
|
|
|
|
|
|
is($db->FIRSTKEY(), "fred"); |
309
|
|
|
|
|
|
checkOutput("fred", "", "", ""); |
310
|
|
|
|
|
|
|
311
|
|
|
|
|
|
# delete the filters |
312
|
|
|
|
|
|
$db->filter_fetch_key (undef); |
313
|
|
|
|
|
|
$db->filter_store_key (undef); |
314
|
|
|
|
|
|
$db->filter_fetch_value (undef); |
315
|
|
|
|
|
|
$db->filter_store_value (undef); |
316
|
|
|
|
|
|
|
317
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
318
|
|
|
|
|
|
$h{"fred"} = "joe"; |
319
|
|
|
|
|
|
checkOutput("", "", "", ""); |
320
|
|
|
|
|
|
|
321
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
322
|
|
|
|
|
|
is($h{"fred"}, "joe"); |
323
|
|
|
|
|
|
checkOutput("", "", "", ""); |
324
|
|
|
|
|
|
|
325
|
|
|
|
|
|
($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; |
326
|
|
|
|
|
|
is($db->FIRSTKEY(), "fred"); |
327
|
|
|
|
|
|
checkOutput("", "", "", ""); |
328
|
|
|
|
|
|
|
329
|
|
|
|
|
|
undef $db; |
330
|
|
|
|
|
|
untie %h; |
331
|
|
|
|
|
|
unlink ; |
332
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
334
|
|
|
|
|
|
{ |
335
|
|
|
|
|
|
# DBM Filter with a closure |
336
|
|
|
|
|
|
|
337
|
|
|
|
|
|
my (%h, $db); |
338
|
|
|
|
|
|
|
339
|
|
|
|
|
|
unlink ; |
340
|
|
|
|
|
|
$db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640; |
341
|
|
|
|
|
|
isa_ok($db, $DBM_Class); |
342
|
|
|
|
|
|
|
343
|
|
|
|
|
|
my %result = (); |
344
|
|
|
|
|
|
|
345
|
|
|
|
|
|
sub Closure |
346
|
|
|
|
|
|
{ |
347
|
4
|
|
|
4
|
12
|
my ($name) = @_; |
348
|
4
|
|
|
|
7
|
my $count = 0; |
349
|
4
|
|
|
|
6
|
my @kept = (); |
350
|
|
|
|
|
|
|
351
|
7
|
|
|
7
|
30
|
return sub { ++$count; |
352
|
7
|
|
|
|
17
|
push @kept, $_; |
353
|
7
|
|
|
|
79
|
$result{$name} = "$name - $count: [@kept]"; |
354
|
|
|
|
|
|
} |
355
|
4
|
|
|
|
27
|
} |
356
|
|
|
|
|
|
|
357
|
|
|
|
|
|
$db->filter_store_key(Closure("store key")); |
358
|
|
|
|
|
|
$db->filter_store_value(Closure("store value")); |
359
|
|
|
|
|
|
$db->filter_fetch_key(Closure("fetch key")); |
360
|
|
|
|
|
|
$db->filter_fetch_value(Closure("fetch value")); |
361
|
|
|
|
|
|
|
362
|
|
|
|
|
|
$_ = "original"; |
363
|
|
|
|
|
|
|
364
|
|
|
|
|
|
$h{"fred"} = "joe"; |
365
|
|
|
|
|
|
is($result{"store key"}, "store key - 1: [fred]"); |
366
|
|
|
|
|
|
is($result{"store value"}, "store value - 1: [joe]"); |
367
|
|
|
|
|
|
is($result{"fetch key"}, undef); |
368
|
|
|
|
|
|
is($result{"fetch value"}, undef); |
369
|
|
|
|
|
|
is($_, "original"); |
370
|
|
|
|
|
|
|
371
|
|
|
|
|
|
is($db->FIRSTKEY(), "fred"); |
372
|
|
|
|
|
|
is($result{"store key"}, "store key - 1: [fred]"); |
373
|
|
|
|
|
|
is($result{"store value"}, "store value - 1: [joe]"); |
374
|
|
|
|
|
|
is($result{"fetch key"}, "fetch key - 1: [fred]"); |
375
|
|
|
|
|
|
is($result{"fetch value"}, undef); |
376
|
|
|
|
|
|
is($_, "original"); |
377
|
|
|
|
|
|
|
378
|
|
|
|
|
|
$h{"jim"} = "john"; |
379
|
|
|
|
|
|
is($result{"store key"}, "store key - 2: [fred jim]"); |
380
|
|
|
|
|
|
is($result{"store value"}, "store value - 2: [joe john]"); |
381
|
|
|
|
|
|
is($result{"fetch key"}, "fetch key - 1: [fred]"); |
382
|
|
|
|
|
|
is($result{"fetch value"}, undef); |
383
|
|
|
|
|
|
is($_, "original"); |
384
|
|
|
|
|
|
|
385
|
|
|
|
|
|
is($h{"fred"}, "joe"); |
386
|
|
|
|
|
|
is($result{"store key"}, "store key - 3: [fred jim fred]"); |
387
|
|
|
|
|
|
is($result{"store value"}, "store value - 2: [joe john]"); |
388
|
|
|
|
|
|
is($result{"fetch key"}, "fetch key - 1: [fred]"); |
389
|
|
|
|
|
|
is($result{"fetch value"}, "fetch value - 1: [joe]"); |
390
|
|
|
|
|
|
is($_, "original"); |
391
|
|
|
|
|
|
|
392
|
|
|
|
|
|
undef $db; |
393
|
|
|
|
|
|
untie %h; |
394
|
|
|
|
|
|
unlink ; |
395
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
397
|
|
|
|
|
|
{ |
398
|
|
|
|
|
|
# DBM Filter recursion detection |
399
|
|
|
|
|
|
my (%h, $db); |
400
|
|
|
|
|
|
unlink ; |
401
|
|
|
|
|
|
|
402
|
|
|
|
|
|
$db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640; |
403
|
|
|
|
|
|
isa_ok($db, $DBM_Class); |
404
|
|
|
|
|
|
|
405
|
|
|
|
|
|
$db->filter_store_key (sub { $_ = $h{$_} }); |
406
|
|
|
|
|
|
|
407
|
|
|
|
|
|
eval '$h{1} = 1234'; |
408
|
|
|
|
|
|
like($@, qr/^recursion detected in filter_store_key at/); |
409
|
|
|
|
|
|
|
410
|
|
|
|
|
|
undef $db; |
411
|
|
|
|
|
|
untie %h; |
412
|
|
|
|
|
|
unlink ; |
413
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
415
|
|
|
|
|
|
{ |
416
|
|
|
|
|
|
# Bug ID 20001013.009 |
417
|
|
|
|
|
|
# |
418
|
|
|
|
|
|
# test that $hash{KEY} = undef doesn't produce the warning |
419
|
|
|
|
|
|
# Use of uninitialized value in null operation |
420
|
|
|
|
|
|
|
421
|
|
|
|
|
|
unlink ; |
422
|
|
|
|
|
|
my %h; |
423
|
|
|
|
|
|
my $a = ""; |
424
|
|
|
|
|
|
local $SIG{__WARN__} = sub {$a = $_[0]}; |
425
|
|
|
|
|
|
|
426
|
|
|
|
|
|
isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class); |
427
|
|
|
|
|
|
$h{ABC} = undef; |
428
|
|
|
|
|
|
is($a, ""); |
429
|
|
|
|
|
|
untie %h; |
430
|
|
|
|
|
|
unlink ; |
431
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
433
|
|
|
|
|
|
{ |
434
|
|
|
|
|
|
# When iterating over a tied hash using "each", the key passed to FETCH |
435
|
|
|
|
|
|
# will be recycled and passed to NEXTKEY. If a Source Filter modifies the |
436
|
|
|
|
|
|
# key in FETCH via a filter_fetch_key method we need to check that the |
437
|
|
|
|
|
|
# modified key doesn't get passed to NEXTKEY. |
438
|
|
|
|
|
|
# Also Test "keys" & "values" while we are at it. |
439
|
|
|
|
|
|
|
440
|
|
|
|
|
|
unlink ; |
441
|
|
|
|
|
|
my $bad_key = 0; |
442
|
|
|
|
|
|
my %h = (); |
443
|
|
|
|
|
|
my $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640; |
444
|
|
|
|
|
|
isa_ok($db, $DBM_Class); |
445
|
|
|
|
|
|
$db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}); |
446
|
|
|
|
|
|
$db->filter_store_key (sub { $bad_key = 1 if /^Beta_/; $_ =~ s/^Alpha_/Beta_/}); |
447
|
|
|
|
|
|
|
448
|
|
|
|
|
|
$h{'Alpha_ABC'} = 2; |
449
|
|
|
|
|
|
$h{'Alpha_DEF'} = 5; |
450
|
|
|
|
|
|
|
451
|
|
|
|
|
|
is($h{'Alpha_ABC'}, 2); |
452
|
|
|
|
|
|
is($h{'Alpha_DEF'}, 5); |
453
|
|
|
|
|
|
|
454
|
|
|
|
|
|
my ($k, $v) = ("", ""); |
455
|
|
|
|
|
|
while (($k, $v) = each %h) {} |
456
|
|
|
|
|
|
is($bad_key, 0); |
457
|
|
|
|
|
|
|
458
|
|
|
|
|
|
$bad_key = 0; |
459
|
|
|
|
|
|
foreach $k (keys %h) {} |
460
|
|
|
|
|
|
is($bad_key, 0); |
461
|
|
|
|
|
|
|
462
|
|
|
|
|
|
$bad_key = 0; |
463
|
|
|
|
|
|
foreach $v (values %h) {} |
464
|
|
|
|
|
|
is($bad_key, 0); |
465
|
|
|
|
|
|
|
466
|
|
|
|
|
|
undef $db; |
467
|
|
|
|
|
|
untie %h; |
468
|
|
|
|
|
|
unlink ; |
469
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
471
|
|
|
|
|
|
{ |
472
|
|
|
|
|
|
# Check that DBM Filter can cope with read-only $_ |
473
|
|
|
|
|
|
|
474
|
|
|
|
|
|
my %h; |
475
|
|
|
|
|
|
unlink ; |
476
|
|
|
|
|
|
|
477
|
|
|
|
|
|
my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640; |
478
|
|
|
|
|
|
isa_ok($db, $DBM_Class); |
479
|
|
|
|
|
|
|
480
|
|
|
|
|
|
$db->filter_fetch_key (sub { }); |
481
|
|
|
|
|
|
$db->filter_store_key (sub { }); |
482
|
|
|
|
|
|
$db->filter_fetch_value (sub { }); |
483
|
|
|
|
|
|
$db->filter_store_value (sub { }); |
484
|
|
|
|
|
|
|
485
|
|
|
|
|
|
$_ = "original"; |
486
|
|
|
|
|
|
|
487
|
|
|
|
|
|
$h{"fred"} = "joe"; |
488
|
|
|
|
|
|
is($h{"fred"}, "joe"); |
489
|
|
|
|
|
|
|
490
|
|
|
|
|
|
is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]); |
491
|
|
|
|
|
|
is($@, ''); |
492
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
494
|
|
|
|
|
|
# delete the filters |
495
|
|
|
|
|
|
$db->filter_fetch_key (undef); |
496
|
|
|
|
|
|
$db->filter_store_key (undef); |
497
|
|
|
|
|
|
$db->filter_fetch_value (undef); |
498
|
|
|
|
|
|
$db->filter_store_value (undef); |
499
|
|
|
|
|
|
|
500
|
|
|
|
|
|
$h{"fred"} = "joe"; |
501
|
|
|
|
|
|
|
502
|
|
|
|
|
|
is($h{"fred"}, "joe"); |
503
|
|
|
|
|
|
|
504
|
|
|
|
|
|
is($db->FIRSTKEY(), "fred"); |
505
|
|
|
|
|
|
|
506
|
|
|
|
|
|
is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]); |
507
|
|
|
|
|
|
is($@, ''); |
508
|
|
|
|
|
|
|
509
|
|
|
|
|
|
undef $db; |
510
|
|
|
|
|
|
untie %h; |
511
|
|
|
|
|
|
unlink ; |
512
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
514
|
|
|
|
|
|
done_testing(); |
515
|
|
|
|
|
|
1; |