This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid negative return value from Win32::GetTickCount()
[perl5.git] / t / lib / sdbm.t
CommitLineData
a687059c
LW
1#!./perl
2
79072805 3# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
a687059c 4
85e6fe83 5BEGIN {
a0d0e21e 6 chdir 't' if -d 't';
93430cb4 7 unshift @INC, '../lib';
85e6fe83 8 require Config; import Config;
bf99883d 9 if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){
a0d0e21e 10 print "1..0\n";
85e6fe83
LW
11 exit 0;
12 }
13}
8990e307 14require SDBM_File;
a0d0e21e
LW
15#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
16use Fcntl;
a687059c 17
f4b9d880 18print "1..20\n";
a687059c 19
bf99883d 20unlink <Op_dbmx.*>;
79072805 21
a687059c 22umask(0);
bf99883d 23print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640)
544a3566 24 ? "ok 1\n" : "not ok 1\n");
79072805 25
bf99883d 26$Dfile = "Op_dbmx.pag";
79072805 27if (! -e $Dfile) {
bf99883d 28 ($Dfile) = <Op_dbmx.*>;
79072805 29}
39e571d4 30if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') {
fac76ed7 31 print "ok 2 # Skipped: different file permission semantics\n";
544a3566
CS
32}
33else {
34 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
35 $blksize,$blocks) = stat($Dfile);
36 print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
37}
463ee0b2 38while (($key,$value) = each(%h)) {
a687059c
LW
39 $i++;
40}
41print (!$i ? "ok 3\n" : "not ok 3\n");
42
43$h{'goner1'} = 'snork';
44
45$h{'abc'} = 'ABC';
46$h{'def'} = 'DEF';
47$h{'jkl','mno'} = "JKL\034MNO";
48$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
49$h{'a'} = 'A';
50$h{'b'} = 'B';
51$h{'c'} = 'C';
52$h{'d'} = 'D';
53$h{'e'} = 'E';
54$h{'f'} = 'F';
55$h{'g'} = 'G';
56$h{'h'} = 'H';
57$h{'i'} = 'I';
58
59$h{'goner2'} = 'snork';
60delete $h{'goner2'};
61
463ee0b2 62untie(%h);
bf99883d 63print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
a687059c
LW
64
65$h{'j'} = 'J';
66$h{'k'} = 'K';
67$h{'l'} = 'L';
68$h{'m'} = 'M';
69$h{'n'} = 'N';
70$h{'o'} = 'O';
71$h{'p'} = 'P';
72$h{'q'} = 'Q';
73$h{'r'} = 'R';
74$h{'s'} = 'S';
75$h{'t'} = 'T';
76$h{'u'} = 'U';
77$h{'v'} = 'V';
78$h{'w'} = 'W';
79$h{'x'} = 'X';
80$h{'y'} = 'Y';
81$h{'z'} = 'Z';
82
83$h{'goner3'} = 'snork';
84
85delete $h{'goner1'};
86delete $h{'goner3'};
87
88@keys = keys(%h);
89@values = values(%h);
90
91if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
92
c6aa4a32 93while (($key,$value) = each(%h)) {
2f52a358 94 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
a687059c
LW
95 $key =~ y/a-z/A-Z/;
96 $i++ if $key eq $value;
97 }
98}
99
100if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
101
c6aa4a32 102@keys = ('blurfl', keys(%h), 'dyick');
a687059c
LW
103if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
104
fe14fcc3
LW
105$h{'foo'} = '';
106$h{''} = 'bar';
107
a687059c
LW
108# check cache overflow and numeric keys and contents
109$ok = 1;
110for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
111for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
112print ($ok ? "ok 8\n" : "not ok 8\n");
113
114($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
79072805 115 $blksize,$blocks) = stat($Dfile);
a687059c
LW
116print ($size > 0 ? "ok 9\n" : "not ok 9\n");
117
0f85fab0
LW
118@h{0..200} = 200..400;
119@foo = @h{0..200};
fe14fcc3
LW
120print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
121
122print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
123print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
0f85fab0 124
4e2a63a7
PM
125
126sub ok
127{
128 my $no = shift ;
129 my $result = shift ;
130
131 print "not " unless $result ;
132 print "ok $no\n" ;
133}
134
135{
136 # sub-class test
137
138 package Another ;
139
140 use strict ;
141
142 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
143 print FILE <<'EOM' ;
144
145 package SubDB ;
146
147 use strict ;
148 use vars qw( @ISA @EXPORT) ;
149
150 require Exporter ;
151 use SDBM_File;
152 @ISA=qw(SDBM_File);
153 @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ;
154
155 sub STORE {
156 my $self = shift ;
157 my $key = shift ;
158 my $value = shift ;
159 $self->SUPER::STORE($key, $value * 2) ;
160 }
161
162 sub FETCH {
163 my $self = shift ;
164 my $key = shift ;
165 $self->SUPER::FETCH($key) - 1 ;
166 }
167
168 sub A_new_method
169 {
170 my $self = shift ;
171 my $key = shift ;
172 my $value = $self->FETCH($key) ;
173 return "[[$value]]" ;
174 }
175
176 1 ;
177EOM
178
179 close FILE ;
180
181 BEGIN { push @INC, '.'; }
182
183 eval 'use SubDB ; use Fcntl ;';
184 main::ok(13, $@ eq "") ;
185 my %h ;
186 my $X ;
187 eval '
bf99883d 188 $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
4e2a63a7
PM
189 ' ;
190
191 main::ok(14, $@ eq "") ;
192
193 my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
194 main::ok(15, $@ eq "") ;
195 main::ok(16, $ret == 5) ;
196
197 $ret = eval '$X->A_new_method("fred") ' ;
198 main::ok(17, $@ eq "") ;
199 main::ok(18, $ret eq "[[5]]") ;
200
fac76ed7
MB
201 undef $X;
202 untie(%h);
bf99883d 203 unlink "SubDB.pm", <dbhash_tmp.*> ;
4e2a63a7
PM
204
205}
f4b9d880
RA
206
207ok(19, !exists $h{'goner1'});
208ok(20, exists $h{'foo'});
209
210untie %h;
211if ($^O eq 'VMS') {
212 unlink 'Op_dbmx.sdbm_dir', $Dfile;
213} else {
214 unlink 'Op_dbmx.dir', $Dfile;
215}