5 regress-win32.pl -- Helper for Windows regression tests
9 This perl script permits to run test Bacula Client Daemon on Windows.
11 - stop/start/upgrade the Bacula Client Daemon
12 - compare to subtree with checksums, attribs and ACL
13 - create test environments
17 X:\> regress-win32.pl [-b basedir] [-i ip_address] [-p c:/bacula]
19 X:\> perl regress-win32.pl ...
21 -b|--base=path Where to find regress and bacula directories
22 -i|--ip=ip Restrict access to this tool to this ip address
23 -p|--prefix=path Path to the windows installation
24 -h|--help Print this help
28 regress-win32.pl -b z:/git # will find z:/git/regress z:/git/bacula
30 regress-win32.pl -i 192.168.0.1 -b z:
34 This perl script needs a Perl distribution on the Windows Client
35 (http://strawberryperl.com)
37 You need to have the following subtree on x:
59 my $bacula_prefix="c:/Program Files/Bacula";
60 my $conf = "C:/Documents and Settings/All Users/Application Data/Bacula";
61 GetOptions("base=s" => \$base,
63 "prefix=s" => \$bacula_prefix,
67 pod2usage(-verbose => 2,
71 if (! -d $bacula_prefix) {
72 print "Could not find Bacula installation dir $bacula_prefix\n";
73 print "Won't be able to upgrade the version or modify the configuration\n";
76 if (-f "$bacula_prefix/bacula-fd.conf" and -f "$conf/bacula-fd.conf") {
77 print "Unable to determine bacula-fd location $bacula_prefix or $conf ?\n";
79 } elsif (-f "$bacula_prefix/bacula-fd.conf") {
80 $conf = $bacula_prefix;
83 #if (! -d "$base/bacula" || ! -d "$base/regress") {
84 # pod2usage(-verbose => 2,
86 # -message => "Can't find bacula or regress dir on $base\n");
92 return `net stop bacula-fd`;
95 # copy binaries for a new fd
98 copy("$base/bacula/src/win32/release32/bacula-fd.exe",
99 "c:/Program Files/bacula/bacula-fd.exe");
101 copy("$base/bacula/src/win32/release32/bacula.dll",
102 "c:/Program Files/bacula/bacula.dll");
105 # start the fd service
108 return `net start bacula-fd`;
111 # initialize the weird directory for runscript test
112 sub init_weird_runscript_test
116 if ($r->url !~ m!^/init_weird_runscript_test\?source=(\w:/[\w/]+)$!) {
117 return "ERR\nIncorrect url\n";
121 if (!chdir($source)) {
122 return "ERR\nCan't access to $source $!\n";
125 if (-d "weird_runscript") {
126 system("rmdir /Q /S weird_runscript");
129 mkdir("weird_runscript");
130 if (!chdir("weird_runscript")) {
131 return "ERR\nCan't access to $source $!\n";
134 open(FP, ">test.bat") or return "ERR\n";
135 print FP "\@echo off\n";
136 print FP "echo hello \%1\n";
139 copy("test.bat", "test space.bat") or return "ERR\n";
140 copy("test.bat", "test2 space.bat") or return "ERR\n";
141 copy("test.bat", "testé.bat") or return "ERR\n";
143 mkdir("dir space") or return "ERR\n";
144 copy("test.bat", "dir space") or return "ERR\n";
145 copy("testé.bat","dir space") or return "ERR\n";
146 copy("test2 space.bat", "dir space") or return "ERR\n";
148 mkdir("Évoilà") or return "ERR\n";
149 copy("test.bat", "Évoilà") or return "ERR\n";
150 copy("testé.bat","Évoilà") or return "ERR\n";
151 copy("test2 space.bat", "Évoilà") or return "ERR\n";
153 mkdir("Éwith space") or return "ERR\n";
154 copy("test.bat", "Éwith space") or return "ERR\n";
155 copy("testé.bat","Éwith space") or return "ERR\n";
156 copy("test2 space.bat", "Éwith space") or return "ERR\n";
160 # init the Attrib test by creating some files and settings attributes
165 if ($r->url !~ m!^/init_attrib_test\?source=(\w:/[\w/]+)$!) {
166 return "ERR\nIncorrect url\n";
171 if (!chdir($source)) {
172 return "ERR\nCan't access to $source $!\n";
175 # cleanup the old directory if any
176 if (-d "attrib_test") {
177 system("rmdir /Q /S attrib_test");
180 mkdir("attrib_test");
181 chdir("attrib_test");
184 mkdir("hidden/something");
185 system("attrib +H hidden");
188 mkdir("readonly/something");
189 system("attrib +R readonly");
192 mkdir("normal/something");
193 system("attrib -R -H -S normal");
196 mkdir("system/something");
197 system("attrib +S system");
199 mkdir("readonly_hidden");
200 mkdir("readonly_hidden/something");
201 system("attrib +R +H readonly_hidden");
203 my $ret = `attrib /S /D`;
204 $ret = strip_base($ret, $source);
212 open(FILE, $file) or return "Can't open $file $!";
214 return Digest::MD5->new->addfile(*FILE)->hexdigest;
217 # set $src and $dst before using Find call
222 my $f = $File::Find::name;
223 $f =~ s!^\Q$src\E/?!!i;
226 if (! -f "$dst/$f") {
227 $error .= "$dst/$f is missing\n";
229 my $a = md5sum("$src/$f");
230 my $b = md5sum("$dst/$f");
232 $error .= "$src/$f $a\n$dst/$f $b\n";
238 sub set_director_name
242 if ($r->url !~ m!^/set_director_name\?name=([\w\d\.\-]+);pass=([\w\d+]+)$!)
244 return "ERR\nIncorrect url\n";
247 my ($name, $pass) = ($1, $2);
249 open(ORG, "$conf/bacula-fd.conf") or return "ERR\nORG $!\n";
250 open(NEW, ">$conf/bacula-fd.conf.new") or return "ERR\nNEW $!\n";
253 while (my $l = <ORG>)
255 if ($l =~ /^\s*Director\s+{/i) {
258 } elsif ($l =~ /^(\s*)Name\s*=/ and $in_dir) {
259 print NEW "${1}Name=$name\n";
260 } elsif ($l =~ /^(\s*)Password\s*=/ and $in_dir) {
261 print NEW "${1}Password=$pass\n";
262 } elsif ($l =~ /\s*}/ and $in_dir) {
272 move("$conf/bacula-fd.conf.new", "$conf/bacula-fd.conf")
278 # convert \ to / and strip the path
281 my ($data, $path) = @_;
283 $data =~ s!\Q$path!!sig;
287 # Compare two directories, make checksums, compare attribs and ACLs
292 if ($r->url !~ m!^/compare\?source=(\w:/[\w/]+);dest=(\w:/[\w/]+)$!) {
293 return "ERR\nIncorrect url\n";
296 my ($source, $dest) = ($1, $2);
298 if (!Cwd::chdir($source)) {
299 return "ERR\nCan't access to $source $!\n";
302 my $src_attrib = `attrib /D /S`;
303 $src_attrib = strip_base($src_attrib, $source);
305 if (!Cwd::chdir($dest)) {
306 return "ERR\nCan't access to $dest $!\n";
309 my $dest_attrib = `attrib /D /S`;
310 $dest_attrib = strip_base($dest_attrib, $dest);
312 if (lc($src_attrib) ne lc($dest_attrib)) {
313 return "ERR\n$src_attrib\n=========\n$dest_attrib\n";
316 ($src, $dst, $error) = ($source, $dest, '');
317 find(\&wanted, $source);
319 return "ERR\n$error";
329 if ($r->url !~ m!^/cleandir\?source=(\w:/[\w/]+)/restore$!) {
330 return "ERR\nIncorrect url\n";
335 if (! -d "$source/restore") {
336 return "ERR\nIncorrect path\n";
339 if (!chdir($source)) {
340 return "ERR\nCan't access to $source $!\n";
343 system("rmdir /Q /S restore");
348 # When adding an action, fill this hash with the right function
352 install => \&install_fd,
353 compare => \&compare,
354 init_attrib_test => \&init_attrib_test,
355 init_weird_runscript_test => \&init_weird_runscript_test,
356 set_director_name => \&set_director_name,
357 cleandir => \&cleandir,
360 # handle client request
365 my $r = $c->get_request ;
368 $c->send_error(RC_FORBIDDEN) ;
371 if ($r->url->path !~ m!^/(\w+)!) {
372 $c->send_error(RC_NOT_FOUND) ;
377 if (($r->method eq 'GET')
378 and $action_list{$action})
380 my $ret = $action_list{$action}($r);
381 my $h = HTTP::Headers->new('Content-Type' => 'text/plain') ;
382 my $r = HTTP::Response->new(HTTP::Status::RC_OK,
385 $c->send_response($r) ;
387 $c->send_error(RC_NOT_FOUND) ;
393 my $d = HTTP::Daemon->new ( LocalPort => 8091,
395 || die "E : Can't bind $!" ;
397 my $olddir = Cwd::cwd();
400 my $ip = $c->peerhost;
402 $c->send_error(RC_FORBIDDEN) ;
403 } elsif ($src_ip && $ip ne $src_ip) {
404 $c->send_error(RC_FORBIDDEN) ;
406 handle_client($c, $ip) ;
408 $c->send_error(RC_FORBIDDEN) ;