+# Collect platform, config data that should allow comparing
+# performance data between different machines. With enough data,
+# and/or clever statistical analysis, it should be possible to
+# determine the effect of config choices, more memory, etc
+
+sub gather_conf_platform_info {
+ # currently rather quick & dirty, and subject to change
+ # for both content and format.
+ require Config;
+ my (%conf, @platform) = ();
+ $conf{$_} = $Config::Config{$_} for
+ grep /cc|git|config_arg\d+/, keys %Config::Config;
+ if (-f '/proc/cpuinfo') {
+ open my $fh, '/proc/cpuinfo' or warn "$!: /proc/cpuinfo\n";
+ @platform = grep /name|cpu/, <$fh>;
+ chomp $_ for @platform;
+ }
+ unshift @platform, $^O;
+
+ return (
+ conf => \%conf,
+ platform => {cpu => \@platform,
+ mem => [ grep s/\s+/ /,
+ grep chomp, `free` ],
+ load => [ grep chomp, `uptime` ],
+ },
+ host => (grep chomp, `hostname -f`),
+ version => '0.03', # bump for conf, platform, or data collection changes
+ );
+}
+
+sub _check_valgrind {
+ return unless $ENV{PERL_VALGRIND};
+
+ my ($toolnm, $grind_ct, $test) = @_;
+
+ $$toolnm = $ENV{VALGRIND};
+ $$toolnm =~ s|.*/||; # keep basename
+ my @valgrind; # gets content of file
+ if (-e $Valgrind_Log) {
+ if (open(V, $Valgrind_Log)) {
+ @valgrind = <V>;
+ close V;
+ } else {
+ warn "$0: Failed to open '$Valgrind_Log': $!\n";
+ }
+ }
+ if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $$toolnm =~ /(perf)/) {
+ $$toolnm = $1;
+ if ($$toolnm eq 'perf') {
+ # append perfs subcommand, not just stat
+ my ($sub) = split /\s/, $ENV{VG_OPTS};
+ $$toolnm .= "-$sub";
+ }
+ if (rename $Valgrind_Log, "$$test.$$toolnm") {
+ $$grind_ct++;
+ } else {
+ warn "$0: Failed to create '$$test.$$toolnm': $!\n";
+ }
+ }
+ elsif (@valgrind) {
+ my $leaks = 0;
+ my $errors = 0;
+ for my $i (0..$#valgrind) {
+ local $_ = $valgrind[$i];
+ if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
+ $errors = $errors + $1; # there may be multiple error summaries
+ } elsif (/^==\d+== LEAK SUMMARY:/) {
+ for my $off (1 .. 4) {
+ if ($valgrind[$i+$off] =~
+ /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
+ $leaks = $leaks + $1;
+ }
+ }
+ }
+ }
+ if ($errors or $leaks) {
+ if (rename $Valgrind_Log, "$$test.valgrind") {
+ $$grind_ct = $$grind_ct + 1;
+ } else {
+ warn "$0: Failed to create '$$test.valgrind': $!\n";
+ }
+ }
+ } else {
+ # Quiet wasn't asked for? Something may be amiss
+ if ($ENV{VG_OPTS} && $ENV{VG_OPTS} !~ /(^|\s)(-q|--quiet)(\s|$)/) {
+ warn "No valgrind output?\n";
+ }
+ }
+ if (-e $Valgrind_Log) {
+ unlink $Valgrind_Log
+ or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
+ }
+}
+
+sub _cleanup_valgrind {
+ return unless $ENV{PERL_VALGRIND};
+
+ my ($toolnm, $grind_ct) = @_;
+ my $s = $$grind_ct == 1 ? '' : 's';
+ print "$$grind_ct valgrind report$s created.\n", ;
+ if ($$toolnm eq 'cachegrind') {
+ # cachegrind leaves a lot of cachegrind.out.$pid litter
+ # around the tree, find and delete them
+ unlink _find_files('cachegrind.out.\d+$',
+ qw ( ../t ../cpan ../ext ../dist/ ));
+ }
+}
+
+# Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt
+my $in;
+
+sub _process_deparse_config {
+ my @deparse_failures;
+ my @deparse_skips;
+
+ my $f = '../Porting/deparse-skips.txt';
+
+ my $skips;
+ if (!open($skips, '<', $f)) {
+ warn "Failed to find $f: $!\n";
+ return;
+ }
+
+ while(<$skips>) {
+ if (/__DEPARSE_FAILURES__/) {
+ $in = \@deparse_failures; next;
+ } elsif (/__DEPARSE_SKIPS__/) {
+ $in = \@deparse_skips; next;
+ } elsif (!$in) {
+ next;
+ }
+
+ s/#.*$//; # Kill comments
+ s/\s+$//; # And trailing whitespace
+
+ next unless $_;
+
+ push @$in, $_;
+ }
+
+ for my $f (@deparse_failures, @deparse_skips) {
+ if ($f =~ m|/$|) { # Dir? Skip everything below it
+ $f = qr/\Q$f\E.*/;
+ } else {
+ $f = qr/\Q$f\E/;
+ }
+ }
+
+ $deparse_failures = join('|', @deparse_failures);
+ $deparse_failures = qr/^(?:$deparse_failures)$/;
+
+ $deparse_skips = join('|', @deparse_skips);
+ $deparse_skips = qr/^(?:$deparse_skips)$/;
+}
+