gecko/testing/tinderbox-standalone-tests/Util.pm

# This Source Code Form is subject to the terms of the Mozilla Public
# License, v. 2.0. If a copy of the MPL was not distributed with this
# file, You can obtain one at http://mozilla.org/MPL/2.0/.

package Util;

use Sys::Hostname;
use File::Copy;
use POSIX qw(sys_wait_h strftime);

sub print_log {
    my ($text) = @_;
    #print LOG $text;
    print $text;
}

sub print_logfile {
    my ($logfile, $test_name) = @_;
    print "DEBUG: $logfile\n";
    print_log "----------- Output from $test_name ------------- \n";
    open READRUNLOG, "$logfile" or die "Can't open log $logfile: $!\n";
    print_log "  $_" while <READRUNLOG>;
    close READRUNLOG or die "Can't close log $logfile: $!\n";
    print_log "----------- End Output from $test_name --------- \n";
}

sub print_test_errors {
    my ($result, $name) = @_;

    if (not $result->{timed_out} and $result->{exit_value} != 0) {
        if ($result->{sig_name} ne '') {
            print_log "Error: $name: received SIG$result->{sig_name}\n";
        }
        print_log "Error: $name: exited with status $result->{exit_value}\n";
        if ($result->{dumped_core}) {
            print_log "Error: $name: dumped core.\n";
        }
    }
}

# Parse a file for $token, return the token.
# Look for the line "<token><delimiter><return-value>", e.g.
# for "__startuptime,5501"
#   token        = "__startuptime"
#   delimiter    = ","
#   return-value = "5501";
#
sub extract_token {
    my ($output, $token, $delimiter) = @_;
    use Data::Dumper;
    print Dumper("extract_token: @_");
    my $token_value = 0;
    if ($output =~ /$token/) {
        $token_value = substr($output, index($output, $delimiter) + 1);
        chomp($token_value);
    }
    return $token_value;
}

sub run_cmd {
    my ($home_dir, $binary_dir, $args, $timeout_secs) = @_;
    my $now = localtime();
    my $pid = 0;
    my $shell_command = join(' ', @{$args});

    my $exit_value = 1;
    my $signal_num;
    my $sig_name;
    my $dumped_core;
    my $timed_out;
    my $output;

    print_log "Begin: $now\n";
    print_log "cmd = $shell_command\n";

    eval{
      # Set XRE_NO_WINDOWS_CRASH_DIALOG to disable showing
      # the windows crash dialog in case the child process
      # crashes
      $ENV{XRE_NO_WINDOWS_CRASH_DIALOG} = 1;

      # Now cd to dir where binary is..
      chdir $binary_dir or die "chdir($binary_dir): $!\n";
        
      local $SIG{ALRM} = sub { die "alarm" };
      alarm $timeout_secs;
      $pid = open CMD, "$shell_command |"
             or die "Could not run command: $!"; 

      while (<CMD>) {
        $output .= $_;
        print_log $_;
      }
      close CMD or die "Could not close command: $!";
      $exit_value = $? >> 8;
      $signal_num = $? >> 127;
      $sig_name = signal_name($signal_num);
      $dumped_core = $? & 128;
      $timed_out = 0;
      alarm 0;
    };
    if($@){
      if($@ =~ /alarm/){
        $timed_out = 1;
        kill_process($pid);
      }else{
        print_log("Error running $shell_command: $@\n");
        $output = $@;
      }
    }

    $now = localtime();
    print_log "End:   $now\n";

    if ($exit_value || $timed_out || $dumped_core || $signal_num){
      print_log("Error running $shell_command\n");
      if($output){
        print_log("Output: $output\n");
      }
      if ($exit_value) {
        print_log("Exit value: $exit_value\n");
      }
      if ($timed_out) {
          print_log("Timed out\n");
          # callers expect exit_value to be non-zero if request timed out
          $exit_value = 1;
      }
      if ($dumped_core) {
          print_log("Segfault (core dumped)\n");
      }
      if ($signal_num) {
          print_log("Received signal: $sig_name\n");
      }
    }

    return { timed_out=>$timed_out,
             exit_value=>$exit_value,
             sig_name=>$sig_name,
             output=>$output,
             dumped_core=>$dumped_core };
}


sub get_system_cwd {
    my $a = Cwd::getcwd()||`pwd`;
    chomp($a);
    return $a;
}

