1package 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
15Devel::NYTProf::Run - Invoke NYTProf on a piece of code and return the profile
16
17=head1 DESCRIPTION
18
19This module is experimental and subject to change.
20
21=cut
22
23use warnings;
24use strict;
25
26use base qw(Exporter);
27
28use Carp;
29use Config qw(%Config);
30use Devel::NYTProf::Data;
31
32our @EXPORT_OK = qw(
33    profile_this
34    perl_command_words
35);
36
37
38my $this_perl = $^X;
39$this_perl .= $Config{_exe} if $^O ne 'VMS' and $this_perl !~ m/$Config{_exe}$/i;
40
41
42sub perl_command_words {
43    my %opt = @_;
44
45    my @perl = ($this_perl);
46
47    # testing just $Config{usesitecustomize} isn't reliable for perl 5.11.x
48    if (($Config{usesitecustomize}||'') eq 'define'
49    or   $Config{ccflags} =~ /(?<!\w)-DUSE_SITECUSTOMIZE\b/
50    ) {
51        push @perl, '-f' if $opt{skip_sitecustomize};
52    }
53
54    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
61sub profile_this {
62    my %opt = @_;
63
64    my $out_file = $opt{out_file} || 'nytprof.out';
65
66    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        if $opt{verbose};
71
72    # ensure child has same libs as us (e.g., if we were run with perl -Mblib)
73    local $ENV{PERL5LIB} = join($Config{path_sep}, @INC);
74
75    if (my $src_file = $opt{src_file}) {
76        system(@perl, $src_file) == 0
77            or carp "Exit status $? from @perl $src_file";
78    }
79    elsif (my $src_code = $opt{src_code}) {
80        my $cmd = join ' ', map qq{"$_"}, @perl;
81        open my $fh, "| $cmd"
82            or croak "Can't open pipe to $cmd";
83        print $fh $src_code;
84        close $fh
85            or carp $! ? "Error closing $cmd pipe: $!"
86                       : "Exit status $? from $cmd";
87
88    }
89    else {
90        croak "Neither src_file or src_code was provided";
91    }
92
93    # undocumented hack that's handy for testing
94    if ($opt{htmlopen}) {
95        my @nytprofhtml_open = ("perl", "nytprofhtml", "--open", "-file=$out_file");
96        warn "Running @nytprofhtml_open\n";
97        system @nytprofhtml_open;
98    }
99
100    my $profile = Devel::NYTProf::Data->new( { filename => $out_file } );
101
102    unlink $out_file;
103
104    return $profile;
105}
106
1071;
108