File Coverage

blib/lib/Devel/NYTProf/Run.pm
Criterion Covered Total %
statement 36 42 85.7
branch 7 20 35.0
condition 3 9 33.3
subroutine 8 8 100.0
pod 0 2 0.0
total 54 81 66.6


line stmt bran cond sub pod time code
1             package Devel::NYTProf::Run;
2              
3             # vim: ts=8 sw=4 expandtab:
4             ##########################################################
5             # This script is part of the Devel::NYTProf distribution
6             #
7             # Copyright, contact and other information can be found
8             # at the bottom of this file, or by going to:
9             # http://metacpan.org/release/Devel-NYTProf/
10             #
11             ###########################################################
12              
13             =head1 NAME
14              
15             Devel::NYTProf::Run - Invoke NYTProf on a piece of code and return the profile
16              
17             =head1 DESCRIPTION
18              
19             This module is experimental and subject to change.
20              
21             =cut
22              
23 44     44   22280 use warnings;
  44         150  
  44         1483  
24 44     44   266 use strict;
  44         116  
  44         1078  
25              
26 44     44   231 use base qw(Exporter);
  44         112  
  44         5170  
27              
28 44     44   296 use Carp;
  44         143  
  44         2865  
29 44     44   307 use Config qw(%Config);
  44         143  
  44         1501  
30 44     44   1904 use Devel::NYTProf::Data;
  44         164  
  44         25871  
31              
32             our @EXPORT_OK = qw(
33             profile_this
34             perl_command_words
35             );
36              
37              
38             my $this_perl = $^X;
39             $this_perl .= $Config{_exe} if $^O ne 'VMS' and $this_perl !~ m/$Config{_exe}$/i;
40              
41              
42             sub perl_command_words {
43 602     602 0 60231942 my %opt = @_;
44              
45 602         3727 my @perl = ($this_perl);
46            
47             # testing just $Config{usesitecustomize} isn't reliable for perl 5.11.x
48 602 50 50     54943 if (($Config{usesitecustomize}||'') eq 'define'
      33        
49             or $Config{ccflags} =~ /(?
50             ) {
51 0 0       0 push @perl, '-f' if $opt{skip_sitecustomize};
52             }
53              
54 602         7018 return @perl;
55             }
56              
57              
58             # croaks on failure to execute
59             # carps, not croak, if process has non-zero exit status
60             # Devel::NYTProf::Data->new may croak, e.g., if data truncated
61             sub profile_this {
62 116     116 0 255576 my %opt = @_;
63              
64 116   50     562 my $out_file = $opt{out_file} || 'nytprof.out';
65              
66 116         539 my @perl = (perl_command_words(%opt), '-d:NYTProf');
67              
68             warn sprintf "profile_this() using %s with NYTPROF=%s\n",
69             join(" ", @perl), $ENV{NYTPROF} || ''
70 116 50 0     476 if $opt{verbose};
71              
72             # ensure child has same libs as us (e.g., if we were run with perl -Mblib)
73 116         2524 local $ENV{PERL5LIB} = join($Config{path_sep}, @INC);
74              
75 116 50       716 if (my $src_file = $opt{src_file}) {
    50          
76 0 0       0 system(@perl, $src_file) == 0
77             or carp "Exit status $? from @perl $src_file";
78             }
79             elsif (my $src_code = $opt{src_code}) {
80 116         1030 my $cmd = join ' ', map qq{"$_"}, @perl;
81 116 50       310804 open my $fh, "| $cmd"
82             or croak "Can't open pipe to $cmd";
83 116         6512 print $fh $src_code;
84 116 0       2758813 close $fh
    50          
85             or carp $! ? "Error closing $cmd pipe: $!"
86             : "Exit status $? from $cmd";
87              
88             }
89             else {
90 0         0 croak "Neither src_file or src_code was provided";
91             }
92              
93             # undocumented hack that's handy for testing
94 116 50       1444 if ($opt{htmlopen}) {
95 0         0 my @nytprofhtml_open = ("perl", "nytprofhtml", "--open", "-file=$out_file");
96 0         0 warn "Running @nytprofhtml_open\n";
97 0         0 system @nytprofhtml_open;
98             }
99              
100 116         11316 my $profile = Devel::NYTProf::Data->new( { filename => $out_file } );
101              
102 116         12146 unlink $out_file;
103              
104 116         6534 return $profile;
105             }
106              
107             1;