Commit | Line | Data |
---|---|---|
7c250e57 | 1 | #!./perl -w |
a0d0e21e LW |
2 | |
3 | BEGIN { | |
610ab055 | 4 | @INC = '../lib' if -d '../lib' ; |
a0d0e21e LW |
5 | require Config; import Config; |
6 | if ($Config{'extensions'} !~ /\bDB_File\b/) { | |
7 | print "1..0\n"; | |
8 | exit 0; | |
9 | } | |
10 | } | |
11 | ||
12 | use DB_File; | |
13 | use Fcntl; | |
14 | ||
a6ed719b | 15 | print "1..62\n"; |
f6b705ef | 16 | |
17 | sub ok | |
18 | { | |
19 | my $no = shift ; | |
20 | my $result = shift ; | |
21 | ||
22 | print "not " unless $result ; | |
23 | print "ok $no\n" ; | |
24 | } | |
a0d0e21e | 25 | |
55d68b4a | 26 | $Dfile = "dbhash.tmp"; |
a0d0e21e LW |
27 | unlink $Dfile; |
28 | ||
29 | umask(0); | |
30 | ||
31 | # Check the interface to HASHINFO | |
32 | ||
f6b705ef | 33 | my $dbh = new DB_File::HASHINFO ; |
34 | ||
3fe9a6f1 | 35 | ok(1, ! defined $dbh->{bsize}) ; |
36 | ok(2, ! defined $dbh->{ffactor}) ; | |
37 | ok(3, ! defined $dbh->{nelem}) ; | |
38 | ok(4, ! defined $dbh->{cachesize}) ; | |
39 | ok(5, ! defined $dbh->{hash}) ; | |
40 | ok(6, ! defined $dbh->{lorder}) ; | |
a0d0e21e LW |
41 | |
42 | $dbh->{bsize} = 3000 ; | |
f6b705ef | 43 | ok(7, $dbh->{bsize} == 3000 ); |
a0d0e21e LW |
44 | |
45 | $dbh->{ffactor} = 9000 ; | |
f6b705ef | 46 | ok(8, $dbh->{ffactor} == 9000 ); |
47 | ||
a0d0e21e | 48 | $dbh->{nelem} = 400 ; |
f6b705ef | 49 | ok(9, $dbh->{nelem} == 400 ); |
a0d0e21e LW |
50 | |
51 | $dbh->{cachesize} = 65 ; | |
f6b705ef | 52 | ok(10, $dbh->{cachesize} == 65 ); |
a0d0e21e LW |
53 | |
54 | $dbh->{hash} = "abc" ; | |
f6b705ef | 55 | ok(11, $dbh->{hash} eq "abc" ); |
a0d0e21e LW |
56 | |
57 | $dbh->{lorder} = 1234 ; | |
f6b705ef | 58 | ok(12, $dbh->{lorder} == 1234 ); |
a0d0e21e LW |
59 | |
60 | # Check that an invalid entry is caught both for store & fetch | |
61 | eval '$dbh->{fred} = 1234' ; | |
f6b705ef | 62 | ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); |
610ab055 | 63 | eval 'my $q = $dbh->{fred}' ; |
f6b705ef | 64 | ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); |
a0d0e21e | 65 | |
610ab055 | 66 | |
a0d0e21e LW |
67 | # Now check the interface to HASH |
68 | ||
f6b705ef | 69 | ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); |
a0d0e21e LW |
70 | |
71 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, | |
72 | $blksize,$blocks) = stat($Dfile); | |
a6ed719b | 73 | ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); |
a0d0e21e LW |
74 | |
75 | while (($key,$value) = each(%h)) { | |
76 | $i++; | |
77 | } | |
f6b705ef | 78 | ok(17, !$i ); |
a0d0e21e LW |
79 | |
80 | $h{'goner1'} = 'snork'; | |
81 | ||
82 | $h{'abc'} = 'ABC'; | |
f6b705ef | 83 | ok(18, $h{'abc'} eq 'ABC' ); |
84 | ok(19, !defined $h{'jimmy'} ); | |
85 | ok(20, !exists $h{'jimmy'} ); | |
86 | ok(21, exists $h{'abc'} ); | |
a0d0e21e LW |
87 | |
88 | $h{'def'} = 'DEF'; | |
89 | $h{'jkl','mno'} = "JKL\034MNO"; | |
90 | $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); | |
91 | $h{'a'} = 'A'; | |
92 | ||
93 | #$h{'b'} = 'B'; | |
94 | $X->STORE('b', 'B') ; | |
95 | ||
96 | $h{'c'} = 'C'; | |
97 | ||
98 | #$h{'d'} = 'D'; | |
99 | $X->put('d', 'D') ; | |
100 | ||
101 | $h{'e'} = 'E'; | |
102 | $h{'f'} = 'F'; | |
103 | $h{'g'} = 'X'; | |
104 | $h{'h'} = 'H'; | |
105 | $h{'i'} = 'I'; | |
106 | ||
107 | $h{'goner2'} = 'snork'; | |
108 | delete $h{'goner2'}; | |
109 | ||
110 | ||
111 | # IMPORTANT - $X must be undefined before the untie otherwise the | |
112 | # underlying DB close routine will not get called. | |
113 | undef $X ; | |
114 | untie(%h); | |
115 | ||
116 | ||
117 | # tie to the same file again, do not supply a type - should default to HASH | |
f6b705ef | 118 | ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); |
a0d0e21e LW |
119 | |
120 | # Modify an entry from the previous tie | |
121 | $h{'g'} = 'G'; | |
122 | ||
123 | $h{'j'} = 'J'; | |
124 | $h{'k'} = 'K'; | |
125 | $h{'l'} = 'L'; | |
126 | $h{'m'} = 'M'; | |
127 | $h{'n'} = 'N'; | |
128 | $h{'o'} = 'O'; | |
129 | $h{'p'} = 'P'; | |
130 | $h{'q'} = 'Q'; | |
131 | $h{'r'} = 'R'; | |
132 | $h{'s'} = 'S'; | |
133 | $h{'t'} = 'T'; | |
134 | $h{'u'} = 'U'; | |
135 | $h{'v'} = 'V'; | |
136 | $h{'w'} = 'W'; | |
137 | $h{'x'} = 'X'; | |
138 | $h{'y'} = 'Y'; | |
139 | $h{'z'} = 'Z'; | |
140 | ||
141 | $h{'goner3'} = 'snork'; | |
142 | ||
143 | delete $h{'goner1'}; | |
144 | $X->DELETE('goner3'); | |
145 | ||
146 | @keys = keys(%h); | |
147 | @values = values(%h); | |
148 | ||
f6b705ef | 149 | ok(23, $#keys == 29 && $#values == 29) ; |
a0d0e21e | 150 | |
f6b705ef | 151 | $i = 0 ; |
55d68b4a | 152 | while (($key,$value) = each(%h)) { |
2f52a358 | 153 | if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { |
a0d0e21e LW |
154 | $key =~ y/a-z/A-Z/; |
155 | $i++ if $key eq $value; | |
156 | } | |
157 | } | |
158 | ||
f6b705ef | 159 | ok(24, $i == 30) ; |
a0d0e21e | 160 | |
55d68b4a | 161 | @keys = ('blurfl', keys(%h), 'dyick'); |
f6b705ef | 162 | ok(25, $#keys == 31) ; |
a0d0e21e LW |
163 | |
164 | $h{'foo'} = ''; | |
f6b705ef | 165 | ok(26, $h{'foo'} eq '' ); |
a0d0e21e LW |
166 | |
167 | $h{''} = 'bar'; | |
f6b705ef | 168 | ok(27, $h{''} eq 'bar' ); |
a0d0e21e LW |
169 | |
170 | # check cache overflow and numeric keys and contents | |
171 | $ok = 1; | |
172 | for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } | |
173 | for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } | |
f6b705ef | 174 | ok(28, $ok ); |
a0d0e21e LW |
175 | |
176 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, | |
177 | $blksize,$blocks) = stat($Dfile); | |
f6b705ef | 178 | ok(29, $size > 0 ); |
a0d0e21e LW |
179 | |
180 | @h{0..200} = 200..400; | |
181 | @foo = @h{0..200}; | |
f6b705ef | 182 | ok(30, join(':',200..400) eq join(':',@foo) ); |
a0d0e21e LW |
183 | |
184 | ||
185 | # Now check all the non-tie specific stuff | |
186 | ||
187 | # Check NOOVERWRITE will make put fail when attempting to overwrite | |
188 | # an existing record. | |
189 | ||
190 | $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; | |
f6b705ef | 191 | ok(31, $status == 1 ); |
a0d0e21e LW |
192 | |
193 | # check that the value of the key 'x' has not been changed by the | |
194 | # previous test | |
f6b705ef | 195 | ok(32, $h{'x'} eq 'X' ); |
a0d0e21e LW |
196 | |
197 | # standard put | |
198 | $status = $X->put('key', 'value') ; | |
f6b705ef | 199 | ok(33, $status == 0 ); |
a0d0e21e LW |
200 | |
201 | #check that previous put can be retrieved | |
f6b705ef | 202 | $value = 0 ; |
a0d0e21e | 203 | $status = $X->get('key', $value) ; |
f6b705ef | 204 | ok(34, $status == 0 ); |
205 | ok(35, $value eq 'value' ); | |
a0d0e21e LW |
206 | |
207 | # Attempting to delete an existing key should work | |
208 | ||
209 | $status = $X->del('q') ; | |
f6b705ef | 210 | ok(36, $status == 0 ); |
a0d0e21e LW |
211 | |
212 | # Make sure that the key deleted, cannot be retrieved | |
f6b705ef | 213 | $^W = 0 ; |
214 | ok(37, $h{'q'} eq undef ); | |
215 | $^W = 1 ; | |
a0d0e21e LW |
216 | |
217 | # Attempting to delete a non-existant key should fail | |
218 | ||
219 | $status = $X->del('joe') ; | |
f6b705ef | 220 | ok(38, $status == 1 ); |
a0d0e21e LW |
221 | |
222 | # Check the get interface | |
223 | ||
224 | # First a non-existing key | |
225 | $status = $X->get('aaaa', $value) ; | |
f6b705ef | 226 | ok(39, $status == 1 ); |
a0d0e21e LW |
227 | |
228 | # Next an existing key | |
229 | $status = $X->get('a', $value) ; | |
f6b705ef | 230 | ok(40, $status == 0 ); |
231 | ok(41, $value eq 'A' ); | |
a0d0e21e LW |
232 | |
233 | # seq | |
234 | # ### | |
235 | ||
236 | # ditto, but use put to replace the key/value pair. | |
237 | ||
238 | # use seq to walk backwards through a file - check that this reversed is | |
239 | ||
240 | # check seq FIRST/LAST | |
241 | ||
242 | # sync | |
243 | # #### | |
244 | ||
245 | $status = $X->sync ; | |
f6b705ef | 246 | ok(42, $status == 0 ); |
a0d0e21e LW |
247 | |
248 | ||
249 | # fd | |
250 | # ## | |
251 | ||
252 | $status = $X->fd ; | |
f6b705ef | 253 | ok(43, $status != 0 ); |
a0d0e21e LW |
254 | |
255 | undef $X ; | |
256 | untie %h ; | |
257 | ||
258 | unlink $Dfile; | |
259 | ||
f6b705ef | 260 | # clear |
261 | # ##### | |
262 | ||
263 | ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); | |
264 | foreach (1 .. 10) | |
265 | { $h{$_} = $_ * 100 } | |
266 | ||
267 | # check that there are 10 elements in the hash | |
268 | $i = 0 ; | |
269 | while (($key,$value) = each(%h)) { | |
270 | $i++; | |
271 | } | |
272 | ok(45, $i == 10); | |
273 | ||
274 | # now clear the hash | |
275 | %h = () ; | |
276 | ||
277 | # check it is empty | |
278 | $i = 0 ; | |
279 | while (($key,$value) = each(%h)) { | |
280 | $i++; | |
281 | } | |
282 | ok(46, $i == 0); | |
283 | ||
284 | untie %h ; | |
285 | unlink $Dfile ; | |
286 | ||
287 | ||
a0d0e21e | 288 | # Now try an in memory file |
f6b705ef | 289 | ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); |
a0d0e21e LW |
290 | |
291 | # fd with an in memory file should return fail | |
292 | $status = $X->fd ; | |
f6b705ef | 293 | ok(48, $status == -1 ); |
a0d0e21e | 294 | |
a0d0e21e | 295 | undef $X ; |
610ab055 PM |
296 | untie %h ; |
297 | ||
298 | { | |
299 | # check ability to override the default hashing | |
300 | my %x ; | |
301 | my $filename = "xyz" ; | |
302 | my $hi = new DB_File::HASHINFO ; | |
303 | $::count = 0 ; | |
304 | $hi->{hash} = sub { ++$::count ; length $_[0] } ; | |
305 | ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; | |
306 | $h{"abc"} = 123 ; | |
307 | ok(50, $h{"abc"} == 123) ; | |
308 | untie %x ; | |
309 | unlink $filename ; | |
310 | ok(51, $::count >0) ; | |
311 | } | |
a0d0e21e | 312 | |
05475680 PM |
313 | { |
314 | # check that attempting to tie an array to a DB_HASH will fail | |
315 | ||
316 | my $filename = "xyz" ; | |
317 | my @x ; | |
318 | eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; | |
319 | ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; | |
320 | unlink $filename ; | |
321 | } | |
322 | ||
a6ed719b PM |
323 | { |
324 | # sub-class test | |
325 | ||
326 | package Another ; | |
327 | ||
328 | use strict ; | |
329 | ||
330 | open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; | |
331 | print FILE <<'EOM' ; | |
332 | ||
333 | package SubDB ; | |
334 | ||
335 | use strict ; | |
336 | use vars qw( @ISA @EXPORT) ; | |
337 | ||
338 | require Exporter ; | |
339 | use DB_File; | |
340 | @ISA=qw(DB_File); | |
341 | @EXPORT = @DB_File::EXPORT ; | |
342 | ||
343 | sub STORE { | |
344 | my $self = shift ; | |
345 | my $key = shift ; | |
346 | my $value = shift ; | |
347 | $self->SUPER::STORE($key, $value * 2) ; | |
348 | } | |
349 | ||
350 | sub FETCH { | |
351 | my $self = shift ; | |
352 | my $key = shift ; | |
353 | $self->SUPER::FETCH($key) - 1 ; | |
354 | } | |
355 | ||
356 | sub put { | |
357 | my $self = shift ; | |
358 | my $key = shift ; | |
359 | my $value = shift ; | |
360 | $self->SUPER::put($key, $value * 3) ; | |
361 | } | |
362 | ||
363 | sub get { | |
364 | my $self = shift ; | |
365 | $self->SUPER::get($_[0], $_[1]) ; | |
366 | $_[1] -= 2 ; | |
367 | } | |
368 | ||
369 | sub A_new_method | |
370 | { | |
371 | my $self = shift ; | |
372 | my $key = shift ; | |
373 | my $value = $self->FETCH($key) ; | |
374 | return "[[$value]]" ; | |
375 | } | |
376 | ||
377 | 1 ; | |
378 | EOM | |
379 | ||
380 | close FILE ; | |
381 | ||
382 | BEGIN { push @INC, '.'; } | |
383 | eval 'use SubDB ; '; | |
384 | main::ok(53, $@ eq "") ; | |
385 | my %h ; | |
386 | my $X ; | |
387 | eval ' | |
388 | $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); | |
389 | ' ; | |
390 | ||
391 | main::ok(54, $@ eq "") ; | |
392 | ||
393 | my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; | |
394 | main::ok(55, $@ eq "") ; | |
395 | main::ok(56, $ret == 5) ; | |
396 | ||
397 | my $value = 0; | |
398 | $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; | |
399 | main::ok(57, $@ eq "") ; | |
400 | main::ok(58, $ret == 10) ; | |
401 | ||
402 | $ret = eval ' R_NEXT eq main::R_NEXT ' ; | |
403 | main::ok(59, $@ eq "" ) ; | |
404 | main::ok(60, $ret == 1) ; | |
405 | ||
406 | $ret = eval '$X->A_new_method("joe") ' ; | |
407 | main::ok(61, $@ eq "") ; | |
408 | main::ok(62, $ret eq "[[11]]") ; | |
409 | ||
fac76ed7 MB |
410 | undef $X; |
411 | untie(%h); | |
a6ed719b PM |
412 | unlink "SubDB.pm", "dbhash.tmp" ; |
413 | ||
414 | } | |
415 | ||
a0d0e21e | 416 | exit ; |