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    This script requires perl to work (http://strawberryperl.com), and by default
  43    it assumes that Bacula is installed in the standard location. Once it's
  44    started on the windows, you can do remote commands like:
  45     - start the service
  46     - stop the service
  47     - edit the bacula-fd.conf to change the director and password setting
  48     - install a new binary version (not tested, no plugin support)
  49     - create weird files and directories
  50     - create files with windows attributes
  51     - compare two directories (with md5)
  52
  53
  54    To test it, you can follow this procedure
  55    On the windows box:
  56     - install perl from http://strawberryperl.com on windows
  57     - copy or export regress directory somewhere on your windows
  58       You can use a network share to your regress directory on linux
  59       Then, copy a link to this script to your desktop
  60       And double-click on it, and always open .pl file with perl.exe
  61
  62     - If you export the regress directory to your windows box and you
  63       make windows binaries available, this script can update bacula version.
  64       You need to put your binaries on:
  65         regress/release32 and regress/release64
  66       or
  67         regress/build/src/win32/release32 and regress/build/src/win32/release64
  68
  69     - start the regress/scripts/regress-win32.pl (open it with perl.exe)
  70     - create $WIN32_FILE
  71     - make sure that the firewall is well configured or just disabled (needs
  72    bacula and 8091/tcp)
  73
  74    On Linux box:
  75     - edit config file to fill the following variables
  76
  77    WIN32_CLIENT="win2008-fd"
  78    # Client FQDN or IP address
  79    WIN32_ADDR="192.168.0.6"
  80    # File or Directory to backup.  This is put in the "File" directive
  81    #   in the FileSet
  82    WIN32_FILE="c:/tmp"
  83    # Port of Win32 client
  84    WIN32_PORT=9102
  85    # Win32 Client password
  86    WIN32_PASSWORD="xxx"
  87    # will be the ip address of the linux box
  88    WIN32_STORE_ADDR="192.168.0.1"
  89    # set for autologon
  90    WIN32_USER=Administrator
  91    WIN32_PASS=password
  92    # set for MSSQL
  93    WIN32_MSSQL_USER=sa
  94    WIN32_MSSQL_PASS=pass
  95     - type make setup
  96     - run ./tests/backup-bacula-test to be sure that everything is ok
  97     - start ./tests/win32-fd-test
  98
  99    I'm not very happy with this script, but it works :)
 100
 101 =cut
 102
 103 use strict;
 104 use HTTP::Daemon;
 105 use HTTP::Status;
 106 use HTTP::Response;
 107 use HTTP::Headers;
 108 use File::Copy;
 109 use Pod::Usage;
 110 use Cwd 'chdir';
 111 use File::Find;
 112 use Digest::MD5;
 113 use Getopt::Long ;
 114 use POSIX;
 115 use File::Basename qw/dirname/;
 116
 117 my $base = 'x:';
 118 my $src_ip = '';
 119 my $help;
 120 my $bacula_prefix="c:/Program Files/Bacula";
 121 my $conf = "C:/Documents and Settings/All Users/Application Data/Bacula";
 122 GetOptions("base=s"   => \$base,
 123            "help"     => \$help,
 124            "prefix=s" => \$bacula_prefix,
 125            "ip=s"     => \$src_ip);
 126
 127 if ($help) {
 128     pod2usage(-verbose => 2,
 129               -exitval => 0);
 130 }
 131
 132 if (! -d $bacula_prefix) {
 133     print "regress-win32.pl: Could not find Bacula installation dir $bacula_prefix\n";
 134     print "regress-win32.pl: Won't be able to upgrade the version or modify the configuration\n";
 135 }
 136
 137 if (-f "$bacula_prefix/bacula-fd.conf" and -f "$conf/bacula-fd.conf") {
 138     print "regress-win32.pl: Unable to determine bacula-fd location $bacula_prefix or $conf ?\n";
 139
 140 } elsif (-f "$bacula_prefix/bacula-fd.conf") {
 141     $conf = $bacula_prefix;
 142 }
 143
 144 #if (! -d "$base/bacula" || ! -d "$base/regress") {
 145 #    pod2usage(-verbose => 2,
 146 #              -exitval => 1,
 147 #              -message => "Can't find bacula or regress dir on $base\n");
 148 #}
 149
 150 # stop the fd service
 151 sub stop_fd
 152 {
 153     return `net stop bacula-fd`;
 154 }
 155
 156 my $arch;
 157 my $bin_path;
 158 sub find_binaries
 159 {
 160     if ($_ =~ /bacula-fd.exe/i) {
 161         if ($File::Find::dir =~ /release$arch/) {
 162             $bin_path = $File::Find::dir;
 163         }
 164     }
 165 }
 166
 167 # copy binaries for a new fd
 168 # to work, you need to mount the regress directory
 169 sub install_fd
 170 {
 171     my ($r) = shift;
 172     if ($r->url !~ m!^/install$!) {
 173         return "ERR\nIncorrect url: " . $r->url . "\n";
 174     }
 175
 176     if (-d "c:/Program Files (x86)") {
 177         $arch = "64";
 178     } else {
 179         $arch = "32";
 180     }
 181
 182     # X:/regress/scripts/regress-win32.pl
 183     # X:/scripts/regress-win32.pl
 184     # perl script location
 185
 186     my $dir = dirname(dirname($0));
 187     print "searching bacula-fd.exe in $dir\n";
 188     find(\&find_binaries, ("$dir\\build\\src\\win32\\release$arch",
 189                            "$dir\\release$arch"));
 190
 191     if (!$bin_path) {
 192         return "ERR\nCan't find bacula-fd.exe in $dir\n";
 193     }
 194
 195     print "Found binaries in $bin_path\n";
 196
 197     stop_fd();
 198
 199     system("del \"c:\\Program Files\\bacula\\bacula.dll\"");
 200     system("del \"c:\\Program Files\\bacula\\bacula-fd.exe\"");
 201     system("del \"c:\\Program Files\\bacula\\plugins\\vss-fd.dll\"");
 202
 203     my $ret="Ok\n";
 204
 205     copy("$bin_path/bacula-fd.exe",
 206          "c:/Program Files/bacula/bacula-fd.exe") or $ret="ERR\n$!\n";
 207
 208     copy("$bin_path/bacula.dll",
 209          "c:/Program Files/bacula/bacula.dll") or $ret="ERR\n$!\n";
 210
 211     copy("$bin_path/vss-fd.dll",
 212          "c:/Program Files/bacula/plugins/vss-fd.dll") or $ret="ERR\n$!\n";
 213
 214     start_fd();
 215     return "OK\n";
 216 }
 217
 218 # start the fd service
 219 sub start_fd
 220 {
 221     return `net start bacula-fd`;
 222 }
 223
 224 # initialize the weird directory for runscript test
 225 sub init_weird_runscript_test
 226 {
 227     my ($r) = shift;
 228
 229     if ($r->url !~ m!^/init_weird_runscript_test\?source=(\w:/[\w\d\-\./]+)$!) {
 230         return "ERR\nIncorrect url: ". $r->url . "\n";
 231     }
 232     my $source = $1;
 233
 234     # Create $source if needed
 235     my $tmp = $source;
 236     $tmp =~ s:/:\\:g;
 237     system("mkdir $tmp");
 238
 239     if (!chdir($source)) {
 240         return "ERR\nCan't access to $source $!\n";
 241     }
 242
 243     if (-d "weird_runscript") {
 244         system("rmdir /Q /S weird_runscript");
 245     }
 246
 247     mkdir("weird_runscript");
 248     if (!chdir("weird_runscript")) {
 249         return "ERR\nCan't access to $source $!\n";
 250     }
 251
 252     open(FP, ">test.bat")                 or return "ERR\n";
 253     print FP "\@echo off\n";
 254     print FP "echo hello \%1\n";
 255     close(FP);
 256
 257     copy("test.bat", "test space.bat")    or return "ERR\n";
 258     copy("test.bat", "test2 space.bat")   or return "ERR\n";
 259     copy("test.bat", "testé.bat")         or return "ERR\n";
 260
 261     mkdir("dir space")                    or return "ERR\n";
 262     copy("test.bat", "dir space")         or return "ERR\n";
 263     copy("testé.bat","dir space")         or return "ERR\n";
 264     copy("test2 space.bat", "dir space")  or return "ERR\n";
 265
 266     mkdir("Évoilà")                       or return "ERR\n";
 267     copy("test.bat", "Évoilà")            or return "ERR\n";
 268     copy("testé.bat","Évoilà")            or return "ERR\n";
 269     copy("test2 space.bat", "Évoilà")     or return "ERR\n";
 270
 271     mkdir("Éwith space")                  or return "ERR\n";
 272     copy("test.bat", "Éwith space")       or return "ERR\n";
 273     copy("testé.bat","Éwith space")       or return "ERR\n";
 274     copy("test2 space.bat", "Éwith space") or return "ERR\n";
 275     mkdir("a"x200);
 276     copy("test.bat", "a"x200);
 277     system("mklink /J junc " . "a"x200); # TODO: need something for win2003
 278     link("test.bat", "link.bat");
 279     return "OK\n";
 280 }
 281
 282 # init the Attrib test by creating some files and settings attributes
 283 sub init_attrib_test
 284 {
 285     my ($r) = shift;
 286
 287     if ($r->url !~ m!^/init_attrib_test\?source=(\w:/[\w/]+)$!) {
 288         return "ERR\nIncorrect url: " . $r->url . "\n";
 289     }
 290
 291     my $source = $1;
 292     system("mkdir $source");
 293
 294     if (!chdir($source)) {
 295         return "ERR\nCan't access to $source $!\n";
 296     }
 297
 298     # cleanup the old directory if any
 299     if (-d "attrib_test") {
 300         system("rmdir /Q /S attrib_test");
 301     }
 302
 303     mkdir("attrib_test");
 304     chdir("attrib_test");
 305
 306     mkdir("hidden");
 307     mkdir("hidden/something");
 308     system("attrib +H hidden");
 309
 310     mkdir("readonly");
 311     mkdir("readonly/something");
 312     system("attrib +R readonly");
 313
 314     mkdir("normal");
 315     mkdir("normal/something");
 316     system("attrib -R -H -S normal");
 317
 318     mkdir("system");
 319     mkdir("system/something");
 320     system("attrib +S system");
 321
 322     mkdir("readonly_hidden");
 323     mkdir("readonly_hidden/something");
 324     system("attrib +R +H readonly_hidden");
 325
 326     my $ret = `attrib /S /D`;
 327     $ret = strip_base($ret, $source);
 328
 329     return "OK\n$ret\n";
 330 }
 331
 332 sub md5sum
 333 {
 334     my $file = shift;
 335     open(FILE, $file) or return "Can't open $file $!";
 336     binmode(FILE);
 337     return Digest::MD5->new->addfile(*FILE)->hexdigest;
 338 }
 339
 340 # set $src and $dst before using Find call
 341 my ($src, $dst);
 342 my $error="";
 343 sub wanted
 344 {
 345     my $f = $File::Find::name;
 346     $f =~ s!^\Q$src\E/?!!i;
 347
 348     if (-f "$src/$f") {
 349         if (! -f "$dst/$f") {
 350             $error .= "$dst/$f is missing\n";
 351         } else {
 352             my $a = md5sum("$src/$f");
 353             my $b = md5sum("$dst/$f");
 354             if ($a ne $b) {
 355                 $error .= "$src/$f $a\n$dst/$f $b\n";
 356             }
 357         }
 358     }
 359 }
 360
 361 sub create_schedtask
 362 {
 363     my ($r) = shift;
 364     if ($r->url !~ m!^/create_schedtask\?name=([\w\d\-.]+)$!) {
 365         return "ERR\nIncorrect url: " . $r->url . "\n";
 366     }
 367     my $ret='';
 368     my ($task,$pass) = ($1, $2);
 369     my (undef, undef, $version, undef) = POSIX::uname();
 370     if ($version < 6) {         # win2003
 371         $ret = `echo pass | SCHTASKS /Create /TN $task /SC ONLOGON  /TR C:\\windows\\system32\\calc.exe /F 2>&1`;
 372     } else {
 373         $ret=`SCHTASKS /Create /TN $task /SC ONLOGON /F /TR C:\\windows\\system32\\calc.exe`;
 374     }
 375
 376     if ($ret =~ /SUCCESS|has been created/) {
 377         return "OK\n$ret";
 378     } else {
 379         return "ERR\n$ret";
 380     }
 381 #
 382 # SCHTASKS /Create [/S system [/U username [/P [password]]]]
 383 #     [/RU username [/RP password]] /SC schedule [/MO modifier] [/D day]
 384 #     [/M months] [/I idletime] /TN taskname /TR taskrun [/ST starttime]
 385 #     [/RI interval] [ {/ET endtime | /DU duration} [/K] [/XML xmlfile] [/V1]]
 386 #     [/SD startdate] [/ED enddate] [/IT | /NP] [/Z] [/F]
 387 }
 388
 389 sub del_schedtask
 390 {
 391     my ($r) = shift;
 392     if ($r->url !~ m!^/del_schedtask\?name=([\w\d\-.]+)$!) {
 393         return "ERR\nIncorrect url: " . $r->url . "\n";
 394     }
 395     my ($task) = ($1);
 396     my $ret=`SCHTASKS /Delete /TN $task /F`;
 397
 398     if ($ret =~ /SUCCESS/) {
 399         return "OK\n$ret";
 400     } else {
 401         return "ERR\n$ret";
 402     }
 403 }
 404
 405 sub check_schedtask
 406 {
 407     my ($r) = shift;
 408     if ($r->url !~ m!^/check_schedtask\?name=([\w\d\-.]+)$!) {
 409         return "ERR\nIncorrect url: " . $r->url . "\n";
 410     }
 411
 412     my ($task) = ($1);
 413     my (undef, undef, $version, undef) = POSIX::uname();
 414     my $ret;
 415     if ($version < 6) {         # win2003
 416         $ret=`SCHTASKS /Query`;
 417     } else {
 418         $ret=`SCHTASKS /Query /TN $task`;
 419     }
 420
 421     if ($ret =~ /^($task .+)$/m) {
 422         return "OK\n$1\n";
 423     } else {
 424         return "ERR\n$ret";
 425     }
 426 }
 427
 428 sub set_director_name
 429 {
 430     my ($r) = shift;
 431
 432     if ($r->url !~ m!^/set_director_name\?name=([\w\d\.\-]+);pass=([\w\d+\-\.*]+)$!)
 433     {
 434         return "ERR\nIncorrect url: " . $r->url . "\n";
 435     }
 436
 437     my ($name, $pass) = ($1, $2);
 438
 439     open(ORG, "$conf/bacula-fd.conf") or return "ERR\nORG $!\n";
 440     open(NEW, ">$conf/bacula-fd.conf.new") or return "ERR\nNEW $!\n";
 441
 442     my $in_dir=0;               # don't use monitoring section
 443     my $nb_dir="";
 444     while (my $l = <ORG>)
 445     {
 446         if ($l =~ /^\s*Director\s+{/i) {
 447             print NEW $l;
 448             $in_dir = 1;
 449         } elsif ($l =~ /^(\s*)Name\s*=/ and $in_dir) {
 450             print NEW "${1}Name=$name$nb_dir\n";
 451         } elsif ($l =~ /^(\s*)Password\s*=/ and $in_dir) {
 452             print NEW "${1}Password=$pass\n";
 453         } elsif ($l =~ /#(\s*Plugin.*)$/) {
 454             print NEW $1;
 455         } elsif ($l =~ /\s*}/ and $in_dir) {
 456             print NEW $l;
 457             $in_dir = 0;
 458             $nb_dir++;
 459         } else {
 460             print NEW $l;
 461         }
 462     }
 463
 464     close(ORG);
 465     close(NEW);
 466     move("$conf/bacula-fd.conf.new", "$conf/bacula-fd.conf")
 467         and return "OK\n";
 468
 469     return "ERR\nCan't set the director name\n";
 470 }
 471
 472 # convert \ to / and strip the path
 473 sub strip_base
 474 {
 475     my ($data, $path) = @_;
 476     $data =~ s!\\!/!sg;
 477     $data =~ s!\Q$path!!sig;
 478     return $data;
 479 }
 480
 481 # Compare two directories, make checksums, compare attribs and ACLs
 482 sub compare
 483 {
 484     my ($r) = shift;
 485
 486     if ($r->url !~ m!^/compare\?source=(\w:/[\w/]+);dest=(\w:/[\w/]+)$!) {
 487         return "ERR\nIncorrect url: " . $r->url . "\n";
 488     }
 489
 490     my ($source, $dest) = ($1, $2);
 491
 492     if (!Cwd::chdir($source)) {
 493         return "ERR\nCan't access to $source $!\n";
 494     }
 495
 496     my $src_attrib = `attrib /D /S`;
 497     $src_attrib = strip_base($src_attrib, $source);
 498
 499     if (!Cwd::chdir($dest)) {
 500         return "ERR\nCan't access to $dest $!\n";
 501     }
 502
 503     my $dest_attrib = `attrib /D /S`;
 504     $dest_attrib = strip_base($dest_attrib, $dest);
 505
 506     if (lc($src_attrib) ne lc($dest_attrib)) {
 507         print "ERR\n$src_attrib\n=========\n$dest_attrib\n";
 508         return "ERR\n$src_attrib\n=========\n$dest_attrib\n";
 509     }
 510
 511     ($src, $dst, $error) = ($source, $dest, '');
 512     find(\&wanted, $source);
 513     if ($error) {
 514         return "ERR\n$error";
 515     } else {
 516         return "OK\n";
 517     }
 518 }
 519
 520 sub cleandir
 521 {
 522     my ($r) = shift;
 523
 524     if ($r->url !~ m!^/cleandir\?source=(\w:/[\w/]+)/restore$!) {
 525         return "ERR\nIncorrect url: " . $r->url . "\n";
 526     }
 527
 528     my $source = $1;
 529
 530     if (! -d "$source/restore") {
 531         return "ERR\nIncorrect path\n";
 532     }
 533
 534     if (!chdir($source)) {
 535         return "ERR\nCan't access to $source $!\n";
 536     }
 537
 538     system("rmdir /Q /S restore");
 539
 540     return "OK\n";
 541 }
 542
 543 sub reboot
 544 {
 545     Win32::InitiateSystemShutdown('', "\nSystem will now Reboot\!", 2, 0, 1 );
 546     exit 0;
 547 }
 548
 549 # boot disabled auto
 550 sub set_service
 551 {
 552     my ($r) = shift;
 553
 554     if ($r->url !~ m!^/set_service\?srv=([\w-]+);action=(\w+)$!) {
 555         return "ERR\nIncorrect url: " . $r->url . "\n";
 556     }
 557     my $out = `sc config $1 start= $2`;
 558     if ($out !~ /SUCCESS/) {
 559         return "ERR\n$out";
 560     }
 561     return "OK\n";
 562 }
 563
 564 # RUNNING, STOPPED
 565 sub get_service
 566 {
 567     my ($r) = shift;
 568
 569     if ($r->url !~ m!^/get_service\?srv=([\w-]+);state=(\w+)$!) {
 570         return "ERR\nIncorrect url: " . $r->url . "\n";
 571     }
 572     my $out = `sc query $1`;
 573     if ($out !~ /$2/) {
 574         return "ERR\n$out";
 575     }
 576     return "OK\n";
 577 }
 578
 579 sub add_registry_key
 580 {
 581     my ($r) = shift;
 582     if ($r->url !~ m!^/add_registry_key\?key=(\w+);val=(\w+)$!) {
 583         return "ERR\nIncorrect url: " . $r->url . "\n";
 584     }
 585     my ($k, $v) = ($1,$2);
 586     my $ret = "ERR";
 587     open(FP, ">tmp.reg")
 588         or return "ERR\nCan't open tmp.reg $!\n";
 589
 590     print FP "Windows Registry Editor Version 5.00
 591
 592 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula]
 593 \"$k\"=\"$v\"
 594
 595 ";
 596     close(FP);
 597     system("regedit /s tmp.reg");
 598
 599     unlink("tmp2.reg");
 600     system("regedit /e tmp2.reg HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula");
 601
 602     open(FP, "<:encoding(UTF-16LE)", "tmp2.reg")
 603        or return "ERR\nCan't open tmp2.reg $!\n";
 604     while (my $l = <FP>) {
 605        if ($l =~ /"$k"="$v"/) {
 606           $ret = "OK";
 607        }
 608     }
 609     close(FP);
 610     unlink("tmp.reg");
 611     unlink("tmp2.reg");
 612     return "$ret\n";
 613 }
 614
 615 sub set_auto_logon
 616 {
 617     my ($r) = shift;
 618     my $self = $0;              # perl script location
 619     $self =~ s/\\/\\\\/g;
 620     my $p = $^X;                # perl.exe location
 621     $p =~ s/\\/\\\\/g;
 622     if ($r->url !~ m!^/set_auto_logon\?user=([\w\d\-+\.]+);pass=([\w\d\.\,:*+%\-]*)$!) {
 623         return "ERR\nIncorrect url: " . $r->url . "\n";
 624     }
 625     my $k = $1;
 626     my $v = $2 || '';           # password can be empty
 627     my $ret = "ERR\nCan't find AutoAdminLogon key\n";
 628     open(FP, ">c:/autologon.reg")
 629         or return "ERR\nCan't open autologon.reg $!\n";
 630     print FP "Windows Registry Editor Version 5.00
 631
 632 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Winlogon]
 633 \"DefaultUserName\"=\"$k\"
 634 \"DefaultPassword\"=\"$v\"
 635 \"AutoAdminLogon\"=\"1\"
 636
 637 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Run]
 638 \"regress\"=\"$p $self\"
 639
 640 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Reliability]
 641 \"ShutdownReasonUI\"=dword:00000000
 642
 643 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Policies\\Microsoft\\Windows NT\\Reliability]
 644 \"ShutdownReasonOn\"=dword:00000000
 645 ";
 646     close(FP);
 647     system("regedit /s c:\\autologon.reg");
 648
 649     unlink("tmp2.reg");
 650     system("regedit /e tmp2.reg \"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Winlogon\"");
 651
 652     open(FP, "<:encoding(UTF-16LE)", "tmp2.reg")
 653        or return "ERR\nCan't open tmp2.reg $!\n";
 654     while (my $l = <FP>) {
 655        if ($l =~ /"AutoAdminLogon"="1"/) {
 656           $ret = "OK\n";
 657        }
 658     }
 659     close(FP);
 660     unlink("tmp2.reg");
 661     return $ret;
 662 }
 663
 664 sub del_registry_key
 665 {
 666     my ($r) = shift;
 667     if ($r->url !~ m!^/del_registry_key\?key=(\w+)$!) {
 668         return "ERR\nIncorrect url: " . $r->url . "\n";
 669     }
 670     my $k = $1;
 671     my $ret = "OK\n";
 672
 673     unlink("tmp2.reg");
 674     open(FP, ">tmp.reg")
 675         or return "ERR\nCan't open tmp.reg $!\n";
 676     print FP "Windows Registry Editor Version 5.00
 677
 678 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula]
 679 \"$k\"=-
 680
 681 ";
 682     close(FP);
 683     system("regedit /s tmp.reg");
 684     system("regedit /e tmp2.reg HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula");
 685
 686     open(FP, "<:encoding(UTF-16LE)", "tmp2.reg")
 687        or return "ERR\nCan't open tmp2.reg $!\n";
 688     while (my $l = <FP>) {
 689        if ($l =~ /"$k"=/) {
 690           $ret = "ERR\nThe key $k is still present\n";
 691        }
 692     }
 693     close(FP);
 694     unlink("tmp.reg");
 695     unlink("tmp2.reg");
 696     return $ret;
 697 }
 698
 699 sub get_registry_key
 700 {
 701     my ($r) = shift;
 702     if ($r->url !~ m!^/get_registry_key\?key=(\w+);val=(\w+)$!) {
 703         return "ERR\nIncorrect url: " . $r->url . "\n";
 704     }
 705     my ($k, $v) = ($1, $2);
 706     my $ret = "ERR\nCan't get or verify registry key $k\n";
 707
 708     unlink("tmp2.reg");
 709     system("regedit /e tmp2.reg HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula");
 710     open(FP, "<:encoding(UTF-16LE)", "tmp2.reg")
 711        or return "ERR\nCan't open tmp2.reg $!\n";
 712     while (my $l = <FP>) {
 713        if ($l =~ /"$k"="$v"/) {
 714           $ret = "OK\n";
 715        }
 716     }
 717     close(FP);
 718     unlink("tmp2.reg");
 719
 720     return $ret;
 721 }
 722
 723 my $mssql_user;
 724 my $mssql_pass;
 725 my $mssql_cred;
 726 my $mssql_bin;
 727 sub find_mssql
 728 {
 729     if ($_ =~ /sqlcmd.exe/i) {
 730         $mssql_bin = $File::Find::name;
 731     }
 732 }
 733
 734 # Verify that we can use SQLCMD.exe
 735 sub check_mssql
 736 {
 737     my ($r) = shift;
 738     my $ret = "ERR";
 739     if ($r->url !~ m!^/check_mssql\?user=(\w*);pass=(.*)$!) {
 740         return "ERR\nIncorrect url: " . $r->url . "\n";
 741     }
 742     ($mssql_user, $mssql_pass) = ($1, $2);
 743
 744     unless ($mssql_bin) {
 745         find(\&find_mssql, 'c:/program files/microsoft sql server/');
 746     }
 747     unless ($mssql_bin) {
 748         find(\&find_mssql, 'c:/program files (x86)/microsoft sql server/');
 749     }
 750
 751     if (!$mssql_bin) {
 752         return "ERR\nCan't find SQLCMD.exe in c:/program files\n";
 753     }
 754
 755     print $mssql_bin, "\n";
 756     $mssql_cred = ($mssql_user)?"-U $mssql_user -P $mssql_pass":"";
 757     my $res = `"$mssql_bin" $mssql_cred -Q "SELECT 'OK';"`;
 758     if ($res !~ /OK/) {
 759         return "ERR\nCan't verify the SQLCMD result\n" .
 760             "Please verify that MSSQL is accepting connection:\n" .
 761             "$mssql_bin $mssql_cred -Q \"SELECT 1;\"\n";
 762     }
 763     return "OK\n";
 764 }
 765
 766 # Create simple DB, a table and some information in
 767 sub setup_mssql_db
 768 {
 769     my ($r) = shift;
 770     my $ret = "ERR";
 771     if ($r->url !~ m!^/setup_mssql_db\?db=([\w\d]+)$!) {
 772         return "ERR\nIncorrect url: " . $r->url . "\n";
 773     }
 774     my $db = $1;
 775
 776     unless ($mssql_bin) {
 777         return "ERR\nCan't find mssql bin (run check_mssql first)\n";
 778     }
 779
 780     my $res = `"$mssql_bin" $mssql_cred -Q "CREATE DATABASE $db;"`;
 781     $res = `"$mssql_bin" $mssql_cred -d $db -Q "CREATE TABLE table1 (a int, b int);"`;
 782     $res = `"$mssql_bin" $mssql_cred -d $db -Q "INSERT INTO table1 (a, b) VALUES (1,1);"`;
 783     $res = `"$mssql_bin" $mssql_cred -d $db -Q "SELECT 'OK' FROM table1;"`;
 784
 785     if ($res !~ /OK/) {
 786         return "ERR\nCan't verify the SQLCMD result\n" .
 787             "Please verify that MSSQL is accepting connection:\n" .
 788             "$mssql_bin $mssql_cred -Q \"SELECT 1;\"\n";
 789     }
 790     return "OK\n";
 791 }
 792
 793 # drop database
 794 sub cleanup_mssql_db
 795 {
 796     my ($r) = shift;
 797     my $ret = "ERR";
 798     if ($r->url !~ m!^/cleanup_mssql_db\?db=([\w\d]+)$!) {
 799         return "ERR\nIncorrect url: " . $r->url . "\n";
 800     }
 801     my $db = $1;
 802
 803     unless ($mssql_bin) {
 804         return "ERR\nCan't find mssql bin\n";
 805     }
 806
 807     my $res = `"$mssql_bin" $mssql_cred -Q "DROP DATABASE $db;"`;
 808
 809     return "OK\n";
 810 }
 811
 812 # truncate the table that is in database
 813 sub truncate_mssql_table
 814 {
 815     my ($r) = shift;
 816     my $ret = "ERR";
 817     if ($r->url !~ m!^/truncate_mssql_table\?db=([\w\d]+)$!) {
 818         return "ERR\nIncorrect url: " . $r->url . "\n";
 819     }
 820     my $db = $1;
 821
 822     unless ($mssql_bin) {
 823         return "ERR\nCan't find mssql bin\n";
 824     }
 825
 826     my $res = `"$mssql_bin" $mssql_cred -d $db -Q "TRUNCATE TABLE table1;"`;
 827     $res = `"$mssql_bin" $mssql_cred -d $db -Q "SELECT 'OK' FROM table1;"`;
 828
 829     if ($res =~ /OK/) {
 830         return "ERR\nCan't truncate $db.table1\n";
 831     }
 832     return "OK\n";
 833 }
 834
 835 # test that table1 contains some rows
 836 sub test_mssql_content
 837 {
 838     my ($r) = shift;
 839     my $ret = "ERR";
 840     if ($r->url !~ m!^/test_mssql_content\?db=([\w\d]+)$!) {
 841         return "ERR\nIncorrect url: " . $r->url . "\n";
 842     }
 843     my $db = $1;
 844
 845     unless ($mssql_bin) {
 846         return "ERR\nCan't find mssql bin\n";
 847     }
 848
 849     my $res = `"$mssql_bin" $mssql_cred -d $db -Q "SELECT 'OK' FROM table1;"`;
 850
 851     if ($res !~ /OK/) {
 852         return "ERR\nNo content from $mssql_bin\n$res\n";
 853     }
 854     return "OK\n";
 855 }
 856
 857 my $mssql_mdf;
 858 my $mdf_to_find;
 859 sub find_mdf
 860 {
 861     if ($_ =~ /$mdf_to_find/i) {
 862         $mssql_mdf = $File::Find::dir;
 863     }
 864 }
 865
 866 # put a mdf online
 867 sub online_mssql_db
 868 {
 869     my ($r) = shift;
 870     if ($r->url !~ m!^/online_mssql_db\?mdf=([\w\d]+);db=([\w\d]+)$!) {
 871         return "ERR\nIncorrect url: " . $r->url . "\n";
 872     }
 873     my ($mdf, $db) = ($1, $2);
 874     $mdf_to_find = "$mdf.mdf";
 875
 876     find(\&find_mdf, 'c:/program files/microsoft sql server/');
 877     unless ($mssql_mdf) {
 878         find(\&find_mssql, 'c:/program files (x86)/microsoft sql server/');
 879     }
 880     unless ($mssql_mdf) {
 881         return "ERR\nCan't find $mdf.mdf in c:/program files\n";
 882     }
 883     $mssql_mdf =~ s:/:\\:g;
 884
 885     open(FP, ">c:/mssql.sql");
 886     print FP "
 887 USE [master]
 888 GO
 889 CREATE DATABASE [$db] ON
 890 ( FILENAME = N'$mssql_mdf\\$mdf.mdf' ),
 891 ( FILENAME = N'$mssql_mdf\\${mdf}_log.LDF' )
 892  FOR ATTACH
 893 GO
 894 USE [$db]
 895 GO
 896 SELECT 'OK' FROM table1
 897 GO
 898 ";
 899     close(FP);
 900     my $res = `"$mssql_bin" $mssql_cred -i c:\\mssql.sql`;
 901     #unlink("c:/mssql.sql");
 902     if ($res !~ /OK/) {
 903         return "ERR\nNo content from $mssql_bin\n";
 904     }
 905     return "OK\n";
 906 }
 907
 908 # create a script c:/del.cmd to delete protected files with runscript
 909 sub remove_dir
 910 {
 911     my ($r) = shift;
 912     if ($r->url !~ m!^/remove_dir\?file=([\w\d:\/\.\-+*]+);dest=([\w\d\.:\/]+)$!) {
 913         return "ERR\nIncorrect url: " . $r->url . "\n";
 914     }
 915     my ($file, $cmd) = ($1, $2);
 916     $file =~ s:/:\\:g;
 917
 918     open(FP, ">$cmd") or return "ERR\nCan't open $file $!\n";
 919     print FP "DEL /F /S /Q $file\n";
 920     close(FP);
 921     return "OK\n";
 922 }
 923
 924 sub get_traces
 925 {
 926     my ($file) = <"c:/program files/bacula/working/*.trace">;
 927     if (!$file || ! -f $file) {
 928         return "ERR\n$!\n";
 929     }
 930     return $file;
 931 }
 932
 933 sub truncate_traces
 934 {
 935     my $f = get_traces();
 936     unlink($f) or return "ERR\n$!\n";
 937     return "OK\n";
 938 }
 939
 940 # When adding an action, fill this hash with the right function
 941 my %action_list = (
 942     nop     => sub { return "OK\n"; },
 943     stop    => \&stop_fd,
 944     start   => \&start_fd,
 945     install => \&install_fd,
 946     compare => \&compare,
 947     init_attrib_test => \&init_attrib_test,
 948     init_weird_runscript_test => \&init_weird_runscript_test,
 949     set_director_name => \&set_director_name,
 950     cleandir => \&cleandir,
 951     add_registry_key => \&add_registry_key,
 952     del_registry_key => \&del_registry_key,
 953     get_registry_key => \&get_registry_key,
 954     quit => sub {  exit 0; },
 955     reboot => \&reboot,
 956     set_service => \&set_service,
 957     get_service => \&get_service,
 958     set_auto_logon => \&set_auto_logon,
 959     remove_dir => \&remove_dir,
 960     reload => \&reload,
 961     create_schedtask => \&create_schedtask,
 962     del_schedtask => \&del_schedtask,
 963     check_schedtask => \&check_schedtask,
 964     get_traces => \&get_traces,
 965     truncate_traces => \&truncate_traces,
 966
 967     check_mssql => \&check_mssql,
 968     setup_mssql_db => \&setup_mssql_db,
 969     cleanup_mssql_db => \&cleanup_mssql_db,
 970     truncate_mssql_table => \&truncate_mssql_table,
 971     test_mssql_content => \&test_mssql_content,
 972     online_mssql_db => \&online_mssql_db,
 973     );
 974
 975 my $reload=0;
 976 sub reload
 977 {
 978     $reload=1;
 979     return "OK\n";
 980 }
 981
 982 # handle client request
 983 sub handle_client
 984 {
 985     my ($c, $ip) = @_ ;
 986     my $action;
 987     my $r = $c->get_request ;
 988
 989     if (!$r) {
 990         $c->send_error(RC_FORBIDDEN) ;
 991         return;
 992     }
 993     if ($r->url->path !~ m!^/(\w+)!) {
 994         $c->send_error(RC_NOT_FOUND) ;
 995         return;
 996     }
 997     $action = $1;
 998
 999     if (($r->method eq 'GET')
1000         and $action_list{$action})
1001     {
1002         print "Exec $action:\n";
1003
1004         my $ret = $action_list{$action}($r);
1005         if ($action eq 'get_traces' && $ret !~ /ERR/) {
1006             print "Sending $ret\n";
1007             $c->send_file_response($ret);
1008
1009         } else {
1010             my $h = HTTP::Headers->new('Content-Type' => 'text/plain') ;
1011             my $r = HTTP::Response->new(HTTP::Status::RC_OK,
1012                                         'OK', $h, $ret) ;
1013             print $ret;
1014             $c->send_response($r) ;
1015         }
1016     } else {
1017         print "$action not found, probably a version problem\n";
1018         $c->send_error(RC_NOT_FOUND) ;
1019     }
1020
1021     $c->close;
1022 }
1023
1024 print "Starting regress-win32.pl daemon...\n";
1025 my $d = HTTP::Daemon->new ( LocalPort =>  8091,
1026                             ReuseAddr => 1)
1027     || die "Error: Can't bind $!" ;
1028
1029 my $olddir = Cwd::cwd();
1030 while (1) {
1031     my $c = $d->accept ;
1032     my $ip = $c->peerhost;
1033     if (!$ip) {
1034         $c->send_error(RC_FORBIDDEN) ;
1035     } elsif ($src_ip && $ip ne $src_ip) {
1036         $c->send_error(RC_FORBIDDEN) ;
1037     } elsif ($c) {
1038         handle_client($c, $ip) ;
1039     } else {
1040         $c->send_error(RC_FORBIDDEN) ;
1041     }
1042     close($c) ;
1043     undef $c;
1044     chdir($olddir);
1045
1046     # When we have the reload command, just close the http daemon
1047     # and exec ourself
1048     if ($reload) {
1049         $d->close();
1050         undef $d;
1051
1052         exec("$^X $0");
1053     }
1054 }