Profile of Want.pm

Filename	/home/hejohns/perl5/lib/perl5/x86_64-linux-gnu-thread-multi/Want.pm
Statements	Executed 18 statements in 798µs

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	11µs	11µs	Want::::bootstrapWant::bootstrap (xsub)
1	1	1	7µs	27µs	Want::::BEGIN@4Want::BEGIN@4
1	1	1	6µs	7µs	Want::::BEGIN@5Want::BEGIN@5
1	1	1	3µs	17µs	Want::::BEGIN@6Want::BEGIN@6
0	0	0	0s	0s	Want::::_wantoneWant::_wantone
0	0	0	0s	0s	Want::::bump_levelWant::bump_level
0	0	0	0s	0s	Want::::howmanyWant::howmany
0	0	0	0s	0s	Want::::lnoreturnWant::lnoreturn
0	0	0	0s	0s	Want::::rreturnWant::rreturn
0	0	0	0s	0s	Want::::wantWant::want
0	0	0	0s	0s	Want::::want_uplevelWant::want_uplevel
0	0	0	0s	0s	Want::::wantassignWant::wantassign
0	0	0	0s	0s	Want::::wantrefWant::wantref

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1					package Want;
2
3	1	8µs			require 5.006;
4	2	15µs	2	46µs	# spent 27µs (7+20) within Want::BEGIN@4 which was called: # once (7µs+20µs) by Contextual::Return::BEGIN@361 at line 4 use Carp 'croak'; # spent 27µs making 1 call to Want::BEGIN@4 # spent 20µs making 1 call to Exporter::import
5	2	16µs	2	9µs	# spent 7µs (6+1) within Want::BEGIN@5 which was called: # once (6µs+1µs) by Contextual::Return::BEGIN@361 at line 5 use strict; # spent 7µs making 1 call to Want::BEGIN@5 # spent 1µs making 1 call to strict::import
6	2	664µs	2	31µs	# spent 17µs (3+14) within Want::BEGIN@6 which was called: # once (3µs+14µs) by Contextual::Return::BEGIN@361 at line 6 use warnings; # spent 17µs making 1 call to Want::BEGIN@6 # spent 14µs making 1 call to warnings::import
7
8	1	500ns			require Exporter;
9	1	74µs			require DynaLoader;
10
11	1	7µs			our @ISA = qw(Exporter DynaLoader);
12
13	1	400ns			our @EXPORT = qw(want rreturn lnoreturn);
14	1	200ns			our @EXPORT_OK = qw(howmany wantref);
15	1	100ns			our $VERSION = '0.29';
16
17	1	3µs	1	151µs	bootstrap Want $VERSION; # spent 151µs making 1 call to DynaLoader::bootstrap
18
19	1	2µs			my %reftype = (
20					ARRAY => 1,
21					HASH => 1,
22					CODE => 1,
23					GLOB => 1,
24					OBJECT => 1,
25					);
26
27					sub _wantone {
28					my ($uplevel, $arg) = @_;
29
30					my $wantref = wantref($uplevel + 1);
31					if ($arg =~ /^\d+$/) {
32					my $want_count = want_count($uplevel);
33					return ($want_count == -1 \|\| $want_count >= $arg);
34					}
35					elsif (lc($arg) eq 'infinity') {
36					return (want_count($uplevel) == -1);
37					}
38					elsif ($arg eq 'REF') {
39					return $wantref;
40					}
41					elsif ($reftype{$arg}) {
42					return ($wantref eq $arg);
43					}
44					elsif ($arg eq 'REFSCALAR') {
45					return ($wantref eq 'SCALAR');
46					}
47					elsif ($arg eq 'LVALUE') {
48					return want_lvalue($uplevel);
49					}
50					elsif ($arg eq 'RVALUE') {
51					return !want_lvalue($uplevel);
52					}
53					elsif ($arg eq 'VOID') {
54					return !defined(wantarray_up($uplevel));
55					}
56					elsif ($arg eq 'SCALAR') {
57					my $gimme = wantarray_up($uplevel);
58					return (defined($gimme) && 0 == $gimme);
59					}
60					elsif ($arg eq 'BOOL' \|\| $arg eq 'BOOLEAN') {
61					return want_boolean(bump_level($uplevel));
62					}
63					elsif ($arg eq 'LIST') {
64					return wantarray_up($uplevel);
65					}
66					elsif ($arg eq 'COUNT') {
67					croak("want: COUNT must be the only parameter");
68					}
69					elsif ($arg eq 'ASSIGN') {
70					return !!wantassign($uplevel + 1);
71					}
72					else {
73					croak ("want: Unrecognised specifier $arg");
74					}
75					}
76
77					sub want {
78					if (@_ == 1 && $_[0] eq 'ASSIGN') {
79					@_ = (1);
80					goto &wantassign;
81					}
82					want_uplevel(1, @_);
83					}
84
85					# Simulate the propagation of context through a return value.
86					sub bump_level {
87					my ($level) = @_;
88					for(;;) {
89					my ($p, $r) = parent_op_name($level+1);
90					if ($p eq "return"
91					or $p eq "(none)" && $r =~ /^leavesub(lv)?$/)
92					{
93					++$level
94					}
95					else {
96					return $level
97					}
98					}
99					}
100
101					sub want_uplevel {
102					my ($level, @args) = @_;
103
104					# Deal with special cases (for RFC21-consistency):
105					if (1 == @args) {
106					@_ = (1 + $level);
107					goto &wantref if $args[0] eq 'REF';
108					goto &howmany if $args[0] eq 'COUNT';
109					goto &wantassign if $args[0] eq 'ASSIGN';
110					}
111
112					for my $arg (map split, @args) {
113					if ($arg =~ /^!(.*)/) {
114					return 0 unless !_wantone(2 + $level, $1);
115					}
116					else {
117					return 0 unless _wantone(2 + $level, $arg);
118					}
119					}
120
121					return 1;
122					}
123
124					sub howmany () {
125					my $level = bump_level(@_, 1);
126					my $count = want_count($level);
127					return ($count < 0 ? undef : $count);
128					}
129
130					sub wantref {
131					my $level = bump_level(@_, 1);
132					my $n = parent_op_name($level);
133					if ($n eq 'rv2av') {
134					return "ARRAY";
135					}
136					elsif ($n eq 'rv2hv') {
137					return "HASH";
138					}
139					elsif ($n eq 'rv2cv' \|\| $n eq 'entersub') {
140					return "CODE";
141					}
142					elsif ($n eq 'rv2gv' \|\| $n eq 'gelem') {
143					return "GLOB";
144					}
145					elsif ($n eq 'rv2sv') {
146					return "SCALAR";
147					}
148					elsif ($n eq 'method_call') {
149					return 'OBJECT';
150					}
151					elsif ($n eq 'multideref') {
152					return first_multideref_type($level);
153					}
154					else {
155					return "";
156					}
157					}
158
159					sub wantassign {
160					my $uplevel = shift();
161					return unless want_lvalue($uplevel);
162					my $r = want_assign(bump_level($uplevel));
163					if (want('BOOL')) {
164					return (defined($r) && 0 != $r);
165					}
166					else {
167					return $r ? (want('SCALAR') ? $r->[$#$r] : @$r) : ();
168					}
169					}
170
171					sub double_return :lvalue;
172
173					sub rreturn (@) {
174					if (want_lvalue(1)) {
175					croak "Can't rreturn in lvalue context";
176					}
177
178					# Extra scope needed to work with perl-5.19.7 or greater.
179					# Prevents the return being optimised out, which is needed
180					# since it's actually going to be used a stack level above
181					# this sub.
182					{
183					return double_return(@_);
184					}
185					}
186
187					sub lnoreturn () : lvalue {
188					if (!want_lvalue(1) \|\| !want_assign(1)) {
189					croak "Can't lnoreturn except in ASSIGN context";
190					}
191
192					# Extra scope needed to work with perl-5.19.7 or greater.
193					# Prevents the return being optimised out, which is needed
194					# since it's actually going to be used a stack level above
195					# this sub.
196					#
197					# But in older versions of perl, adding the extra scope
198					# causes the error:
199					# Can't modify loop exit in lvalue subroutine return
200					# so we have to check the version.
201					if ($] >= 5.019) {
202					return double_return(disarm_temp(my $undef));
203					}
204					return double_return(disarm_temp(my $undef));
205					}
206
207					# Some naughty people were relying on these internal methods.
208	1	1µs			*_wantref = \&wantref;
209	1	300ns			*_wantassign = \&wantassign;
210
211	1	6µs			1;
212
213					__END__

					# spent 11µs within Want::bootstrap which was called: # once (11µs+0s) by DynaLoader::bootstrap at line 218 of DynaLoader.pm sub Want::bootstrap; # xsub