Revision: 871 Author: tim.bunce Date: Thu Oct 22 09:05:10 2009 Log: Added PRIVLIB_EXP and ARCHLIB_EXP attributes to profile data file. Used them to implement a sane $fileinfo->is_perl_std_lib method. Used is_perl_std_lib to remove called_by data for calls from std modules. Added NYTPROF_TEST_PROFPERLOPTS env var. Added $profile->attributes method. Hid PRIVLIB_EXP and ARCHLIB_EXP from dump output.
http://code.google.com/p/perl-devel-nytprof/source/detail?r=871 Modified: /trunk/NYTProf.xs /trunk/lib/Devel/NYTProf/Data.pm /trunk/lib/Devel/NYTProf/FileInfo.pm /trunk/lib/Devel/NYTProf/SubInfo.pm /trunk/t/lib/NYTProfTest.pm /trunk/t/test14.rdt ======================================= --- /trunk/NYTProf.xs Thu Oct 22 07:42:40 2009 +++ /trunk/NYTProf.xs Thu Oct 22 09:05:10 2009 @@ -897,6 +897,9 @@ /* $0 - application name */ sv = get_sv("0",GV_ADDWARN); NYTP_printf(out, ":%s=%s\n", "application", SvPV_nolen(sv)); + /* %Config values */ + NYTP_printf(out, ":%s=%s\n", "PRIVLIB_EXP", PRIVLIB_EXP); + NYTP_printf(out, ":%s=%s\n", "ARCHLIB_EXP", ARCHLIB_EXP); #ifdef HAS_ZLIB if (compression_level) { ======================================= --- /trunk/lib/Devel/NYTProf/Data.pm Tue Jul 14 23:28:44 2009 +++ /trunk/lib/Devel/NYTProf/Data.pm Thu Oct 22 09:05:10 2009 @@ -108,6 +108,10 @@ sub _caches { return shift->{caches} ||= {} } sub _clear_caches { return delete shift->{caches} } + +sub attributes { + return shift->{attribute} || {}; +} sub subname_subinfo_map { return { %{ shift->{sub_subinfo} } }; # shallow copy @@ -330,12 +334,18 @@ my $callback = sub { my ($path, $value) = @_; + if ($path->[0] eq 'attribute' && @$path == 1) { + my %v = %$value; + delete @v{qw(PRIVLIB_EXP ARCHLIB_EXP)}; + return ({}, \%v); + } + if ($args->{skip_stdlib}) { # for fid_fileinfo don't dump internal details of lib modules if ($path->[0] eq 'fid_fileinfo' && @$path==2) { my $is_lib = ($value->filename =~ $is_lib_regex) ? 1 : 0; - return { skip_internal_details => $is_lib }; + return ({ skip_internal_details => $is_lib }, $value); } # skip sub_subinfo data for 'library modules' @@ -351,7 +361,7 @@ or $fi->filename =~ m!^/\.\.\./!; } } - return {}; + return ({}, $value); }; _dump_elements($startnode, $separator, $filehandle, [], $callback); @@ -391,7 +401,7 @@ my $dump_opts = {}; if ($callback) { - $dump_opts = $callback->([ @$path, $key ], $value); + ($dump_opts, $value) = $callback->([ @$path, $key ], $value); next if not $dump_opts; } @@ -480,6 +490,7 @@ sub normalize_variables { my $self = shift; + my $attributes = $self->attributes; for my $attr (qw( basetime xs_version perl_version clock_id ticks_per_sec nv_size @@ -487,7 +498,7 @@ total_stmts_duration total_stmts_measured total_stmts_discounted total_sub_calls )) { - $self->{attribute}{$attr} = 0; + $attributes->{$attr} = 0; } my $abs_path_regex = $^O eq "MSWin32" ? qr,^\w:/, : qr,^/,; ======================================= --- /trunk/lib/Devel/NYTProf/FileInfo.pm Thu Jul 9 14:28:02 2009 +++ /trunk/lib/Devel/NYTProf/FileInfo.pm Thu Oct 22 09:05:10 2009 @@ -113,6 +113,16 @@ sub is_pmc { return (shift->flags & NYTP_FIDf_IS_PMC()); } + + +sub is_perl_std_lib { + my $self = shift; + my $filename = $self->filename; + my $attributes = $self->profile->attributes; + return 1 if $filename =~ /\Q$attributes->{PRIVLIB_EXP}/; + return 1 if $filename =~ /\Q$attributes->{ARCHLIB_EXP}/; + return 0; +} # should return the filename that the application used ======================================= --- /trunk/lib/Devel/NYTProf/SubInfo.pm Fri Jul 17 06:44:28 2009 +++ /trunk/lib/Devel/NYTProf/SubInfo.pm Thu Oct 22 09:05:10 2009 @@ -210,16 +210,23 @@ sub normalize_for_test { my $self = shift; + my $profile = $self->profile; # zero subroutine inclusive time $self->[NYTP_SIi_INCL_RTIME] = 0; $self->[NYTP_SIi_EXCL_RTIME] = 0; $self->[NYTP_SIi_RECI_RTIME] = 0; - my $subname = $self->subname(' and '); - # { fid => { line => [ count, incl, excl, ucpu, scpu, reci, recdepth ] } } my $callers = $self->caller_fid_line_places || {}; + + # delete calls from modules shipped with perl + for my $fid (keys %$callers) { + next if not $fid; + my $fileinfo = $profile->fileinfo_of($fid) or next; + next if not $fileinfo->is_perl_std_lib; + delete $callers->{$fid}; + } # zero per-call-location subroutine inclusive time for my $sc (map { values %$_ } values %$callers) { ======================================= --- /trunk/t/lib/NYTProfTest.pm Thu Aug 6 19:20:50 2009 +++ /trunk/t/lib/NYTProfTest.pm Thu Oct 22 09:05:10 2009 @@ -28,7 +28,8 @@ my %opts = ( - profperlopts => '-d:NYTProf', + one => $ENV{NYTPROF_TEST_ONE}, + profperlopts => $ENV{NYTPROF_TEST_PROFPERLOPTS} || '-d:NYTProf', html => $ENV{NYTPROF_TEST_HTML}, ); GetOptions(\%opts, qw/p=s I=s v|verbose d|debug html open profperlopts=s leave=i use_db_sub=i savesrc=i compress=i one abort/) @@ -73,7 +74,6 @@ # turn ./perl into ../perl, because of chdir(t) above. $perl = ".$perl" if $perl =~ m|^\./|; -$opts{one} ||= $ENV{NYTPROF_TEST_ONE}; if ($opts{one}) { # for one quick test $opts{leave} = 1; $opts{use_db_sub} = 0; ======================================= --- /trunk/t/test14.rdt Thu Oct 22 07:42:40 2009 +++ /trunk/t/test14.rdt Thu Oct 22 09:05:10 2009 @@ -59,12 +59,9 @@ profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1 16 16 0 0 0 0 0 ] sub_subinfo main::CORE:require [ 1 0 0 2 0 0 0 0 ] -sub_subinfo main::CORE:require called_by 3 92 [ 2 0 0 0 0 0 0 AutoLoader::AUTOLOAD ] sub_subinfo main::RUNTIME [ 1 1 1 0 0 0 0 0 ] sub_subinfo test14::BEGIN [ 2 2 2 0 0 0 0 0 ] sub_subinfo test14::bar [ 2 16 18 1 0 0 0 0 ] -sub_subinfo test14::bar called_by 3 116 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo test14::foo [ 2 12 14 1 0 0 0 0 ] -sub_subinfo test14::foo called_by 3 116 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo test14::pre [ 2 8 8 1 0 0 0 0 ] sub_subinfo test14::pre called_by 1 17 [ 1 0 0 0 0 0 0 main::RUNTIME ] --~--~---------~--~----~------------~-------~--~----~ 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] -~----------~----~----~----~------~----~------~--~---
