git.sur5r.net Git - bacula/bacula/blob - regress/scripts/regress-win32.pl

   1 #!/usr/bin/perl -w
   2
   3 =head1 NAME
   4
   5     regress-win32.pl -- Helper for Windows regression tests
   6
   7 =head2 DESCRIPTION
   8
   9     This perl script permits to run test Bacula Client Daemon on Windows.
  10     It allows to:
  11        - stop/start/upgrade the Bacula Client Daemon
  12        - compare to subtree with checksums, attribs and ACL
  13        - create test environments
  14
  15 =head2 USAGE
  16
  17   X:\> regress-win32.pl [-b basedir] [-i ip_address] [-p c:/bacula]
  18    or
  19   X:\> perl regress-win32.pl ...
  20
  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
  25
  26 =head2 EXAMPLE
  27
  28     regress-win32.pl -b z:/git         # will find z:/git/regress z:/git/bacula
  29
  30     regress-win32.pl -i 192.168.0.1 -b z:
  31
  32 =head2 INSTALL
  33
  34     This perl script needs a Perl distribution on the Windows Client
  35     (http://strawberryperl.com)
  36
  37     You need to have the following subtree on x:
  38     x:/
  39       bacula/
  40       regress/
  41
  42 =cut
  43
  44 use strict;
  45 use HTTP::Daemon;
  46 use HTTP::Status;
  47 use HTTP::Response;
  48 use HTTP::Headers;
  49 use File::Copy;
  50 use Pod::Usage;
  51 use Cwd 'chdir';
  52 use File::Find;
  53 use Digest::MD5;
  54 use Getopt::Long ;
  55
  56 my $base = 'x:';
  57 my $src_ip = '';
  58 my $help;
  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,
  62            "help"     => \$help,
  63            "prefix=s" => \$bacula_prefix,
  64            "ip=s"     => \$src_ip);
  65
  66 if ($help) {
  67     pod2usage(-verbose => 2,
  68               -exitval => 0);
  69 }
  70
  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";
  74 }
  75
  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";
  78
  79 } elsif (-f "$bacula_prefix/bacula-fd.conf") {
  80     $conf = $bacula_prefix;
  81 }
  82
  83 #if (! -d "$base/bacula" || ! -d "$base/regress") {
  84 #    pod2usage(-verbose => 2,
  85 #              -exitval => 1,
  86 #              -message => "Can't find bacula or regress dir on $base\n");
  87 #}
  88
  89 # stop the fd service
  90 sub stop_fd
  91 {
  92     return `net stop bacula-fd`;
  93 }
  94
  95 # copy binaries for a new fd
  96 sub install_fd
  97 {
  98     copy("$base/bacula/src/win32/release32/bacula-fd.exe",
  99          "c:/Program Files/bacula/bacula-fd.exe");
 100
 101     copy("$base/bacula/src/win32/release32/bacula.dll",
 102          "c:/Program Files/bacula/bacula.dll");
 103 }
 104
 105 # start the fd service
 106 sub start_fd
 107 {
 108     return `net start bacula-fd`;
 109 }
 110
 111 # initialize the weird directory for runscript test
 112 sub init_weird_runscript_test
 113 {
 114     my ($r) = shift;
 115
 116     if ($r->url !~ m!^/init_weird_runscript_test\?source=(\w:/[\w/]+)$!) {
 117         return "ERR\nIncorrect url\n";
 118     }
 119     my $source = $1;
 120
 121     if (!chdir($source)) {
 122         return "ERR\nCan't access to $source $!\n";
 123     }
 124
 125     if (-d "weird_runscript") {
 126         system("rmdir /Q /S weird_runscript");
 127     }
 128
 129     mkdir("weird_runscript");
 130     if (!chdir("weird_runscript")) {
 131         return "ERR\nCan't access to $source $!\n";
 132     }
 133
 134     open(FP, ">test.bat")                 or return "ERR\n";
 135     print FP "\@echo off\n";
 136     print FP "echo hello \%1\n";
 137     close(FP);
 138
 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";
 142
 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";
 147
 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";
 152
 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";
 157     return "OK\n";
 158 }
 159
 160 # init the Attrib test by creating some files and settings attributes
 161 sub init_attrib_test
 162 {
 163     my ($r) = shift;
 164
 165     if ($r->url !~ m!^/init_attrib_test\?source=(\w:/[\w/]+)$!) {
 166         return "ERR\nIncorrect url\n";
 167     }
 168
 169     my $source = $1;
 170
 171     if (!chdir($source)) {
 172         return "ERR\nCan't access to $source $!\n";
 173     }
 174
 175     # cleanup the old directory if any
 176     if (-d "attrib_test") {
 177         system("rmdir /Q /S attrib_test");
 178     }
 179
 180     mkdir("attrib_test");
 181     chdir("attrib_test");
 182
 183     mkdir("hidden");
 184     mkdir("hidden/something");
 185     system("attrib +H hidden");
 186
 187     mkdir("readonly");
 188     mkdir("readonly/something");
 189     system("attrib +R readonly");
 190
 191     mkdir("normal");
 192     mkdir("normal/something");
 193     system("attrib -R -H -S normal");
 194
 195     mkdir("system");
 196     mkdir("system/something");
 197     system("attrib +S system");
 198
 199     mkdir("readonly_hidden");
 200     mkdir("readonly_hidden/something");
 201     system("attrib +R +H readonly_hidden");
 202
 203     my $ret = `attrib /S /D`;
 204     $ret = strip_base($ret, $source);
 205
 206     return "OK\n$ret\n";
 207 }
 208
 209 sub md5sum
 210 {
 211     my $file = shift;
 212     open(FILE, $file) or return "Can't open $file $!";
 213     binmode(FILE);
 214     return Digest::MD5->new->addfile(*FILE)->hexdigest;
 215 }
 216
 217 # set $src and $dst before using Find call
 218 my ($src, $dst);
 219 my $error="";
 220 sub wanted
 221 {
 222     my $f = $File::Find::name;
 223     $f =~ s!^\Q$src\E/?!!i;
 224
 225     if (-f "$src/$f") {
 226         if (! -f "$dst/$f") {
 227             $error .= "$dst/$f is missing\n";
 228         } else {
 229             my $a = md5sum("$src/$f");
 230             my $b = md5sum("$dst/$f");
 231             if ($a ne $b) {
 232                 $error .= "$src/$f $a\n$dst/$f $b\n";
 233             }
 234         }
 235     }
 236 }
 237
 238 sub set_director_name
 239 {
 240     my ($r) = shift;
 241
 242     if ($r->url !~ m!^/set_director_name\?name=([\w\d\.\-]+);pass=([\w\d+]+)$!)
 243     {
 244         return "ERR\nIncorrect url\n";
 245     }
 246
 247     my ($name, $pass) = ($1, $2);
 248
 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";
 251
 252     my $in_dir=0;               # don't use monitoring section
 253     my $nb_dir="";
 254     while (my $l = <ORG>)
 255     {
 256         if ($l =~ /^\s*Director\s+{/i) {
 257             print NEW $l;
 258             $in_dir = 1;
 259         } elsif ($l =~ /^(\s*)Name\s*=/ and $in_dir) {
 260             print NEW "${1}Name=$name$nb_dir\n";
 261         } elsif ($l =~ /^(\s*)Password\s*=/ and $in_dir) {
 262             print NEW "${1}Password=$pass\n";
 263         } elsif ($l =~ /\s*}/ and $in_dir) {
 264             print NEW $l;
 265             $in_dir = 0;
 266             $nb_dir++;
 267         } else {
 268             print NEW $l;
 269         }
 270     }
 271
 272     close(ORG);
 273     close(NEW);
 274     move("$conf/bacula-fd.conf.new", "$conf/bacula-fd.conf")
 275         and return "OK\n";
 276
 277     return "ERR\n";
 278 }
 279
 280 # convert \ to / and strip the path
 281 sub strip_base
 282 {
 283     my ($data, $path) = @_;
 284     $data =~ s!\\!/!sg;
 285     $data =~ s!\Q$path!!sig;
 286     return $data;
 287 }
 288
 289 # Compare two directories, make checksums, compare attribs and ACLs
 290 sub compare
 291 {
 292     my ($r) = shift;
 293
 294     if ($r->url !~ m!^/compare\?source=(\w:/[\w/]+);dest=(\w:/[\w/]+)$!) {
 295         return "ERR\nIncorrect url\n";
 296     }
 297
 298     my ($source, $dest) = ($1, $2);
 299
 300     if (!Cwd::chdir($source)) {
 301         return "ERR\nCan't access to $source $!\n";
 302     }
 303
 304     my $src_attrib = `attrib /D /S`;
 305     $src_attrib = strip_base($src_attrib, $source);
 306
 307     if (!Cwd::chdir($dest)) {
 308         return "ERR\nCan't access to $dest $!\n";
 309     }
 310
 311     my $dest_attrib = `attrib /D /S`;
 312     $dest_attrib = strip_base($dest_attrib, $dest);
 313
 314     if (lc($src_attrib) ne lc($dest_attrib)) {
 315         return "ERR\n$src_attrib\n=========\n$dest_attrib\n";
 316     }
 317
 318     ($src, $dst, $error) = ($source, $dest, '');
 319     find(\&wanted, $source);
 320     if ($error) {
 321         return "ERR\n$error";
 322     } else {
 323         return "OK\n";
 324     }
 325 }
 326
 327 sub cleandir
 328 {
 329     my ($r) = shift;
 330
 331     if ($r->url !~ m!^/cleandir\?source=(\w:/[\w/]+)/restore$!) {
 332         return "ERR\nIncorrect url\n";
 333     }
 334
 335     my $source = $1;
 336
 337     if (! -d "$source/restore") {
 338         return "ERR\nIncorrect path\n";
 339     }
 340
 341     if (!chdir($source)) {
 342         return "ERR\nCan't access to $source $!\n";
 343     }
 344
 345     system("rmdir /Q /S restore");
 346
 347     return "OK\n";
 348 }
 349
 350 # When adding an action, fill this hash with the right function
 351 my %action_list = (
 352     stop    => \&stop_fd,
 353     start   => \&start_fd,
 354     install => \&install_fd,
 355     compare => \&compare,
 356     init_attrib_test => \&init_attrib_test,
 357     init_weird_runscript_test => \&init_weird_runscript_test,
 358     set_director_name => \&set_director_name,
 359     cleandir => \&cleandir,
 360     );
 361
 362 # handle client request
 363 sub handle_client
 364 {
 365     my ($c, $ip) = @_ ;
 366     my $action;
 367     my $r = $c->get_request ;
 368
 369     if (!$r) {
 370         $c->send_error(RC_FORBIDDEN) ;
 371         return;
 372     }
 373     if ($r->url->path !~ m!^/(\w+)!) {
 374         $c->send_error(RC_NOT_FOUND) ;
 375         return;
 376     }
 377     $action = $1;
 378
 379     if (($r->method eq 'GET')
 380         and $action_list{$action})
 381     {
 382         my $ret = $action_list{$action}($r);
 383         my $h = HTTP::Headers->new('Content-Type' => 'text/plain') ;
 384         my $r = HTTP::Response->new(HTTP::Status::RC_OK,
 385                                     'OK', $h, $ret) ;
 386
 387         $c->send_response($r) ;
 388     } else {
 389         $c->send_error(RC_NOT_FOUND) ;
 390     }
 391
 392     $c->close;
 393 }
 394
 395 my $d = HTTP::Daemon->new ( LocalPort =>  8091,
 396                             ReuseAddr => 1)
 397     || die "E : Can't bind $!" ;
 398
 399 my $olddir = Cwd::cwd();
 400 while (1) {
 401     my $c = $d->accept ;
 402     my $ip = $c->peerhost;
 403     if (!$ip) {
 404         $c->send_error(RC_FORBIDDEN) ;
 405     } elsif ($src_ip && $ip ne $src_ip) {
 406         $c->send_error(RC_FORBIDDEN) ;
 407     } elsif ($c) {
 408         handle_client($c, $ip) ;
 409     } else {
 410         $c->send_error(RC_FORBIDDEN) ;
 411     }
 412     close($c) ;
 413     chdir($olddir);
 414 }