=head1 SYNOPSIS
-To verify that B::Concise properly reports whether functions are XS or
-perl, we test against 2 (currently) core packages which have lots of
-XS functions: B and Digest::MD5. They're listed in %$testpkgs, along
-with a list of functions that are (or are not) XS. For brevity, you
-can specify the shorter list; if they're non-xs routines, start list
-with a '!'. Data::Dumper is also tested, partly to prove the non-!
-usage.
-
-We demand-load each package, scan its stash for function names, and
-mark them as XS/not-XS according to the list given for each package.
-Then we test B::Concise's report on each.
+To verify that B::Concise properly reports whether functions are XS,
+perl, or optimized constant subs, we test against a few core packages
+which have a stable API, and which have functions of all 3 types.
+
+=head1 WHAT IS TESTED
+
+5 core packages are tested; Digest::MD5, B, B::Deparse, Data::Dumper,
+and POSIX. These have a mix of the 3 expected implementation types;
+perl, XS, and constant (optimized constant subs).
+
+%$testpkgs specifies what packages are tested; each package is loaded,
+and the stash is scanned for the function-names in that package.
+
+Each value in %$testpkgs is a hash-of-lists (HoL) whose keys are
+implementation-types and values are lists of function-names of that type.
+
+To keep these HoLs smaller and more managable, they may carry an
+additional 'dflt' => $impl_Type, which means that unnamed functions
+are expected to be of that default implementation type. Those unnamed
+functions are known from the scan of the package stash.
+
+=head1 HOW THEY'RE TESTED
+
+Each function is 'rendered' by B::Concise, and result is matched
+against regexs for each possible implementation-type. For some
+packages, some functions may be unimplemented on some platforms.
+
+To slay this maintenance dragon, the regexs used in like() match
+against renderings which indicate that there is no implementation.
+
+If a function is implemented differently on different platforms, the
+test for that function will fail on one of those platforms. These
+specific functions can be skipped by a 'skip' => [ @list ] to the HoL
+mentioned previously. See usage for skip in B's HoL, which avoids
+testing a function which doesnt exist on non-threaded builds.
=head1 OPTIONS AND ARGUMENTS
gives some interesting results.
C<-c> causes the expected XS/non-XS results to be marked with
-corrections, which are then reported at program END, in a
-Data::Dumper statement
+corrections, which are then reported at program END, in a form that's
+readily cut-and-pastable into this file.
+
C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
results accordingly. The file is 'required', so @INC settings apply.
=head1 EXAMPLES
-All following examples avoid using PERL_CORE=1, since that changes @INC
-
=over 4
=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
use Getopt::Std;
use Carp;
-use Test::More tests => ( 1 * !!$Config::Config{useithreads}
+use Test::More tests => ( 0 * !!$Config::Config{useithreads}
+ 3 * ($] > 5.009)
+ 14 * ($] >= 5.009003)
- + 780 );
+ + 780 + 588 );
require_ok("B::Concise");
-my $testpkgs = {
-
- Digest::MD5 => [qw/ ! import /],
-
- B => [qw/ ! class clearsym compile_stats debug objsym parents
- peekop savesym timing_info walkoptree_exec
- walkoptree_slow walksymtable /],
-
- Data::Dumper => [qw/ bootstrap Dumpxs /],
-
- B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
- CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
- OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
- OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
- OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
- OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
- OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
- OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
- OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
- OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
- PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
- PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
- POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
- SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
- main_root main_start opnumber perlstring
- svref_2object /],
+my %matchers =
+ ( constant => qr{ (?-x: is a constant sub, optimized to a \w+)
+ |(?-x: exists in stash, but has no START) }x,
+ XS => qr{ (?-x: is XS code)
+ |(?-x: exists in stash, but has no START) }x,
+ perl => qr{ (?-x: (next|db)state)
+ |(?-x: exists in stash, but has no START) }x,
+ noSTART => qr/exists in stash, but has no START/,
+);
+my $testpkgs = {
+ # packages to test, with expected types for named funcs
+
+ Digest::MD5 => { perl => [qw/ import /],
+ dflt => 'XS' },
+
+ Data::Dumper => { XS => [qw/ bootstrap Dumpxs /],
+ dflt => 'perl' },
+ B => {
+ dflt => 'constant', # all but 47/274
+ skip => [ 'regex_padav' ], # threaded only
+ perl => [qw(
+ walksymtable walkoptree_slow walkoptree_exec
+ timing_info savesym peekop parents objsym debug
+ compile_stats clearsym class
+ )],
+ XS => [qw(
+ warnhook walkoptree_debug walkoptree threadsv_names
+ svref_2object sv_yes sv_undef sv_no save_BEGINs
+ regex_padav ppname perlstring opnumber minus_c
+ main_start main_root main_cv init_av inc_gv hash
+ formfeed end_av dowarn diehook defstash curstash
+ cstring comppadlist check_av cchar cast_I32 bootstrap
+ begin_av amagic_generation address
+ )],
+ },
+
+ B::Deparse => { dflt => 'perl', # 235 functions
+
+ XS => [qw( svref_2object perlstring opnumber main_start
+ main_root main_cv )],
+
+ constant => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
+ CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
+ OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
+ OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
+ OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
+ OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
+ OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
+ OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
+ OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
+ OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
+ PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
+ PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
+ POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
+ SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN
+ /],
+ },
+
+ POSIX => { dflt => 'constant', # all but 252/589
+ perl => [qw/ import croak AUTOLOAD /],
+
+ XS => [qw/ write wctomb wcstombs uname tzset tzname
+ ttyname tmpnam times tcsetpgrp tcsendbreak
+ tcgetpgrp tcflush tcflow tcdrain tanh tan
+ sysconf strxfrm strtoul strtol strtod
+ strftime strcoll sinh sigsuspend sigprocmask
+ sigpending sigaction setuid setsid setpgid
+ setlocale setgid read pipe pause pathconf
+ open nice modf mktime mkfifo mbtowc mbstowcs
+ mblen lseek log10 localeconv ldexp lchown
+ isxdigit isupper isspace ispunct isprint
+ islower isgraph isdigit iscntrl isalpha
+ isalnum int_macro_int getcwd frexp fpathconf
+ fmod floor dup2 dup difftime cuserid ctime
+ ctermid cosh constant close clock ceil
+ bootstrap atan asin asctime acos access abort
+ _exit _POSIX_SAVED_IDS _POSIX_JOB_CONTROL
+ /],
+ },
};
############
-c : writes test corrections as a Data::Dumper expression
-r <file> : reads file of tests, as written by -c
<args> : additional modules are loaded and tested
- (will report failures, since no XS funcs are known aprior)
+ (will report failures, since no XS funcs are known apriori)
EODIE
;
############
sub test_pkg {
- my ($pkg_name, $xslist) = @_;
- require_ok($pkg_name);
+ my ($pkg, $fntypes) = @_;
+ require_ok($pkg);
- unless (ref $xslist eq 'ARRAY') {
- warn "no XS/non-XS function list given, assuming empty XS list";
- $xslist = [''];
- }
-
- my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
- $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!';
-
- # build %stash: keys are func-names, vals: 1 if XS, 0 if not
+ # build %stash: keys are func-names, vals filled in below
my (%stash) = map
- ( ($_ => $assumeXS)
- => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
+ ( ($_ => 0)
+ => ( grep exists &{"$pkg\::$_"} # grab CODE symbols
=> grep !/__ANON__/ # but not anon subs
- => keys %{$pkg_name.'::'} # from symbol table
+ => keys %{$pkg.'::'} # from symbol table
));
- # now invert according to supplied list
- $stash{$_} = int ! $assumeXS foreach @$xslist;
-
- # and cleanup cruft (easier than preventing)
- delete @stash{'!',''};
+ for my $type (keys %matchers) {
+ foreach my $fn (@{$fntypes->{$type}}) {
+ carp "$fn can only be one of $type, $stash{$fn}\n"
+ if $stash{$fn};
+ $stash{$fn} = $type;
+ }
+ }
+ # set default type for un-named functions
+ my $dflt = $fntypes->{dflt} || 'perl';
+ for my $k (keys %stash) {
+ $stash{$k} = $dflt unless $stash{$k};
+ }
+ $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
if ($opts{v}) {
- diag("xslist: " => Dumper($xslist));
- diag("$pkg_name stash: " => Dumper(\%stash));
+ diag("fntypes: " => Dumper($fntypes));
+ diag("$pkg stash: " => Dumper(\%stash));
}
- my $err;
- foreach $func_name (reverse sort keys %stash) {
- my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
- if (!$res) {
- $stash{$func_name} ^= 1;
- print "$func_name ";
- $err++;
+ foreach my $fn (reverse sort keys %stash) {
+ next if $stash{$fn} eq 'skip';
+ my $res = checkXS("${pkg}::$fn", $stash{$fn});
+ if ($res ne '1') {
+ push @{$report{$pkg}{$res}}, $fn;
}
}
- $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
}
sub checkXS {
- my ($func_name, $wantXS) = @_;
+ my ($func_name, $want) = @_;
+
+ croak "unknown type $want: $func_name\n"
+ unless defined $matchers{$want};
my ($buf, $err) = render($func_name);
- if ($wantXS) {
- like($buf, qr/\Q$func_name is XS code/,
- "XS code:\t $func_name");
- } else {
- unlike($buf, qr/\Q$func_name is XS code/,
- "perl code:\t $func_name");
+ my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
+
+ unless ($res) {
+ # test failed. return type that would give success
+ for my $m (keys %matchers) {
+ return $m if $buf =~ $matchers{$m};
+ }
}
- #returns like or unlike, whichever was called
+ $res;
}
sub render {
}
sub corecheck {
-
eval { require Module::CoreList };
if ($@) {
warn "Module::CoreList not available on $]\n";
END {
if ($opts{c}) {
- # print "Corrections: ", Dumper(\%report);
- print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
- print "\$VAR1 = {\n";
+ $Data::Dumper::Indent = 1;
+ print "Corrections: ", Dumper(\%report);
foreach my $pkg (sort keys %report) {
- my (@xs, @perl);
- my $stash = $report{$pkg};
-
- @xs = sort grep $stash->{$_} == 1, keys %$stash;
- @perl = sort grep $stash->{$_} == 0, keys %$stash;
-
- my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
- print "\t$pkg => [qw/ @list /],\n";
+ for my $type (keys %matchers) {
+ print "$pkg: $type: @{$report{$pkg}{$type}}\n"
+ if @{$report{$pkg}{$type}};
+ }
}
- print "};\n";
}
}
--- /dev/null
+#!perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ # require 'test.pl'; # now done by OptreeCheck
+}
+
+use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
+use Config;
+
+my $tests = 18;
+plan tests => $tests;
+SKIP: {
+skip "no perlio in this build", $tests unless $Config::Config{useperlio};
+
+#################################
+
+use constant { # see also t/op/gv.t line 282
+ myint => 42,
+ mystr => 'hithere',
+ myfl => 3.14159,
+ myrex => qr/foo/,
+ myglob => \*STDIN,
+ myaref => [ 1,2,3 ],
+ myhref => { a => 1 },
+};
+
+use constant WEEKDAYS
+ => qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );
+
+
+sub pi () { 3.14159 };
+$::{napier} = \2.71828; # counter-example (doesn't get optimized).
+eval "sub napier ();";
+
+
+# should be able to undefine constant::import here ???
+INIT {
+ # eval 'sub constant::import () {}';
+ # undef *constant::import::{CODE};
+};
+
+#################################
+pass("CONSTANT SUBS RETURNING SCALARS");
+
+checkOptree ( name => 'myint() as coderef',
+ code => \&myint,
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is a constant sub, optimized to a IV
+EOT_EOT
+ is a constant sub, optimized to a IV
+EONT_EONT
+
+
+checkOptree ( name => 'mystr() as coderef',
+ code => \&mystr,
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is a constant sub, optimized to a PV
+EOT_EOT
+ is a constant sub, optimized to a PV
+EONT_EONT
+
+
+checkOptree ( name => 'myfl() as coderef',
+ code => \&myfl,
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is a constant sub, optimized to a NV
+EOT_EOT
+ is a constant sub, optimized to a NV
+EONT_EONT
+
+
+checkOptree ( name => 'myrex() as coderef',
+ code => \&myrex,
+ todo => '- currently renders as XS code',
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is XS code
+EOT_EOT
+ is XS code
+EONT_EONT
+
+
+checkOptree ( name => 'myglob() as coderef',
+ code => \&myglob,
+ todo => '- currently renders as XS code',
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is XS code
+EOT_EOT
+ is XS code
+EONT_EONT
+
+
+checkOptree ( name => 'myaref() as coderef',
+ code => \&myaref,
+ todo => '- currently renders as XS code',
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is XS code
+EOT_EOT
+ is XS code
+EONT_EONT
+
+
+checkOptree ( name => 'myhref() as coderef',
+ code => \&myhref,
+ todo => '- currently renders as XS code',
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is XS code
+EOT_EOT
+ is XS code
+EONT_EONT
+
+
+##############
+
+checkOptree ( name => 'call myint',
+ code => 'myint',
+ bc_opts => '-nobanner',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+3 <1> leavesub[2 refs] K/REFC,1 ->(end)
+- <@> lineseq KP ->3
+1 <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
+2 <$> const[IV 42] s ->3
+EOT_EOT
+3 <1> leavesub[2 refs] K/REFC,1 ->(end)
+- <@> lineseq KP ->3
+1 <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
+2 <$> const(IV 42) s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'call mystr',
+ code => 'mystr',
+ bc_opts => '-nobanner',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+3 <1> leavesub[2 refs] K/REFC,1 ->(end)
+- <@> lineseq KP ->3
+1 <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
+2 <$> const[PV "hithere"] s ->3
+EOT_EOT
+3 <1> leavesub[2 refs] K/REFC,1 ->(end)
+- <@> lineseq KP ->3
+1 <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
+2 <$> const(PV "hithere") s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'call myfl',
+ code => 'myfl',
+ bc_opts => '-nobanner',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+3 <1> leavesub[2 refs] K/REFC,1 ->(end)
+- <@> lineseq KP ->3
+1 <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
+2 <$> const[NV 3.14159] s ->3
+EOT_EOT
+3 <1> leavesub[2 refs] K/REFC,1 ->(end)
+- <@> lineseq KP ->3
+1 <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
+2 <$> const(NV 3.14159) s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'call myrex',
+ code => 'myrex',
+ todo => '- RV value is bare backslash',
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 753 (eval 27):1) v ->2
+# 2 <$> const[RV \\] s ->3
+EOT_EOT
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 753 (eval 27):1) v ->2
+# 2 <$> const(RV \\) s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'call myglob',
+ code => 'myglob',
+ todo => '- RV value is bare backslash',
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 753 (eval 27):1) v ->2
+# 2 <$> const[RV \\] s ->3
+EOT_EOT
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 753 (eval 27):1) v ->2
+# 2 <$> const(RV \\) s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'call myaref',
+ code => 'myaref',
+ todo => '- RV value is bare backslash',
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 758 (eval 29):1) v ->2
+# 2 <$> const[RV \\] s ->3
+EOT_EOT
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 758 (eval 29):1) v ->2
+# 2 <$> const(RV \\) s ->3
+EONT_EONT
+
+
+checkOptree ( name => 'call myhref',
+ code => 'myhref',
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 763 (eval 31):1) v ->2
+# 2 <$> const[RV \\HASH] s ->3
+EOT_EOT
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 763 (eval 31):1) v ->2
+# 2 <$> const(RV \\HASH) s ->3
+EONT_EONT
+
+
+##################
+
+# test constant sub defined w/o 'use constant'
+
+checkOptree ( name => "pi(), defined w/o 'use constant'",
+ code => \&pi,
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is a constant sub, optimized to a NV
+EOT_EOT
+ is a constant sub, optimized to a NV
+EONT_EONT
+
+
+checkOptree ( name => 'constant subs returning lists are not optimized',
+ code => \&WEEKDAYS,
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3 <1> leavesub[2 refs] K/REFC,1 ->(end)
+# - <@> lineseq K ->3
+# 1 <;> nextstate(constant 685 constant.pm:121) v ->2
+# 2 <0> padav[@list:FAKE:m:102] ->3
+EOT_EOT
+# 3 <1> leavesub[2 refs] K/REFC,1 ->(end)
+# - <@> lineseq K ->3
+# 1 <;> nextstate(constant 685 constant.pm:121) v ->2
+# 2 <0> padav[@list:FAKE:m:76] ->3
+EONT_EONT
+
+
+sub printem {
+ printf "myint %d mystr %s myfl %f pi %f\n"
+ , myint, mystr, myfl, pi;
+}
+
+checkOptree ( name => 'call em all in a print statement',
+ code => \&printem,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->9
+# 1 <;> nextstate(main 635 optree_constants.t:163) v ->2
+# 8 <@> prtf sK ->9
+# 2 <0> pushmark s ->3
+# 3 <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
+# 4 <$> const[IV 42] s ->5
+# 5 <$> const[PV "hithere"] s ->6
+# 6 <$> const[NV 3.14159] s ->7
+# 7 <$> const[NV 3.14159] s ->8
+EOT_EOT
+# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->9
+# 1 <;> nextstate(main 635 optree_constants.t:163) v ->2
+# 8 <@> prtf sK ->9
+# 2 <0> pushmark s ->3
+# 3 <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
+# 4 <$> const(IV 42) s ->5
+# 5 <$> const(PV "hithere") s ->6
+# 6 <$> const(NV 3.14159) s ->7
+# 7 <$> const(NV 3.14159) s ->8
+EONT_EONT
+
+
+} #skip
+
+__END__
+
+=head NB
+
+Optimized constant subs are stored as bare scalars in the stash
+(package hash), which formerly held only GVs (typeglobs).
+
+But you cant create them manually - you cant assign a scalar to a
+stash element, and expect it to work like a constant-sub, even if you
+provide a prototype.
+
+This is a feature; alternative is too much action-at-a-distance. The
+following test demonstrates - napier is not seen as a function at all,
+much less an optimized one.
+
+=cut
+
+checkOptree ( name => 'not evertnapier',
+ code => \&napier,
+ noanchors => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ has no START
+EOT_EOT
+ has no START
+EONT_EONT
+
+
projects / p5sagit/p5-mst-13.2.git / commitdiff