Commit | Line | Data |
a0d0e21e |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | @INC = '../lib'; |
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 | |
15 | print "1..30\n"; |
16 | |
17 | $Dfile = "Op.db-recno"; |
18 | unlink $Dfile; |
19 | |
20 | umask(0); |
21 | |
22 | # Check the interface to RECNOINFO |
23 | |
24 | $dbh = TIEHASH DB_File::RECNOINFO ; |
25 | print (($dbh->{bval} == undef) ? "ok 1\n" : "not ok 1\n") ; |
26 | print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ; |
27 | print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ; |
28 | print (($dbh->{flags} == undef) ? "ok 4\n" : "not ok 4\n") ; |
29 | print (($dbh->{lorder} == undef) ? "ok 5\n" : "not ok 5\n") ; |
30 | print (($dbh->{reclen} == undef) ? "ok 6\n" : "not ok 6\n") ; |
31 | print (($dbh->{bfname} == undef) ? "ok 7\n" : "not ok 7\n") ; |
32 | |
33 | $dbh->{bval} = 3000 ; |
34 | print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ; |
35 | |
36 | $dbh->{cachesize} = 9000 ; |
37 | print ($dbh->{cachesize} == 9000 ? "ok 9\n" : "not ok 9\n") ; |
38 | |
39 | $dbh->{psize} = 400 ; |
40 | print (($dbh->{psize} == 400) ? "ok 10\n" : "not ok 10\n") ; |
41 | |
42 | $dbh->{flags} = 65 ; |
43 | print (($dbh->{flags} == 65) ? "ok 11\n" : "not ok 11\n") ; |
44 | |
45 | $dbh->{lorder} = 123 ; |
46 | print (($dbh->{lorder} == 123) ? "ok 12\n" : "not ok 12\n") ; |
47 | |
48 | $dbh->{reclen} = 1234 ; |
49 | print ($dbh->{reclen} == 1234 ? "ok 13\n" : "not ok 13\n") ; |
50 | |
51 | $dbh->{bfname} = 1234 ; |
52 | print ($dbh->{bfname} == 1234 ? "ok 14\n" : "not ok 14\n") ; |
53 | |
54 | |
55 | # Check that an invalid entry is caught both for store & fetch |
56 | eval '$dbh->{fred} = 1234' ; |
57 | print ($@ eq '' ? "ok 15\n" : "not ok 15\n") ; |
58 | eval '$q = $dbh->{fred}' ; |
59 | print ($@ eq '' ? "ok 16\n" : "not ok 16\n") ; |
60 | |
61 | # Now check the interface to RECNOINFO |
62 | |
63 | print (($X = tie(@h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO )) ? "ok 17\n" : "not ok 17"); |
64 | |
65 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
66 | $blksize,$blocks) = stat($Dfile); |
67 | print (($mode & 0777) == 0640 ? "ok 18\n" : "not ok 18\n"); |
68 | |
69 | #$l = @h ; |
70 | $l = $X->length ; |
71 | print (!$l ? "ok 19\n" : "not ok 19\n"); |
72 | |
73 | @data = qw( a b c d ever f g h i j k longername m n o p) ; |
74 | |
75 | $h[0] = shift @data ; |
76 | print ($h[0] eq 'a' ? "ok 20\n" : "not ok 20\n") ; |
77 | |
78 | foreach (@data) |
79 | { $h[++$i] = $_ } |
80 | |
81 | unshift (@data, 'a') ; |
82 | |
83 | print (defined $h[1] ? "ok 21\n" : "not ok 21\n"); |
84 | print (! defined $h[16] ? "ok 22\n" : "not ok 22\n"); |
85 | print ($X->length == @data ? "ok 23\n" : "not ok 23\n") ; |
86 | |
87 | |
88 | # Overwrite an entry & check fetch it |
89 | $h[3] = 'replaced' ; |
90 | $data[3] = 'replaced' ; |
91 | print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n"); |
92 | |
93 | #PUSH |
94 | @push_data = qw(added to the end) ; |
95 | #push (@h, @push_data) ; |
96 | $X->push(@push_data) ; |
97 | push (@data, @push_data) ; |
98 | print ($h[++$i] eq 'added' ? "ok 25\n" : "not ok 25\n"); |
99 | |
100 | # POP |
101 | pop (@data) ; |
102 | #$value = pop(@h) ; |
103 | $value = $X->pop ; |
104 | print ($value eq 'end' ? "not ok 26\n" : "ok 26\n"); |
105 | |
106 | # SHIFT |
107 | #$value = shift @h |
108 | $value = $X->shift ; |
109 | print ($value eq shift @data ? "not ok 27\n" : "ok 27\n"); |
110 | |
111 | # UNSHIFT |
112 | |
113 | # empty list |
114 | $X->unshift ; |
115 | print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ; |
116 | |
117 | @new_data = qw(add this to the start of the array) ; |
118 | #unshift @h, @new_data ; |
119 | $X->unshift (@new_data) ; |
120 | unshift (@data, @new_data) ; |
121 | print ($X->length == @data ? "ok 29\n" : "not ok 29\n") ; |
122 | |
123 | # SPLICE |
124 | |
125 | # Now both arrays should be identical |
126 | |
127 | $ok = 1 ; |
128 | $j = 0 ; |
129 | foreach (@data) |
130 | { |
131 | $ok = 0, last if $_ ne $h[$j ++] ; |
132 | } |
133 | print ($ok ? "ok 30\n" : "not ok 30\n") ; |
134 | |
135 | # IMPORTANT - $X must be undefined before the untie otherwise the |
136 | # underlying DB close routine will not get called. |
137 | undef $X ; |
138 | untie(@h); |
139 | |
140 | unlink $Dfile; |
141 | |
142 | exit ; |