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     - start the regress/scripts/regress-win32.pl (open it with perl.exe)
  59     - create c:/tmp (not sure it's mandatory)
  60     - make sure that the firewall is well configured or just disabled (needs
  61    bacula and 8091/tcp)
  62
  63    On Linux box:
  64     - edit config file to fill the following variables
  65
  66    WIN32_CLIENT="win2008-fd"
  67    # Client FQDN or IP address
  68    WIN32_ADDR="192.168.0.6"
  69    # File or Directory to backup.  This is put in the "File" directive
  70    #   in the FileSet
  71    WIN32_FILE="c:/tmp"
  72    # Port of Win32 client
  73    WIN32_PORT=9102
  74    # Win32 Client password
  75    WIN32_PASSWORD="xxx"
  76    # will be the ip address of the linux box
  77    WIN32_STORE_ADDR="192.168.0.1"
  78    # set for autologon
  79    WIN32_USER=Administrator
  80    WIN32_PASS=password
  81    # set for MSSQL
  82    WIN32_MSSQL_USER=sa
  83    WIN32_MSSQL_PASS=pass
  84     - type make setup
  85     - run ./tests/backup-bacula-test to be sure that everything is ok
  86     - start ./tests/win32-fd-test
  87
  88    I'm not very happy with this script, but it works :)
  89
  90 =cut
  91
  92 use strict;
  93 use HTTP::Daemon;
  94 use HTTP::Status;
  95 use HTTP::Response;
  96 use HTTP::Headers;
  97 use File::Copy;
  98 use Pod::Usage;
  99 use Cwd 'chdir';
 100 use File::Find;
 101 use Digest::MD5;
 102 use Getopt::Long ;
 103
 104 my $base = 'x:';
 105 my $src_ip = '';
 106 my $help;
 107 my $bacula_prefix="c:/Program Files/Bacula";
 108 my $conf = "C:/Documents and Settings/All Users/Application Data/Bacula";
 109 GetOptions("base=s"   => \$base,
 110            "help"     => \$help,
 111            "prefix=s" => \$bacula_prefix,
 112            "ip=s"     => \$src_ip);
 113
 114 if ($help) {
 115     pod2usage(-verbose => 2,
 116               -exitval => 0);
 117 }
 118
 119 if (! -d $bacula_prefix) {
 120     print "Could not find Bacula installation dir $bacula_prefix\n";
 121     print "Won't be able to upgrade the version or modify the configuration\n";
 122 }
 123
 124 if (-f "$bacula_prefix/bacula-fd.conf" and -f "$conf/bacula-fd.conf") {
 125     print "Unable to determine bacula-fd location $bacula_prefix or $conf ?\n";
 126
 127 } elsif (-f "$bacula_prefix/bacula-fd.conf") {
 128     $conf = $bacula_prefix;
 129 }
 130
 131 #if (! -d "$base/bacula" || ! -d "$base/regress") {
 132 #    pod2usage(-verbose => 2,
 133 #              -exitval => 1,
 134 #              -message => "Can't find bacula or regress dir on $base\n");
 135 #}
 136
 137 # stop the fd service
 138 sub stop_fd
 139 {
 140     return `net stop bacula-fd`;
 141 }
 142
 143 # copy binaries for a new fd
 144 sub install_fd
 145 {
 146     copy("$base/bacula/src/win32/release32/bacula-fd.exe",
 147          "c:/Program Files/bacula/bacula-fd.exe");
 148
 149     copy("$base/bacula/src/win32/release32/bacula.dll",
 150          "c:/Program Files/bacula/bacula.dll");
 151 }
 152
 153 # start the fd service
 154 sub start_fd
 155 {
 156     return `net start bacula-fd`;
 157 }
 158
 159 # initialize the weird directory for runscript test
 160 sub init_weird_runscript_test
 161 {
 162     my ($r) = shift;
 163
 164     if ($r->url !~ m!^/init_weird_runscript_test\?source=(\w:/[\w/]+)$!) {
 165         return "ERR\nIncorrect url\n";
 166     }
 167     my $source = $1;
 168
 169     if (!chdir($source)) {
 170         return "ERR\nCan't access to $source $!\n";
 171     }
 172
 173     if (-d "weird_runscript") {
 174         system("rmdir /Q /S weird_runscript");
 175     }
 176
 177     mkdir("weird_runscript");
 178     if (!chdir("weird_runscript")) {
 179         return "ERR\nCan't access to $source $!\n";
 180     }
 181
 182     open(FP, ">test.bat")                 or return "ERR\n";
 183     print FP "\@echo off\n";
 184     print FP "echo hello \%1\n";
 185     close(FP);
 186
 187     copy("test.bat", "test space.bat")    or return "ERR\n";
 188     copy("test.bat", "test2 space.bat")   or return "ERR\n";
 189     copy("test.bat", "testé.bat")         or return "ERR\n";
 190
 191     mkdir("dir space")                    or return "ERR\n";
 192     copy("test.bat", "dir space")         or return "ERR\n";
 193     copy("testé.bat","dir space")         or return "ERR\n";
 194     copy("test2 space.bat", "dir space")  or return "ERR\n";
 195
 196     mkdir("Évoilà")                       or return "ERR\n";
 197     copy("test.bat", "Évoilà")            or return "ERR\n";
 198     copy("testé.bat","Évoilà")            or return "ERR\n";
 199     copy("test2 space.bat", "Évoilà")     or return "ERR\n";
 200
 201     mkdir("Éwith space")                  or return "ERR\n";
 202     copy("test.bat", "Éwith space")       or return "ERR\n";
 203     copy("testé.bat","Éwith space")       or return "ERR\n";
 204     copy("test2 space.bat", "Éwith space") or return "ERR\n";
 205     return "OK\n";
 206 }
 207
 208 # init the Attrib test by creating some files and settings attributes
 209 sub init_attrib_test
 210 {
 211     my ($r) = shift;
 212
 213     if ($r->url !~ m!^/init_attrib_test\?source=(\w:/[\w/]+)$!) {
 214         return "ERR\nIncorrect url\n";
 215     }
 216
 217     my $source = $1;
 218
 219     if (!chdir($source)) {
 220         return "ERR\nCan't access to $source $!\n";
 221     }
 222
 223     # cleanup the old directory if any
 224     if (-d "attrib_test") {
 225         system("rmdir /Q /S attrib_test");
 226     }
 227
 228     mkdir("attrib_test");
 229     chdir("attrib_test");
 230
 231     mkdir("hidden");
 232     mkdir("hidden/something");
 233     system("attrib +H hidden");
 234
 235     mkdir("readonly");
 236     mkdir("readonly/something");
 237     system("attrib +R readonly");
 238
 239     mkdir("normal");
 240     mkdir("normal/something");
 241     system("attrib -R -H -S normal");
 242
 243     mkdir("system");
 244     mkdir("system/something");
 245     system("attrib +S system");
 246
 247     mkdir("readonly_hidden");
 248     mkdir("readonly_hidden/something");
 249     system("attrib +R +H readonly_hidden");
 250
 251     my $ret = `attrib /S /D`;
 252     $ret = strip_base($ret, $source);
 253
 254     return "OK\n$ret\n";
 255 }
 256
 257 sub md5sum
 258 {
 259     my $file = shift;
 260     open(FILE, $file) or return "Can't open $file $!";
 261     binmode(FILE);
 262     return Digest::MD5->new->addfile(*FILE)->hexdigest;
 263 }
 264
 265 # set $src and $dst before using Find call
 266 my ($src, $dst);
 267 my $error="";
 268 sub wanted
 269 {
 270     my $f = $File::Find::name;
 271     $f =~ s!^\Q$src\E/?!!i;
 272
 273     if (-f "$src/$f") {
 274         if (! -f "$dst/$f") {
 275             $error .= "$dst/$f is missing\n";
 276         } else {
 277             my $a = md5sum("$src/$f");
 278             my $b = md5sum("$dst/$f");
 279             if ($a ne $b) {
 280                 $error .= "$src/$f $a\n$dst/$f $b\n";
 281             }
 282         }
 283     }
 284 }
 285
 286 sub set_director_name
 287 {
 288     my ($r) = shift;
 289
 290     if ($r->url !~ m!^/set_director_name\?name=([\w\d\.\-]+);pass=([\w\d+]+)$!)
 291     {
 292         return "ERR\nIncorrect url\n";
 293     }
 294
 295     my ($name, $pass) = ($1, $2);
 296
 297     open(ORG, "$conf/bacula-fd.conf") or return "ERR\nORG $!\n";
 298     open(NEW, ">$conf/bacula-fd.conf.new") or return "ERR\nNEW $!\n";
 299
 300     my $in_dir=0;               # don't use monitoring section
 301     my $nb_dir="";
 302     while (my $l = <ORG>)
 303     {
 304         if ($l =~ /^\s*Director\s+{/i) {
 305             print NEW $l;
 306             $in_dir = 1;
 307         } elsif ($l =~ /^(\s*)Name\s*=/ and $in_dir) {
 308             print NEW "${1}Name=$name$nb_dir\n";
 309         } elsif ($l =~ /^(\s*)Password\s*=/ and $in_dir) {
 310             print NEW "${1}Password=$pass\n";
 311         } elsif ($l =~ /\s*}/ and $in_dir) {
 312             print NEW $l;
 313             $in_dir = 0;
 314             $nb_dir++;
 315         } else {
 316             print NEW $l;
 317         }
 318     }
 319
 320     close(ORG);
 321     close(NEW);
 322     move("$conf/bacula-fd.conf.new", "$conf/bacula-fd.conf")
 323         and return "OK\n";
 324
 325     return "ERR\n";
 326 }
 327
 328 # convert \ to / and strip the path
 329 sub strip_base
 330 {
 331     my ($data, $path) = @_;
 332     $data =~ s!\\!/!sg;
 333     $data =~ s!\Q$path!!sig;
 334     return $data;
 335 }
 336
 337 # Compare two directories, make checksums, compare attribs and ACLs
 338 sub compare
 339 {
 340     my ($r) = shift;
 341
 342     if ($r->url !~ m!^/compare\?source=(\w:/[\w/]+);dest=(\w:/[\w/]+)$!) {
 343         return "ERR\nIncorrect url\n";
 344     }
 345
 346     my ($source, $dest) = ($1, $2);
 347
 348     if (!Cwd::chdir($source)) {
 349         return "ERR\nCan't access to $source $!\n";
 350     }
 351
 352     my $src_attrib = `attrib /D /S`;
 353     $src_attrib = strip_base($src_attrib, $source);
 354
 355     if (!Cwd::chdir($dest)) {
 356         return "ERR\nCan't access to $dest $!\n";
 357     }
 358
 359     my $dest_attrib = `attrib /D /S`;
 360     $dest_attrib = strip_base($dest_attrib, $dest);
 361
 362     if (lc($src_attrib) ne lc($dest_attrib)) {
 363         return "ERR\n$src_attrib\n=========\n$dest_attrib\n";
 364     }
 365
 366     ($src, $dst, $error) = ($source, $dest, '');
 367     find(\&wanted, $source);
 368     if ($error) {
 369         return "ERR\n$error";
 370     } else {
 371         return "OK\n";
 372     }
 373 }
 374
 375 sub cleandir
 376 {
 377     my ($r) = shift;
 378
 379     if ($r->url !~ m!^/cleandir\?source=(\w:/[\w/]+)/restore$!) {
 380         return "ERR\nIncorrect url\n";
 381     }
 382
 383     my $source = $1;
 384
 385     if (! -d "$source/restore") {
 386         return "ERR\nIncorrect path\n";
 387     }
 388
 389     if (!chdir($source)) {
 390         return "ERR\nCan't access to $source $!\n";
 391     }
 392
 393     system("rmdir /Q /S restore");
 394
 395     return "OK\n";
 396 }
 397
 398 sub reboot
 399 {
 400     Win32::InitiateSystemShutdown('', "\nSystem will now Reboot\!", 2, 0, 1 );
 401     exit 0;
 402 }
 403
 404 # boot disabled auto
 405 sub set_service
 406 {
 407     my ($r) = shift;
 408
 409     if ($r->url !~ m!^/set_service\?srv=([\w-]+);action=(\w+)$!) {
 410         return "ERR\nIncorrect url\n";
 411     }
 412     my $out = `sc config $1 start= $2`;
 413     if ($out !~ /SUCCESS/) {
 414         return "ERR\n$out";
 415     }
 416     return "OK\n";
 417 }
 418
 419 # RUNNING, STOPPED
 420 sub get_service
 421 {
 422     my ($r) = shift;
 423
 424     if ($r->url !~ m!^/get_service\?srv=([\w-]+);state=(\w+)$!) {
 425         return "ERR\nIncorrect url\n";
 426     }
 427     my $out = `sc query $1`;
 428     if ($out !~ /$2/) {
 429         return "ERR\n$out";
 430     }
 431     return "OK\n";
 432 }
 433
 434 sub add_registry_key
 435 {
 436     my ($r) = shift;
 437     if ($r->url !~ m!^/add_registry_key\?key=(\w+);val=(\w+)$!) {
 438         return "ERR\nIncorrect url\n";
 439     }
 440     my ($k, $v) = ($1,$2);
 441     my $ret = "ERR";
 442     open(FP, ">tmp.reg")
 443         or return "ERR\nCan't open tmp.reg $!\n";
 444
 445     print FP "Windows Registry Editor Version 5.00
 446
 447 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula]
 448 \"$k\"=\"$v\"
 449
 450 ";
 451     close(FP);
 452     system("regedit /s tmp.reg");
 453
 454     unlink("tmp2.reg");
 455     system("regedit /e tmp2.reg HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula");
 456
 457     open(FP, "<:encoding(UTF-16LE)", "tmp2.reg")
 458        or return "ERR\nCan't open tmp2.reg $!\n";
 459     while (my $l = <FP>) {
 460        if ($l =~ /"$k"="$v"/) {
 461           $ret = "OK";
 462        }
 463     }
 464     close(FP);
 465     unlink("tmp.reg");
 466     unlink("tmp2.reg");
 467     return "$ret\n";
 468 }
 469
 470 sub set_auto_logon
 471 {
 472     my ($r) = shift;
 473     my $self = $0;
 474     $self =~ s/\\/\\\\/g;
 475     my $p = $^X;
 476     $p =~ s/\\/\\\\/g;
 477     if ($r->url !~ m!^/set_auto_logon\?user=(\w+);pass=([\w\d\,:*+-]*)$!) {
 478         return "ERR\nIncorrect url\n";
 479     }
 480     my $k = $1;
 481     my $v = $2 || '';           # password can be empty
 482     my $ret = "ERR";
 483     open(FP, ">c:/autologon.reg")
 484         or return "ERR\nCan't open tmp.reg $!\n";
 485     print FP "Windows Registry Editor Version 5.00
 486
 487 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Winlogon]
 488 \"DefaultUserName\"=\"$k\"
 489 \"DefaultPassword\"=\"$v\"
 490 \"AutoAdminLogon\"=\"1\"
 491
 492 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Run]
 493 \"regress\"=\"$p $self\"
 494
 495 ";
 496     close(FP);
 497     system("regedit /s c:\autologon.reg");
 498
 499     unlink("tmp2.reg");
 500     system("regedit /e tmp2.reg \"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Winlogon\"");
 501
 502     open(FP, "<:encoding(UTF-16LE)", "tmp2.reg")
 503        or return "ERR\nCan't open tmp2.reg $!\n";
 504     while (my $l = <FP>) {
 505        if ($l =~ /"AutoAdminLogon"="1"/) {
 506           $ret = "OK\n";
 507        }
 508     }
 509     close(FP);
 510     unlink("tmp2.reg");
 511     return "$ret\n";
 512 }
 513
 514 sub del_registry_key
 515 {
 516     my ($r) = shift;
 517     if ($r->url !~ m!^/del_registry_key\?key=(\w+)$!) {
 518         return "ERR\nIncorrect url\n";
 519     }
 520     my $k = $1;
 521     my $ret = "OK";
 522
 523     unlink("tmp2.reg");
 524     open(FP, ">tmp.reg")
 525         or return "ERR\nCan't open tmp.reg $!\n";
 526     print FP "Windows Registry Editor Version 5.00
 527
 528 [HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula]
 529 \"$k\"=-
 530
 531 ";
 532     close(FP);
 533     system("regedit /s tmp.reg");
 534     system("regedit /e tmp2.reg HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula");
 535
 536     open(FP, "<:encoding(UTF-16LE)", "tmp2.reg")
 537        or return "ERR\nCan't open tmp2.reg $!\n";
 538     while (my $l = <FP>) {
 539        if ($l =~ /"$k"=/) {
 540           $ret = "ERR\n";
 541        }
 542     }
 543     close(FP);
 544     unlink("tmp.reg");
 545     unlink("tmp2.reg");
 546     return "$ret\n";
 547 }
 548
 549 sub get_registry_key
 550 {
 551     my ($r) = shift;
 552     my $ret = "ERR";
 553     if ($r->url !~ m!^/get_registry_key\?key=(\w+);val=(\w+)$!) {
 554         return "ERR\nIncorrect url\n";
 555     }
 556     my ($k, $v) = ($1, $2);
 557
 558     unlink("tmp2.reg");
 559     system("regedit /e tmp2.reg HKEY_LOCAL_MACHINE\\SOFTWARE\\Bacula");
 560     open(FP, "<:encoding(UTF-16LE)", "tmp2.reg")
 561        or return "ERR\nCan't open tmp2.reg $!\n";
 562     while (my $l = <FP>) {
 563        if ($l =~ /"$k"="$v"/) {
 564           $ret = "OK";
 565        }
 566     }
 567     close(FP);
 568     unlink("tmp2.reg");
 569
 570     return "$ret\n";
 571 }
 572
 573 my $mssql_user;
 574 my $mssql_pass;
 575 my $mssql_bin;
 576 use File::Find qw/find/;
 577 sub find_mssql
 578 {
 579     if ($_ =~ /sqlcmd.exe/i) {
 580         $mssql_bin = $File::Find::name;
 581     }
 582 }
 583
 584 # Verify that we can use SQLCMD.exe
 585 sub check_mssql
 586 {
 587     my ($r) = shift;
 588     my $ret = "ERR";
 589     if ($r->url !~ m!^/check_mssql\?user=(\w+);pass=(.+)$!) {
 590         return "ERR\nIncorrect url\n";
 591     }
 592     ($mssql_user, $mssql_pass) = ($1, $2);
 593
 594     unless ($mssql_bin) {
 595         find(\&find_mssql, 'c:/program files/microsoft sql server/');
 596     }
 597
 598     if (!$mssql_bin) {
 599         return "ERR\n";
 600     }
 601
 602     print $mssql_bin, "\n";
 603
 604     my $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -Q "SELECT 'OK';"`;
 605     if ($res !~ /OK/) {
 606         print "Can't run sql\n";
 607         return "ERR\n";
 608     }
 609     return "OK\n";
 610 }
 611
 612 # Create simple DB, a table and some information in
 613 sub setup_mssql_db
 614 {
 615     my ($r) = shift;
 616     my $ret = "ERR";
 617     if ($r->url !~ m!^/setup_mssql_db\?db=([\w\d]+)$!) {
 618         return "ERR\nIncorrect url\n";
 619     }
 620     my $db = $1;
 621
 622     unless ($mssql_bin) {
 623         print "Can't find mssql bin\n";
 624         return "ERR\n";
 625     }
 626
 627     my $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -Q "CREATE DATABASE $db;"`;
 628     $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -d $db -Q "CREATE TABLE table1 (a int, b int);"`;
 629     $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -d $db -Q "INSERT INTO table1 (a, b) VALUES (1,1);"`;
 630     $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -d $db -Q "SELECT 'OK' FROM table1;"`;
 631
 632     if ($res !~ /OK/) {
 633         print "Can't run sql\n";
 634         return "ERR\n";
 635     }
 636     return "OK\n";
 637 }
 638
 639 # drop database
 640 sub cleanup_mssql_db
 641 {
 642     my ($r) = shift;
 643     my $ret = "ERR";
 644     if ($r->url !~ m!^/cleanup_mssql_db\?db=([\w\d]+)$!) {
 645         return "ERR\nIncorrect url\n";
 646     }
 647     my $db = $1;
 648
 649     unless ($mssql_bin) {
 650         print "Can't find mssql bin\n";
 651         return "ERR\n";
 652     }
 653
 654     my $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -Q "DROP DATABASE $db;"`;
 655
 656     return "OK\n";
 657 }
 658
 659 # truncate the table that is in database
 660 sub truncate_mssql_table
 661 {
 662     my ($r) = shift;
 663     my $ret = "ERR";
 664     if ($r->url !~ m!^/truncate_mssql_table\?db=([\w\d]+)$!) {
 665         return "ERR\nIncorrect url\n";
 666     }
 667     my $db = $1;
 668
 669     unless ($mssql_bin) {
 670         print "Can't find mssql bin\n";
 671         return "ERR\n";
 672     }
 673
 674     my $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -d $db -Q "TRUNCATE TABLE table1;"`;
 675     $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -d $db -Q "SELECT 'OK' FROM table1;"`;
 676
 677     if ($res =~ /OK/) {
 678         print "Can't truncate\n";
 679         return "ERR\n";
 680     }
 681     return "OK\n";
 682 }
 683
 684 # test that table1 contains some rows
 685 sub test_mssql_content
 686 {
 687     my ($r) = shift;
 688     my $ret = "ERR";
 689     if ($r->url !~ m!^/test_mssql_content\?db=([\w\d]+)$!) {
 690         return "ERR\nIncorrect url\n";
 691     }
 692     my $db = $1;
 693
 694     unless ($mssql_bin) {
 695         print "Can't find mssql bin\n";
 696         return "ERR\n";
 697     }
 698
 699     my $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -d $db -Q "SELECT 'OK' FROM table1;"`;
 700
 701     if ($res !~ /OK/) {
 702         print "no content\n";
 703         return "ERR\n";
 704     }
 705     return "OK\n";
 706 }
 707
 708 my $mssql_mdf;
 709 my $mdf_to_find;
 710 sub find_mdf
 711 {
 712     if ($_ =~ /$mdf_to_find/i) {
 713         $mssql_mdf = $File::Find::dir;
 714     }
 715 }
 716
 717 # put a mdf online
 718 sub online_mssql_db
 719 {
 720     my ($r) = shift;
 721     if ($r->url !~ m!^/online_mssql_db\?mdf=([\w\d]+);db=([\w\d]+)$!) {
 722         return "ERR\nIncorrect url\n";
 723     }
 724     my ($mdf, $db) = ($1, $2);
 725     $mdf_to_find = "$mdf.mdf";
 726
 727     find(\&find_mdf, 'c:/program files/microsoft sql server/');
 728     $mssql_mdf =~ s:/:\\:g;
 729
 730     open(FP, ">c:/mssql.sql");
 731     print FP "
 732 USE [master]
 733 GO
 734 CREATE DATABASE [$db] ON
 735 ( FILENAME = N'$mssql_mdf\\$mdf.mdf' ),
 736 ( FILENAME = N'$mssql_mdf\\${mdf}_log.LDF' )
 737  FOR ATTACH
 738 GO
 739 USE [$db]
 740 GO
 741 SELECT 'OK' FROM table1
 742 GO
 743 ";
 744     close(FP);
 745     my $res = `"$mssql_bin" -U $mssql_user -P $mssql_pass -i c:\\mssql.sql`;
 746     #unlink("c:/mssql.sql");
 747     if ($res !~ /OK/) {
 748         print "no content\n";
 749         return "ERR\n";
 750     }
 751     return "OK\n";
 752 }
 753
 754 # When adding an action, fill this hash with the right function
 755 my %action_list = (
 756     nop     => sub { return "OK\n"; },
 757     stop    => \&stop_fd,
 758     start   => \&start_fd,
 759     install => \&install_fd,
 760     compare => \&compare,
 761     init_attrib_test => \&init_attrib_test,
 762     init_weird_runscript_test => \&init_weird_runscript_test,
 763     set_director_name => \&set_director_name,
 764     cleandir => \&cleandir,
 765     add_registry_key => \&add_registry_key,
 766     del_registry_key => \&del_registry_key,
 767     get_registry_key => \&get_registry_key,
 768     quit => sub {  exit 0; },
 769     reboot => \&reboot,
 770     set_service => \&set_service,
 771     get_service => \&get_service,
 772     set_auto_logon => \&set_auto_logon,
 773
 774     check_mssql => \&check_mssql,
 775     setup_mssql_db => \&setup_mssql_db,
 776     cleanup_mssql_db => \&cleanup_mssql_db,
 777     truncate_mssql_table => \&truncate_mssql_table,
 778     test_mssql_content => \&test_mssql_content,
 779     online_mssql_db => \&online_mssql_db,
 780     );
 781
 782 # handle client request
 783 sub handle_client
 784 {
 785     my ($c, $ip) = @_ ;
 786     my $action;
 787     my $r = $c->get_request ;
 788
 789     if (!$r) {
 790         $c->send_error(RC_FORBIDDEN) ;
 791         return;
 792     }
 793     if ($r->url->path !~ m!^/(\w+)!) {
 794         $c->send_error(RC_NOT_FOUND) ;
 795         return;
 796     }
 797     $action = $1;
 798
 799     if (($r->method eq 'GET')
 800         and $action_list{$action})
 801     {
 802         my $ret = $action_list{$action}($r);
 803         my $h = HTTP::Headers->new('Content-Type' => 'text/plain') ;
 804         my $r = HTTP::Response->new(HTTP::Status::RC_OK,
 805                                     'OK', $h, $ret) ;
 806
 807         $c->send_response($r) ;
 808     } else {
 809         $c->send_error(RC_NOT_FOUND) ;
 810     }
 811
 812     $c->close;
 813 }
 814
 815 my $d = HTTP::Daemon->new ( LocalPort =>  8091,
 816                             ReuseAddr => 1)
 817     || die "Error: Can't bind $!" ;
 818
 819 my $olddir = Cwd::cwd();
 820 while (1) {
 821     print "Starting daemon...\n";
 822     my $c = $d->accept ;
 823     my $ip = $c->peerhost;
 824     if (!$ip) {
 825         $c->send_error(RC_FORBIDDEN) ;
 826     } elsif ($src_ip && $ip ne $src_ip) {
 827         $c->send_error(RC_FORBIDDEN) ;
 828     } elsif ($c) {
 829         handle_client($c, $ip) ;
 830     } else {
 831         $c->send_error(RC_FORBIDDEN) ;
 832     }
 833     close($c) ;
 834     chdir($olddir);
 835 }