sub get_graph_tbox_name {
  if ($Settings::GraphNameOverride ne '') {
    return $Settings::GraphNameOverride;
  }

  my $name = hostname();
  if ($Settings::BuildTag ne '') {
    $name .= '_' . $Settings::BuildTag;
  }
  return $name;
}

sub print_log_test_result {
  my ($test_name, $test_title, $num_result, $units, $print_name, $print_result) = @_;

  print_log "\nTinderboxPrint:";
  if ($Settings::TestsPhoneHome) {
    my $time = POSIX::strftime "%Y:%m:%d:%H:%M:%S", localtime;
    print_log "<a title=\"$test_title\" href=\"http://$Settings::results_server/graph/query.cgi?testname=" . $test_name . "&units=$units&tbox=" . get_graph_tbox_name() . "&autoscale=1&days=7&avg=1&showpoint=$time,$num_result\">";
  } else {
    print_log "<abbr title=\"$test_title\">";
  }
  print_log $print_name;
  if (!$Settings::TestsPhoneHome) {
    print_log "</abbr>";
  }
  print_log ':' . $print_result;
  if ($Settings::TestsPhoneHome) {
    print_log "</a>";
  }
  print_log "\n";

}

sub print_log_test_result_ms {
  my ($test_name, $test_title, $result, $print_name) = @_;
  print_log_test_result($test_name, $test_title, $result, 'ms',
                        $print_name, $result . 'ms');
}

sub print_log_test_result_bytes {
  my ($test_name, $test_title, $result, $print_name, $sig_figs) = @_;

  print_log_test_result($test_name, $test_title, $result, 'bytes',
                        $print_name, PrintSize($result, $sig_figs) . 'B');
}

sub print_log_test_result_count {
  my ($test_name, $test_title, $result, $print_name, $sig_figs) = @_;
  print_log_test_result($test_name, $test_title, $result, 'count',
                        $print_name, PrintSize($result, $sig_figs));
}


# Report test results back to a server.
# Netscape-internal now, will push to mozilla.org, ask
# mcafee or jrgm for details.
#
# Needs the following perl stubs, installed for rh7.1:
# perl-Digest-MD5-2.13-1.i386.rpm
# perl-MIME-Base64-2.12-6.i386.rpm
# perl-libnet-1.0703-6.noarch.rpm
# perl-HTML-Tagset-3.03-3.i386.rpm
# perl-HTML-Parser-3.25-2.i386.rpm
# perl-URI-1.12-5.noarch.rpm
# perl-libwww-perl-5.53-3.noarch.rpm
#
sub send_results_to_server {
    my ($value, $raw_data, $testname) = @_;

    # Prepend raw data with cvs checkout date, performance
    # Use MOZ_CO_DATE, but with same graph/collect.cgi format. (server)
    #my $data_plus_co_time = "MOZ_CO_DATE=$co_time_str\t$raw_data";
    my $data_plus_co_time = "MOZ_CO_DATE=test";
    my $tbox = get_graph_tbox_name();

    my $tmpurl = "http://$Settings::results_server/graph/collect.cgi";
    $tmpurl .= "?value=$value&data=$data_plus_co_time&testname=$testname&tbox=$tbox";

    print_log "send_results_to_server(): \n";
    print_log "tmpurl = $tmpurl\n";

    # libwww-perl has process control problems on windows,
    # spawn wget instead.
    if ($Settings::OS =~ /^WIN/) {
        system ("wget", "-O", "/dev/null", $tmpurl);
        print_log "send_results_to_server() succeeded.\n";
    } else {
        my $res = eval q{
            use LWP::UserAgent;
            use HTTP::Request;
            my $ua  = LWP::UserAgent->new;
            $ua->timeout(10); # seconds
            my $req = HTTP::Request->new(GET => $tmpurl);
            my $res = $ua->request($req);
            return $res;
        };
        if ($@) {
            warn "Failed to submit startup results: $@";
            print_log "send_results_to_server() failed.\n";
        } else {
            print_log "Results submitted to server: \n" .
              $res->status_line . "\n" . $res->content . "\n";
            print_log "send_results_to_server() succeeded.\n";
        }
    }
}

