view release on metacpan or  search on metacpan

t/lib/NYTProfTest.pm  view on Meta::CPAN

sub _quote_join {
    join ' ', map qq{"$_"}, @_;
}

# some tests use profile_this() in Devel::NYTProf::Run
sub run_perl_command {
    my ($cmd, $show_stdout) = @_;
    local $ENV{PERL5LIB} = $perl5lib;
    my @perl = perl_command_words(skip_sitecustomize => 1);
    run_command(_quote_join(@perl) . " $cmd", $show_stdout);
}


sub profile { # TODO refactor to use run_perl_command()?
    my ($test, $profile_datafile) = @_;

    my @perl = perl_command_words(skip_sitecustomize => 1);
    my $cmd = _quote_join(@perl) . " $opts{profperlopts} $test";
    return ok run_command($cmd), "$test runs ok under the profiler";
}


sub verify_data {
    my ($test, $tag, $profile_datafile) = @_;

    my $profile = eval { Devel::NYTProf::Data->new({filename => $profile_datafile}) };
    if ($@) {
        diag($@);
        fail($test);
        return;
    }

    SKIP: {
        skip 'Expected profile data does not have VMS paths', 1
            if $^O eq 'VMS' and $test =~ m/test60|test14/i;
        $profile->normalize_variables(1); # and options
        dump_profile_to_file($profile, $test.'_new', $test.'_newp');
        is_file_content_same($test.'_new', $test, "$test match generated profile data for $tag");
    }
}

sub is_file_content_same {
    my ($got_file, $exp_file, $testname) = @_;

    my @got = slurp_file($got_file); chomp @got;
    my @exp = slurp_file($exp_file); chomp @exp;
    
    my $updated = update_file_content_array (\@got);
    #  Sort the got and exp data if we updated.
    #  This avoids mismatches due to file sort orders.
    if ($updated) {
        @got = sort @got;
        @exp = sort @exp;
    }

    is_deeply(\@got, \@exp, $testname)
        ? unlink($got_file)
        : diff_files($exp_file, $got_file, $got_file."_patch");
}

sub update_file_content_array {
    my $lines = shift;
    
    my $file_info_start;
    foreach my $i (0 .. $#$lines) {
        next if not $lines->[$i] =~ /^fid_fileinfo/;
        #  Remove path info that creeps in when run under prove
        #  Should perhaps use Regexp::Common, or borrow from it.
        $lines->[$i] =~ s|(\d\t\[ )(\w:/)?([\-\w\s]+/)+|$1|;
        $file_info_start ||= $i;
        last if $i > $file_info_start + 4;
    }

    return if !$file_info_start;

    my $re_eval_id = qr /\(eval ([0-9]+)\)/;
    my $start_eval_id = 1;
    #  find the first fid_fileinfo line with an eval in it
    for my $i ($file_info_start .. 10+$file_info_start) {
        if ($lines->[$i] =~ $re_eval_id) {
            $start_eval_id = $1;
            last;
        };
    }
    return if $start_eval_id <= 1;
    
    my $eval_id_offset = $start_eval_id - 1;
    
    #  now update the eval IDs for the offset
    foreach my $i ($file_info_start .. $#$lines) {
        if (my @matches = ($lines->[$i] =~ m/$re_eval_id/g)) {
            foreach my $got (@matches) {
                my $replace = $got - $eval_id_offset;
                if ($lines->[$i] =~ /test22-strevala.p/) {
                    #  Correct for the alphabetical ordering
                    #  as otherwise the 10 is listed before the 9
                    #  and the line does not match exactly.
                    #  Clunky, but works for now.
                    if ($got == 10) {
                        $replace -= 1;
                    }
                    elsif (@matches > 2 && $got == 9) {
                        $replace += 1;
                    }
                }
                $lines->[$i] =~ s/\(eval $got\)/\(eval $replace\)/;
            }
        }
    }

    #  indicate changes
    return 1;
}


sub dump_data_to_file {
    my ($profile, $file) = @_;
    open my $fh, ">", $file or croak "Can't open $file: $!";
    local $Data::Dumper::Indent   = 1;
    local $Data::Dumper::Sortkeys = 1;
    print $fh Data::Dumper->Dump([$profile], ['expected']);