t/TestUtils.pm

   1 #!/usr/bin/env perl
   2
   3 package TestUtils;
   4
   5 ##################################################
   6 # Test Utils
   7 ##################################################
   8
   9 use warnings;
  10 use strict;
  11 use Carp;
  12 use Cwd;
  13 use Test::More;
  14 use Data::Dumper;
  15 use LWP::UserAgent;
  16 use HTTP::Cookies::Netscape;
  17 use File::Temp qw/ tempfile /;
  18 use File::Copy qw/ cp /;
  19 use File::Basename;
  20 use Test::Cmd;
  21
  22 if($> != 0) {
  23     plan( skip_all => "creating testsites requires root permission" );
  24 }
  25 our $omd_symlink_created = 0;
  26
  27 ##################################################
  28 # HTML::Lint installed?
  29 my $use_html_lint = 0;
  30 eval {
  31     require HTML::Lint;
  32     $use_html_lint = 1;
  33 };
  34
  35 ##################################################
  36 # dont test over a proxy
  37 delete $ENV{'HTTP_PROXY'};
  38 delete $ENV{'HTTPS_PROXY'};
  39 delete $ENV{'FTP_PROXY'};
  40 delete $ENV{'http_proxy'};
  41 delete $ENV{'https_proxy'};
  42 delete $ENV{'ftp_proxy'};
  43
  44
  45 ##################################################
  46
  47 =head2 get_omd_bin
  48
  49   returns path to omd binary
  50
  51 =cut
  52
  53 sub get_omd_bin {
  54     our $omd_bin;
  55     return $omd_bin if defined $omd_bin;
  56
  57     $omd_bin = $ENV{'OMD_BIN'} || '/usr/bin/omd';
  58
  59     # first check /omd
  60     if( ! -e '/omd' ) {
  61         if($omd_bin eq '/usr/bin/omd') {
  62             BAIL_OUT('Broken installation, got /usr/bin/omd but no /omd')
  63         } elsif($omd_bin eq 'destdir/opt/omd/versions/default/bin/omd') {
  64             symlink(getcwd()."/destdir/omd", '/omd');
  65             $omd_symlink_created = 1;
  66         } else {
  67             BAIL_OUT('did not find a valid /omd, please make sure it exists')
  68         }
  69     }
  70     else {
  71         if(-l '/omd') {
  72             my $target = readlink('/omd');
  73             if($omd_bin eq '/usr/bin/omd') {
  74                 if($target ne "/opt/omd" && $target ne "opt/omd") {
  75                     BAIL_OUT('symlink for /omd already exists but is wrong: should be: /opt/omd but got: '.$target);
  76                 }
  77             }
  78             elsif($omd_bin eq 'destdir/opt/omd/versions/default/bin/omd') {
  79                 if($target ne getcwd()."/destdir/omd") {
  80                     BAIL_OUT('symlink for /omd already exists but is wrong: should be: '.getcwd().'/destdir/omd but got: '.$target);
  81                 }
  82             }
  83         } else {
  84             BAIL_OUT('cannot run tests, /omd has to be a symlink to '.getcwd().'/destdir/omd (or /opt/omd for testing packages) in order to run tests for the source version');
  85         }
  86     }
  87
  88     -x $omd_bin or BAIL_OUT($omd_bin." is required for further tests: $!");
  89
  90     return $omd_bin;
  91 }
  92
  93 ##################################################
  94
  95 =head2 test_command
  96
  97   execute a test command
  98
  99   needs test hash
 100   {
 101     cmd     => command line to execute
 102     exit    => expected exit code
 103     like    => (list of) regular expressions which have to match stdout
 104     errlike => (list of) regular expressions which have to match stderr, default: empty
 105     sleep   => time to wait after executing the command
 106   }
 107
 108 =cut
 109 sub test_command {
 110     my $test = shift;
 111     my($rc, $stderr) = ( -1, '') ;
 112     my $return = 1;
 113
 114     # run the command
 115     isnt($test->{'cmd'}, undef, "running cmd: ".$test->{'cmd'}) or $return = 0;
 116
 117     my($prg,$arg) = split(/\s+/, $test->{'cmd'}, 2);
 118     my $t = Test::Cmd->new(prog => $prg, workdir => '') or die($!);
 119     alarm(300);
 120     eval {
 121         local $SIG{ALRM} = sub { die "timeout on cmd: ".$test->{'cmd'}."\n" };
 122         $t->run(args => $arg, stdin => $test->{'stdin'});
 123         $rc = $?>>8;
 124     };
 125     if($@) {
 126         $stderr = $@;
 127     } else {
 128         $stderr = $t->stderr;
 129         $stderr = TestUtils::_clean_stderr($stderr);
 130     }
 131     alarm(0);
 132
 133     # exit code?
 134     $test->{'exit'} = 0 unless exists $test->{'exit'};
 135     if(defined $test->{'exit'} and $test->{'exit'} != -1) {
 136         ok($rc == $test->{'exit'}, "exit code: ".$rc." == ".$test->{'exit'}) or do { _diag_cmd($test, $t); $return = 0 };
 137     }
 138
 139     # matches on stdout?
 140     if(defined $test->{'like'}) {
 141         for my $expr (ref $test->{'like'} eq 'ARRAY' ? @{$test->{'like'}} : $test->{'like'} ) {
 142             like($t->stdout, $expr, "stdout like ".$expr) or do { diag("\ncmd: '".$test->{'cmd'}."' failed\n"); $return = 0 };
 143         }
 144     }
 145
 146     # matches on stderr?
 147     $test->{'errlike'} = '/^\s*$/' unless exists $test->{'errlike'};
 148     if(defined $test->{'errlike'}) {
 149         for my $expr (ref $test->{'errlike'} eq 'ARRAY' ? @{$test->{'errlike'}} : $test->{'errlike'} ) {
 150             like($stderr, $expr, "stderr like ".$expr) or do { diag("\ncmd: '".$test->{'cmd'}."' failed"); $return = 0 };
 151         }
 152     }
 153
 154     # sleep after the command?
 155     if(defined $test->{'sleep'}) {
 156         ok(sleep($test->{'sleep'}), "slept $test->{'sleep'} seconds") or do { $return = 0 };
 157     }
 158
 159     # set some values
 160     $test->{'stdout'} = $t->stdout;
 161     $test->{'stderr'} = $t->stderr;
 162     $test->{'exit'}   = $rc;
 163
 164     return $return;
 165 }
 166
 167
 168 ##################################################
 169
 170 =head2 file_contains
 171
 172   verify contents of a file
 173
 174   needs test hash
 175   {
 176     file    => file to check
 177     like    => (list of) regular expressions which have to match
 178     unlike  => (list of) regular expressions which must not match stderr
 179   }
 180
 181 =cut
 182 sub file_contains {
 183     my $test    = shift;
 184     my $failed  = 0;
 185     my $content = "";
 186
 187     my @like = ();
 188     if(defined $test->{'like'}) {
 189         @like   = ref $test->{'like'}   eq 'ARRAY' ? @{$test->{'like'}}   : $test->{'like'};
 190     }
 191     my @unlike = ();
 192     if(defined $test->{'unlike'}) {
 193         @unlike = ref $test->{'unlike'} eq 'ARRAY' ? @{$test->{'unlike'}} : $test->{'unlike'};
 194     }
 195
 196     ok(-r $test->{'file'}, $test->{'file'}." does exist");
 197
 198     SKIP: {
 199         skip 'file missing', (scalar @like + scalar @unlike) unless -r $test->{'file'};
 200
 201         local $/ = undef;
 202         open my $fh, $test->{'file'} or die "Couldn't open file ".$test->{'file'}.": $!";
 203         binmode $fh;
 204         $content = <$fh>;
 205
 206         # matches?
 207         if(defined $test->{'like'}) {
 208             for my $expr (@like) {
 209                 like($content, $expr, "content like ".$expr) or $failed++;
 210             }
 211         }
 212
 213         # don't matches
 214         if(defined $test->{'unlike'}) {
 215             for my $expr (@unlike) {
 216                 unlike($content, $expr, "output unlike ".$expr) or $failed++;
 217             }
 218         }
 219     };
 220
 221     return 1 unless $failed;
 222     return 0;
 223 }
 224
 225
 226 ##################################################
 227
 228 =head2 create_test_site
 229
 230   creates a test site and returns the name
 231
 232 =cut
 233 sub create_test_site {
 234     my $site = "testsite";
 235     if(test_command({ cmd => TestUtils::get_omd_bin()." create $site" })) {
 236         return $site;
 237     }
 238     return;
 239 }
 240
 241
 242 ##################################################
 243
 244 =head2 remove_test_site
 245
 246   removes a test site
 247
 248 =cut
 249 sub remove_test_site {
 250     my $site = shift;
 251     test_command({ cmd => TestUtils::get_omd_bin()." rm $site", stdin => "yes\n" });
 252     return;
 253 }
 254
 255
 256 ##################################################
 257
 258 =head2 test_url
 259
 260   test a url
 261
 262   needs test hash
 263   {
 264     url              => url to request
 265     auth             => authentication (realm:user:pass)
 266     code             => expected response code
 267     like             => (list of) regular expressions which have to match content
 268     unlike           => (list of) regular expressions which must not match content
 269     skip_html_lint   => flag to disable the html lint checking
 270     skip_link_check  => (list of) regular expressions to skip the link checks for
 271     waitfor          => wait till regex occurs (max 60sec)
 272   }
 273
 274 =cut
 275 sub test_url {
 276     my $test = shift;
 277
 278     my $start = time();
 279     my $page  = _request($test);
 280
 281     # wait for something?
 282     if(defined $test->{'waitfor'}) {
 283         my $now = time();
 284         my $waitfor = $test->{'waitfor'};
 285         my $found   = 0;
 286         while($now < $start + 60) {
 287             if($page->{'content'} =~ m/$waitfor/mx) {
 288                 ok(1, "content ".$waitfor." found after ".($now - $start)."seconds");
 289                 $found = 1;
 290                 last;
 291             }
 292             sleep(1);
 293             $now = time();
 294             $page = _request($test);
 295         }
 296         fail("content did not occur within 60 seconds") unless $found;
 297         return $page;
 298     }
 299
 300     # response code?
 301     $test->{'code'} = 200 unless exists $test->{'code'};
 302     if(defined $test->{'code'}) {
 303         is($page->{'code'}, $test->{'code'}, "response code for ".$test->{'url'}." is: ".$test->{'code'}) or _diag_request($test, $page);
 304     }
 305
 306     # content type?
 307     if(defined $test->{'content_type'}) {
 308         is($page->{'content_type'}, $test->{'content_type'}, 'Content-Type is: '.$test->{'content_type'});
 309     }
 310
 311     # matches output?
 312     if(defined $test->{'like'}) {
 313         for my $expr (ref $test->{'like'} eq 'ARRAY' ? @{$test->{'like'}} : $test->{'like'} ) {
 314             like($page->{'content'}, $expr, "content like ".$expr);
 315         }
 316     }
 317
 318     # not matching output
 319     if(defined $test->{'unlike'}) {
 320         for my $expr (ref $test->{'unlike'} eq 'ARRAY' ? @{$test->{'unlike'}} : $test->{'unlike'} ) {
 321             unlike($page->{'content'}, $expr, "content unlike ".$expr)  or _diag_request($test, $page);
 322         }
 323     }
 324
 325     # html valitidy
 326     SKIP: {
 327         if($page->{'content_type'} =~ 'text\/html') {
 328             unless(defined $test->{'skip_html_lint'} && $test->{'skip_html_lint'} == 1) {
 329                 if($use_html_lint == 0) {
 330                     skip "no HTML::Lint installed", 2;
 331                 }
 332                 if($page->{'content'} =~ /^\[.*\]$/mx) {
 333                     skip "no lint check for json data", 2;
 334                 }
 335                 my $lint = new HTML::Lint;
 336                 isa_ok( $lint, "HTML::Lint" );
 337
 338                 $lint->parse($page->{'content'});
 339                 my @errors = $lint->errors;
 340                 @errors = _diag_lint_errors_and_remove_some_exceptions($lint);
 341                 is( scalar @errors, 0, "No errors found in HTML" );
 342                 $lint->clear_errors();
 343             }
 344         }
 345     }
 346
 347     # check for missing images / css or js
 348     if($page->{'content_type'} =~ 'text\/html'
 349        and (!defined $test->{'skip_html_links'} or $test->{'skip_html_links'} == 0)
 350       ) {
 351         my $content = $page->{'content'};
 352         $content =~ s/<\!\-\-.*?\-\->//gsmx;
 353         my @matches = $content =~ m/(src|href)=['|"](.+?)['|"]/gi;
 354         my $links_to_check;
 355         my $x=0;
 356         for my $match (@matches) {
 357             $x++;
 358             next if $x%2==1;
 359             next if $match =~ m/^http/;
 360             next if $match =~ m/^mailto:/;
 361             next if $match =~ m/^#/;
 362             next if $match =~ m/^javascript:/;
 363             next if $match =~ m/internal&srv=runtime/;
 364             if(defined $test->{'skip_link_check'}) {
 365                 my $skip = 0;
 366                 for my $expr (ref $test->{'skip_link_check'} eq 'ARRAY' ? @{$test->{'skip_link_check'}} : $test->{'skip_link_check'} ) {
 367                     if($skip == 0 and $match =~ m/$expr/) {
 368                         $skip = 1;
 369                     }
 370                 }
 371                 next if $skip == 1;
 372             }
 373             $links_to_check->{$match} = 1;
 374         }
 375         my $errors = 0;
 376         for my $test_url (keys %{$links_to_check}) {
 377             $test_url = _get_url($test->{'url'}, $test_url);
 378             our $already_checked;
 379             $already_checked = {} unless defined $already_checked;
 380             next if defined $already_checked->{$test_url};
 381             #diag("checking link: ".$test_url);
 382             my $req = _request({url => $test_url, auth => $test->{'auth'}});
 383             if($req->{'response'}->is_redirect) {
 384                 my $redirects = 0;
 385                 while(my $location = $req->{'response'}->{'_headers'}->{'location'}) {
 386                     if($location !~ m/^(http|\/)/gmx) { $location = _relative_url($location, $req->{'response'}->base()->as_string()); }
 387                     $req= _request($location);
 388                     $redirects++;
 389                     last if $redirects > 10;
 390                 }
 391             }
 392             if($req->{'code'} == 200) {
 393                 $already_checked->{$test_url} = 1;
 394             } else {
 395                 $errors++;
 396                 diag("got status ".$req->{'code'}." for url: '$test_url'");
 397                 diag(Dumper($req));
 398                 my $tmp_test = { 'url' => $test_url };
 399                 _diag_request($tmp_test, $req);
 400                 TestUtils::bail_out_clean("error in url '$test_url' linked from '".$test->{'url'}."'");
 401             }
 402         }
 403         is( $errors, 0, 'All stylesheets, images and javascript exist' );
 404     }
 405     return $page;
 406 }
 407
 408 ##################################################
 409
 410 =head2 config
 411
 412   return config value
 413
 414 =cut
 415 sub config {
 416     my $key = shift;
 417     our $config;
 418     return $config->{$key} if defined $config;
 419
 420     my $conf_file = "/omd/versions/default/share/omd/distro.info";
 421     $config = read_config($conf_file);
 422
 423     return $config->{$key};
 424 }
 425
 426
 427 ##################################################
 428
 429 =head2 read_config
 430
 431   return config from file
 432
 433 =cut
 434 sub read_config {
 435     my $conf_file = shift;
 436
 437     my $config = {};
 438     open(my $fh, '<', $conf_file) or carp("cannot open $conf_file: $!");
 439     while(<$fh>) {
 440         my $line = $_;
 441         chomp($line);
 442         next if $line =~ m/^\s*(#|$)/;
 443         $line =~ s/\s*#.*$//;
 444         my $append = 0;
 445         my($key,$value) = split/\s+\+=\s*/,$line,2;
 446         if(defined $value) {
 447             $append = 1;
 448         } else {
 449             ($key,$value) = split/\s+=\s*/,$line,2;
 450         }
 451         $key   =~ s/^\s+//;
 452         $value =~ s/\s+$// if defined $value;
 453         if($append) {
 454             $config->{$key} .= " ".$value;
 455         } else {
 456             $config->{$key} = $value;
 457         }
 458     }
 459     close($fh);
 460     return $config;
 461 }
 462
 463
 464
 465 ##################################################
 466
 467 =head2 config
 468
 469   return config value
 470
 471 =cut
 472 sub wait_for_file {
 473     my $file    = shift;
 474     my $timeout = shift || 120;
 475
 476     my $x = 0;
 477     if(-e $file) {
 478         pass("file: $file does already exist");
 479         return 1;
 480     }
 481     while($x < $timeout) {
 482         if(-e $file) {
 483             pass("file: $file appeared after $x seconds");
 484             return 1;
 485         }
 486         $x++;
 487         sleep(1);
 488     }
 489     fail("file: $file did not appear within $x seconds");
 490     return 0;
 491 }
 492
 493
 494 ##################################################
 495
 496 =head2 wait_for_content
 497
 498   waits for web page content until timeout
 499
 500   needs test hash
 501   {
 502     url            => url to request
 503     auth           => authentication (realm:user:pass)
 504     code           => expected response code
 505     like           => (list of) regular expressions which have to match content
 506   }
 507
 508 =cut
 509 sub wait_for_content {
 510     my $test    = shift;
 511     my $timeout = shift || 120;
 512
 513     my $req;
 514     my $x = 0;
 515     while ($x < $timeout) {
 516         $req = _request($test);
 517         if($req->{'code'} == 200) {
 518             #diag("code:$req->{code} url:$test->{url} auth:$test->{auth}");
 519             my $errors=0;
 520             for my $pattern (@{$test->{'like'}}) {
 521                 if ($req->{'content'}!~/$pattern/) {
 522                     #diag("errors:$errors pattern:$pattern");
 523                     $errors++;
 524                 }
 525             }
 526             if ($errors == 0) {
 527                 pass(sprintf "content: [ %s ] appeared after $x seconds", join(',',@{$test->{'like'}}));
 528                 return 1;
 529             }
 530         } else {
 531             diag("Error searching for web content:\ncode:$req->{code}\nurl:$test->{url}\nauth:$test->{auth}\ncontent:$req->{content}");
 532         }
 533         $x++;
 534         sleep(1);
 535     }
 536     fail(sprintf "content: [ %s ] did not appear within $x seconds", join(',',@{$test->{'like'}}));
 537     return 0;
 538 }
 539
 540
 541 ##################################################
 542
 543 =head2 prepare_obj_config
 544
 545   prepare test object config
 546
 547 =cut
 548 sub prepare_obj_config {
 549     my $src  = shift;
 550     my $dst  = shift;
 551     my $site = shift;
 552
 553     my $files = join(" ", (ref $src eq 'ARRAY' ? @{$src} : $src));
 554     for my $file (`find $files -type f`) {
 555         chomp($file);
 556         my $dstfile = $dst;
 557         if(-d $dst) { $dstfile = $dst.'/'.basename($file); }
 558         cp($file, $dstfile) or die("copy $file $dstfile failed: $!");
 559         test_command({ cmd => "/usr/bin/env sed -i $dstfile -e 's/###SITE###/".$site."/' -e 's|###ROOT###|/omd/sites/".$site."|'" }) if defined $site;
 560     }
 561
 562     return;
 563 }
 564
 565
 566 ##################################################
 567
 568 =head2 bail_out_clean
 569
 570   bail out from testing but some minor cleanup before
 571
 572 =cut
 573 sub bail_out_clean {
 574     my $msg = shift;
 575
 576     carp("cleaning up before bailout");
 577
 578     my $omd_bin = get_omd_bin();
 579     for my $site (qw/testsite testsite2 testsite3/) {
 580         test_command({ cmd => $omd_bin." rm $site", stdin => "yes\n", 'exit' => undef, errlike => undef });
 581     }
 582
 583     BAIL_OUT($msg);
 584     return;
 585 }
 586
 587 ##################################################
 588
 589 =head2 _diag_lint_errors_and_remove_some_exceptions
 590
 591   removes some lint errors we want to ignore
 592
 593 =cut
 594 sub _diag_lint_errors_and_remove_some_exceptions {
 595     my $lint = shift;
 596     my @return;
 597     LINT_ERROR: for my $error ( $lint->errors ) {
 598         my $err_str = $error->as_string;
 599         for my $exclude_pattern (
 600             "<IMG SRC=[^>]*>\ tag\ has\ no\ HEIGHT\ and\ WIDTH\ attributes",
 601             "<IMG SRC=[^>]*>\ does\ not\ have\ ALT\ text\ defined",
 602             "<input>\ is\ not\ a\ container\ \-\-\ <\/input>\ is\ not\ allowed",
 603             "Unknown attribute \"start\" for tag <div>",
 604             "Unknown attribute \"end\" for tag <div>",
 605             "for tag <meta>",
 606             "Unknown\ attribute\ \"placeholder\"\ for\ tag\ <input>",
 607         ) {
 608             next LINT_ERROR if($err_str =~ m/$exclude_pattern/i);
 609         }
 610         diag($error->as_string."\n");
 611         push @return, $error;
 612     }
 613     return @return;
 614 }
 615
 616
 617 ##################################################
 618
 619 =head2 _request
 620
 621   returns a page
 622
 623   expects a hash
 624   {
 625     url     => url to request
 626     auth    => authentication (realm:user:pass)
 627   }
 628
 629 =cut
 630 sub _request {
 631     my $data = shift;
 632
 633     my $return = {};
 634     our $cookie_jar;
 635
 636     if(!defined $cookie_jar) {
 637         my($fh, $cookie_file) = tempfile(undef, UNLINK => 1);
 638         unlink ($cookie_file);
 639         $cookie_jar = HTTP::Cookies::Netscape->new(
 640                                        file     => $cookie_file,
 641                                        autosave => 1,
 642                                        );
 643     }
 644
 645     my $ua = LWP::UserAgent->new;
 646     $ua->timeout(30);
 647     $ua->env_proxy;
 648     $ua->cookie_jar($cookie_jar);
 649
 650     if(defined $data->{'auth'}) {
 651         $data->{'url'} =~ m/(http|https):\/\/(.*?)(\/|:\d+)/;
 652         my $netloc = $2;
 653         my $port   = $3;
 654         if(defined $port and $port =~ m/^:(\d+)/) { $port = $1; } else { $port = 80; }
 655         my($realm,$user,$pass) = split(/:/, $data->{'auth'}, 3);
 656         $ua->credentials($netloc.":".$port, $realm, $user, $pass);
 657     }
 658
 659     my $response;
 660     if(defined $data->{'post'}) {
 661         $response = $ua->post($data->{'url'}, $data->{'post'});
 662     } else {
 663         $response = $ua->get($data->{'url'});
 664     }
 665
 666     $return->{'response'}     = $response;
 667     $return->{'code'}         = $response->code;
 668     $return->{'content'}      = $response->decoded_content;
 669     $return->{'content_type'} = $response->header('Content-Type');
 670
 671     return($return);
 672 }
 673
 674
 675 ##################################################
 676
 677 =head2 _get_url
 678
 679   returns a absolute url
 680
 681   expects
 682   $VAR1 = origin url
 683   $VAR2 = target link
 684
 685 =cut
 686 sub _get_url {
 687     my $url  = shift;
 688     my $link = shift;
 689     my $newurl;
 690
 691     # split original url in host, path and file
 692     if($url =~ m/^(http|https):\/\/([^\/]*)(|\/|:\d+)(.*?)$/) {
 693         my $host     = $1."://".$2.$3;
 694         $host        =~ s/\/$//;      # remove last /
 695         my $fullpath = $4 || '';
 696         $fullpath    =~ s/\?.*$//;
 697         $fullpath    =~ s/^\///;
 698         my($path,$file) = ('', '');
 699         if($fullpath =~ m/^(.+)\/(.*)$/) {
 700             $path = $1;
 701             $file = $2;
 702         }
 703         else {
 704             $file = $fullpath;
 705         }
 706         $path =~ s/^\///; # remove first /
 707
 708         if($link =~ m/^(http|https):\/\//) {
 709             return $link;
 710         }
 711         elsif($link =~ m/^\//) { # absolute link
 712             return $host.$link;
 713         }
 714         elsif($path eq '') {
 715             return $host."/".$link;
 716         } else {
 717             return $host."/".$path."/".$link;
 718         }
 719     }
 720     else {
 721         TestUtils::bail_out_clean("unknown url scheme in _get_url: '".$url."'");
 722     }
 723
 724     return $newurl;
 725 }
 726
 727
 728 ##################################################
 729
 730 =head2 _clean_stderr
 731
 732   remove some know errors from stderr
 733
 734 =cut
 735 sub _clean_stderr {
 736     my $text = shift || '';
 737     $text =~ s/[\w\-]+: Could not reliably determine the server's fully qualified domain name, using .*? for ServerName//g;
 738     $text =~ s/\[warn\] module \w+ is already loaded, skipping//g;
 739     $text =~ s/Syntax OK//g;
 740     $text =~ s/no crontab for \w+//g;
 741     return $text;
 742 }
 743
 744 ##################################################
 745
 746 =head2 _diag_cmd
 747
 748   print diagnostic output for failed commands
 749
 750 =cut
 751 sub _diag_cmd {
 752     my $test = shift;
 753     my $cmd  = shift;
 754     my $stdout = $cmd->stdout || '';
 755     my $stderr = $cmd->stderr || '';
 756     diag("\ncmd: '".$test->{'cmd'}."' failed\n");
 757     diag("stdout: ".$stdout."\n");
 758     diag("stderr: ".$stderr."\n");
 759
 760     # check logfiles on apache errors
 761     if(   $stdout =~ m/Starting dedicated Apache for site (\w+)[\.\ ]*ERROR/
 762        or $stdout =~ m/500 Internal Server Error/) {
 763         my $site = $1;
 764         _tail("apache logs:", "/omd/sites/$site/var/log/apache/error_log") if defined $site;
 765         _tail_apache_logs();
 766     }
 767     if( $stderr =~ m/User '(\w+)' still logged in or running processes/ ) {
 768         my $site = $1;
 769         diag("ps: ".`ps -fu $site`) if $site;
 770     }
 771     return;
 772 }
 773
 774 ##################################################
 775
 776 =head2 _diag_request
 777
 778   print diagnostic output for failed requests
 779
 780 =cut
 781 sub _diag_request {
 782     my $test  = shift;
 783     my $page  = shift;
 784
 785     $test->{'url'} =~ m/localhost\/(\w+)\//;
 786     my $site = $1;
 787     return unless defined $site;
 788
 789     # check logfiles on apache errors
 790     if(   $page->{'code'}    == 500
 791        or $page->{'content'} =~ m/Internal Server Error/) {
 792         _tail("apache logs:", "/omd/sites/$site/var/log/apache/error_log");
 793         _tail_apache_logs();
 794         _tail("thruk logs:", "/omd/sites/$site/var/log/thruk.log") if $test->{'url'} =~ m/\/thruk\//;
 795     }
 796     diag(Dumper($page->{'response'}));
 797     return;
 798 }
 799
 800 ##################################################
 801
 802 =head2 _tail
 803
 804   print tail of fail
 805
 806 =cut
 807 sub _tail {
 808     my $name = shift;
 809     my $file = shift;
 810     return unless defined $file;
 811     diag($name);
 812     if(-f $file) {
 813         diag(`tail -n100 $file`);
 814     } else {
 815         diag("cannot read $file: $!");
 816     }
 817     return;
 818 }
 819
 820
 821 ##################################################
 822
 823 =head2 _tail_apache_logs
 824
 825   print tail of all apache logs
 826
 827 =cut
 828 sub _tail_apache_logs {
 829     _tail("global apache logs:", glob('/var/log/apache*/error*log'));
 830     _tail("global apache logs:", glob('/var/log/httpd*/error*log'));
 831     return;
 832 }
 833
 834 ##################################################
 835
 836 END {
 837     if(defined $omd_symlink_created and $omd_symlink_created == 1) {
 838         unlink('/omd');
 839     }
 840 };
 841
 842 1;
 843
 844 __END__