sub kill_process {
    my ($target_pid) = @_;
    my $start_time = time;

    # Try to kill and wait 10 seconds, then try a kill -9
    my $sig;
    for $sig ('TERM', 'KILL') {
        print "kill $sig $target_pid\n";
        kill $sig => $target_pid;
        my $interval_start = time;
        while (time - $interval_start < 10) {
            # the following will work with 'cygwin' perl on win32, but not 
            # with 'MSWin32' (ActiveState) perl
            my $pid = waitpid($target_pid, POSIX::WNOHANG());
            if (($pid == $target_pid and POSIX::WIFEXITED($?)) or $pid == -1) {
                my $secs = time - $start_time;
                $secs = $secs == 1 ? '1 second' : "$secs seconds";
                print_log "Process killed. Took $secs to die.\n";
                return;
            }
            sleep 1;
        }
    }
    die "Unable to kill process: $target_pid";
}

BEGIN {
    my %sig_num = ();
    my @sig_name = ();

    sub signal_name {
        # Find the name of a signal number
        my ($number) = @_;

        unless (@sig_name) {
            unless($Config::Config{sig_name} && $Config::Config{sig_num}) {
                die "No sigs?";
            } else {
                my @names = split ' ', $Config::Config{sig_name};
                @sig_num{@names} = split ' ', $Config::Config{sig_num};
                foreach (@names) {
                    $sig_name[$sig_num{$_}] ||= $_;
                }
            }
        }
        return $sig_name[$number];
    }
}

sub PercentChange($$) {
    my ($old, $new) = @_;
    if ($old == 0) {
        return 0;
    }
    return ($new - $old) / $old;
}

# Print a value of bytes out in a reasonable
# KB, MB, or GB form.  Sig figs should probably
# be 3, 4, or 5 for most purposes here.  This used
# to default to 3 sig figs, but I wanted 4 so I
# generalized here.  -mcafee
#
# Usage: PrintSize(valueAsInteger, numSigFigs)
# 
sub PrintSize($$) {

    # print a number with 3 significant figures
    sub PrintNum($$) {
        my ($num, $sigs) = @_;
        my $rv;

        # Figure out how many decimal places to show.
        # Only doing a few cases here, for normal range
        # of test numbers.

        # Handle zero case first.
        if ($num == 0) {
          $rv = "0";
        } elsif ($num < 10**($sigs-5)) {
          $rv = sprintf "%.5f", ($num);
        } elsif ($num < 10**($sigs-4)) {
          $rv = sprintf "%.4f", ($num);
        } elsif ($num < 10**($sigs-3)) {
          $rv = sprintf "%.3f", ($num);
        } elsif ($num < 10**($sigs-2)) {
          $rv = sprintf "%.2f", ($num);
        } elsif ($num < 10**($sigs-1)) {
          $rv = sprintf "%.1f", ($num);
        } else {
          $rv = sprintf "%d", ($num);
        }

    }

    my ($size, $sigfigs) = @_;

    # 1K = 1024, previously this was approximated as 1000.
    my $rv;
    if ($size > 1073741824) {  # 1024^3
        $rv = PrintNum($size / 1073741824.0, $sigfigs) . "G";
    } elsif ($size > 1048576) {  # 1024^2
        $rv = PrintNum($size / 1048576.0, $sigfigs) . "M";
    } elsif ($size > 1024) {
        $rv = PrintNum($size / 1024.0, $sigfigs) . "K";
    } else {
        $rv = PrintNum($size, $sigfigs);
    }
}

# Page loader (-f option):
# If you are building optimized, you need to add
#   --enable-trace-malloc --enable-perf-metrics
# to turn the pageloader code on.  If you are building debug you only
# need
#   --enable-trace-malloc
#

sub ReadLeakstatsLog($) {
    my ($filename) = @_;
    my $leaks = 0;
    my $leaked_allocs = 0;
    my $mhs = 0;
    my $bytes = 0;
    my $allocs = 0;

    open LEAKSTATS, "$filename"
        or die "unable to open $filename";
    while (<LEAKSTATS>) {
        chop;
        my $line = $_;
        if ($line =~ /Leaks: (\d+) bytes, (\d+) allocations/) {
            $leaks = $1;
            $leaked_allocs = $2;
        } elsif ($line =~ /Maximum Heap Size: (\d+) bytes/) {
            $mhs = $1;
        } elsif ($line =~ /(\d+) bytes were allocated in (\d+) allocations./) {
            $bytes = $1;
            $allocs = $2;
        }
    }

    return {
        'leaks' => $leaks,
        'leaked_allocs' => $leaked_allocs,
        'mhs' => $mhs,
        'bytes' => $bytes,
        'allocs' => $allocs
        };
}

1;