Revision: 1230
Author: [email protected]
Date: Mon May 24 07:37:09 2010
Log: Multiple BEGINs (e.g., use) on the same line get distinct names
http://code.google.com/p/perl-devel-nytprof/source/detail?r=1230
Modified:
/trunk/Changes
/trunk/NYTProf.xs
/trunk/t/42-global.t
=======================================
--- /trunk/Changes Thu May 20 12:01:28 2010
+++ /trunk/Changes Mon May 24 07:37:09 2010
@@ -36,6 +36,7 @@
Improved behaviour for 'duplicate' anon-subs defined in separate
invocations of a particular string eval.
+ Multiple BEGINs (e.g., use) on the same line get distinct names.
Added automatic detection of calls to POSIX::_exit() by the sub profiler
so finish_profile() gets called and a usable profile is produced.
=======================================
--- /trunk/NYTProf.xs Fri May 21 08:49:31 2010
+++ /trunk/NYTProf.xs Mon May 24 07:37:09 2010
@@ -1761,13 +1761,18 @@
if (DBsv && parse_DBsub_value(aTHX_ DBsv, NULL, &line, NULL)) {
SvREFCNT_inc(DBsv); /* was made mortal by hv_delete */
sv_catpvf(fullnamesv, "@%u", (unsigned int)line);
+ if (hv_fetch(GvHV(PL_DBsub), SvPV_nolen(fullnamesv),
(I32)SvCUR(fullnamesv), 0)) {
+ static unsigned int dup_begin_seqn;
+ sv_catpvf(fullnamesv, ".%u", ++dup_begin_seqn);
+ }
+ (void) hv_store(GvHV(PL_DBsub), SvPV_nolen(fullnamesv),
(I32)SvCUR(fullnamesv), DBsv, 0);
+
/* As we know the length of fullnamesv *before* the concatenation,
we
can calculate the length and offset of the formatted addition,
and
hence directly string append it, rather than duplicating the
call to
a *printf function. */
sv_catpvn(subr_entry->called_subnam_sv, SvPVX(fullnamesv) +
total_len,
SvCUR(fullnamesv) - total_len);
- (void) hv_store(GvHV(PL_DBsub), SvPV_nolen(fullnamesv),
(I32)SvCUR(fullnamesv), DBsv, 0);
}
SvREFCNT_dec(fullnamesv);
}
=======================================
--- /trunk/t/42-global.t Mon May 3 14:44:45 2010
+++ /trunk/t/42-global.t Mon May 24 07:37:09 2010
@@ -15,7 +15,7 @@
run_test_group( {
extra_options => { start => 'begin' },
- extra_test_count => 16,
+ extra_test_count => 15,
extra_test_code => sub {
my ($profile, $env) = @_;
@@ -26,13 +26,12 @@
);
isa_ok $profile, 'Devel::NYTProf::Data';
- my $subs = $profile->subname_subinfo_map;
+ my $subs1 = $profile->subname_subinfo_map;
my $begin = ($pre589) ? 'main::BEGIN' : 'main::be...@3';
- is scalar keys %$subs, 3, "should be 3 subs (got @{[ keys %$subs
]})";
- ok $subs->{$begin};
- ok $subs->{'main::RUNTIME'};
- ok $subs->{'main::foo'};
+ ok $subs1->{$begin};
+ ok $subs1->{'main::RUNTIME'};
+ ok $subs1->{'main::foo'};
my @fi = $profile->all_fileinfos;
is @fi, 1, 'should be 1 fileinfo';
@@ -46,17 +45,21 @@
@a = $profile->file_line_range_of_sub('main::foo');
is "$a[1] $a[2] $a[3]", "$fid 2 2", 'details for main::foo should
match';
- $subs = $profile->subs_defined_in_file($fid);
+ my $subs2 = $profile->subs_defined_in_file($fid);
+
+ is_deeply [ keys %$subs2 ], [ keys %$subs1 ],
+ 'keys from subname_subinfo_map and subs_defined_in_file should
match';
+
+ my @begins = grep { $_->subname =~ /\bBEGIN\b/ } values %$subs2;
+ is @begins, ($pre589) ? 1 : 3,
+ 'number of BEGIN subs';
+ is grep({ $_->calls == 1 } @begins), scalar @begins,
+ 'all BEGINs should be called just once';
+
my $sub;
- is scalar keys %$subs, 3, 'should be 3 subs';
- ok $sub = $subs->{$begin};
- SKIP: {
- skip "needs perl >= 5.8.9 or >= 5.10.1", 1 if $pre589;
- is $sub->calls, 1, "$begin should be called 1 time";
- };
- ok $sub = $subs->{'main::RUNTIME'};
+ ok $sub = $subs2->{'main::RUNTIME'};
is $sub->calls, 0, 'main::RUNTIME should be called 0 times';
- ok $sub = $subs->{'main::foo'};
+ ok $sub = $subs2->{'main::foo'};
is $sub->calls, 2, 'main::foo should be called 2 times';
},
@@ -65,8 +68,10 @@
__DATA__
#!perl
sub foo { 42 }
-BEGIN {
+BEGIN { # be...@3
foo(2);
*CORE::GLOBAL::sleep = \&foo;
}
sleep 1;
+
+BEGIN { 'b' } BEGIN { 'c' } # two on same line
--
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]
