LC_COLLATE.
[perl.git] / t / lib / db-hash.t
1 #!./perl 
2 #!./perl -w 
3
4 BEGIN {
5     #@INC = '../lib' if -d '../lib' ;
6     @INC = '../lib' ;
7     require Config; import Config;
8     if ($Config{'extensions'} !~ /\bDB_File\b/) {
9         print "1..0\n";
10         exit 0;
11     }
12 }
13
14 use DB_File; 
15 use Fcntl;
16
17 print "1..48\n";
18
19 sub ok
20 {
21     my $no = shift ;
22     my $result = shift ;
23  
24     print "not " unless $result ;
25     print "ok $no\n" ;
26 }
27
28 $Dfile = "dbhash.tmp";
29 unlink $Dfile;
30
31 umask(0);
32
33 # Check the interface to HASHINFO
34
35 my $dbh = new DB_File::HASHINFO ;
36
37 $^W = 0 ;
38 ok(1, $dbh->{bsize} == undef) ;
39 ok(2, $dbh->{ffactor} == undef) ;
40 ok(3, $dbh->{nelem} == undef) ;
41 ok(4, $dbh->{cachesize} == undef) ;
42 ok(5, $dbh->{hash} == undef) ;
43 ok(6, $dbh->{lorder} == undef) ;
44 $^W = 1 ;
45
46 $dbh->{bsize} = 3000 ;
47 ok(7, $dbh->{bsize} == 3000 );
48
49 $dbh->{ffactor} = 9000 ;
50 ok(8, $dbh->{ffactor} == 9000 );
51
52 $dbh->{nelem} = 400 ;
53 ok(9, $dbh->{nelem} == 400 );
54
55 $dbh->{cachesize} = 65 ;
56 ok(10, $dbh->{cachesize} == 65 );
57
58 $dbh->{hash} = "abc" ;
59 ok(11, $dbh->{hash} eq "abc" );
60
61 $dbh->{lorder} = 1234 ;
62 ok(12, $dbh->{lorder} == 1234 );
63
64 # Check that an invalid entry is caught both for store & fetch
65 eval '$dbh->{fred} = 1234' ;
66 ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
67 eval '$q = $dbh->{fred}' ;
68 ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
69
70 # Now check the interface to HASH
71
72 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
73
74 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
75    $blksize,$blocks) = stat($Dfile);
76 ok(16, ($mode & 0777) == 0640 );
77
78 while (($key,$value) = each(%h)) {
79     $i++;
80 }
81 ok(17, !$i );
82
83 $h{'goner1'} = 'snork';
84
85 $h{'abc'} = 'ABC';
86 ok(18, $h{'abc'} eq 'ABC' );
87 ok(19, !defined $h{'jimmy'} );
88 ok(20, !exists $h{'jimmy'} );
89 ok(21, exists $h{'abc'} );
90
91 $h{'def'} = 'DEF';
92 $h{'jkl','mno'} = "JKL\034MNO";
93 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
94 $h{'a'} = 'A';
95
96 #$h{'b'} = 'B';
97 $X->STORE('b', 'B') ;
98
99 $h{'c'} = 'C';
100
101 #$h{'d'} = 'D';
102 $X->put('d', 'D') ;
103
104 $h{'e'} = 'E';
105 $h{'f'} = 'F';
106 $h{'g'} = 'X';
107 $h{'h'} = 'H';
108 $h{'i'} = 'I';
109
110 $h{'goner2'} = 'snork';
111 delete $h{'goner2'};
112
113
114 # IMPORTANT - $X must be undefined before the untie otherwise the
115 #             underlying DB close routine will not get called.
116 undef $X ;
117 untie(%h);
118
119
120 # tie to the same file again, do not supply a type - should default to HASH
121 ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
122
123 # Modify an entry from the previous tie
124 $h{'g'} = 'G';
125
126 $h{'j'} = 'J';
127 $h{'k'} = 'K';
128 $h{'l'} = 'L';
129 $h{'m'} = 'M';
130 $h{'n'} = 'N';
131 $h{'o'} = 'O';
132 $h{'p'} = 'P';
133 $h{'q'} = 'Q';
134 $h{'r'} = 'R';
135 $h{'s'} = 'S';
136 $h{'t'} = 'T';
137 $h{'u'} = 'U';
138 $h{'v'} = 'V';
139 $h{'w'} = 'W';
140 $h{'x'} = 'X';
141 $h{'y'} = 'Y';
142 $h{'z'} = 'Z';
143
144 $h{'goner3'} = 'snork';
145
146 delete $h{'goner1'};
147 $X->DELETE('goner3');
148
149 @keys = keys(%h);
150 @values = values(%h);
151
152 ok(23, $#keys == 29 && $#values == 29) ;
153
154 $i = 0 ;
155 while (($key,$value) = each(%h)) {
156     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
157         $key =~ y/a-z/A-Z/;
158         $i++ if $key eq $value;
159     }
160 }
161
162 ok(24, $i == 30) ;
163
164 @keys = ('blurfl', keys(%h), 'dyick');
165 ok(25, $#keys == 31) ;
166
167 $h{'foo'} = '';
168 ok(26, $h{'foo'} eq '' );
169
170 $h{''} = 'bar';
171 ok(27, $h{''} eq 'bar' );
172
173 # check cache overflow and numeric keys and contents
174 $ok = 1;
175 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
176 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
177 ok(28, $ok );
178
179 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
180    $blksize,$blocks) = stat($Dfile);
181 ok(29, $size > 0 );
182
183 @h{0..200} = 200..400;
184 @foo = @h{0..200};
185 ok(30, join(':',200..400) eq join(':',@foo) );
186
187
188 # Now check all the non-tie specific stuff
189
190 # Check NOOVERWRITE will make put fail when attempting to overwrite
191 # an existing record.
192  
193 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
194 ok(31, $status == 1 );
195  
196 # check that the value of the key 'x' has not been changed by the 
197 # previous test
198 ok(32, $h{'x'} eq 'X' );
199
200 # standard put
201 $status = $X->put('key', 'value') ;
202 ok(33, $status == 0 );
203
204 #check that previous put can be retrieved
205 $value = 0 ;
206 $status = $X->get('key', $value) ;
207 ok(34, $status == 0 );
208 ok(35, $value eq 'value' );
209
210 # Attempting to delete an existing key should work
211
212 $status = $X->del('q') ;
213 ok(36, $status == 0 );
214
215 # Make sure that the key deleted, cannot be retrieved
216 $^W = 0 ;
217 ok(37, $h{'q'} eq undef );
218 $^W = 1 ;
219
220 # Attempting to delete a non-existant key should fail
221
222 $status = $X->del('joe') ;
223 ok(38, $status == 1 );
224
225 # Check the get interface
226
227 # First a non-existing key
228 $status = $X->get('aaaa', $value) ;
229 ok(39, $status == 1 );
230
231 # Next an existing key
232 $status = $X->get('a', $value) ;
233 ok(40, $status == 0 );
234 ok(41, $value eq 'A' );
235
236 # seq
237 # ###
238
239 # ditto, but use put to replace the key/value pair.
240
241 # use seq to walk backwards through a file - check that this reversed is
242
243 # check seq FIRST/LAST
244
245 # sync
246 # ####
247
248 $status = $X->sync ;
249 ok(42, $status == 0 );
250
251
252 # fd
253 # ##
254
255 $status = $X->fd ;
256 ok(43, $status != 0 );
257
258 undef $X ;
259 untie %h ;
260
261 unlink $Dfile;
262
263 # clear
264 # #####
265
266 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
267 foreach (1 .. 10)
268   { $h{$_} = $_ * 100 }
269
270 # check that there are 10 elements in the hash
271 $i = 0 ;
272 while (($key,$value) = each(%h)) {
273     $i++;
274 }
275 ok(45, $i == 10);
276
277 # now clear the hash
278 %h = () ;
279
280 # check it is empty
281 $i = 0 ;
282 while (($key,$value) = each(%h)) {
283     $i++;
284 }
285 ok(46, $i == 0);
286
287 untie %h ;
288 unlink $Dfile ;
289
290
291 # Now try an in memory file
292 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
293
294 # fd with an in memory file should return fail
295 $status = $X->fd ;
296 ok(48, $status == -1 );
297
298 untie %h ;
299 undef $X ;
300
301 exit ;