CoCalc Public Fileswww / cgi-bin / openwebmail / misc / test / dbmtest.plOpen with one click!
Author: William A. Stein
1
#!/usr/bin/perl
2
#
3
# find out proper settings for option dbm_ext, dbmopen_ext and dbmopen_haslock
4
#
5
use strict;
6
use Fcntl qw(:DEFAULT :flock);
7
use FileHandle;
8
9
print "\n";
10
11
check_tell_bug();
12
my ($dbm_ext, $dbmopen_ext, $dbmopen_haslock)=guessoptions();
13
print_dbm_module();
14
check_db_file_pm();
15
print_dbm_option($dbm_ext, $dbmopen_ext, $dbmopen_haslock);
16
check_savedsuid_support();
17
18
exit 0;
19
20
# test routines #########################################################
21
22
sub check_tell_bug {
23
my $offset;
24
my $testfile="/tmp/testfile.$$";
25
($testfile =~ /^(.+)$/) && ($testfile = $1);
26
27
open(F, ">$testfile"); print F "test"; close(F);
28
open(F, ">>$testfile"); $offset=tell(F); close(F);
29
unlink($testfile);
30
31
if ($offset==0) {
32
print qq|WARNING!\n\n|.
33
qq|The perl on your system has serious bug in routine tell()!\n|.
34
qq|While openwebmail can work properly with this bug, other perl application\n|.
35
qq|may not function properly and thus cause data loss.\n\n|.
36
qq|We suggest that you should patch your perl as soon as possible.\n\n\n|.
37
return -1;
38
}
39
return 0;
40
}
41
42
sub guessoptions {
43
my (%DB, @filelist, @delfiles);
44
my ($dbm_ext, $dbmopen_ext, $dbmopen_haslock);
45
46
mkdir ("/tmp/dbmtest.$$", 0755);
47
48
dbmopen(%DB, "/tmp/dbmtest.$$/test", 0600); dbmclose(%DB);
49
50
@delfiles=();
51
opendir(TESTDIR, "/tmp/dbmtest.$$");
52
while (defined(my $filename = readdir(TESTDIR))) {
53
($filename =~ /^(.+)$/) && ($filename = $1); # untaint ...
54
if ($filename!~/^\./ ) {
55
push(@filelist, $filename);
56
push(@delfiles, "/tmp/dbmtest.$$/$filename");
57
}
58
}
59
closedir(TESTDIR);
60
unlink(@delfiles) if ($#delfiles>=0);
61
62
@filelist=reverse sort(@filelist);
63
if ($filelist[0]=~/(\..*)$/) {
64
($dbm_ext, $dbmopen_ext)=($1, '');
65
} else {
66
($dbm_ext, $dbmopen_ext)=('.db', '.db');
67
}
68
69
my $result;
70
flock_lock("/tmp/dbmtest.$$/test$dbm_ext", LOCK_EX);
71
eval {
72
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
73
alarm 5; # timeout 5 sec
74
$result = dbmopen(%DB, "/tmp/dbmtest.$$/test$dbmopen_ext", 0600);
75
dbmclose(%DB) if ($result);
76
alarm 0;
77
};
78
if ([email protected] or !$result) { # eval error, it means timeout
79
$dbmopen_haslock=1;
80
} else {
81
$dbmopen_haslock=0;
82
}
83
flock_lock("/tmp/dbmtest.$$/test$dbm_ext", LOCK_UN);
84
85
@delfiles=();
86
opendir(TESTDIR, "/tmp/dbmtest.$$");
87
while (defined(my $filename = readdir(TESTDIR))) {
88
($filename =~ /^(.+)$/) && ($filename = $1); # untaint ...
89
push(@delfiles, "/tmp/dbmtest.$$/$filename") if ($filename!~/^\./ );
90
}
91
closedir(TESTDIR);
92
unlink(@delfiles) if ($#delfiles>=0);
93
94
rmdir("/tmp/dbmtest.$$");
95
96
return($dbm_ext, $dbmopen_ext, $dbmopen_haslock);
97
}
98
99
sub print_dbm_module {
100
print "You perl uses the following packages for dbm::\n\n";
101
my @pm;
102
foreach (keys %INC) { push (@pm, $_) if (/DB.*File/); }
103
foreach (sort @pm) { print "$_\t\t$INC{$_}\n"; }
104
print "\n\n";
105
}
106
107
sub check_db_file_pm {
108
my $dbfile_pm=$INC{'DB_File.pm'};
109
if ($dbfile_pm) {
110
my $t;
111
open(F, $dbfile_pm); while(<F>) {$t.=$_;} close(F);
112
$t=~s/\s//gms;
113
if ($t!~/\$arg\[3\]=0666unlessdefined\$arg\[3\];/sm) {
114
print qq|Please modify $dbfile_pm by adding\n\n|.
115
qq|\t\$arg[3] = 0666 unless defined \$arg[3];\n\n|.
116
qq|before the following text (about line 247)\n\n|.
117
qq|\t# make recno in Berkeley DB version 2 work like recno in version 1\n\n\n|;
118
return -1;
119
}
120
}
121
return 0;
122
}
123
124
sub print_dbm_option {
125
my ($dbm_ext, $dbmopen_ext, $dbmopen_haslock)=@_;
126
127
$dbm_ext='none' if ($dbm_ext eq '');
128
$dbmopen_ext='none' if ($dbmopen_ext eq '');
129
if ($dbmopen_haslock) {
130
$dbmopen_haslock='yes';
131
} else {
132
$dbmopen_haslock='no';
133
}
134
print qq|The dbm options in dbm.conf should be set as follows:\n\n|.
135
qq|dbm_ext \t\t$dbm_ext\n|.
136
qq|dbmopen_ext\t\t$dbmopen_ext\n|.
137
qq|dbmopen_haslock\t\t$dbmopen_haslock\n\n\n|;
138
}
139
140
sub check_savedsuid_support {
141
return if ($>!=0);
142
143
$>=65534;
144
$>=0;
145
if ($>!=0) {
146
print qq|Your system didn't have saved suid support,\n|.
147
qq|please set the following option in suid.conf\n\n|.
148
qq|\tsavedsuid_support no\n\n\n|;
149
return -1;
150
}
151
return 0;
152
}
153
154
155
# Routine from filelock.pl ##############################################
156
use vars qw(%opentable);
157
%opentable=();
158
159
# this routine provides flock with filename
160
# it opens the file to get the handle if need,
161
# than do lock operation on the related filehandle
162
sub flock_lock {
163
my ($filename, $lockflag, $perm)[email protected]_;
164
($filename =~ /^(.+)$/) && ($filename = $1); # untaint ...
165
166
my ($dev, $inode, $fh, $n, $retval);
167
168
# deal unlock first
169
if ($lockflag & LOCK_UN) {
170
return 1 if ( !-e $filename);
171
($dev, $inode)=(stat($filename))[0,1];
172
return 0 if ($dev eq '' || $inode eq '');
173
174
if (defined($opentable{"$dev-$inode"}) ) {
175
$fh=$opentable{"$dev-$inode"}{fh};
176
$retval=flock($fh, LOCK_UN);
177
if ($retval) {
178
$opentable{"$dev-$inode"}{n}--;
179
if ($opentable{"$dev-$inode"}{n}==0) {
180
delete($opentable{"$dev-$inode"});
181
close($fh) if ( defined(fileno($fh)) );
182
}
183
}
184
} else {
185
return 0;
186
}
187
return $retval;
188
}
189
190
# else are file lock
191
if (!-e $filename) {
192
$perm=0600 if (!$perm);
193
sysopen(F, $filename, O_RDWR|O_CREAT, $perm) or return 0; # create file for lock
194
close(F);
195
}
196
($dev, $inode)=(stat($filename))[0,1];
197
return 0 if ($dev eq '' || $inode eq '');
198
199
if (!defined($opentable{"$dev-$inode"}) ) {
200
$fh=do { local *FH };
201
if (sysopen($fh, $filename, O_RDWR) || # try RDWR open first
202
sysopen($fh, $filename, O_RDONLY) ) { # then RDONLY for readonly file
203
$opentable{"$dev-$inode"}{fh}=$fh;
204
} else {
205
return 0;
206
}
207
} else {
208
$fh=$opentable{"$dev-$inode"}{fh};
209
}
210
211
# turn nonblocking lock to 30 secs timeouted lock
212
# so owm gets higher chance to success in case other ap locks same file for only few secs
213
# turn blocking lock to 120 secs timeouted lock
214
# so openwebmaill won't hang because of file locking
215
eval {
216
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
217
if ( $lockflag & LOCK_NB ) { # nonblocking lock
218
alarm 30;
219
} else {
220
alarm 120;
221
}
222
$retval=flock($fh, $lockflag&(~LOCK_NB));
223
alarm 0;
224
};
225
$retval=0 if ([email protected]); # eval error, it means timeout
226
$opentable{"$dev-$inode"}{n}++ if ($retval);
227
228
return($retval);
229
}
230