Revision: 985 Author: tim.bunce Date: Sun Dec 20 15:44:19 2009 Log: BEGIN's are now recorded as be...@line to make them unique. (Been meaning to do this for ages - it makes a big difference.) Refactored parsing of line numbers from %DBsub values into a new sub.
http://code.google.com/p/perl-devel-nytprof/source/detail?r=985 Modified: /trunk/Changes /trunk/NYTProf.xs /trunk/demo/demo-code.pl /trunk/demo/demo-run.pl /trunk/t/42-global.t ======================================= --- /trunk/Changes Fri Dec 18 13:01:10 2009 +++ /trunk/Changes Sun Dec 20 15:44:19 2009 @@ -7,7 +7,6 @@ =head2 Changes in Devel::NYTProf 2.11 XXX subroutine profiler docs need update -XXX handling of BEGIN's e.g., Perl::Critic::Document (1.105) line 325 XXX add u key to treemap to trigger moving 'up' a level XXX add "calls N subs" to treemap mouseover box XXX string eval merging - must allow at least viewing of source for called subs defined in a nested eval @@ -63,6 +62,8 @@ linking of call trees. Previously only the calling file and line were recorded. (This is more significant than it sounds :) Added docs describing how the subroutine profiler works. + Multiple BEGIN blocks (i.e., "use") within a package are now distinguished + by appending the number of the line they start on. Changes to nytprofhtml: ======================================= --- /trunk/NYTProf.xs Sat Dec 19 04:41:59 2009 +++ /trunk/NYTProf.xs Sun Dec 20 15:44:19 2009 @@ -335,6 +335,7 @@ static void finish_profile(pTHX); static void open_output_file(pTHX_ char *); static int reinit_if_forked(pTHX); +static int parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *last_line_p); static void write_cached_fids(void); static void write_src_of_files(pTHX); static void write_sub_line_ranges(pTHX); @@ -1703,6 +1704,34 @@ static I32 subr_entry_ix = 0; #define subr_entry_ix_ptr(ix) ((ix) ? SSPTR(ix, subr_entry_t *) : NULL) + + +static void +append_linenum_to_begin(pTHX_ subr_entry_t *subr_entry) { + UV line = 0; + SV *fullnamesv; + SV *DBsv; + char *subname = SvPVX(subr_entry->called_subnam_sv); + + /* If sub is a BEGIN then append the line number to our name + * so multiple BEGINs (either explicit or implicit, e.g., "use") + * in the same file/package can be distinguished. + */ + if (!subname || *subname != 'B' || strNE(subname,"BEGIN")) + return; + + /* get, and delete, the entry for this sub in the PL_DBsub hash */ + fullnamesv = newSVpvf("%s::%s", subr_entry->called_subpkg_pv, subname); + DBsv = hv_delete(GvHV(PL_DBsub), SvPV_nolen(fullnamesv), SvCUR(fullnamesv), 1); + + if (DBsv && parse_DBsub_value(aTHX_ DBsv, NULL, &line, NULL)) { + SvREFCNT_inc(DBsv); /* was made mortal by hv_delete */ + sv_catpvf(subr_entry->called_subnam_sv, "@%u", (unsigned int)line); + sv_catpvf(fullnamesv, "@%u", (unsigned int)line); + hv_store(GvHV(PL_DBsub), SvPV_nolen(fullnamesv), SvCUR(fullnamesv), DBsv, 0); + } + SvREFCNT_dec(fullnamesv); +} static char * @@ -1818,14 +1847,6 @@ /* { called_subname => { "caller_subname[fid:line]" => [ count, incl_time, ... ] } } */ sv_tmp = *hv_fetch(sub_callers_hv, called_subname_pv, strlen(called_subname_pv), 1); -#ifdef BUG_HUNT -if (strEQ(called_subname_pv,"CORE::print")) { - (void)newHV(); /* adding or removing this newHV() changes the behaviour */ - subr_entry_destroy(aTHX_ subr_entry); - return; -} -#endif - if (!SvROK(sv_tmp)) { /* autoviv hash ref - is first call of this called subname from anywhere */ HV *hv = newHV(); sv_setsv(sv_tmp, newRV_noinc((SV *)hv)); @@ -2385,7 +2406,7 @@ } if (is_slowop) { - /* else already fully handled by subr_entry_setup */ + /* already fully handled by subr_entry_setup */ } else { char *stash_name = NULL; @@ -2456,7 +2477,10 @@ if (trace_level >= 9) sv_dump(sub_sv); } + subr_entry->called_subpkg_pv = stash_name; + if (*SvPVX(subr_entry->called_subnam_sv) == 'B') + append_linenum_to_begin(aTHX_ subr_entry); /* if called was xsub then we've already left it, so use depth+1 */ subr_entry->called_cv_depth = (called_cv) ? CvDEPTH(called_cv)+(is_xs?1:0) : 0; @@ -2895,6 +2919,24 @@ return Nullsv; /* not a package we've profiled sub calls into */ return *svp; } + + +static int +parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *last_line_p) { + /* "filename:first-last" */ + char *filename = SvPV_nolen(sv); + char *first = strrchr(filename, ':'); + char *last = (first) ? strchr(first, '-') : NULL; + + if (!first || !last || !grok_number(first+1, last-first-1, first_line_p)) + return 0; + if (last_line_p) + *last_line_p = atoi(++last); + if (filename_len_p) + *filename_len_p = first - filename; + + return 1; +} static void @@ -2972,19 +3014,13 @@ while (NULL != (file_lines_sv = hv_iternextsv(hv, &sub_name, &sub_name_len))) { /* "filename:first-last" */ char *filename = SvPV_nolen(file_lines_sv); - char *first = strrchr(filename, ':'); - char *last = (first) ? strchr(first, '-') : NULL; - STRLEN filename_len = first - filename; + STRLEN filename_len; UV first_line, last_line; - if (!first || !last || !grok_number(first+1, last-first-1, &first_line)) { + if (!parse_DBsub_value(aTHX_ file_lines_sv, &filename_len, &first_line, &last_line)) { logwarn("Can't parse %%DB::sub entry for %s '%s'\n", sub_name, filename); continue; } - last_line = atoi(++last); - - if (0 &&!first_line && !last_line && strstr(sub_name, "::BEGIN")) - continue; /* no point writing these XXX? */ if (!filename_len) { /* no filename, so presumably a fake entry for xsub */ /* do we know a filename that contains subs in the same package */ ======================================= --- /trunk/demo/demo-code.pl Tue Jul 7 06:24:31 2009 +++ /trunk/demo/demo-code.pl Sun Dec 20 15:44:19 2009 @@ -18,6 +18,9 @@ } 1; } + +BEGIN { add() } +BEGIN { add() } sub inc { 1; ======================================= --- /trunk/demo/demo-run.pl Fri Jul 24 15:36:26 2009 +++ /trunk/demo/demo-run.pl Sun Dec 20 15:44:19 2009 @@ -6,11 +6,11 @@ my %runs = ( start_begin => { - skip => 1, + skip => 0, NYTPROF => 'start=begin:optimize=0', }, start_check => { - skip => 0, + skip => 1, NYTPROF => 'start=init:optimize=0', }, start_end => { ======================================= --- /trunk/t/42-global.t Fri Nov 27 05:13:19 2009 +++ /trunk/t/42-global.t Sun Dec 20 15:44:19 2009 @@ -31,8 +31,8 @@ my $subs = $profile->subname_subinfo_map; - is scalar keys %$subs, 3, 'should be 3 subs'; - ok $subs->{'main::BEGIN'}; + is scalar keys %$subs, 3, "should be 3 subs (found: @{[ keys %$subs ]})"; + ok $subs->{'main::be...@3'}; ok $subs->{'main::RUNTIME'}; ok $subs->{'main::foo'}; @@ -41,7 +41,7 @@ my $fid = $fi[0]->fid; my @a; # ($file, $fid, $first, $last); - @a = $profile->file_line_range_of_sub('main::BEGIN'); + @a = $profile->file_line_range_of_sub('main::be...@3'); is "$a[1] $a[2] $a[3]", "$fid 3 6", 'details for main::BEGIN should match'; @a = $profile->file_line_range_of_sub('main::RUNTIME'); is "$a[1] $a[2] $a[3]", "$fid 1 1", 'details for main::RUNTIME should match'; @@ -51,7 +51,7 @@ $subs = $profile->subs_defined_in_file($fid); my $sub; is scalar keys %$subs, 3, 'should be 3 subs'; - ok $sub = $subs->{'main::BEGIN'}; + ok $sub = $subs->{'main::be...@3'}; SKIP: { skip "needs perl >= 5.8.9 or >= 5.10.1", 1 if $] < 5.008009 or $] eq "5.010000"; -- 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]
