Author: tim.bunce
Date: Wed Nov 12 04:38:10 2008
New Revision: 594
Added:
trunk/lib/Devel/NYTProf/FileInfo.pm
trunk/lib/Devel/NYTProf/SubInfo.pm
Modified:
trunk/MANIFEST
trunk/NYTProf.xs
trunk/lib/Devel/NYTProf/Data.pm
Log:
Move ::ProfFile class out to new ::FileInfo class.
Move ::ProfSub class out to new ::SubInfo class.
Add Devel::NYTProf::Constants module
Add constants for elements of FileInfo array.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Wed Nov 12 04:38:10 2008
@@ -17,9 +17,12 @@
lib/Devel/NYTProf.pm
lib/Devel/NYTProf/Apache.pm
lib/Devel/NYTProf/Core.pm
+lib/Devel/NYTProf/Constants.pm
lib/Devel/NYTProf/Data.pm
+lib/Devel/NYTProf/FileInfo.pm
lib/Devel/NYTProf/Reader.pm
lib/Devel/NYTProf/ReadStream.pm
+lib/Devel/NYTProf/SubInfo.pm
lib/Devel/NYTProf/Test.pm
lib/Devel/NYTProf/Util.pm
lib/Devel/NYTProf/js/jquery.min.js
Modified: trunk/NYTProf.xs
==============================================================================
--- trunk/NYTProf.xs (original)
+++ trunk/NYTProf.xs Wed Nov 12 04:38:10 2008
@@ -84,9 +84,20 @@
#define NYTP_TAG_STRING '\''
#define NYTP_TAG_STRING_UTF8 '"'
#define NYTP_TAG_START_DEFLATE 'z'
-
#define NYTP_TAG_NO_TAG '\0' /* Used as a flag to mean "no tag"
*/
+/* indices to elements of the file info array */
+#define NYTP_FIDi_FILENAME 0
+#define NYTP_FIDi_EVAL_FID 1
+#define NYTP_FIDi_EVAL_LINE 2
+#define NYTP_FIDi_FID 3
+#define NYTP_FIDi_FLAGS 4
+#define NYTP_FIDi_FILESIZE 5
+#define NYTP_FIDi_FILEMTIME 6
+#define NYTP_FIDi_PROFILE 7
+#define NYTP_FIDi_EVAL_FI 8
+#define NYTP_FIDi_SUBS_DEFN 9
+
/* Hash table definitions */
#define MAX_HASH_SIZE 512
@@ -2987,14 +2998,16 @@
*/
av = newAV();
/* drop newline */
- av_store(av, 0, filename_sv); /* av now owns the sv */
- av_store(av, 1, (eval_file_num) ? newSVuv(eval_file_num) :
&PL_sv_no);
- av_store(av, 2, (eval_file_num) ? newSVuv(eval_line_num) :
&PL_sv_no);
- av_store(av, 3, newSVuv(file_num));
- av_store(av, 4, newSVuv(fid_flags));
- av_store(av, 5, newSVuv(file_size));
- av_store(av, 6, newSVuv(file_mtime));
- /* 7: profile ref */
+ av_store(av, NYTP_FIDi_FILENAME, filename_sv); /* av now
owns the sv */
+ av_store(av, NYTP_FIDi_EVAL_FID, (eval_file_num) ?
newSVuv(eval_file_num) : &PL_sv_no);
+ av_store(av, NYTP_FIDi_EVAL_LINE, (eval_file_num) ?
newSVuv(eval_line_num) : &PL_sv_no);
+ av_store(av, NYTP_FIDi_FID, newSVuv(file_num));
+ av_store(av, NYTP_FIDi_FLAGS, newSVuv(fid_flags));
+ av_store(av, NYTP_FIDi_FILESIZE, newSVuv(file_size));
+ av_store(av, NYTP_FIDi_FILEMTIME, newSVuv(file_mtime));
+ av_store(av, NYTP_FIDi_PROFILE, &PL_sv_undef);
+ av_store(av, NYTP_FIDi_EVAL_FI, &PL_sv_undef);
+ av_store(av, NYTP_FIDi_SUBS_DEFN, &PL_sv_undef);
av_store(fid_fileinfo_av, file_num, newRV_noinc((SV*)av));
break;
@@ -3069,11 +3082,11 @@
sv_setuv(*av_fetch(av, 0, 1), fid);
sv_setuv(*av_fetch(av, 1, 1), first_line);
sv_setuv(*av_fetch(av, 2, 1), last_line);
- sv_setuv(*av_fetch(av, 3, 1), 0); /* cal count */
+ sv_setuv(*av_fetch(av, 3, 1), 0); /* call count */
sv_setnv(*av_fetch(av, 4, 1), 0.0); /* incl_time */
sv_setnv(*av_fetch(av, 5, 1), 0.0); /* excl_time */
sv_setsv(*av_fetch(av, 6, 1), subname_sv);
- sv_setsv(*av_fetch(av, 6, 1), &PL_sv_undef); /* ref to
profile */
+ sv_setsv(*av_fetch(av, 7, 1), &PL_sv_undef); /* ref to
profile */
sv_setuv(*av_fetch(av, 8, 1), 0); /* rec_depth */
sv_setnv(*av_fetch(av, 9, 1), 0.0); /* reci_time */
break;
@@ -3409,19 +3422,26 @@
* Perl XS Code Below Here *
***********************************/
-MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf
+MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Constants
PROTOTYPES: DISABLE
-I32
-constant()
- PROTOTYPE:
- ALIAS:
- NYTP_FIDf_IS_PMC = NYTP_FIDf_IS_PMC
- CODE:
- RETVAL = ix;
- OUTPUT:
- RETVAL
+BOOT:
+ {
+ HV *stash = gv_stashpv("Devel::NYTProf::Constants", GV_ADDWARN);
+ newCONSTSUB(stash, "NYTP_FIDf_IS_PMC", newSViv(NYTP_FIDf_IS_PMC));
+ /* NYTP_FIDi_* */
+ newCONSTSUB(stash, "NYTP_FIDi_FILENAME", newSViv(NYTP_FIDi_FILENAME));
+ newCONSTSUB(stash, "NYTP_FIDi_EVAL_FID", newSViv(NYTP_FIDi_EVAL_FID));
+ newCONSTSUB(stash, "NYTP_FIDi_EVAL_LINE",
newSViv(NYTP_FIDi_EVAL_LINE));
+ newCONSTSUB(stash, "NYTP_FIDi_FID", newSViv(NYTP_FIDi_FID));
+ newCONSTSUB(stash, "NYTP_FIDi_FLAGS", newSViv(NYTP_FIDi_FLAGS));
+ newCONSTSUB(stash, "NYTP_FIDi_FILESIZE", newSViv(NYTP_FIDi_FILESIZE));
+ newCONSTSUB(stash, "NYTP_FIDi_FILEMTIME",
newSViv(NYTP_FIDi_FILEMTIME));
+ newCONSTSUB(stash, "NYTP_FIDi_PROFILE", newSViv(NYTP_FIDi_PROFILE));
+ newCONSTSUB(stash, "NYTP_FIDi_EVAL_FI", newSViv(NYTP_FIDi_EVAL_FI));
+ newCONSTSUB(stash, "NYTP_FIDi_SUBS_DEFN",
newSViv(NYTP_FIDi_SUBS_DEFN));
+ }
MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Test
Modified: trunk/lib/Devel/NYTProf/Data.pm
==============================================================================
--- trunk/lib/Devel/NYTProf/Data.pm (original)
+++ trunk/lib/Devel/NYTProf/Data.pm Wed Nov 12 04:38:10 2008
@@ -48,6 +48,8 @@
use Scalar::Util qw(blessed);
use Devel::NYTProf::Core;
+use Devel::NYTProf::FileInfo;
+use Devel::NYTProf::SubInfo;
use Devel::NYTProf::Util qw(strip_prefix_from_paths
get_abs_paths_alternation_regex);
our $VERSION = '2.07';
@@ -86,18 +88,18 @@
$_->[7] = $profile for values %$sub_subinfo;
# bless fid_fileinfo data
- (my $fid_class = $class) =~ s/\w+$/ProfFile/;
+ (my $fid_class = $class) =~ s/\w+$/FileInfo/;
$_ and bless $_ => $fid_class for @$fid_fileinfo;
# bless sub_subinfo data
- (my $sub_class = $class) =~ s/\w+$/ProfSub/;
+ (my $sub_class = $class) =~ s/\w+$/SubInfo/;
$_ and bless $_ => $sub_class for values %$sub_subinfo;
#$profile->_migrate_sub_callers_from_eval_fids;
# XXX merge evals - should become a method optionally called here
# (which uses other methods to do the work and those methods
- # should also be called by Devel::NYTProf::ProfSub::callers())
+ # should also be called by Devel::NYTProf::SubInfo::callers())
my %anon_eval_subs_merged;
while (my ($subname, $subinfo) = each %$sub_subinfo) {
@@ -199,8 +201,8 @@
return undef;
}
- # check if already a ProfFile object
- return $arg if ref $arg and $arg->isa('Devel::NYTProf::ProfFile');
+ # check if already a file info object
+ return $arg if ref $arg and $arg->isa('Devel::NYTProf::FileInfo');
my $fid = $self->resolve_fid($arg);
if (not $fid) {
@@ -711,7 +713,7 @@
Returns undef if the profile contains no C<sub_subinfo> data for the $file.
The keys of the returned hash are fully qualified subroutine names and the
-corresponding value is a hash reference containing
L<Devel::NYTProf::ProfSub>
+corresponding value is a hash reference containing
L<Devel::NYTProf::SubInfo>
objects.
If $include_lines is true then the hash also contains integer keys
@@ -990,221 +992,6 @@
require Data::Dumper;
return Data::Dumper::Dumper(@_);
}
-
-## --- will move out to separate files later ---
-# for now these are viewed as private classes
-
-{
-
- package Devel::NYTProf::ProfFile; # fid_fileinfo
-
- use Devel::NYTProf::Util qw(strip_prefix_from_paths);
-
- sub filename { shift->[0] }
- sub eval_fid { shift->[1] }
- sub eval_line { shift->[2] }
- sub fid { shift->[3] }
- sub flags { shift->[4] }
- sub size { shift->[5] }
- sub mtime { shift->[6] }
- sub profile { shift->[7] }
-
- # if fid is an eval then return fileinfo obj for the fid that executed
the eval
- sub eval_fi { $_[0]->[8] ||=
$_[0]->profile->fileinfo_of($_[0]->eval_fid || return) }
- # return a ref to a hash of { subname => subinfo, ... }
- sub subs { $_[0]->[9] ||= $_[0]->profile->fid_subs_map->{
$_[0]->fid } }
-
- sub line_time_data {
- my ($self, $levels) = @_;
- $levels ||= [ 'line' ];
- # XXX this can be optimized once the fidinfo contains directs refs
to the data
- my $profile = $self->profile;
- my $fid = $self->fid;
- for my $level (@$levels) {
- my $line_data = $profile->get_fid_line_data($level)->[$fid];
- return $line_data if $line_data;
- }
- return undef;
- }
-
- sub excl_time { # total exclusive time for fid
- my $self = shift;
- my $line_data = $self->line_time_data([qw(sub block line)])
- || return undef;
- my $excl_time = 0;
- for (@$line_data) {
- next unless $_;
- $excl_time += $_->[0];
- if (my $eval_lines = $_->[2]) {
- # line contains a string eval
- $excl_time += $_->[0] for values %$eval_lines;
- }
- }
- return $excl_time;
- }
-
- sub outer {
- my ($self, $recurse) = @_;
- my $fi = $self->eval_fi
- or return;
- my $prev = $self;
-
- while ($recurse and my $eval_fi = $fi->eval_fi) {
- $prev = $fi;
- $fi = $eval_fi;
- }
- return $fi unless wantarray;
- return ($fi, $prev->eval_line);
- }
-
-
- sub is_pmc {
- return (shift->flags & 1); # NYTP_FIDf_IS_PMC
- }
-
-
- # should return the filename that the application used
- # when loading the file
- sub filename_without_inc {
- my $self = shift;
- my $f = [$self->filename];
- strip_prefix_from_paths([$self->profile->inc], $f);
- return $f->[0];
- }
-
- sub _values_for_dump {
- my $self = shift;
- my @values = @$self;
- $values[0] = $self->filename_without_inc;
- pop @values; # remove profile ref
- return [EMAIL PROTECTED];
- }
-
- sub delete_subs_called_info {
- my $self = shift;
- my $profile = $self->profile;
- my $sub_caller = $profile->{sub_caller}
- or return;
- my $fid = $self->fid;
- # remove sub_caller info for calls made *from within* this file
- delete $_->{$fid} for values %$sub_caller;
- return;
- }
-
- sub srclines_array {
- my $self = shift;
- my $profile = $self->profile;
- #warn Dumper($profile->{fid_srclines});
- my $fid = $self->fid;
- if (my $srclines = $profile->{fid_srclines}[ $fid ]) {
- my $copy = [ @$srclines ]; # shallow clone
- shift @$copy; # line 0 not used
- return $copy;
- }
- # open file
- my $filename = $self->filename;
- # if it's a .pmc then assume that's the file we want to look at
- # (because the main use for .pmc's are related to perl6)
- $filename .= "c" if $self->is_pmc;
- open my $fh, "<", $filename
- or return undef;
- return [ <$fh> ];
- }
-
-} # end of package
-
-
-{
-
- package Devel::NYTProf::ProfSub; # sub_subinfo
-
- use List::Util qw(sum);
-
- sub fid { $_[0]->[0] ||=
$_[0]->profile->package_fids($_[0]->package) }
- sub first_line { shift->[1] }
- sub last_line { shift->[2] }
- sub calls { shift->[3] }
- sub incl_time { shift->[4] }
- sub excl_time { shift->[5] }
- sub subname { shift->[6] }
- sub profile { shift->[7] }
- sub package { (my $pkg = shift->subname) =~ s/::.*?$//; return $pkg
}
- sub recur_max_depth { shift->[8] }
- sub recur_incl_time { shift->[9] }
-
- sub is_xsub {
- my $self = shift;
-
- # XXX should test == 0 but some xsubs still have undef first_line
etc
- return (!$self->first_line && !$self->last_line);
- }
-
- sub fileinfo {
- my $self = shift;
- my $fid = $self->fid;
- if (!$fid) {
- return undef; # sub not have a known fid
- }
- $self->profile->fileinfo_of($fid);
- }
-
- sub merge_in {
- my $self = shift;
- my $newinfo = shift;
- $self->[3] += $newinfo->[3]; # calls
- $self->[4] += $newinfo->[4]; # calls
- return;
- }
-
- sub _values_for_dump {
- my $self = shift;
- my @values = @{$self}[0 .. 5, 8, 9 ];
- return [EMAIL PROTECTED];
- }
-
- sub callers {
- my $self = shift;
-
- # { fid => { line => [ count, incl_time ] } } }
- my $callers = $self->profile->{sub_caller}->{$self->subname}
- or return undef;
-
- # XXX should 'collapse' data for calls from eval fids
- # (with an option to not collapse)
- return $callers;
- }
-
- sub caller_fids {
- my ($self, $merge_evals) = @_;
- my $callers = $self->callers($merge_evals) || {};
- my @fids = keys %$callers;
- return @fids; # count in scalar context
- }
-
- sub caller_count {
- my ($self, $merge_evals) = @_;
- my $callers = $self->callers($merge_evals) || {};
-
- # count of the number of distinct locations sub is called from
- return sum(map { scalar keys %$_ } values %$callers);
- }
-
- sub caller_places {
- my ($self, $merge_evals) = @_;
- my $callers = $self->callers
- or return 0;
-
- # scalar: count of the number of distinct locations sub is called
from
- # list: array of [ fid, line, @... ]
- my @callers;
- warn "caller_places in list context not implemented/tested yet";
- while (my ($fid, $lines) = each %$callers) {
- push @callers, map { [$fid, $_, @{$lines->{$_}}] }
keys %$lines;
- }
- return [EMAIL PROTECTED];
- }
-
-} # end of package
1;
Added: trunk/lib/Devel/NYTProf/FileInfo.pm
==============================================================================
--- (empty file)
+++ trunk/lib/Devel/NYTProf/FileInfo.pm Wed Nov 12 04:38:10 2008
@@ -0,0 +1,126 @@
+package Devel::NYTProf::FileInfo; # fid_fileinfo
+
+use strict;
+
+use Devel::NYTProf::Util qw(strip_prefix_from_paths);
+
+use Devel::NYTProf::Constants qw(
+ NYTP_FIDi_FILENAME NYTP_FIDi_EVAL_FID NYTP_FIDi_EVAL_LINE NYTP_FIDi_FID
+ NYTP_FIDi_FLAGS NYTP_FIDi_FILESIZE NYTP_FIDi_FILEMTIME
NYTP_FIDi_PROFILE
+ NYTP_FIDi_EVAL_FI NYTP_FIDi_SUBS_DEFN
+);
+
+sub filename { shift->[NYTP_FIDi_FILENAME()] }
+sub eval_fid { shift->[NYTP_FIDi_EVAL_FID()] }
+sub eval_line { shift->[NYTP_FIDi_EVAL_LINE()] }
+sub fid { shift->[NYTP_FIDi_FID()] }
+sub flags { shift->[NYTP_FIDi_FLAGS()] }
+sub size { shift->[NYTP_FIDi_FILESIZE()] }
+sub mtime { shift->[NYTP_FIDi_FILEMTIME()] }
+sub profile { shift->[NYTP_FIDi_PROFILE()] }
+
+# if fid is an eval then return fileinfo obj for the fid that executed the
eval
+sub eval_fi { $_[0]->[NYTP_FIDi_EVAL_FI()] ||=
$_[0]->profile->fileinfo_of($_[0]->eval_fid || return) }
+# return a ref to a hash of { subname => subinfo, ... }
+sub subs { $_[0]->[NYTP_FIDi_SUBS_DEFN()] ||=
$_[0]->profile->fid_subs_map->{ $_[0]->fid } }
+
+sub _values_for_dump {
+ my $self = shift;
+ my @values = @{$self}[
+ NYTP_FIDi_FILENAME, NYTP_FIDi_EVAL_FID, NYTP_FIDi_EVAL_LINE,
NYTP_FIDi_FID,
+ NYTP_FIDi_FLAGS, NYTP_FIDi_FILESIZE, NYTP_FIDi_FILEMTIME
+ ];
+ $values[0] = $self->filename_without_inc;
+ return [EMAIL PROTECTED];
+}
+
+sub line_time_data {
+ my ($self, $levels) = @_;
+ $levels ||= [ 'line' ];
+ # XXX this can be optimized once the fidinfo contains directs refs to
the data
+ my $profile = $self->profile;
+ my $fid = $self->fid;
+ for my $level (@$levels) {
+ my $line_data = $profile->get_fid_line_data($level)->[$fid];
+ return $line_data if $line_data;
+ }
+ return undef;
+}
+
+sub excl_time { # total exclusive time for fid
+ my $self = shift;
+ my $line_data = $self->line_time_data([qw(sub block line)])
+ || return undef;
+ my $excl_time = 0;
+ for (@$line_data) {
+ next unless $_;
+ $excl_time += $_->[0];
+ if (my $eval_lines = $_->[2]) {
+ # line contains a string eval
+ $excl_time += $_->[0] for values %$eval_lines;
+ }
+ }
+ return $excl_time;
+}
+
+sub outer {
+ my ($self, $recurse) = @_;
+ my $fi = $self->eval_fi
+ or return;
+ my $prev = $self;
+
+ while ($recurse and my $eval_fi = $fi->eval_fi) {
+ $prev = $fi;
+ $fi = $eval_fi;
+ }
+ return $fi unless wantarray;
+ return ($fi, $prev->eval_line);
+}
+
+
+sub is_pmc {
+ return (shift->flags & 1); # NYTP_FIDf_IS_PMC
+}
+
+
+# should return the filename that the application used
+# when loading the file
+sub filename_without_inc {
+ my $self = shift;
+ my $f = [$self->filename];
+ strip_prefix_from_paths([$self->profile->inc], $f);
+ return $f->[0];
+}
+
+sub delete_subs_called_info {
+ my $self = shift;
+ my $profile = $self->profile;
+ my $sub_caller = $profile->{sub_caller}
+ or return;
+ my $fid = $self->fid;
+ # remove sub_caller info for calls made *from within* this file
+ delete $_->{$fid} for values %$sub_caller;
+ return;
+}
+
+sub srclines_array {
+ my $self = shift;
+ my $profile = $self->profile;
+ #warn Dumper($profile->{fid_srclines});
+ my $fid = $self->fid;
+ if (my $srclines = $profile->{fid_srclines}[ $fid ]) {
+ my $copy = [ @$srclines ]; # shallow clone
+ shift @$copy; # line 0 not used
+ return $copy;
+ }
+ # open file
+ my $filename = $self->filename;
+ # if it's a .pmc then assume that's the file we want to look at
+ # (because the main use for .pmc's are related to perl6)
+ $filename .= "c" if $self->is_pmc;
+ open my $fh, "<", $filename
+ or return undef;
+ return [ <$fh> ];
+}
+
+1;
Added: trunk/lib/Devel/NYTProf/SubInfo.pm
==============================================================================
--- (empty file)
+++ trunk/lib/Devel/NYTProf/SubInfo.pm Wed Nov 12 04:38:10 2008
@@ -0,0 +1,89 @@
+package Devel::NYTProf::SubInfo; # sub_subinfo
+
+use List::Util qw(sum);
+
+sub fid { $_[0]->[0] ||=
$_[0]->profile->package_fids($_[0]->package) }
+sub first_line { shift->[1] }
+sub last_line { shift->[2] }
+sub calls { shift->[3] }
+sub incl_time { shift->[4] }
+sub excl_time { shift->[5] }
+sub subname { shift->[6] }
+sub profile { shift->[7] }
+sub package { (my $pkg = shift->subname) =~ s/::.*?$//; return $pkg }
+sub recur_max_depth { shift->[8] }
+sub recur_incl_time { shift->[9] }
+
+sub is_xsub {
+ my $self = shift;
+
+ # XXX should test == 0 but some xsubs still have undef first_line etc
+ return (!$self->first_line && !$self->last_line);
+}
+
+sub fileinfo {
+ my $self = shift;
+ my $fid = $self->fid;
+ if (!$fid) {
+ return undef; # sub not have a known fid
+ }
+ $self->profile->fileinfo_of($fid);
+}
+
+sub merge_in {
+ my $self = shift;
+ my $newinfo = shift;
+ $self->[3] += $newinfo->[3]; # calls
+ $self->[4] += $newinfo->[4]; # calls
+ return;
+}
+
+sub _values_for_dump {
+ my $self = shift;
+ my @values = @{$self}[0 .. 5, 8, 9 ];
+ return [EMAIL PROTECTED];
+}
+
+sub callers {
+ my $self = shift;
+
+ # { fid => { line => [ count, incl_time ] } }
+ my $callers = $self->profile->{sub_caller}->{$self->subname}
+ or return undef;
+
+ # XXX should 'collapse' data for calls from eval fids
+ # (with an option to not collapse)
+ return $callers;
+}
+
+sub caller_fids {
+ my ($self, $merge_evals) = @_;
+ my $callers = $self->callers($merge_evals) || {};
+ my @fids = keys %$callers;
+ return @fids; # count in scalar context
+}
+
+sub caller_count {
+ my ($self, $merge_evals) = @_;
+ my $callers = $self->callers($merge_evals) || {};
+
+ # count of the number of distinct locations sub is called from
+ return sum(map { scalar keys %$_ } values %$callers);
+}
+
+sub caller_places {
+ my ($self, $merge_evals) = @_;
+ my $callers = $self->callers
+ or return 0;
+
+ # scalar: count of the number of distinct locations sub is called from
+ # list: array of [ fid, line, @... ]
+ my @callers;
+ warn "caller_places in list context not implemented/tested yet";
+ while (my ($fid, $lines) = each %$callers) {
+ push @callers, map { [$fid, $_, @{$lines->{$_}}] } keys %$lines;
+ }
+ return [EMAIL PROTECTED];
+}
+
+1;
--~--~---------~--~----~------------~-------~--~----~
You've received this message because you are subscribed to
the Devel::NYTProf Development User group.
Group hosted at: http://groups.google.com/group/develnytprof-dev
Project hosted at: http://perl-devel-nytprof.googlecode.com
CPAN distribution: http://search.cpan.org/dist/Devel-NYTProf
To post, email: [email protected]
To unsubscribe, email: [EMAIL PROTECTED]
-~----------~----~----~----~------~----~------~--~---
