diff options
Diffstat (limited to 'gnu/usr.bin/perl/ext')
131 files changed, 22289 insertions, 56 deletions
diff --git a/gnu/usr.bin/perl/ext/B/B.pm b/gnu/usr.bin/perl/ext/B/B.pm index 8a1a2fe821d..bd6a60ad076 100644 --- a/gnu/usr.bin/perl/ext/B/B.pm +++ b/gnu/usr.bin/perl/ext/B/B.pm @@ -7,7 +7,7 @@ # package B; -our $VERSION = '1.02'; +our $VERSION = '1.07'; use XSLoader (); require Exporter; @@ -36,7 +36,8 @@ use strict; @B::PVIV::ISA = qw(B::PV B::IV); @B::PVNV::ISA = qw(B::PV B::NV); @B::PVMG::ISA = 'B::PVNV'; -@B::PVLV::ISA = 'B::PVMG'; +# Change in the inheritance hierarchy post 5.8 +@B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG'; @B::BM::ISA = 'B::PVMG'; @B::AV::ISA = 'B::PVMG'; @B::GV::ISA = 'B::PVMG'; @@ -177,7 +178,7 @@ sub walkoptree_exec { $op->$method($level); $ppname = $op->name; if ($ppname =~ - /^(or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/) + /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/) { print $prefix, uc($1), " => {\n"; walkoptree_exec($op->other, $method, $level + 1); @@ -341,7 +342,7 @@ get an initial "handle" on an internal object. =head2 Functions Returning C<B::SV>, C<B::AV>, C<B::HV>, and C<B::CV> objects -For descriptions of the class hierachy of these objects and the +For descriptions of the class hierarchy of these objects and the methods that can be called on them, see below, L<"OVERVIEW OF CLASSES"> and L<"SV-RELATED CLASSES">. @@ -429,7 +430,7 @@ Methods">, below. =head2 Functions Returning C<B::OP> objects or for walking op trees -For descriptions of the class hierachy of these objects and the +For descriptions of the class hierarchy of these objects and the methods that can be called on them, see below, L<"OVERVIEW OF CLASSES"> and L<"OP-RELATED CLASSES">. @@ -529,7 +530,8 @@ using this module. B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV, B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in the obvious way to the underlying C structures of similar names. The -inheritance hierarchy mimics the underlying C "inheritance": +inheritance hierarchy mimics the underlying C "inheritance". For 5.9 and +later this is: B::SV | @@ -547,6 +549,20 @@ inheritance hierarchy mimics the underlying C "inheritance": | B::PVMG | + +-----+----+------+-----+-----+ + | | | | | | + B::BM B::AV B::GV B::HV B::CV B::IO + | | + B::PVLV | + B::FM + + +For 5.8 and earlier, PVLV is a direct subclass of PVMG, so the base of this +diagram is + + | + B::PVMG + | +------+-----+----+------+-----+-----+ | | | | | | | B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO @@ -920,6 +936,9 @@ with the leading "class indication" prefix (C<"op_">) removed. =head2 B::OP Methods +These methods get the values of similarly named fields within the OP +data structure. See top of C<op.h> for more info. + =over 4 =item next @@ -944,12 +963,16 @@ This returns the op description from the global C PL_op_desc array =item type -=item seq +=item opt + +=item static =item flags =item private +=item spare + =back =head2 B::UNOP METHOD diff --git a/gnu/usr.bin/perl/ext/B/B.xs b/gnu/usr.bin/perl/ext/B/B.xs index 1dad6c083d4..63f5a99fa3c 100644 --- a/gnu/usr.bin/perl/ext/B/B.xs +++ b/gnu/usr.bin/perl/ext/B/B.xs @@ -29,11 +29,16 @@ static char *svclassnames[] = { "B::PVNV", "B::PVMG", "B::BM", +#if PERL_VERSION >= 9 + "B::GV", +#endif "B::PVLV", "B::AV", "B::HV", "B::CV", +#if PERL_VERSION <= 8 "B::GV", +#endif "B::FM", "B::IO", }; @@ -416,9 +421,15 @@ oplist(pTHX_ OP *o, SV **SP) { for(; o; o = o->op_next) { SV *opsv; - if (o->op_seq == 0) +#if PERL_VERSION >= 9 + if (o->op_opt == 0) + break; + o->op_opt = 0; +#else + if (o->op_seq == 0) break; o->op_seq = 0; +#endif opsv = sv_newmortal(); sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o)); XPUSHs(opsv); @@ -494,6 +505,9 @@ BOOT: specialsv_list[4] = pWARN_ALL; specialsv_list[5] = pWARN_NONE; specialsv_list[6] = pWARN_STD; +#if PERL_VERSION <= 8 +# define CVf_ASSERTION 0 +#endif #include "defsubs.h" } @@ -707,24 +721,31 @@ cchar(sv) void threadsv_names() PPCODE: -#ifdef USE_5005THREADS +#if PERL_VERSION <= 8 +# ifdef USE_5005THREADS int i; STRLEN len = strlen(PL_threadsv_names); EXTEND(sp, len); for (i = 0; i < len; i++) PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1))); +# endif #endif - #define OP_next(o) o->op_next #define OP_sibling(o) o->op_sibling #define OP_desc(o) PL_op_desc[o->op_type] #define OP_targ(o) o->op_targ #define OP_type(o) o->op_type -#define OP_seq(o) o->op_seq +#if PERL_VERSION >= 9 +# define OP_opt(o) o->op_opt +# define OP_static(o) o->op_static +#else +# define OP_seq(o) o->op_seq +#endif #define OP_flags(o) o->op_flags #define OP_private(o) o->op_private +#define OP_spare(o) o->op_spare MODULE = B PACKAGE = B::OP PREFIX = OP_ @@ -779,10 +800,24 @@ U16 OP_type(o) B::OP o +#if PERL_VERSION >= 9 + +U8 +OP_opt(o) + B::OP o + +U8 +OP_static(o) + B::OP o + +#else + U16 OP_seq(o) B::OP o +#endif + U8 OP_flags(o) B::OP o @@ -791,6 +826,14 @@ U8 OP_private(o) B::OP o +#if PERL_VERSION >= 9 + +U8 +OP_spare(o) + B::OP o + +#endif + void OP_oplist(o) B::OP o diff --git a/gnu/usr.bin/perl/ext/B/B/Showlex.pm b/gnu/usr.bin/perl/ext/B/B/Showlex.pm index 0140c8ac519..3b261a337df 100644 --- a/gnu/usr.bin/perl/ext/B/B/Showlex.pm +++ b/gnu/usr.bin/perl/ext/B/B/Showlex.pm @@ -1,10 +1,11 @@ package B::Showlex; -our $VERSION = '1.00'; +our $VERSION = '1.02'; use strict; use B qw(svref_2object comppadlist class); use B::Terse (); +use B::Concise (); # # Invoke as @@ -13,21 +14,32 @@ use B::Terse (); # or as # perl -MO=Showlex bar.pl # to see the names of file scope lexicals used by bar.pl -# +# + + +# borrowed from B::Concise +our $walkHandle = \*STDOUT; + +sub walk_output { # updates $walkHandle + $walkHandle = B::Concise::walk_output(@_); + #print "got $walkHandle"; + #print $walkHandle "using it"; + $walkHandle; +} sub shownamearray { my ($name, $av) = @_; my @els = $av->ARRAY; my $count = @els; my $i; - print "$name has $count entries\n"; + print $walkHandle "$name has $count entries\n"; for ($i = 0; $i < $count; $i++) { - print "$i: "; my $sv = $els[$i]; if (class($sv) ne "SPECIAL") { - printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; } else { - $sv->terse; + printf $walkHandle "$i: %s\n", $sv->terse; + #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); } } } @@ -37,10 +49,10 @@ sub showvaluearray { my @els = $av->ARRAY; my $count = @els; my $i; - print "$name has $count entries\n"; + print $walkHandle "$name has $count entries\n"; for ($i = 0; $i < $count; $i++) { - print "$i: "; - $els[$i]->terse; + printf $walkHandle "$i: %s\n", $els[$i]->terse; + #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]); } } @@ -50,28 +62,60 @@ sub showlex { showvaluearray("Pad of lexical values for $objname", $valsav); } +my ($newlex, $nosp1); # rendering state vars + +sub newlex { # drop-in for showlex + my ($objname, $names, $vals) = @_; + my @names = $names->ARRAY; + my @vals = $vals->ARRAY; + my $count = @names; + print $walkHandle "$objname Pad has $count entries\n"; + printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; + for (my $i = 1; $i < $count; $i++) { + printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse + unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; + } +} + sub showlex_obj { my ($objname, $obj) = @_; $objname =~ s/^&main::/&/; - showlex($objname, svref_2object($obj)->PADLIST->ARRAY); + showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex; + newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex; } sub showlex_main { - showlex("comppadlist", comppadlist->ARRAY); + showlex("comppadlist", comppadlist->ARRAY) if !$newlex; + newlex ("main", comppadlist->ARRAY) if $newlex; } sub compile { - my @options = @_; - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { + my @options = grep(/^-/, @_); + my @args = grep(!/^-/, @_); + for my $o (@options) { + $newlex = 1 if $o eq "-newlex"; + $nosp1 = 1 if $o eq "-nosp"; + } + + return \&showlex_main unless @args; + return sub { + my $objref; + foreach my $objname (@args) { + next unless $objname; # skip nulls w/o carping + + if (ref $objname) { + print $walkHandle "B::Showlex::compile($objname)\n"; + $objref = $objname; + } else { $objname = "main::$objname" unless $objname =~ /::/; - eval "showlex_obj('&$objname', \\&$objname)"; + print $walkHandle "$objname:\n"; + no strict 'refs'; + die "err: unknown function ($objname)\n" + unless *{$objname}{CODE}; + $objref = \&$objname; } + showlex_obj($objname, $objref); } - } else { - return \&showlex_main; } } @@ -85,13 +129,74 @@ B::Showlex - Show lexical variables used in functions or files =head1 SYNOPSIS - perl -MO=Showlex[,SUBROUTINE] foo.pl + perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl =head1 DESCRIPTION -When a subroutine name is provided in OPTIONS, prints the lexical -variables used in that subroutine. Otherwise, prints the file-scope -lexicals in the file. +When a comma-separated list of subroutine names is given as options, Showlex +prints the lexical variables used in those subroutines. Otherwise, it prints +the file-scope lexicals in the file. + +=head1 EXAMPLES + +Traditional form: + + $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' + Pad of lexical names for comppadlist has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0x9db0fb0) $i + 2: PVNV (0x9db0f38) $j + 3: PVNV (0x9db0f50) $k + Pad of lexical values for comppadlist has 5 entries + 0: SPECIAL #1 &PL_sv_undef + 1: NULL (0x9da4234) + 2: NULL (0x9db0f2c) + 3: NULL (0x9db0f44) + 4: NULL (0x9da4264) + -e syntax OK + +New-style form: + + $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' + main Pad has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234) + 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34) + 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c) + -e syntax OK + +New form, no specials, outside O framework: + + $ perl -MB::Showlex -e \ + 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' + main Pad has 4 entries + 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1 + 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo" + 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74) + +Note that this example shows the values of the lexicals, whereas the other +examples did not (as they're compile-time only). + +=head2 OPTIONS + +The C<-newlex> option produces a more readable C<< name => value >> format, +and is shown in the second example above. + +The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL +#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm +your declared lexicals. + +=head1 SEE ALSO + +C<B::Showlex> can also be used outside of the O framework, as in the third +example. See C<B::Concise> for a fuller explanation of reasons. + +=head1 TODO + +Some of the reported info, such as hex addresses, is not particularly +valuable. Other information would be more useful for the typical +programmer, such as line-numbers, pad-slot reuses, etc.. Given this, +-newlex isnt a particularly good flag-name. =head1 AUTHOR diff --git a/gnu/usr.bin/perl/ext/B/B/Terse.pm b/gnu/usr.bin/perl/ext/B/B/Terse.pm index 401dfc2668c..8d295cdd714 100644 --- a/gnu/usr.bin/perl/ext/B/B/Terse.pm +++ b/gnu/usr.bin/perl/ext/B/B/Terse.pm @@ -16,7 +16,6 @@ sub terse { } else { concise_subref('basic', $subref); } - } sub compile { @@ -28,7 +27,7 @@ sub compile { } sub indent { - my $level = @_ ? shift : 0; + my ($level) = @_ ? shift : 0; return " " x $level; } @@ -43,20 +42,27 @@ sub B::SV::terse { my($sv, $level) = (@_, 0); my %info; B::Concise::concise_sv($sv, \%info); - my $s = B::Concise::fmt_line(\%info, "#svclass~(?((#svaddr))?)~#svval", 0); - print indent($level), $s, "\n"; + my $s = indent($level) + . B::Concise::fmt_line(\%info, $sv, + "#svclass~(?((#svaddr))?)~#svval", 0); + chomp $s; + print "$s\n" unless defined wantarray; + $s; } sub B::NULL::terse { my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx)\n", class($sv), $$sv; + my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv; + print "$s\n" unless defined wantarray; + $s; } sub B::SPECIAL::terse { my ($sv, $level) = @_; - print indent($level); - printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv]; + my $s = indent($level) + . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]); + print "$s\n" unless defined wantarray; + $s; } 1; diff --git a/gnu/usr.bin/perl/ext/B/defsubs_h.PL b/gnu/usr.bin/perl/ext/B/defsubs_h.PL index 46b91072dbd..6e9f3062960 100644 --- a/gnu/usr.bin/perl/ext/B/defsubs_h.PL +++ b/gnu/usr.bin/perl/ext/B/defsubs_h.PL @@ -15,6 +15,7 @@ END foreach my $const (qw( AVf_REAL CVf_ANON + CVf_ASSERTION CVf_CLONE CVf_CLONED CVf_CONST diff --git a/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm b/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm new file mode 100644 index 00000000000..f8e2995346a --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm @@ -0,0 +1,777 @@ +# non-package OptreeCheck.pm +# pm allows 'use OptreeCheck', which also imports +# no package decl means all functions defined into main +# otherwise, it's like "require './test.pl'" + +=head1 NAME + +OptreeCheck - check optrees as rendered by B::Concise + +=head1 SYNOPSIS + +OptreeCheck supports regression testing of perl's parser, optimizer, +bytecode generator, via a single function: checkOptree(%args). It +invokes B::Concise upon sample code, and checks that it 'agrees' with +reference renderings. + + checkOptree ( + name => "test-name', # optional, (synth from others) + + # 2 kinds of code-under-test: must provide 1 + code => sub {my $a}, # coderef, or source (wrapped and evald) + prog => 'sort @a', # run in subprocess, aka -MO=Concise + + bcopts => '-exec', # $opt or \@opts, passed to BC::compile + # errs => '.*', # match against any emitted errs, -w warnings + # skip => 1, # skips test + # todo => 'excuse', # anticipated failures + # fail => 1 # force fail (by redirecting result) + # debug => 1, # turns on regex debug for match test !! + # retry => 1 # retry with debug on test failure + + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); + # 1 <;> nextstate(main 45 optree.t:23) v + # 2 <0> padsv[$a:45,46] M/LVINTRO + # 3 <1> leavesub[1 ref] K/REFC,1 + EOT_EOT + # 1 <;> nextstate(main 45 optree.t:23) v + # 2 <0> padsv[$a:45,46] M/LVINTRO + # 3 <1> leavesub[1 ref] K/REFC,1 + EONT_EONT + +=head1 checkOptree(%in) Overview + +optreeCheck() calls getRendering(), which runs code or prog through +B::Concise, and captures its rendering. + +It then calls mkCheckRex() to produce a regex which will match the +expected rendering, and fail when it doesn't match. + +Finally, it compares the 2; like($rendering,/$regex/,$testname). + + +=head1 checkOptree(%Args) API + +Accepts %Args, with following requirements and actions: + +Either code or prog must be present. prog is some source code, and is +passed through via test.pl:runperl, to B::Concise like this: (bcopts +are fixed up for cmdline) + + './perl -w -MO=Concise,$bcopts_massaged -e $src' + +code is a subref, or $src, like above. If it's not a subref, it's +treated like source-code, is wrapped as a subroutine, and is passed to +B::Concise::compile(). + + $subref = eval "sub{$src}"; + B::Concise::compile($subref). + +expect and expect_nt are the reference optree renderings. Theyre +required, except when the code/prog compilation fails. + +I suppose I should also explain these more, but they seem obvious. + + # prog => 'sort @a', # run in subprocess, aka -MO=Concise + # noanchors => 1, # no /^$/. needed for 1-liners like above + + # skip => 1, # skips test + # todo => 'excuse', # anticipated failures + # fail => 1 # fails (by redirecting result) + # debug => 1, # turns on regex debug for match test !! + # retry => 1 # retry with debug on test failure + +=head1 Test Philosophy + +2 platforms --> 2 reftexts: You want an accurate test, independent of +which platform you're on. So, two refdata properties, 'expect' and +'expect_nt', carry renderings taken from threaded and non-threaded +builds. This has several benefits: + + 1. native reference data allows closer matching by regex. + 2. samples can be eyeballed to grok t-nt differences. + 3. data can help to validate mkCheckRex() operation. + 4. can develop regexes which accomodate t-nt differences. + 5. can test with both native and cross+converted regexes. + +Cross-testing (expect_nt on threaded, expect on non-threaded) exposes +differences in B::Concise output, so mkCheckRex has code to do some +cross-test manipulations. This area needs more work. + +=head1 Test Modes + +One consequence of a single-function API is difficulty controlling +test-mode. Ive chosen for now to use a package hash, %gOpts, to store +test-state. These properties alter checkOptree() function, either +short-circuiting to selftest, or running a loop that runs the testcase +2^N times, varying conditions each time. (current N is 2 only). + +So Test-mode is controlled with cmdline args, also called options below. +Run with 'help' to see the test-state, and how to change it. + +=head2 selftest + +This argument invokes runSelftest(), which tests a regex against the +reference renderings that they're made from. Failure of a regex match +its 'mold' is a strong indicator that mkCheckRex is buggy. + +That said, selftest mode currently runs a cross-test too, they're not +completely orthogonal yet. See below. + +=head2 testmode=cross + +Cross-testing is purposely creating a T-NT mismatch, looking at the +fallout, and tweaking the regex to deal with it. Thus tests lead to +'provably' complete understanding of the differences. + +The tweaking appears contrary to the 2-refs philosophy, but the tweaks +will be made in conversion-specific code, which (will) handles T->NT +and NT->T separately. The tweaking is incomplete. + +A reasonable 1st step is to add tags to indicate when TonNT or NTonT +is known to fail. This needs an option to force failure, so the +test.pl reporting mechanics show results to aid the user. + +=head2 testmode=native + +This is normal mode. Other valid values are: native, cross, both. + +=head2 checkOptree Notes + +Accepts test code, renders its optree using B::Concise, and matches that +rendering against a regex built from one of 2 reference-renderings %in data. + +The regex is built by mkCheckRex(\%in), which scrubs %in data to +remove match-irrelevancies, such as (args) and [args]. For example, +it strips leading '# ', making it easy to cut-paste new tests into +your test-file, run it, and cut-paste actual results into place. You +then retest and reedit until all 'errors' are gone. (now make sure you +haven't 'enshrined' a bug). + +name: The test name. May be augmented by a label, which is built from +important params, and which helps keep names in sync with whats being +tested.' + +=cut + +use Config; +use Carp; +use B::Concise qw(walk_output); +use Data::Dumper; +$Data::Dumper::Sortkeys = 1; + +BEGIN { + $SIG{__WARN__} = sub { + my $err = shift; + $err =~ m/Subroutine re::(un)?install redefined/ and return; + }; +} + +# but wait - more skullduggery ! +sub OptreeCheck::import { &getCmdLine; } # process @ARGV + +# %gOpts params comprise a global test-state. Initial values here are +# HELP strings, they MUST BE REPLACED by runtime values before use, as +# is done by getCmdLine(), via import + +our %gOpts = # values are replaced at runtime !! + ( + # scalar values are help string + rextract => 'writes src-code todo same Optree matching', + vbasic => 'prints $str and $rex', + retry => 'retry failures after turning on re debug', + retrydbg => 'retry failures after turning on re debug', + selftest => 'self-tests mkCheckRex vs the reference rendering', + selfdbg => 'redo failing selftests with re debug', + xtest => 'extended thread/non-thread testing', + fail => 'force all test to fail, print to stdout', + dump => 'dump cmdline arg prcessing', + rexpedant => 'try tighter regex, still buggy', + noanchors => 'dont anchor match rex', + help => 0, # 1 ends in die + + # array values are one-of selections, with 1st value as default + testmode => [qw/ native cross both /], + + # fixup for VMS, cygwin, which dont have stderr b4 stdout + # 2nd value is used as help-str, 1st val (still) default + + rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0], + strip => [1, 'if 1, catch errs and remove from renderings',0], + stripv => 'if strip&&1, be verbose about it', + errs => 'expected compile errs', + ); + + +# Not sure if this is too much cheating. Officially we say that +# $Config::Config{usethreads} is true if some sort of threading is in use, +# in which case we ought to be able to use it in place of the || below. +# However, it is now possible to Configure perl with "threads" but neither +# ithreads or 5005threads, which forces the re-entrant APIs, but no perl +# user visible threading. This seems to have the side effect that most of perl +# doesn't think that it's threaded, hence the ops aren't threaded either. +# Not sure if this is actually a "supported" configuration, but given that +# ponie uses it, it's going to be used by something official at least in the +# interim. So it's nice for tests to all pass. +our $threaded = 1 + if $Config::Config{useithreads} || $Config::Config{use5005threads}; +our $platform = ($threaded) ? "threaded" : "plain"; +our $thrstat = ($threaded) ? "threaded" : "nonthreaded"; + +our ($MatchRetry,$MatchRetryDebug); # let mylike be generic +# test.pl-ish hack +*MatchRetry = \$gOpts{retry}; # but alias it into %gOpts +*MatchRetryDebug = \$gOpts{retrydbg}; # but alias it into %gOpts + +our %modes = ( + both => [ 'expect', 'expect_nt'], + native => [ ($threaded) ? 'expect' : 'expect_nt'], + cross => [ !($threaded) ? 'expect' : 'expect_nt'], + expect => [ 'expect' ], + expect_nt => [ 'expect_nt' ], + ); + +our %msgs # announce cross-testing. + = ( + # cross-platform + 'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)", + 'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)", + # native - nothing to say + 'expect_nt-nonthreaded' => '', + 'expect-threaded' => '', + ); + +####### +sub getCmdLine { # import assistant + # offer help + print(qq{\n$0 accepts args to update these state-vars: + turn on a flag by typing its name, + select a value from list by typing name=val.\n }, + Dumper \%gOpts) + if grep /help/, @ARGV; + + # replace values for each key !! MUST MARK UP %gOpts + foreach my $opt (keys %gOpts) { + + # scan ARGV for known params + if (ref $gOpts{$opt} eq 'ARRAY') { + + # $opt is a One-Of construct + # replace with valid selection from the list + + # uhh this WORKS. but it's inscrutable + # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV; + my $tval; # temp + if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) { + # check val before accepting + my @allowed = @{$gOpts{$opt}}; + if (grep { $_ eq $tval } @allowed) { + $gOpts{$opt} = $tval; + } + else {die "invalid value: '$tval' for $opt\n"} + } + + # take 1st val as default + $gOpts{$opt} = ${$gOpts{$opt}}[0] + if ref $gOpts{$opt} eq 'ARRAY'; + } + else { # handle scalars + + # if 'opt' is present, true + $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0; + + # override with 'foo' if 'opt=foo' appears + grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV; + } + } + print("$0 heres current state:\n", Dumper \%gOpts) + if $gOpts{help} or $gOpts{dump}; + + exit if $gOpts{help}; +} +# the above arg-handling cruft should be replaced by a Getopt call + +################################## +# API + +sub checkOptree { + my %in = @_; + my ($in, $res) = (\%in,0); # set up privates. + + print "checkOptree args: ",Dumper \%in if $in{dump}; + SKIP: { + label(\%in); + skip($in{name}, 1) if $in{skip}; + + # cpy globals into each test + foreach $k (keys %gOpts) { + if ($gOpts{$k}) { + $in{$k} = $gOpts{$k} unless $in{$k}; + } + } + #die "no reftext found for $want: $in->{name}" unless $str; + + return runSelftest(\%in) if $gOpts{selftest}; + + my ($rendering,@errs) = getRendering(\%in); # get the actual output + + if ($in->{errs}) { + if (@errs) { + like ("@errs", qr/$in->{errs}\s*/, "$in->{name} - matched expected errs"); + next; + } + } + fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ? + + # Test rendering against .. + TODO: + foreach $want (@{$modes{$gOpts{testmode}}}) { + local $TODO = $in{todo} if $in{todo}; + + my ($rex,$txt,$rexstr) = mkCheckRex(\%in,$want); + my $cross = $msgs{"$want-$thrstat"}; + + # bad is anticipated failure on cross testing ONLY + my $bad = (0 or ( $cross && $in{crossfail}) + or (!$cross && $in{fail}) + or 0); # no undefs! pedant + + # couldn't bear to pass \%in to likeyn + $res = mylike ( # custom test mode stuff + [ !$bad, + $in{retry} || $gOpts{retry}, + $in{debug} || $gOpts{retrydbg}, + $rexstr, + ], + # remaining is std API + $rendering, qr/$rex/ms, "$cross $in{name} $in{label}") + || 0; + printhelp(\%in, $rendering, $rex); + } + } + $res; +} + +################# +# helpers + +sub label { + # may help get/keep test output consistent + my ($in) = @_; + return if $in->{name}; + + my $buf = (ref $in->{bcopts}) + ? join(',', @{$in->{bcopts}}) : $in->{bcopts}; + + foreach (qw( note prog code )) { + $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_}; + } + return $in->{label} = $buf; +} + +sub testCombo { + # generate a set of test-cases from the options + my $in = @_; + my @cases; + foreach $want (@{$modes{$gOpts{testmode}}}) { + push @cases, [ %in ] + } + return @cases; +} + +sub runSelftest { + # tests the test-cases offered (expect, expect_nt) + # needs Unification with above. + my ($in) = @_; + my $ok; + foreach $want (@{$modes{$gOpts{testmode}}}) {} + + for my $provenance (qw/ expect expect_nt /) { + next unless $in->{$provenance}; + my ($rex,$gospel) = mkCheckRex($in, $provenance); + return unless $gospel; + + my $cross = $msgs{"$provenance-$thrstat"}; + my $bad = (0 or ( $cross && $in->{crossfail}) + or (!$cross && $in->{fail}) + or 0); + # couldn't bear to pass \%in to likeyn + $res = mylike ( [ !$bad, + $in->{retry} || $gOpts{retry}, + $in->{debug} || $gOpts{retrydbg}, + #label($in) + ], + $rendering, qr/$rex/ms, "$cross $in{name}") + || 0; + } + $ok; +} + +# use re; +sub mylike { + # note dependence on unlike() + my ($control) = shift; + my ($yes,$retry,$debug,$postmortem) = @$control; # or dies + my ($got, $expected, $name, @mess) = @_; # pass thru mostly + + die "unintended usage, expecting Regex". Dumper \@_ + unless ref $_[1] eq 'Regexp'; + + #ok($got=~/$expected/, "wow"); + + # same as A ^ B, but B has side effects + my $ok = ( (!$yes and unlike($got, $expected, $name, @mess)) + or ($yes and like($got, $expected, $name, @mess))); + + if (not $ok and $postmortem) { + # split rexstr into units that should eat leading lines. + my @rexs = map qr/^$_/, split (/\n/,$postmortem); + foreach my $rex (@rexs) { + #$got =~ s/($rex)/ate: $1/msg; # noisy + $got =~ s/($rex)\n//msg; # remove matches + } + print "these lines not matched:\n$got\n"; + } + + if (not $ok and $retry) { + # redo, perhaps with use re debug - NOT ROBUST + eval "use re 'debug'" if $debug; + $ok = (!$yes and unlike($got, $expected, "(RETRY) $name", @mess) + or $yes and like($got, $expected, "(RETRY) $name", @mess)); + + no re 'debug'; + } + return $ok; +} + +sub getRendering { + my ($in) = @_; + die "getRendering: code or prog is required\n" + unless $in->{code} or $in->{prog}; + + my @opts = get_bcopts($in); + my $rendering = ''; # suppress "Use of uninitialized value in open" + my @errs; # collect errs via + + + if ($in->{prog}) { + $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)], + prog => $in->{prog}, stderr => 1, + ); # verbose => 1); + } else { + my $code = $in->{code}; + unless (ref $code eq 'CODE') { + # treat as source, and wrap + $code = eval "sub { $code }"; + # return errors + push @errs, $@ if $@; + } + # set walk-output b4 compiling, which writes 'announce' line + walk_output(\$rendering); + if ($in->{fail}) { + fail("forced failure: stdout follows"); + walk_output(\*STDOUT); + } + my $opwalker = B::Concise::compile(@opts, $code); + die "bad BC::compile retval" unless ref $opwalker eq 'CODE'; + + B::Concise::reset_sequence(); + $opwalker->(); + } + if ($in->{strip}) { + $rendering =~ s/(B::Concise::compile.*?\n)//; + print "stripped from rendering <$1>\n" if $1 and $in->{stripv}; + + while ($rendering =~ s/^(.*?-e line .*?\n)//g) { + print "stripped <$1>\n" if $in->{stripv}; + push @errs, $1; + } + $rendering =~ s/-e syntax OK\n//; + $rendering =~ s/-e had compilation errors\.\n//; + } + return $rendering, @errs; +} + +sub get_bcopts { + # collect concise passthru-options if any + my ($in) = shift; + my @opts = (); + if ($in->{bcopts}) { + @opts = (ref $in->{bcopts} eq 'ARRAY') + ? @{$in->{bcopts}} : ($in->{bcopts}); + } + return @opts; +} + +=head1 mkCheckRex + +mkCheckRex receives the full testcase object, and constructs a regex. +1st, it selects a reftxt from either the expect or expect_nt items. + +Once selected, the reftext is massaged & converted into a Regex that +accepts 'good' concise renderings, with appropriate input variations, +but is otherwise as strict as possible. For example, it should *not* +match when opcode flags change, or when optimizations convert an op to +an ex-op. + +selection is driven by platform mostly, but also by test-mode, which +rather complicates the code. this is worsened by the potential need +to make platform specific conversions on the reftext. + +=head2 match criteria + +Opcode arguments (text within braces) are disregarded for matching +purposes. This loses some info in 'add[t5]', but greatly simplifys +matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing +for regressions, not for complete accuracy. + +The regex is anchored by default, but can be suppressed with +'noanchors', allowing 1-liner tests to succeed if opcode is found. + +=cut + +# needless complexity due to 'too much info' from B::Concise v.60 +my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';; + +sub mkCheckRex { + # converts expected text into Regexp which should match against + # unaltered version. also adjusts threaded => non-threaded + my ($in, $want) = @_; + eval "no re 'debug'"; + + my $str = $in->{expect} || $in->{expect_nt}; # standard bias + $str = $in->{$want} if $want; # stated pref + + #fail("rex-str is empty, won't allow false positives") unless $str; + + $str =~ s/^\# //mg; # ease cut-paste testcase authoring + my $reftxt = $str; # extra return val !! + + # convert all (args) and [args] to temp forms wo bracing + $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg; + $str =~ s/\((.*?)\)/__CAPRND$1__/msg; + $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate + + # escape bracing, etc.. manual \Q (doesnt escape '+') + $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg; + + # now replace temp forms with original, preserving reference bracing + $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important + $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; + $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate + + # no 'invisible' failures in debugger + $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg; + # widened for -terse mode + $str =~ s/(?:next|db)state/(?:next|db)state/msg; + + # don't care about: + $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers + $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args + $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values + $str =~ s/".*?"/".*?"/msg; # quoted strings + + $str =~ s/(\d refs?)/\\d refs?/msg; + $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse + + croak "no reftext found for $want: $in->{name}" + unless $str =~ /\w+/; # fail unless a real test + + # $str = '.*' if 1; # sanity test + # $str .= 'FAIL' if 1; # sanity test + + # allow -eval, banner at beginning of anchored matches + $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str + unless $in->{noanchors} or $in->{rxnoorder}; + + eval "use re 'debug'" if $debug; + my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ; + no re 'debug'; + + return ($qr, $reftxt, $str) if wantarray; + return $qr; +} + + +sub printhelp { + # crufty - may be still useful + my ($in, $rendering, $rex) = @_; + print "<$rendering>\nVS\n<$rex>\n" if $gOpts{vbasic}; + + # save this output to afile, edit out 'ok's and 1..N + # then perl -d afile, and add re 'debug' to suit. + print("\$str = q%$rendering%;\n". + "\$rex = qr%$rex%;\n\n". + #"print \"\$str =~ m%\$rex%ms \";\n". + "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n") + if $in{rextract} or $gOpts{rextract}; +} + + +######################### +# support for test writing + +sub preamble { + my $testct = shift || 1; + return <<EO_HEADER; +#!perl + +BEGIN { + chdir q(t); + \@INC = qw(../lib ../ext/B/t); + require q(./test.pl); +} +use OptreeCheck; +plan tests => $testct; + +EO_HEADER + +} + +sub OptreeCheck::wrap { + my $code = shift; + $code =~ s/(?:(\#.*?)\n)//gsm; + $code =~ s/\s+/ /mgs; + chomp $code; + return unless $code =~ /\S/; + my $comment = $1; + + my $testcode = qq{ + +checkOptree(note => q{$comment}, + bcopts => q{-exec}, + code => q{$code}, + expect => <<EOT_EOT, expect_nt => <<EONT_EONT); +ThreadedRef +EOT_EOT +NonThreadRef +EONT_EONT + +}; + return $testcode; +} + +sub OptreeCheck::gentest { + my ($code,$opts) = @_; + my $rendering = getRendering({code => $code}); + my $testcode = OptreeCheck::wrap($code); + return unless $testcode; + + # run the prog, capture 'reference' concise output + my $preamble = preamble(1); + my $got = runperl( prog => "$preamble $testcode", stderr => 1, + #switches => ["-I../ext/B/t", "-MOptreeCheck"], + ); #verbose => 1); + + # extract the 'reftext' ie the got 'block' + if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) { + my $reftext = $1; + #and plug it into the test-src + if ($threaded) { + $testcode =~ s/ThreadedRef/$reftext/; + } else { + $testcode =~ s/NonThreadRef/$reftext/; + } + my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT}; + my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'}; + $testcode =~ s/$b4/$af/; + + my $got; + if ($internal_retest) { + $got = runperl( prog => "$preamble $testcode", stderr => 1, + #switches => ["-I../ext/B/t", "-MOptreeCheck"], + verbose => 1); + print "got: $got\n"; + } + return $testcode; + } + return ''; +} + + +sub OptreeCheck::processExamples { + my @files = @_; + # gets array of paragraphs, which should be tests. + + foreach my $file (@files) { + open (my $fh, $file) or die "cant open $file: $!\n"; + $/ = ""; + my @chunks = <$fh>; + print preamble (scalar @chunks); + foreach $t (@chunks) { + print "\n\n=for gentest\n\n# chunk: $t=cut\n\n"; + print OptreeCheck::gentest ($t); + } + } +} + +# OK - now for the final insult to your good taste... + +if ($0 =~ /OptreeCheck\.pm/) { + + #use lib 't'; + require './t/test.pl'; + + # invoked as program. Work like former gentest.pl, + # ie read files given as cmdline args, + # convert them to usable test files. + + require Getopt::Std; + Getopt::Std::getopts('') or + die qq{ $0 sample-files* # no options + + expecting filenames as args. Each should have paragraphs, + these are converted to checkOptree() tests, and printed to + stdout. Redirect to file then edit for test. \n}; + + OptreeCheck::processExamples(@ARGV); +} + +1; + +__END__ + +=head1 TEST DEVELOPMENT SUPPORT + +This optree regression testing framework needs tests in order to find +bugs. To that end, OptreeCheck has support for developing new tests, +according to the following model: + + 1. write a set of sample code into a single file, one per + paragraph. f_map and f_sort in ext/B/t/ are examples. + + 2. run OptreeCheck as a program on the file + + ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map + ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort + + gentest reads the sample code, runs each to generate a reference + rendering, folds this rendering into an optreeCheck() statement, + and prints it to stdout. + + 3. run the output file as above, redirect to files, then rerun on + same build (for sanity check), and on thread-opposite build. With + editor in 1 window, and cmd in other, it's fairly easy to cut-paste + the gots into the expects, easier than running step 2 on both + builds then trying to sdiff them together. + +=head1 TODO + +There's a considerable amount of cruft in the whole arg-handling setup. +I'll replace / strip it before 5.10 + +Treat %in as a test object, interwork better with Test::* + +Refactor mkCheckRex() and selfTest() to isolate the selftest, +crosstest, etc selection mechanics. + +improve retry, retrydbg, esp. it's control of eval "use re debug". +This seems to work part of the time, but isn't stable enough. + +=head1 CAVEATS + +This code is purely for testing core. While checkOptree feels flexible +enough to be stable, the whole selftest framework is subject to change +w/o notice. + +=cut diff --git a/gnu/usr.bin/perl/ext/B/t/b.t b/gnu/usr.bin/perl/ext/B/t/b.t index 5e7201e490c..0d2e8bc350d 100644 --- a/gnu/usr.bin/perl/ext/B/t/b.t +++ b/gnu/usr.bin/perl/ext/B/t/b.t @@ -18,7 +18,7 @@ BEGIN { $| = 1; use warnings; use strict; -use Test::More tests => 5; +use Test::More tests => 41; BEGIN { use_ok( 'B' ); } @@ -69,3 +69,77 @@ ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' ); like( $e, qr/Can't call method "TYPE" on an undefined value/, '$. has no more magic' ); } + +my $iv = 1; +my $iv_ref = B::svref_2object(\$iv); +is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object"); +is($iv_ref->REFCNT, 1, "Test B::IV->REFCNT"); +# Flag tests are needed still +#diag $iv_ref->FLAGS(); +my $iv_ret = $iv_ref->object_2svref(); +is(ref $iv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); +is($$iv_ret, $iv, "Test object_2svref()"); +is($iv_ref->int_value, $iv, "Test int_value()"); +is($iv_ref->IV, $iv, "Test IV()"); +is($iv_ref->IVX(), $iv, "Test IVX()"); +is($iv_ref->UVX(), $iv, "Test UVX()"); + +my $pv = "Foo"; +my $pv_ref = B::svref_2object(\$pv); +is(ref $pv_ref, "B::PV", "Test B::PV return from svref_2object"); +is($pv_ref->REFCNT, 1, "Test B::PV->REFCNT"); +# Flag tests are needed still +#diag $pv_ref->FLAGS(); +my $pv_ret = $pv_ref->object_2svref(); +is(ref $pv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); +is($$pv_ret, $pv, "Test object_2svref()"); +is($pv_ref->PV(), $pv, "Test PV()"); +eval { is($pv_ref->RV(), $pv, "Test RV()"); }; +ok($@, "Test RV()"); +is($pv_ref->PVX(), $pv, "Test PVX()"); + +my $nv = 1.1; +my $nv_ref = B::svref_2object(\$nv); +is(ref $nv_ref, "B::NV", "Test B::NV return from svref_2object"); +is($nv_ref->REFCNT, 1, "Test B::NV->REFCNT"); +# Flag tests are needed still +#diag $nv_ref->FLAGS(); +my $nv_ret = $nv_ref->object_2svref(); +is(ref $nv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); +is($$nv_ret, $nv, "Test object_2svref()"); +is($nv_ref->NV, $nv, "Test NV()"); +is($nv_ref->NVX(), $nv, "Test NVX()"); + +my $null = undef; +my $null_ref = B::svref_2object(\$null); +is(ref $null_ref, "B::NULL", "Test B::NULL return from svref_2object"); +is($null_ref->REFCNT, 1, "Test B::NULL->REFCNT"); +# Flag tests are needed still +#diag $null_ref->FLAGS(); +my $null_ret = $nv_ref->object_2svref(); +is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR"); +is($$null_ret, $nv, "Test object_2svref()"); + +my $cv = sub{ 1; }; +my $cv_ref = B::svref_2object(\$cv); +is($cv_ref->REFCNT, 1, "Test B::RV->REFCNT"); +is(ref $cv_ref, "B::RV", "Test B::RV return from svref_2object - code"); +my $cv_ret = $cv_ref->object_2svref(); +is(ref $cv_ret, "REF", "Test object_2svref() return is REF"); +is($$cv_ret, $cv, "Test object_2svref()"); + +my $av = []; +my $av_ref = B::svref_2object(\$av); +is(ref $av_ref, "B::RV", "Test B::RV return from svref_2object - array"); + +my $hv = []; +my $hv_ref = B::svref_2object(\$hv); +is(ref $hv_ref, "B::RV", "Test B::RV return from svref_2object - hash"); + +local *gv = *STDOUT; +my $gv_ref = B::svref_2object(\*gv); +is(ref $gv_ref, "B::GV", "Test B::GV return from svref_2object"); +ok(! $gv_ref->is_empty(), "Test is_empty()"); +is($gv_ref->NAME(), "gv", "Test NAME()"); +is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()"); +like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()"); diff --git a/gnu/usr.bin/perl/ext/B/t/bytecode.t b/gnu/usr.bin/perl/ext/B/t/bytecode.t new file mode 100755 index 00000000000..831dae8e972 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/bytecode.t @@ -0,0 +1,155 @@ +#!./perl +my $keep_plc = 0; # set it to keep the bytecode files +my $keep_plc_fail = 1; # set it to keep the bytecode files on failures + +BEGIN { + if ($^O eq 'VMS') { + print "1..0 # skip - Bytecode/ByteLoader doesn't work on VMS\n"; + exit 0; + } + chdir 't' if -d 't'; + @INC = qw(../lib); + use Config; + if (($Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + if ($Config{ccflags} =~ /-DPERL_COPY_ON_WRITE/) { + print "1..0 # skip - no COW for now\n"; + exit 0; + } + require './test.pl'; # for run_perl() +} +use strict; + +undef $/; +my @tests = split /\n###+\n/, <DATA>; + +print "1..".($#tests+1)."\n"; + +my $cnt = 1; +my $test; + +for (@tests) { + my $got; + my ($script, $expect) = split />>>+\n/; + $expect =~ s/\n$//; + $test = "bytecode$cnt.pl"; + open T, ">$test"; print T $script; close T; + $got = run_perl(switches => [ "-MO=Bytecode,-H,-o${test}c" ], + verbose => 0, # for debugging + stderr => 1, # to capture the "bytecode.pl syntax ok" + progfile => $test); + unless ($?) { + $got = run_perl(progfile => "${test}c"); # run the .plc + unless ($?) { + if ($got =~ /^$expect$/) { + print "ok $cnt\n"; + next; + } else { + $keep_plc = $keep_plc_fail unless $keep_plc; + print <<"EOT"; next; +not ok $cnt +--------- SCRIPT +$script +--------- GOT +$got +--------- EXPECT +$expect +---------------- + +EOT + } + } + } + print <<"EOT"; +--------- SCRIPT +$script +--------- $? +$got +EOT +} continue { + 1 while unlink($test, $keep_plc ? () : "${test}c"); + $cnt++; +} + +__DATA__ + +print 'hi' +>>>> +hi +############################################################ +for (1,2,3) { print if /\d/ } +>>>> +123 +############################################################ +$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_ +>>>> +zzz2y2y2 +############################################################ +$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_ +>>>> +z2y2y2 +############################################################ +split /a/,"bananarama"; print @_ +>>>> +bnnrm +############################################################ +{ package P; sub x { print 'ya' } x } +>>>> +ya +############################################################ +@z = split /:/,"b:r:n:f:g"; print @z +>>>> +brnfg +############################################################ +sub AUTOLOAD { print 1 } &{"a"}() +>>>> +1 +############################################################ +my $l = 3; $x = sub { print $l }; &$x +>>>> +3 +############################################################ +my $i = 1; +my $foo = sub {$i = shift if @_}; +&$foo(3); +############################################################ +$x="Cannot use"; print index $x, "Can" +>>>> +0 +############################################################ +my $i=6; eval "print \$i\n" +>>>> +6 +############################################################ +BEGIN { %h=(1=>2,3=>4) } print $h{3} +>>>> +4 +############################################################ +open our $T,"a" +############################################################ +print <DATA> +__DATA__ +a +b +>>>> +a +b +############################################################ +BEGIN { tie @a, __PACKAGE__; sub TIEARRAY { bless{} } sub FETCH { 1 } } +print $a[1] +>>>> +1 +############################################################ +my $i=3; print 1 .. $i +>>>> +123 +############################################################ +my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h +>>>> +ba +############################################################ +print sort { my $p; $b <=> $a } 1,4,3 +>>>> +431 diff --git a/gnu/usr.bin/perl/ext/B/t/concise.t b/gnu/usr.bin/perl/ext/B/t/concise.t index cb095a60523..16c56121807 100644 --- a/gnu/usr.bin/perl/ext/B/t/concise.t +++ b/gnu/usr.bin/perl/ext/B/t/concise.t @@ -11,7 +11,7 @@ BEGIN { require './test.pl'; } -plan tests => 5; +plan tests => 142; require_ok("B::Concise"); @@ -35,8 +35,287 @@ is($cop_base, 1, "Smallest COP sequence number"); $out = runperl( switches => ["-MO=Concise,-exec"], - prog => q{$a||=$b && print q/foo/}, + prog => q{$a=$b && print q/foo/}, stderr => 1, ); -like($out, qr/print/, "-exec option with ||="); +like($out, qr/print/, "'-exec' option output has print opcode"); + +######## API tests v.60 + +use Config; # used for perlio check +B::Concise->import(qw( set_style set_style_standard add_callback + add_style walk_output reset_sequence )); + +## walk_output argument checking + +# test that walk_output rejects non-HANDLE args +foreach my $foo ("string", [], {}) { + eval { walk_output($foo) }; + isnt ($@, '', "walk_output() rejects arg '$foo'"); + $@=''; # clear the fail for next test +} +# test accessor mode when arg undefd or 0 +foreach my $foo (undef, 0) { + my $handle = walk_output($foo); + is ($handle, \*STDOUT, "walk_output set to STDOUT (default)"); +} + +{ # any object that can print should be ok for walk_output + package Hugo; + sub new { my $foo = bless {} }; + sub print { CORE::print @_ } +} +my $foo = new Hugo; # suggested this API fix +eval { walk_output($foo) }; +is ($@, '', "walk_output() accepts obj that can print"); + +# test that walk_output accepts a HANDLE arg +SKIP: { + skip("no perlio in this build", 4) + unless $Config::Config{useperlio}; + + foreach my $foo (\*STDOUT, \*STDERR) { + eval { walk_output($foo) }; + is ($@, '', "walk_output() accepts STD* " . ref $foo); + } + + # now test a ref to scalar + eval { walk_output(\my $junk) }; + is ($@, '', "walk_output() accepts ref-to-sprintf target"); + + $junk = "non-empty"; + eval { walk_output(\$junk) }; + is ($@, '', "walk_output() accepts ref-to-non-empty-scalar"); +} + +## add_style +my @stylespec; +$@=''; +eval { add_style ('junk_B' => @stylespec) }; +like ($@, 'expecting 3 style-format args', + "add_style rejects insufficient args"); + +@stylespec = (0,0,0); # right length, invalid values +$@=''; +eval { add_style ('junk' => @stylespec) }; +is ($@, '', "add_style accepts: stylename => 3-arg-array"); + +$@=''; +eval { add_style (junk => @stylespec) }; +like ($@, qr/style 'junk' already exists, choose a new name/, + "add_style correctly disallows re-adding same style-name" ); + +# test new arg-checks on set_style +$@=''; +eval { set_style (@stylespec) }; +is ($@, '', "set_style accepts 3 style-format args"); + +@stylespec = (); # bad style + +eval { set_style (@stylespec) }; +like ($@, qr/expecting 3 style-format args/, + "set_style rejects bad style-format args"); + +#### for content with doc'd options + +my $func = sub{ $a = $b+42 }; # canonical example asub + +SKIP: { + # tests output to GLOB, using perlio feature directly + skip "no perlio on this build", 122 + unless $Config::Config{useperlio}; + + set_style_standard('concise'); # MUST CALL before output needed + + @options = qw( + -basic -exec -tree -compact -loose -vt -ascii + -base10 -bigendian -littleendian + ); + foreach $opt (@options) { + walk_output(\my $out); + my $treegen = B::Concise::compile($opt, $func); + $treegen->(); + #print "foo:$out\n"; + isnt($out, '', "got output with option $opt"); + } + + ## test output control via walk_output + + my $treegen = B::Concise::compile('-basic', $func); # reused + + { # test output into a package global string (sprintf-ish) + our $thing; + walk_output(\$thing); + $treegen->(); + ok($thing, "walk_output to our SCALAR, output seen"); + } + + # test walkoutput acceptance of a scalar-bound IO handle + open (my $fh, '>', \my $buf); + walk_output($fh); + $treegen->(); + ok($buf, "walk_output to GLOB, output seen"); + + ## Test B::Concise::compile error checking + + # call compile on non-CODE ref items + if (0) { + # pending STASH splaying + + foreach my $ref ([], {}) { + my $typ = ref $ref; + walk_output(\my $out); + eval { B::Concise::compile('-basic', $ref)->() }; + like ($@, qr/^err: not a coderef: $typ/, + "compile detects $typ-ref where expecting subref"); + # is($out,'', "no output when errd"); # announcement prints + } + } + + # test against a bogus autovivified subref. + # in debugger, it should look like: + # 1 CODE(0x84840cc) + # -> &CODE(0x84840cc) in ??? + sub nosuchfunc; + eval { B::Concise::compile('-basic', \&nosuchfunc)->() }; + like ($@, qr/^err: coderef has no START/, + "compile detects CODE-ref w/o actual code"); + + foreach my $opt (qw( -concise -exec )) { + eval { B::Concise::compile($opt,'non_existent_function')->() }; + like ($@, qr/unknown function \(main::non_existent_function\)/, + "'$opt' reports non-existent-function properly"); + } + + # v.62 tests + + pass ("TEST POST-COMPILE OPTION-HANDLING IN WALKER SUBROUTINE"); + + my $sample; + + my $walker = B::Concise::compile('-basic', $func); + walk_output(\$sample); + $walker->('-exec'); + like($sample, qr/goto/m, "post-compile -exec"); + + walk_output(\$sample); + $walker->('-basic'); + unlike($sample, qr/goto/m, "post-compile -basic"); + + + # bang at it combinatorically + my %combos; + my @modes = qw( -basic -exec ); + my @styles = qw( -concise -debug -linenoise -terse ); + + # prep samples + for $style (@styles) { + for $mode (@modes) { + walk_output(\$sample); + reset_sequence(); + $walker->($style, $mode); + $combos{"$style$mode"} = $sample; + } + } + # crosscheck that samples are all text-different + @list = sort keys %combos; + for $i (0..$#list) { + for $j ($i+1..$#list) { + isnt ($combos{$list[$i]}, $combos{$list[$j]}, + "combos for $list[$i] and $list[$j] are different, as expected"); + } + } + + # add samples with styles in different order + for $mode (@modes) { + for $style (@styles) { + reset_sequence(); + walk_output(\$sample); + $walker->($mode, $style); + $combos{"$mode$style"} = $sample; + } + } + # test commutativity of flags, ie that AB == BA + for $mode (@modes) { + for $style (@styles) { + is ( $combos{"$style$mode"}, + $combos{"$mode$style"}, + "results for $style$mode vs $mode$style are the same" ); + } + } + + my %save = %combos; + my %combos; # outputs for $mode=any($order) and any($style) + + # add more samples with switching modes & sticky styles + for $style (@styles) { + walk_output(\$sample); + reset_sequence(); + $walker->($style); + for $mode (@modes) { + walk_output(\$sample); + reset_sequence(); + $walker->($mode); + $combos{"$style/$mode"} = $sample; + } + } + # crosscheck that samples are all text-different + @nm = sort keys %combos; + for $i (0..$#nm) { + for $j ($i+1..$#nm) { + isnt ($combos{$nm[$i]}, $combos{$nm[$j]}, + "results for $nm[$i] and $nm[$j] are different, as expected"); + } + } + + # add samples with switching styles & sticky modes + for $mode (@modes) { + walk_output(\$sample); + reset_sequence(); + $walker->($mode); + for $style (@styles) { + walk_output(\$sample); + reset_sequence(); + $walker->($style); + $combos{"$mode/$style"} = $sample; + } + } + # test commutativity of flags, ie that AB == BA + for $mode (@modes) { + for $style (@styles) { + is ( $combos{"$style/$mode"}, + $combos{"$mode/$style"}, + "results for $style/$mode vs $mode/$style are the same" ); + } + } + + + #now do double crosschecks: commutativity across stick / nostick + my %combos = (%combos, %save); + + # test commutativity of flags, ie that AB == BA + for $mode (@modes) { + for $style (@styles) { + + is ( $combos{"$style$mode"}, + $combos{"$style/$mode"}, + "$style$mode VS $style/$mode are the same" ); + + is ( $combos{"$mode$style"}, + $combos{"$mode/$style"}, + "$mode$style VS $mode/$style are the same" ); + + is ( $combos{"$style$mode"}, + $combos{"$mode/$style"}, + "$style$mode VS $mode/$style are the same" ); + + is ( $combos{"$mode$style"}, + $combos{"$style/$mode"}, + "$mode$style VS $style/$mode are the same" ); + } + } +} + +__END__ + diff --git a/gnu/usr.bin/perl/ext/B/t/f_map b/gnu/usr.bin/perl/ext/B/t/f_map new file mode 100644 index 00000000000..a0e1a0865c4 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/f_map @@ -0,0 +1,29 @@ +#!perl +# examples shamelessly snatched from perldoc -f map + +# translates a list of numbers to the corresponding characters. +@chars = map(chr, @nums); + +%hash = map { getkey($_) => $_ } @array; + +{ + %hash = (); + foreach $_ (@array) { + $hash{getkey($_)} = $_; + } +} + +#%hash = map { "\L$_", 1 } @array; # perl guesses EXPR. wrong +%hash = map { +"\L$_", 1 } @array; # perl guesses BLOCK. right + +%hash = map { ("\L$_", 1) } @array; # this also works + +%hash = map { lc($_), 1 } @array; # as does this. + +%hash = map +( lc($_), 1 ), @array; # this is EXPR and works! + +%hash = map ( lc($_), 1 ), @array; # evaluates to (1, @array) + +@hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end + + diff --git a/gnu/usr.bin/perl/ext/B/t/f_map.t b/gnu/usr.bin/perl/ext/B/t/f_map.t new file mode 100755 index 00000000000..ff22dde8e3c --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/f_map.t @@ -0,0 +1,530 @@ +#!perl + +BEGIN { + chdir q(t); + @INC = qw(../lib ../ext/B/t); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + if (!$Config::Config{useperlio}) { + print "1..0 # Skip -- need perlio to walk the optree\n"; + exit 0; + } + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } + require q(./test.pl); +} +use OptreeCheck; +plan tests => 9; + + +=for gentest + +# chunk: #!perl +# examples shamelessly snatched from perldoc -f map + +=cut + +=for gentest + +# chunk: # translates a list of numbers to the corresponding characters. +@chars = map(chr, @nums); + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@chars = map(chr, @nums); }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 475 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*nums] s +# 5 <1> rv2av[t7] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t8] lK +# 8 <#> gvsv[*_] s +# 9 <1> chr[t5] sK/1 +# goto 7 +# a <0> pushmark s +# b <#> gv[*chars] s +# c <1> rv2av[t2] lKRM*/1 +# d <2> aassign[t9] KS/COMMON +# e <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 559 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*nums) s +# 5 <1> rv2av[t4] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t5] lK +# 8 <$> gvsv(*_) s +# 9 <1> chr[t3] sK/1 +# goto 7 +# a <0> pushmark s +# b <$> gv(*chars) s +# c <1> rv2av[t1] lKRM*/1 +# d <2> aassign[t6] KS/COMMON +# e <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map { getkey($_) => $_ } @array; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map { getkey($_) => $_ } @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 476 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t8] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t9] lK +# 8 <0> enter l +# 9 <;> nextstate(main 475 (eval 10):1) v +# a <0> pushmark s +# b <0> pushmark s +# c <#> gvsv[*_] s +# d <#> gv[*getkey] s/EARLYCV +# e <1> entersub[t5] lKS/TARG,1 +# f <#> gvsv[*_] s +# g <@> list lK +# h <@> leave lKP +# goto 7 +# i <0> pushmark s +# j <#> gv[*hash] s +# k <1> rv2hv[t2] lKRM*/1 +# l <2> aassign[t10] KS/COMMON +# m <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 560 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> enter l +# 9 <;> nextstate(main 559 (eval 15):1) v +# a <0> pushmark s +# b <0> pushmark s +# c <$> gvsv(*_) s +# d <$> gv(*getkey) s/EARLYCV +# e <1> entersub[t2] lKS/TARG,1 +# f <$> gvsv(*_) s +# g <@> list lK +# h <@> leave lKP +# goto 7 +# i <0> pushmark s +# j <$> gv(*hash) s +# k <1> rv2hv[t1] lKRM*/1 +# l <2> aassign[t5] KS/COMMON +# m <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: { + %hash = (); + foreach $_ (@array) { + $hash{getkey($_)} = $_; + } +} + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{{ %hash = (); foreach $_ (@array) { $hash{getkey($_)} = $_; } } }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 478 (eval 10):1) v +# 2 <{> enterloop(next->u last->u redo->3) +# 3 <;> nextstate(main 475 (eval 10):1) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <#> gv[*hash] s +# 7 <1> rv2hv[t2] lKRM*/1 +# 8 <2> aassign[t3] vKS +# 9 <;> nextstate(main 476 (eval 10):1) v +# a <0> pushmark sM +# b <#> gv[*array] s +# c <1> rv2av[t6] sKRM/1 +# d <#> gv[*_] s +# e <1> rv2gv sKRM/1 +# f <{> enteriter(next->q last->t redo->g) lKS +# r <0> iter s +# s <|> and(other->g) K/1 +# g <;> nextstate(main 475 (eval 10):1) v +# h <#> gvsv[*_] s +# i <#> gv[*hash] s +# j <1> rv2hv sKR/1 +# k <0> pushmark s +# l <#> gvsv[*_] s +# m <#> gv[*getkey] s/EARLYCV +# n <1> entersub[t10] sKS/TARG,1 +# o <2> helem sKRM*/2 +# p <2> sassign vKS/2 +# q <0> unstack s +# goto r +# t <2> leaveloop K/2 +# u <2> leaveloop K/2 +# v <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 562 (eval 15):1) v +# 2 <{> enterloop(next->u last->u redo->3) +# 3 <;> nextstate(main 559 (eval 15):1) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <$> gv(*hash) s +# 7 <1> rv2hv[t1] lKRM*/1 +# 8 <2> aassign[t2] vKS +# 9 <;> nextstate(main 560 (eval 15):1) v +# a <0> pushmark sM +# b <$> gv(*array) s +# c <1> rv2av[t3] sKRM/1 +# d <$> gv(*_) s +# e <1> rv2gv sKRM/1 +# f <{> enteriter(next->q last->t redo->g) lKS +# r <0> iter s +# s <|> and(other->g) K/1 +# g <;> nextstate(main 559 (eval 15):1) v +# h <$> gvsv(*_) s +# i <$> gv(*hash) s +# j <1> rv2hv sKR/1 +# k <0> pushmark s +# l <$> gvsv(*_) s +# m <$> gv(*getkey) s/EARLYCV +# n <1> entersub[t4] sKS/TARG,1 +# o <2> helem sKRM*/2 +# p <2> sassign vKS/2 +# q <0> unstack s +# goto r +# t <2> leaveloop K/2 +# u <2> leaveloop K/2 +# v <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: #%hash = map { "\L$_", 1 } @array; # perl guesses EXPR. wrong +%hash = map { +"\L$_", 1 } @array; # perl guesses BLOCK. right + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map { +"\L$_", 1 } @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 476 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t7] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t9] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <@> stringify[t5] sK/1 +# c <$> const[IV 1] s +# d <@> list lK +# - <@> scope lK +# goto 7 +# e <0> pushmark s +# f <#> gv[*hash] s +# g <1> rv2hv[t2] lKRM*/1 +# h <2> aassign[t10] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 560 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t4] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t5] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <@> stringify[t3] sK/1 +# c <$> const(IV 1) s +# d <@> list lK +# - <@> scope lK +# goto 7 +# e <0> pushmark s +# f <$> gv(*hash) s +# g <1> rv2hv[t1] lKRM*/1 +# h <2> aassign[t6] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map { ("\L$_", 1) } @array; # this also works + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map { ("\L$_", 1) } @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 476 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t7] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t9] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <@> stringify[t5] sK/1 +# c <$> const[IV 1] s +# d <@> list lKP +# - <@> scope lK +# goto 7 +# e <0> pushmark s +# f <#> gv[*hash] s +# g <1> rv2hv[t2] lKRM*/1 +# h <2> aassign[t10] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 560 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t4] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t5] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <@> stringify[t3] sK/1 +# c <$> const(IV 1) s +# d <@> list lKP +# - <@> scope lK +# goto 7 +# e <0> pushmark s +# f <$> gv(*hash) s +# g <1> rv2hv[t1] lKRM*/1 +# h <2> aassign[t6] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map { lc($_), 1 } @array; # as does this. + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map { lc($_), 1 } @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 476 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t6] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t8] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <$> const[IV 1] s +# c <@> list lK +# - <@> scope lK +# goto 7 +# d <0> pushmark s +# e <#> gv[*hash] s +# f <1> rv2hv[t2] lKRM*/1 +# g <2> aassign[t9] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 589 (eval 26):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <$> const(IV 1) s +# c <@> list lK +# - <@> scope lK +# goto 7 +# d <0> pushmark s +# e <$> gv(*hash) s +# f <1> rv2hv[t1] lKRM*/1 +# g <2> aassign[t5] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map +( lc($_), 1 ), @array; # this is EXPR and works! + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map +( lc($_), 1 ), @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 475 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t6] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t7] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <$> const[IV 1] s +# c <@> list lKP +# goto 7 +# d <0> pushmark s +# e <#> gv[*hash] s +# f <1> rv2hv[t2] lKRM*/1 +# g <2> aassign[t8] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 593 (eval 28):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <$> const(IV 1) s +# c <@> list lKP +# goto 7 +# d <0> pushmark s +# e <$> gv(*hash) s +# f <1> rv2hv[t1] lKRM*/1 +# g <2> aassign[t5] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map ( lc($_), 1 ), @array; # evaluates to (1, @array) + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map ( lc($_), 1 ), @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 475 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> const[IV 1] sM +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t5] lK +# 8 <#> gvsv[*_] s +# 9 <1> lc[t4] sK/1 +# goto 7 +# a <0> pushmark s +# b <#> gv[*hash] s +# c <1> rv2hv[t2] lKRM*/1 +# d <2> aassign[t6] KS/COMMON +# e <#> gv[*array] s +# f <1> rv2av[t8] K/1 +# g <@> list K +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 597 (eval 30):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> const(IV 1) sM +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t3] lK +# 8 <$> gvsv(*_) s +# 9 <1> lc[t2] sK/1 +# goto 7 +# a <0> pushmark s +# b <$> gv(*hash) s +# c <1> rv2hv[t1] lKRM*/1 +# d <2> aassign[t4] KS/COMMON +# e <$> gv(*array) s +# f <1> rv2av[t5] K/1 +# g <@> list K +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: @hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@hashes = map +{ lc($_), 1 }, @array }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 475 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t6] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t7] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <$> const[IV 1] s +# c <@> anonhash sKRM/1 +# d <1> srefgen sK/1 +# goto 7 +# e <0> pushmark s +# f <#> gv[*hashes] s +# g <1> rv2av[t2] lKRM*/1 +# h <2> aassign[t8] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 601 (eval 32):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <$> const(IV 1) s +# c <@> anonhash sKRM/1 +# d <1> srefgen sK/1 +# goto 7 +# e <0> pushmark s +# f <$> gv(*hashes) s +# g <1> rv2av[t1] lKRM*/1 +# h <2> aassign[t5] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/f_sort b/gnu/usr.bin/perl/ext/B/t/f_sort new file mode 100644 index 00000000000..759523bb70f --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/f_sort @@ -0,0 +1,91 @@ +#!perl +#examples poached from perldoc -f sort + +# sort lexically +@articles = sort @files; + +# same thing, but with explicit sort routine +@articles = sort {$a cmp $b} @files; + +# now case-insensitively +@articles = sort {uc($a) cmp uc($b)} @files; + +# same thing in reversed order +@articles = sort {$b cmp $a} @files; + +# sort numerically ascending +@articles = sort {$a <=> $b} @files; + +# sort numerically descending +@articles = sort {$b <=> $a} @files; + +# this sorts the %age hash by value instead of key +# using an in-line function +@eldest = sort { $age{$b} <=> $age{$a} } keys %age; + +# sort using explicit subroutine name +sub byage { + $age{$a} <=> $age{$b}; # presuming numeric +} +@sortedclass = sort byage @class; + +sub backwards { $b cmp $a } +@harry = qw(dog cat x Cain Abel); +@george = qw(gone chased yz Punished Axed); +print sort @harry; +# prints AbelCaincatdogx +print sort backwards @harry; +# prints xdogcatCainAbel +print sort @george, 'to', @harry; +# prints AbelAxedCainPunishedcatchaseddoggonetoxyz + +# inefficiently sort by descending numeric compare using +# the first integer after the first = sign, or the +# whole record case-insensitively otherwise +@new = @old[ sort { + $nums[$b] <=> $nums[$a] + || $caps[$a] cmp $caps[$b] + } 0..$#old ]; + +# same thing, but without any temps +@new = map { $_->[0] } +sort { $b->[1] <=> $a->[1] + || $a->[2] cmp $b->[2] + } map { [$_, /=(\d+)/, uc($_)] } @old; + +# using a prototype allows you to use any comparison subroutine +# as a sort subroutine (including other package's subroutines) +package other; +sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here +package main; +@new = sort other::backwards @old; + +# repeat, condensed. $main::a and $b are unaffected +sub other::backwards ($$) { $_[1] cmp $_[0]; } +@new = sort other::backwards @old; + +# guarantee stability, regardless of algorithm +use sort 'stable'; +@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; + +# force use of mergesort (not portable outside Perl 5.8) +use sort '_mergesort'; +@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; + +# you should have a good reason to do this! +@articles = sort {$FooPack::b <=> $FooPack::a} @files; + +# fancy +@result = sort { $a <=> $b } grep { $_ == $_ } @input; + +# void return context sort +sort { $a <=> $b } @input; + +# more void context, propagating ? +sort { $a <=> $b } grep { $_ == $_ } @input; + +# scalar return context sort +$s = sort { $a <=> $b } @input; + +$s = sort { $a <=> $b } grep { $_ == $_ } @input; + diff --git a/gnu/usr.bin/perl/ext/B/t/f_sort.t b/gnu/usr.bin/perl/ext/B/t/f_sort.t new file mode 100755 index 00000000000..26dfbe4c54e --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/f_sort.t @@ -0,0 +1,960 @@ +#!perl + +BEGIN { + chdir q(t); + @INC = qw(../lib ../ext/B/t); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + if (!$Config::Config{useperlio}) { + print "1..0 # Skip -- need perlio to walk the optree\n"; + exit 0; + } + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } + require q(./test.pl); +} +use OptreeCheck; +plan tests => 20; + + +=head1 Test Notes + +# chunk: #!perl +#examples poached from perldoc -f sort + +NOTE: name is no longer a required arg for checkOptree, as label is +synthesized out of others. HOWEVER, if the test-code has newlines in +it, the label must be overridden by an explicit name. + +This is because t/TEST is quite particular about the test output it +processes, and multi-line labels violate its 1-line-per-test +expectations. + +=for gentest + +# chunk: # sort lexically +@articles = sort @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 545 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t4] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 545 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t2] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t3] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # same thing, but with explicit sort routine +@articles = sort {$a cmp $b} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$a cmp $b} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t2] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # now case-insensitively +@articles = sort {uc($a) cmp uc($b)} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {uc($a) cmp uc($b)} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t9] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t10] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t5] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t6] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # same thing in reversed order +@articles = sort {$b cmp $a} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$b cmp $a} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lK/DESC +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lK/DESC +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t2] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # sort numerically ascending +@articles = sort {$a <=> $b} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$a <=> $b} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lK/NUM +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lK/NUM +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t2] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # sort numerically descending +@articles = sort {$b <=> $a} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$b <=> $a} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 587 (eval 26):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lK/DESC,NUM +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lK/DESC,NUM +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t2] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # this sorts the %age hash by value instead of key +# using an in-line function +@eldest = sort { $age{$b} <=> $age{$a} } keys %age; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@eldest = sort { $age{$b} <=> $age{$a} } keys %age; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 592 (eval 28):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*age] s +# 5 <1> rv2hv[t9] lKRM/1 +# 6 <1> keys[t10] lK/1 +# 7 <@> sort lKS* +# 8 <0> pushmark s +# 9 <#> gv[*eldest] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t11] KS +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*age) s +# 5 <1> rv2hv[t3] lKRM/1 +# 6 <1> keys[t4] lK/1 +# 7 <@> sort lKS* +# 8 <0> pushmark s +# 9 <$> gv(*eldest) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t5] KS +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # sort using explicit subroutine name +sub byage { + $age{$a} <=> $age{$b}; # presuming numeric +} +@sortedclass = sort byage @class; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{sub byage { $age{$a} <=> $age{$b}; } @sortedclass = sort byage @class; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 597 (eval 30):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const[PV "byage"] s/BARE +# 5 <#> gv[*class] s +# 6 <1> rv2av[t4] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <#> gv[*sortedclass] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t5] KS +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const(PV "byage") s/BARE +# 5 <$> gv(*class) s +# 6 <1> rv2av[t2] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <$> gv(*sortedclass) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t3] KS +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: sub backwards { $b cmp $a } +@harry = qw(dog cat x Cain Abel); +@george = qw(gone chased yz Punished Axed); +print sort @harry; +# prints AbelCaincatdogx +print sort backwards @harry; +# prints xdogcatCainAbel +print sort @george, 'to', @harry; +# prints AbelAxedCainPunishedcatchaseddoggonetoxyz + +=cut + +checkOptree(name => q{sort USERSUB LIST }, + bcopts => q{-exec}, + code => q{sub backwards { $b cmp $a } + @harry = qw(dog cat x Cain Abel); + @george = qw(gone chased yz Punished Axed); + print sort @harry; print sort backwards @harry; + print sort @george, 'to', @harry; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 602 (eval 32):2) v +# 2 <0> pushmark s +# 3 <$> const[PV "dog"] s +# 4 <$> const[PV "cat"] s +# 5 <$> const[PV "x"] s +# 6 <$> const[PV "Cain"] s +# 7 <$> const[PV "Abel"] s +# 8 <0> pushmark s +# 9 <#> gv[*harry] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t3] vKS +# c <;> nextstate(main 602 (eval 32):3) v +# d <0> pushmark s +# e <$> const[PV "gone"] s +# f <$> const[PV "chased"] s +# g <$> const[PV "yz"] s +# h <$> const[PV "Punished"] s +# i <$> const[PV "Axed"] s +# j <0> pushmark s +# k <#> gv[*george] s +# l <1> rv2av[t5] lKRM*/1 +# m <2> aassign[t6] vKS +# n <;> nextstate(main 602 (eval 32):4) v +# o <0> pushmark s +# p <0> pushmark s +# q <#> gv[*harry] s +# r <1> rv2av[t8] lK/1 +# s <@> sort lK +# t <@> print vK +# u <;> nextstate(main 602 (eval 32):4) v +# v <0> pushmark s +# w <0> pushmark s +# x <$> const[PV "backwards"] s/BARE +# y <#> gv[*harry] s +# z <1> rv2av[t10] lK/1 +# 10 <@> sort lKS +# 11 <@> print vK +# 12 <;> nextstate(main 602 (eval 32):5) v +# 13 <0> pushmark s +# 14 <0> pushmark s +# 15 <#> gv[*george] s +# 16 <1> rv2av[t12] lK/1 +# 17 <$> const[PV "to"] s +# 18 <#> gv[*harry] s +# 19 <1> rv2av[t14] lK/1 +# 1a <@> sort lK +# 1b <@> print sK +# 1c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 602 (eval 32):2) v +# 2 <0> pushmark s +# 3 <$> const(PV "dog") s +# 4 <$> const(PV "cat") s +# 5 <$> const(PV "x") s +# 6 <$> const(PV "Cain") s +# 7 <$> const(PV "Abel") s +# 8 <0> pushmark s +# 9 <$> gv(*harry) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t2] vKS +# c <;> nextstate(main 602 (eval 32):3) v +# d <0> pushmark s +# e <$> const(PV "gone") s +# f <$> const(PV "chased") s +# g <$> const(PV "yz") s +# h <$> const(PV "Punished") s +# i <$> const(PV "Axed") s +# j <0> pushmark s +# k <$> gv(*george) s +# l <1> rv2av[t3] lKRM*/1 +# m <2> aassign[t4] vKS +# n <;> nextstate(main 602 (eval 32):4) v +# o <0> pushmark s +# p <0> pushmark s +# q <$> gv(*harry) s +# r <1> rv2av[t5] lK/1 +# s <@> sort lK +# t <@> print vK +# u <;> nextstate(main 602 (eval 32):4) v +# v <0> pushmark s +# w <0> pushmark s +# x <$> const(PV "backwards") s/BARE +# y <$> gv(*harry) s +# z <1> rv2av[t6] lK/1 +# 10 <@> sort lKS +# 11 <@> print vK +# 12 <;> nextstate(main 602 (eval 32):5) v +# 13 <0> pushmark s +# 14 <0> pushmark s +# 15 <$> gv(*george) s +# 16 <1> rv2av[t7] lK/1 +# 17 <$> const(PV "to") s +# 18 <$> gv(*harry) s +# 19 <1> rv2av[t8] lK/1 +# 1a <@> sort lK +# 1b <@> print sK +# 1c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # inefficiently sort by descending numeric compare using +# the first integer after the first = sign, or the +# whole record case-insensitively otherwise +@new = @old[ sort { + $nums[$b] <=> $nums[$a] + || $caps[$a] cmp $caps[$b] + } 0..$#old ]; + +=cut +=for gentest + +# chunk: # same thing, but without any temps +@new = map { $_->[0] } +sort { $b->[1] <=> $a->[1] + || $a->[2] cmp $b->[2] + } map { [$_, /=(\d+)/, uc($_)] } @old; + +=cut + +checkOptree(name => q{Compound sort/map Expression }, + bcopts => q{-exec}, + code => q{ @new = map { $_->[0] } + sort { $b->[1] <=> $a->[1] || $a->[2] cmp $b->[2] } + map { [$_, /=(\d+)/, uc($_)] } @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 609 (eval 34):3) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <#> gv[*old] s +# 7 <1> rv2av[t19] lKM/1 +# 8 <@> mapstart lK* +# 9 <|> mapwhile(other->a)[t20] lK +# a <0> enter l +# b <;> nextstate(main 608 (eval 34):2) v +# c <0> pushmark s +# d <#> gvsv[*_] s +# e </> match(/"=(\\d+)"/) l/RTIME +# f <#> gvsv[*_] s +# g <1> uc[t17] sK/1 +# h <@> anonlist sKRM/1 +# i <1> srefgen sK/1 +# j <@> leave lKP +# goto 9 +# k <@> sort lKMS* +# l <@> mapstart lK* +# m <|> mapwhile(other->n)[t26] lK +# n <#> gv[*_] s +# o <1> rv2sv sKM/DREFAV,1 +# p <1> rv2av[t4] sKR/1 +# q <$> const[IV 0] s +# r <2> aelem sK/2 +# - <@> scope lK +# goto m +# s <0> pushmark s +# t <#> gv[*new] s +# u <1> rv2av[t2] lKRM*/1 +# v <2> aassign[t27] KS/COMMON +# w <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 609 (eval 34):3) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <$> gv(*old) s +# 7 <1> rv2av[t10] lKM/1 +# 8 <@> mapstart lK* +# 9 <|> mapwhile(other->a)[t11] lK +# a <0> enter l +# b <;> nextstate(main 608 (eval 34):2) v +# c <0> pushmark s +# d <$> gvsv(*_) s +# e </> match(/"=(\\d+)"/) l/RTIME +# f <$> gvsv(*_) s +# g <1> uc[t9] sK/1 +# h <@> anonlist sKRM/1 +# i <1> srefgen sK/1 +# j <@> leave lKP +# goto 9 +# k <@> sort lKMS* +# l <@> mapstart lK* +# m <|> mapwhile(other->n)[t12] lK +# n <$> gv(*_) s +# o <1> rv2sv sKM/DREFAV,1 +# p <1> rv2av[t2] sKR/1 +# q <$> const(IV 0) s +# r <2> aelem sK/2 +# - <@> scope lK +# goto m +# s <0> pushmark s +# t <$> gv(*new) s +# u <1> rv2av[t1] lKRM*/1 +# v <2> aassign[t13] KS/COMMON +# w <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # using a prototype allows you to use any comparison subroutine +# as a sort subroutine (including other package's subroutines) +package other; +sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here +package main; +@new = sort other::backwards @old; + +=cut + +checkOptree(name => q{sort other::sub LIST }, + bcopts => q{-exec}, + code => q{package other; sub backwards ($$) { $_[1] cmp $_[0]; } + package main; @new = sort other::backwards @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 614 (eval 36):2) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const[PV "other::backwards"] s/BARE +# 5 <#> gv[*old] s +# 6 <1> rv2av[t4] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <#> gv[*new] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t5] KS +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 614 (eval 36):2) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const(PV "other::backwards") s/BARE +# 5 <$> gv(*old) s +# 6 <1> rv2av[t2] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <$> gv(*new) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t3] KS +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # repeat, condensed. $main::a and $b are unaffected +sub other::backwards ($$) { $_[1] cmp $_[0]; } +@new = sort other::backwards @old; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{sub other::backwards ($$) { $_[1] cmp $_[0]; } @new = sort other::backwards @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 619 (eval 38):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const[PV "other::backwards"] s/BARE +# 5 <#> gv[*old] s +# 6 <1> rv2av[t4] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <#> gv[*new] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t5] KS +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const(PV "other::backwards") s/BARE +# 5 <$> gv(*old) s +# 6 <1> rv2av[t2] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <$> gv(*new) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t3] KS +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # guarantee stability, regardless of algorithm +use sort 'stable'; +@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 656 (eval 40):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*old] s +# 5 <1> rv2av[t9] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <#> gv[*new] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t14] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 578 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*old) s +# 5 <1> rv2av[t5] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <$> gv(*new) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t6] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # force use of mergesort (not portable outside Perl 5.8) +use sort '_mergesort'; +@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{use sort '_mergesort'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 662 (eval 42):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*old] s +# 5 <1> rv2av[t9] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <#> gv[*new] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t14] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 578 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*old) s +# 5 <1> rv2av[t5] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <$> gv(*new) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t6] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # you should have a good reason to do this! +@articles = sort {$FooPack::b <=> $FooPack::a} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$FooPack::b <=> $FooPack::a} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 667 (eval 44):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t8] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t4] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # fancy +@result = sort { $a <=> $b } grep { $_ == $_ } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@result = sort { $a <=> $b } grep { $_ == $_ } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 673 (eval 46):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <#> gv[*input] s +# 6 <1> rv2av[t9] lKM/1 +# 7 <@> grepstart lK* +# 8 <|> grepwhile(other->9)[t10] lK +# 9 <#> gvsv[*_] s +# a <#> gvsv[*_] s +# b <2> eq sK/2 +# - <@> scope sK +# goto 8 +# c <@> sort lK/NUM +# d <0> pushmark s +# e <#> gv[*result] s +# f <1> rv2av[t2] lKRM*/1 +# g <2> aassign[t5] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 547 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> gv(*input) s +# 6 <1> rv2av[t3] lKM/1 +# 7 <@> grepstart lK* +# 8 <|> grepwhile(other->9)[t4] lK +# 9 <$> gvsv(*_) s +# a <$> gvsv(*_) s +# b <2> eq sK/2 +# - <@> scope sK +# goto 8 +# c <@> sort lK/NUM +# d <0> pushmark s +# e <$> gv(*result) s +# f <1> rv2av[t1] lKRM*/1 +# g <2> aassign[t2] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # void return context sort +sort { $a <=> $b } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{sort { $a <=> $b } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 678 (eval 48):1) v +# 2 <0> pushmark s +# 3 <#> gv[*input] s +# 4 <1> rv2av[t5] lK/1 +# 5 <@> sort K/NUM +# 6 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <$> gv(*input) s +# 4 <1> rv2av[t2] lK/1 +# 5 <@> sort K/NUM +# 6 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # more void context, propagating ? +sort { $a <=> $b } grep { $_ == $_ } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{sort { $a <=> $b } grep { $_ == $_ } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 684 (eval 50):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*input] s +# 5 <1> rv2av[t7] lKM/1 +# 6 <@> grepstart lK* +# 7 <|> grepwhile(other->8)[t8] lK +# 8 <#> gvsv[*_] s +# 9 <#> gvsv[*_] s +# a <2> eq sK/2 +# - <@> scope sK +# goto 7 +# b <@> sort K/NUM +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 547 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*input) s +# 5 <1> rv2av[t2] lKM/1 +# 6 <@> grepstart lK* +# 7 <|> grepwhile(other->8)[t3] lK +# 8 <$> gvsv(*_) s +# 9 <$> gvsv(*_) s +# a <2> eq sK/2 +# - <@> scope sK +# goto 7 +# b <@> sort K/NUM +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # scalar return context sort +$s = sort { $a <=> $b } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{$s = sort { $a <=> $b } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 689 (eval 52):1) v +# 2 <0> pushmark s +# 3 <#> gv[*input] s +# 4 <1> rv2av[t6] lK/1 +# 5 <@> sort sK/NUM +# 6 <#> gvsv[*s] s +# 7 <2> sassign sKS/2 +# 8 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <$> gv(*input) s +# 4 <1> rv2av[t2] lK/1 +# 5 <@> sort sK/NUM +# 6 <$> gvsv(*s) s +# 7 <2> sassign sKS/2 +# 8 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: $s = sort { $a <=> $b } grep { $_ == $_ } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{$s = sort { $a <=> $b } grep { $_ == $_ } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 695 (eval 54):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*input] s +# 5 <1> rv2av[t8] lKM/1 +# 6 <@> grepstart lK* +# 7 <|> grepwhile(other->8)[t9] lK +# 8 <#> gvsv[*_] s +# 9 <#> gvsv[*_] s +# a <2> eq sK/2 +# - <@> scope sK +# goto 7 +# b <@> sort sK/NUM +# c <#> gvsv[*s] s +# d <2> sassign sKS/2 +# e <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 547 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*input) s +# 5 <1> rv2av[t2] lKM/1 +# 6 <@> grepstart lK* +# 7 <|> grepwhile(other->8)[t3] lK +# 8 <$> gvsv(*_) s +# 9 <$> gvsv(*_) s +# a <2> eq sK/2 +# - <@> scope sK +# goto 7 +# b <@> sort sK/NUM +# c <$> gvsv(*s) s +# d <2> sassign sKS/2 +# e <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_check.t b/gnu/usr.bin/perl/ext/B/t/optree_check.t new file mode 100755 index 00000000000..2e2ef9cf3db --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_check.t @@ -0,0 +1,239 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} + +use OptreeCheck; + +=head1 OptreeCheck selftest harness + +This file is primarily to test services of OptreeCheck itself, ie +checkOptree(). %gOpts provides test-state info, it is 'exported' into +main:: + +doing use OptreeCheck runs import(), which processes @ARGV to process +cmdline args in 'standard' way across all clients of OptreeCheck. + +=cut + +use Config; +plan tests => 5 + 18 + 14 * $gOpts{selftest}; # fudged + +SKIP: { + skip "no perlio in this build", 5 + 18 + 14 * $gOpts{selftest} + unless $Config::Config{useperlio}; + + +pass("REGEX TEST HARNESS SELFTEST"); + +checkOptree ( name => "bare minimum opcode search", + bcopts => '-exec', + code => sub {my $a}, + noanchors => 1, # unanchored match + expect => 'leavesub', + expect_nt => 'leavesub'); + +checkOptree ( name => "found print opcode", + bcopts => '-exec', + code => sub {print 1}, + noanchors => 1, # unanchored match + expect => 'print', + expect_nt => 'leavesub'); + +checkOptree ( name => 'test skip itself', + skip => 1, + bcopts => '-exec', + code => sub {print 1}, + expect => 'dont-care, skipping', + expect_nt => 'this insures failure'); + +# This test 'unexpectedly succeeds', but that is "expected". Theres +# no good way to expect a successful todo, and inducing a failure +# causes the harness to print verbose errors, which is NOT helpful. + +checkOptree ( name => 'test todo itself. suppressed, remove skip to test', + todo => "suppress todo test for now", + skip => 1, + bcopts => '-exec', + code => sub {print 1}, + noanchors => 1, # unanchored match + expect => 'print', + expect_nt => 'print'); + +checkOptree ( name => 'impossible match, remove skip to see failure', + todo => "see! it breaks!", + skip => 1, # but skip it 1st + code => sub {print 1}, + expect => 'look out ! Boy Wonder', + expect_nt => 'holy near earth asteroid Batman !'); + +pass ("TEST FATAL ERRS"); + +if (1) { + # test for fatal errors. Im unsettled on fail vs die. + # calling fail isnt good enough by itself. + eval { + + checkOptree ( name => 'empty code or prog', + todo => "your excuse here ;-)", + code => '', + prog => '', + ); + }; + like($@, 'code or prog is required', 'empty code or prog prevented'); + + $@=''; + eval { + checkOptree ( name => 'test against empty expectations', + bcopts => '-exec', + code => sub {print 1}, + expect => '', + expect_nt => ''); + }; + like($@, 'no reftext found for', "empty expectations prevented"); + + $@=''; + eval { + checkOptree ( name => 'prevent whitespace only expectations', + bcopts => '-exec', + code => sub {my $a}, + #skip => 1, + expect_nt => "\n", + expect => "\n"); + }; + like($@, 'no reftext found for', "just whitespace expectations prevented"); +} + +pass ("TEST -e \$srcCode"); + +checkOptree + ( name => '-w errors seen', + prog => 'sort our @a', + errs => 'Useless use of sort in void context at -e line 1.', + ); + +checkOptree + ( name => "self strict, catch err", + prog => 'use strict; bogus', + errs => 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.', + ); + +checkOptree ( name => "sort vK - flag specific search", + prog => 'sort our @a', + noanchors => 1, + expect => '<@> sort vK ', + expect_nt => '<@> sort vK '); + +checkOptree ( name => "'prog' => 'sort our \@a'", + prog => 'sort our @a', + noanchors => 1, + expect => '<@> sort vK', + expect_nt => '<@> sort vK'); + +checkOptree ( name => "'code' => 'sort our \@a'", + code => 'sort our @a', + noanchors => 1, + expect => '<@> sort K', + expect_nt => '<@> sort K'); + +pass ("REFTEXT FIXUP TESTS"); + +checkOptree ( name => 'fixup nextstate (in reftext)', + bcopts => '-exec', + code => sub {my $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v +# 2 <0> padsv[$a:54,55] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 54 optree_concise.t:84) v +# 2 <0> padsv[$a:54,55] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'fixup opcode args', + bcopts => '-exec', + #fail => 1, # uncomment to see real padsv args: [$a:491,492] + code => sub {my $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 56 optree_concise.t:96) v +# 2 <0> padsv[$a:56,57] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 56 optree_concise.t:96) v +# 2 <0> padsv[$a:56,57] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +################################# +pass("CANONICAL B::Concise EXAMPLE"); + +checkOptree ( name => 'canonical example w -basic', + bcopts => '-basic', + code => sub{$a=$b+42}, + crossfail => 1, + debug => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(main 380 optree_selftest.t:139) v ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <2> add[t3] sK/2 ->5 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <#> gvsv[*b] s ->3 +# 3 <$> const[IV 42] s ->4 +# - <1> ex-rv2sv sKRM*/1 ->6 +# 5 <#> gvsv[*a] s ->6 +EOT_EOT +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <2> add[t1] sK/2 ->5 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <$> gvsv(*b) s ->3 +# 3 <$> const(IV 42) s ->4 +# - <1> ex-rv2sv sKRM*/1 ->6 +# 5 <$> gvsv(*a) s ->6 +EONT_EONT + +checkOptree ( name => 'canonical example w -exec', + bcopts => '-exec', + code => sub{$a=$b+42}, + crossfail => 1, + retry => 1, + debug => 1, + xtestfail => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 61 optree_concise.t:139) v +# 2 <#> gvsv[*b] s +# 3 <$> const[IV 42] s +# 4 <2> add[t3] sK/2 +# 5 <#> gvsv[*a] s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 61 optree_concise.t:139) v +# 2 <$> gvsv(*b) s +# 3 <$> const(IV 42) s +# 4 <2> add[t1] sK/2 +# 5 <$> gvsv(*a) s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'tree reftext is messy cut-paste', + skip => 1); + +} # skip + +__END__ + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_concise.t b/gnu/usr.bin/perl/ext/B/t/optree_concise.t new file mode 100755 index 00000000000..97140c1d0d0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_concise.t @@ -0,0 +1,458 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} + +# import checkOptree(), and %gOpts (containing test state) +use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! +use Config; + +plan tests => 24; +SKIP: { +skip "no perlio in this build", 24 unless $Config::Config{useperlio}; + +$SIG{__WARN__} = sub { + my $err = shift; + $err =~ m/Subroutine re::(un)?install redefined/ and return; +}; +################################# +pass("CANONICAL B::Concise EXAMPLE"); + +checkOptree ( name => 'canonical example w -basic', + bcopts => '-basic', + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 7 <1> leavesub[\d+ refs?] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(foo bar) v ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <2> add[t\d+] sK/2 ->5 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <#> gvsv[*b] s ->3 +# 3 <$> const[IV 42] s ->4 +# - <1> ex-rv2sv sKRM*/1 ->6 +# 5 <#> gvsv[*a] s ->6 +EOT_EOT +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <2> add[t1] sK/2 ->5 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <$> gvsv(*b) s ->3 +# 3 <$> const(IV 42) s ->4 +# - <1> ex-rv2sv sKRM*/1 ->6 +# 5 <$> gvsv(*a) s ->6 +EONT_EONT + +checkOptree ( name => 'canonical example w -exec', + bcopts => '-exec', + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 61 optree_concise.t:139) v +# 2 <#> gvsv[*b] s +# 3 <$> const[IV 42] s +# 4 <2> add[t3] sK/2 +# 5 <#> gvsv[*a] s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 61 optree_concise.t:139) v +# 2 <$> gvsv(*b) s +# 3 <$> const(IV 42) s +# 4 <2> add[t1] sK/2 +# 5 <$> gvsv(*a) s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +################################# +pass("B::Concise OPTION TESTS"); + +checkOptree ( name => '-base3 sticky-exec', + bcopts => '-base3', + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> dbstate(main 24 optree_concise.t:132) v +2 <#> gvsv[*b] s +10 <$> const[IV 42] s +11 <2> add[t3] sK/2 +12 <#> gvsv[*a] s +20 <2> sassign sKS/2 +21 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 62 optree_concise.t:161) v +# 2 <$> gvsv(*b) s +# 10 <$> const(IV 42) s +# 11 <2> add[t1] sK/2 +# 12 <$> gvsv(*a) s +# 20 <2> sassign sKS/2 +# 21 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sticky-base3, -basic over sticky-exec', + bcopts => '-basic', + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +21 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->21 +1 <;> nextstate(main 32 optree_concise.t:164) v ->2 +20 <2> sassign sKS/2 ->21 +11 <2> add[t3] sK/2 ->12 +- <1> ex-rv2sv sK/1 ->10 +2 <#> gvsv[*b] s ->10 +10 <$> const[IV 42] s ->11 +- <1> ex-rv2sv sKRM*/1 ->20 +12 <#> gvsv[*a] s ->20 +EOT_EOT +# 21 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->21 +# 1 <;> nextstate(main 63 optree_concise.t:186) v ->2 +# 20 <2> sassign sKS/2 ->21 +# 11 <2> add[t1] sK/2 ->12 +# - <1> ex-rv2sv sK/1 ->10 +# 2 <$> gvsv(*b) s ->10 +# 10 <$> const(IV 42) s ->11 +# - <1> ex-rv2sv sKRM*/1 ->20 +# 12 <$> gvsv(*a) s ->20 +EONT_EONT + +checkOptree ( name => '-base4', + bcopts => [qw/ -basic -base4 /], + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +13 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->13 +1 <;> nextstate(main 26 optree_concise.t:145) v ->2 +12 <2> sassign sKS/2 ->13 +10 <2> add[t3] sK/2 ->11 +- <1> ex-rv2sv sK/1 ->3 +2 <#> gvsv[*b] s ->3 +3 <$> const[IV 42] s ->10 +- <1> ex-rv2sv sKRM*/1 ->12 +11 <#> gvsv[*a] s ->12 +EOT_EOT +# 13 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->13 +# 1 <;> nextstate(main 64 optree_concise.t:193) v ->2 +# 12 <2> sassign sKS/2 ->13 +# 10 <2> add[t1] sK/2 ->11 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <$> gvsv(*b) s ->3 +# 3 <$> const(IV 42) s ->10 +# - <1> ex-rv2sv sKRM*/1 ->12 +# 11 <$> gvsv(*a) s ->12 +EONT_EONT + +checkOptree ( name => "restore -base36 default", + bcopts => [qw/ -basic -base36 /], + code => sub{$a}, + crossfail => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +3 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->3 +1 <;> nextstate(main 27 optree_concise.t:161) v ->2 +- <1> ex-rv2sv sK/1 ->- +2 <#> gvsv[*a] s ->3 +EOT_EOT +# 3 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->3 +# 1 <;> nextstate(main 65 optree_concise.t:210) v ->2 +# - <1> ex-rv2sv sK/1 ->- +# 2 <$> gvsv(*a) s ->3 +EONT_EONT + +checkOptree ( name => "terse basic", + bcopts => [qw/ -basic -terse /], + code => sub{$a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +UNOP (0x82b0918) leavesub [1] + LISTOP (0x82b08d8) lineseq + COP (0x82b0880) nextstate + UNOP (0x82b0860) null [15] + PADOP (0x82b0840) gvsv GV (0x82a818c) *a +EOT_EOT +# UNOP (0x8282310) leavesub [1] +# LISTOP (0x82822f0) lineseq +# COP (0x82822b8) nextstate +# UNOP (0x812fc20) null [15] +# SVOP (0x812fc00) gvsv GV (0x814692c) *a +EONT_EONT + +checkOptree ( name => "sticky-terse exec", + bcopts => [qw/ -exec /], + code => sub{$a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +COP (0x82b0d70) nextstate +PADOP (0x82b0d30) gvsv GV (0x82a818c) *a +UNOP (0x82b0e08) leavesub [1] +EOT_EOT +# COP (0x82828e0) nextstate +# SVOP (0x82828a0) gvsv GV (0x814692c) *a +# UNOP (0x8282938) leavesub [1] +EONT_EONT + +pass("OPTIONS IN CMDLINE MODE"); + +checkOptree ( name => 'cmdline invoke -basic works', + prog => 'sort @a', + #bcopts => '-basic', # default + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 7 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 6 <@> sort vK ->7 +# 3 <0> pushmark s ->4 +# 5 <1> rv2av[t2] lK/1 ->6 +# 4 <#> gv[*a] s ->5 +EOT_EOT +# 7 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 6 <@> sort vK ->7 +# 3 <0> pushmark s ->4 +# 5 <1> rv2av[t1] lK/1 ->6 +# 4 <$> gv(*a) s ->5 +EONT_EONT + +checkOptree ( name => 'cmdline invoke -exec works', + prog => 'sort @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> pushmark s +4 <#> gv[*a] s +5 <1> rv2av[t2] lK/1 +6 <@> sort vK +7 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t1] lK/1 +# 6 <@> sort vK +# 7 <@> leave[1 ref] vKP/REFC +EONT_EONT + +; +$DB::single=1; +checkOptree + ( name => 'cmdline self-strict compile err using prog', + prog => 'use strict; sort @a', + bcopts => [qw/ -basic -concise -exec /], + errs => 'Global symbol "@a" requires explicit package name at .*? line 1.', + ); + +checkOptree + ( name => 'cmdline self-strict compile err using code', + code => 'use strict; sort @a', + bcopts => [qw/ -basic -concise -exec /], + #noanchors => 1, + errs => 'Global symbol "@a" requires explicit package name at .*? line 1.', + ); + +checkOptree + ( name => 'useless use of sort in void context', + prog => 'our @a; sort @a', + bcopts => [qw/ -basic -concise -exec /], + errs => 'Useless use of sort in void context at -e line 1.', + ); + +checkOptree + ( name => 'cmdline -basic -concise -exec works', + prog => 'our @a; sort @a', + bcopts => [qw/ -basic -concise -exec /], + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <#> gv[*a] s +# 4 <1> rv2av[t3] vK/OURINTR,1 +# 5 <;> nextstate(main 2 -e:1) v +# 6 <0> pushmark s +# 7 <#> gv[*a] s +# 8 <1> rv2av[t5] lK/1 +# 9 <@> sort vK +# a <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <$> gv(*a) s +# 4 <1> rv2av[t2] vK/OURINTR,1 +# 5 <;> nextstate(main 2 -e:1) v +# 6 <0> pushmark s +# 7 <$> gv(*a) s +# 8 <1> rv2av[t3] lK/1 +# 9 <@> sort vK +# a <@> leave[1 ref] vKP/REFC +EONT_EONT + + +################################# +pass("B::Concise STYLE/CALLBACK TESTS"); + +use B::Concise qw( walk_output add_style set_style_standard add_callback ); + +# new relative style, added by set_up_relative_test() +@stylespec = + ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) " + . "(x(;~=> #extra)x)\n" # new 'variable' used here + + , " (*( )*) goto #seq\n" + , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)" + #. "(x(;~=> #extra)x)\n" # new 'variable' used here + ); + +sub set_up_relative_test { + # add a new style, and a callback which adds an 'extra' property + + add_style ( "relative" => @stylespec ); + #set_style_standard ( "relative" ); + + add_callback + ( sub { + my ($h, $op, $format, $level, $style) = @_; + + # callback marks up const ops + $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const'; + $h->{extra} = ''; + + if ($lastnext and $$lastnext != $$op) { + $h->{goto} = ($h->{seq} eq '-') + ? 'unresolved' : $h->{seq}; + } + + # 2 style specific behaviors + if ($style eq 'relative') { + $h->{extra} = 'RELATIVE'; + $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub'; + } + elsif ($style eq 'scope') { + # supress printout entirely + $$format="" unless grep { $h->{name} eq $_ } @scopeops; + } + }); +} + +################################# +set_up_relative_test(); +pass("set_up_relative_test, new callback installed"); + +checkOptree ( name => 'callback used, independent of style', + bcopts => [qw/ -concise -exec /], + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 76 optree_concise.t:337) v +2 <#> gvsv[*b] s +3 <$> const[IV 42] CALLBACK s +4 <2> add[t3] sK/2 +5 <#> gvsv[*a] s +6 <2> sassign sKS/2 +7 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 455 optree_concise.t:328) v +# 2 <$> gvsv(*b) s +# 3 <$> const(IV 42) CALLBACK s +# 4 <2> add[t1] sK/2 +# 5 <$> gvsv(*a) s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => "new 'relative' style, -exec mode", + bcopts => [qw/ -basic -relative /], + code => sub{$a=$b+42}, + crossfail => 1, + #retry => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE +- <@> lineseq KP ->7 => RELATIVE +1 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE +6 <2> sassign sKS ->7 => RELATIVE +4 <2> add[t3] sK ->5 => RELATIVE +- <1> ex-rv2sv sK ->3 => RELATIVE +2 <#> gvsv[*b] s ->3 => RELATIVE +3 <$> const[IV 42] CALLBACK s ->4 => RELATIVE +- <1> ex-rv2sv sKRM* ->6 => RELATIVE +5 <#> gvsv[*a] s ->6 => RELATIVE +EOT_EOT +# 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE +# - <@> lineseq KP ->7 => RELATIVE +# 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE +# 6 <2> sassign sKS ->7 => RELATIVE +# 4 <2> add[t1] sK ->5 => RELATIVE +# - <1> ex-rv2sv sK ->3 => RELATIVE +# 2 <$> gvsv(*b) s ->3 => RELATIVE +# 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE +# - <1> ex-rv2sv sKRM* ->6 => RELATIVE +# 5 <$> gvsv(*a) s ->6 => RELATIVE +EONT_EONT + +checkOptree ( name => "both -exec -relative", + bcopts => [qw/ -exec -relative /], + code => sub{$a=$b+42}, + crossfail => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 50 optree_concise.t:326) v +2 <#> gvsv[*b] s +3 <$> const[IV 42] CALLBACK s +4 <2> add[t3] sK +5 <#> gvsv[*a] s +6 <2> sassign sKS +7 <1> leavesub RELATIVE[1 ref] K +EOT_EOT +# 1 <;> nextstate(main 78 optree_concise.t:371) v +# 2 <$> gvsv(*b) s +# 3 <$> const(IV 42) CALLBACK s +# 4 <2> add[t1] sK +# 5 <$> gvsv(*a) s +# 6 <2> sassign sKS +# 7 <1> leavesub RELATIVE[1 ref] K +EONT_EONT + +################################# + +@scopeops = qw( leavesub enter leave nextstate ); +add_style + ( 'scope' # concise copy + , "#hyphseq2 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) " + , " (*( )*) goto #seq\n" + , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)" + ); + +checkOptree ( name => "both -exec -scope", + bcopts => [qw/ -exec -scope /], + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 50 optree_concise.t:337) v +7 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +1 <;> nextstate(main 75 optree_concise.t:396) v +7 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +checkOptree ( name => "both -basic -scope", + bcopts => [qw/ -basic -scope /], + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +7 <1> leavesub[1 ref] K/REFC,1 ->(end) +1 <;> nextstate(main 51 optree_concise.t:347) v ->2 +EOT_EOT +7 <1> leavesub[1 ref] K/REFC,1 ->(end) +1 <;> nextstate(main 76 optree_concise.t:407) v ->2 +EONT_EONT + +} #skip + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_samples.t b/gnu/usr.bin/perl/ext/B/t/optree_samples.t new file mode 100755 index 00000000000..c51eeaeb353 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_samples.t @@ -0,0 +1,664 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } + require './test.pl'; +} +use OptreeCheck; +use Config; +plan tests => 20; +SKIP: { + skip "no perlio in this build", 20 unless $Config::Config{useperlio}; + +pass("GENERAL OPTREE EXAMPLES"); + +pass("IF,THEN,ELSE, ?:"); + +checkOptree ( name => '-basic sub {if shift print then,else}', + bcopts => '-basic', + code => sub { if (shift) { print "then" } + else { print "else" } + }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 9 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->9 +# 1 <;> nextstate(main 426 optree.t:16) v ->2 +# - <1> null K/1 ->- +# 5 <|> cond_expr(other->6) K/1 ->a +# 4 <1> shift sK/1 ->5 +# 3 <1> rv2av[t2] sKRM/1 ->4 +# 2 <#> gv[*_] s ->3 +# - <@> scope K ->- +# - <0> ex-nextstate v ->6 +# 8 <@> print sK ->9 +# 6 <0> pushmark s ->7 +# 7 <$> const[PV "then"] s ->8 +# f <@> leave KP ->9 +# a <0> enter ->b +# b <;> nextstate(main 424 optree.t:17) v ->c +# e <@> print sK ->f +# c <0> pushmark s ->d +# d <$> const[PV "else"] s ->e +EOT_EOT +# 9 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->9 +# 1 <;> nextstate(main 427 optree_samples.t:18) v ->2 +# - <1> null K/1 ->- +# 5 <|> cond_expr(other->6) K/1 ->a +# 4 <1> shift sK/1 ->5 +# 3 <1> rv2av[t1] sKRM/1 ->4 +# 2 <$> gv(*_) s ->3 +# - <@> scope K ->- +# - <0> ex-nextstate v ->6 +# 8 <@> print sK ->9 +# 6 <0> pushmark s ->7 +# 7 <$> const(PV "then") s ->8 +# f <@> leave KP ->9 +# a <0> enter ->b +# b <;> nextstate(main 425 optree_samples.t:19) v ->c +# e <@> print sK ->f +# c <0> pushmark s ->d +# d <$> const(PV "else") s ->e +EONT_EONT + +checkOptree ( name => '-basic (see above, with my $a = shift)', + bcopts => '-basic', + code => sub { my $a = shift; + if ($a) { print "foo" } + else { print "bar" } + }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# d <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->d +# 1 <;> nextstate(main 431 optree.t:68) v ->2 +# 6 <2> sassign vKS/2 ->7 +# 4 <1> shift sK/1 ->5 +# 3 <1> rv2av[t3] sKRM/1 ->4 +# 2 <#> gv[*_] s ->3 +# 5 <0> padsv[$a:431,435] sRM*/LVINTRO ->6 +# 7 <;> nextstate(main 435 optree.t:69) v ->8 +# - <1> null K/1 ->- +# 9 <|> cond_expr(other->a) K/1 ->e +# 8 <0> padsv[$a:431,435] s ->9 +# - <@> scope K ->- +# - <0> ex-nextstate v ->a +# c <@> print sK ->d +# a <0> pushmark s ->b +# b <$> const[PV "foo"] s ->c +# j <@> leave KP ->d +# e <0> enter ->f +# f <;> nextstate(main 433 optree.t:70) v ->g +# i <@> print sK ->j +# g <0> pushmark s ->h +# h <$> const[PV "bar"] s ->i +EOT_EOT +# d <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->d +# 1 <;> nextstate(main 428 optree_samples.t:48) v ->2 +# 6 <2> sassign vKS/2 ->7 +# 4 <1> shift sK/1 ->5 +# 3 <1> rv2av[t2] sKRM/1 ->4 +# 2 <$> gv(*_) s ->3 +# 5 <0> padsv[$a:428,432] sRM*/LVINTRO ->6 +# 7 <;> nextstate(main 432 optree_samples.t:49) v ->8 +# - <1> null K/1 ->- +# 9 <|> cond_expr(other->a) K/1 ->e +# 8 <0> padsv[$a:428,432] s ->9 +# - <@> scope K ->- +# - <0> ex-nextstate v ->a +# c <@> print sK ->d +# a <0> pushmark s ->b +# b <$> const(PV "foo") s ->c +# j <@> leave KP ->d +# e <0> enter ->f +# f <;> nextstate(main 430 optree_samples.t:50) v ->g +# i <@> print sK ->j +# g <0> pushmark s ->h +# h <$> const(PV "bar") s ->i +EONT_EONT + +checkOptree ( name => '-exec sub {if shift print then,else}', + bcopts => '-exec', + code => sub { if (shift) { print "then" } + else { print "else" } + }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 426 optree.t:16) v +# 2 <#> gv[*_] s +# 3 <1> rv2av[t2] sKRM/1 +# 4 <1> shift sK/1 +# 5 <|> cond_expr(other->6) K/1 +# 6 <0> pushmark s +# 7 <$> const[PV "then"] s +# 8 <@> print sK +# goto 9 +# a <0> enter +# b <;> nextstate(main 424 optree.t:17) v +# c <0> pushmark s +# d <$> const[PV "else"] s +# e <@> print sK +# f <@> leave KP +# 9 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 436 optree_samples.t:123) v +# 2 <$> gv(*_) s +# 3 <1> rv2av[t1] sKRM/1 +# 4 <1> shift sK/1 +# 5 <|> cond_expr(other->6) K/1 +# 6 <0> pushmark s +# 7 <$> const(PV "then") s +# 8 <@> print sK +# goto 9 +# a <0> enter +# b <;> nextstate(main 434 optree_samples.t:124) v +# c <0> pushmark s +# d <$> const(PV "else") s +# e <@> print sK +# f <@> leave KP +# 9 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '-exec (see above, with my $a = shift)', + bcopts => '-exec', + code => sub { my $a = shift; + if ($a) { print "foo" } + else { print "bar" } + }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 423 optree.t:16) v +# 2 <#> gv[*_] s +# 3 <1> rv2av[t3] sKRM/1 +# 4 <1> shift sK/1 +# 5 <0> padsv[$a:423,427] sRM*/LVINTRO +# 6 <2> sassign vKS/2 +# 7 <;> nextstate(main 427 optree.t:17) v +# 8 <0> padsv[$a:423,427] s +# 9 <|> cond_expr(other->a) K/1 +# a <0> pushmark s +# b <$> const[PV "foo"] s +# c <@> print sK +# goto d +# e <0> enter +# f <;> nextstate(main 425 optree.t:18) v +# g <0> pushmark s +# h <$> const[PV "bar"] s +# i <@> print sK +# j <@> leave KP +# d <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 437 optree_samples.t:112) v +# 2 <$> gv(*_) s +# 3 <1> rv2av[t2] sKRM/1 +# 4 <1> shift sK/1 +# 5 <0> padsv[$a:437,441] sRM*/LVINTRO +# 6 <2> sassign vKS/2 +# 7 <;> nextstate(main 441 optree_samples.t:113) v +# 8 <0> padsv[$a:437,441] s +# 9 <|> cond_expr(other->a) K/1 +# a <0> pushmark s +# b <$> const(PV "foo") s +# c <@> print sK +# goto d +# e <0> enter +# f <;> nextstate(main 439 optree_samples.t:114) v +# g <0> pushmark s +# h <$> const(PV "bar") s +# i <@> print sK +# j <@> leave KP +# d <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '-exec sub { print (shift) ? "foo" : "bar" }', + code => sub { print (shift) ? "foo" : "bar" }, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 428 optree.t:31) v +# 2 <0> pushmark s +# 3 <#> gv[*_] s +# 4 <1> rv2av[t2] sKRM/1 +# 5 <1> shift sK/1 +# 6 <@> print sK +# 7 <|> cond_expr(other->8) K/1 +# 8 <$> const[PV "foo"] s +# goto 9 +# a <$> const[PV "bar"] s +# 9 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 442 optree_samples.t:144) v +# 2 <0> pushmark s +# 3 <$> gv(*_) s +# 4 <1> rv2av[t1] sKRM/1 +# 5 <1> shift sK/1 +# 6 <@> print sK +# 7 <|> cond_expr(other->8) K/1 +# 8 <$> const(PV "foo") s +# goto 9 +# a <$> const(PV "bar") s +# 9 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +pass ("FOREACH"); + +checkOptree ( name => '-exec sub { foreach (1..10) {print "foo $_"} }', + code => sub { foreach (1..10) {print "foo $_"} }, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 443 optree.t:158) v +# 2 <0> pushmark s +# 3 <$> const[IV 1] s +# 4 <$> const[IV 10] s +# 5 <#> gv[*_] s +# 6 <{> enteriter(next->d last->g redo->7) lKS +# e <0> iter s +# f <|> and(other->7) K/1 +# 7 <;> nextstate(main 442 optree.t:158) v +# 8 <0> pushmark s +# 9 <$> const[PV "foo "] s +# a <#> gvsv[*_] s +# b <2> concat[t4] sK/2 +# c <@> print vK +# d <0> unstack s +# goto e +# g <2> leaveloop K/2 +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 444 optree_samples.t:182) v +# 2 <0> pushmark s +# 3 <$> const(IV 1) s +# 4 <$> const(IV 10) s +# 5 <$> gv(*_) s +# 6 <{> enteriter(next->d last->g redo->7) lKS +# e <0> iter s +# f <|> and(other->7) K/1 +# 7 <;> nextstate(main 443 optree_samples.t:182) v +# 8 <0> pushmark s +# 9 <$> const(PV "foo ") s +# a <$> gvsv(*_) s +# b <2> concat[t3] sK/2 +# c <@> print vK +# d <0> unstack s +# goto e +# g <2> leaveloop K/2 +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }', + code => sub { print "foo $_" foreach (1..10) }, + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# h <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->h +# 1 <;> nextstate(main 445 optree.t:167) v ->2 +# 2 <;> nextstate(main 445 optree.t:167) v ->3 +# g <2> leaveloop K/2 ->h +# 7 <{> enteriter(next->d last->g redo->8) lKS ->e +# - <0> ex-pushmark s ->3 +# - <1> ex-list lK ->6 +# 3 <0> pushmark s ->4 +# 4 <$> const[IV 1] s ->5 +# 5 <$> const[IV 10] s ->6 +# 6 <#> gv[*_] s ->7 +# - <1> null K/1 ->g +# f <|> and(other->8) K/1 ->g +# e <0> iter s ->f +# - <@> lineseq sK ->- +# c <@> print vK ->d +# 8 <0> pushmark s ->9 +# - <1> ex-stringify sK/1 ->c +# - <0> ex-pushmark s ->9 +# b <2> concat[t2] sK/2 ->c +# 9 <$> const[PV "foo "] s ->a +# - <1> ex-rv2sv sK/1 ->b +# a <#> gvsv[*_] s ->b +# d <0> unstack s ->e +EOT_EOT +# h <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->h +# 1 <;> nextstate(main 446 optree_samples.t:192) v ->2 +# 2 <;> nextstate(main 446 optree_samples.t:192) v ->3 +# g <2> leaveloop K/2 ->h +# 7 <{> enteriter(next->d last->g redo->8) lKS ->e +# - <0> ex-pushmark s ->3 +# - <1> ex-list lK ->6 +# 3 <0> pushmark s ->4 +# 4 <$> const(IV 1) s ->5 +# 5 <$> const(IV 10) s ->6 +# 6 <$> gv(*_) s ->7 +# - <1> null K/1 ->g +# f <|> and(other->8) K/1 ->g +# e <0> iter s ->f +# - <@> lineseq sK ->- +# c <@> print vK ->d +# 8 <0> pushmark s ->9 +# - <1> ex-stringify sK/1 ->c +# - <0> ex-pushmark s ->9 +# b <2> concat[t1] sK/2 ->c +# 9 <$> const(PV "foo ") s ->a +# - <1> ex-rv2sv sK/1 ->b +# a <$> gvsv(*_) s ->b +# d <0> unstack s ->e +EONT_EONT + +checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', + prog => 'foreach (1..10) {print qq{foo $_}}', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <0> enter +# 2 <;> nextstate(main 2 -e:1) v +# 3 <0> pushmark s +# 4 <$> const[IV 1] s +# 5 <$> const[IV 10] s +# 6 <#> gv[*_] s +# 7 <{> enteriter(next->e last->h redo->8) lKS +# f <0> iter s +# g <|> and(other->8) vK/1 +# 8 <;> nextstate(main 1 -e:1) v +# 9 <0> pushmark s +# a <$> const[PV "foo "] s +# b <#> gvsv[*_] s +# c <2> concat[t4] sK/2 +# d <@> print vK +# e <0> unstack v +# goto f +# h <2> leaveloop vK/2 +# i <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 2 -e:1) v +# 3 <0> pushmark s +# 4 <$> const(IV 1) s +# 5 <$> const(IV 10) s +# 6 <$> gv(*_) s +# 7 <{> enteriter(next->e last->h redo->8) lKS +# f <0> iter s +# g <|> and(other->8) vK/1 +# 8 <;> nextstate(main 1 -e:1) v +# 9 <0> pushmark s +# a <$> const(PV "foo ") s +# b <$> gvsv(*_) s +# c <2> concat[t3] sK/2 +# d <@> print vK +# e <0> unstack v +# goto f +# h <2> leaveloop vK/2 +# i <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => '-exec sub { print "foo $_" foreach (1..10) }', + code => sub { print "foo $_" foreach (1..10) }, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 445 optree.t:167) v +# 2 <;> nextstate(main 445 optree.t:167) v +# 3 <0> pushmark s +# 4 <$> const[IV 1] s +# 5 <$> const[IV 10] s +# 6 <#> gv[*_] s +# 7 <{> enteriter(next->d last->g redo->8) lKS +# e <0> iter s +# f <|> and(other->8) K/1 +# 8 <0> pushmark s +# 9 <$> const[PV "foo "] s +# a <#> gvsv[*_] s +# b <2> concat[t2] sK/2 +# c <@> print vK +# d <0> unstack s +# goto e +# g <2> leaveloop K/2 +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 447 optree_samples.t:252) v +# 2 <;> nextstate(main 447 optree_samples.t:252) v +# 3 <0> pushmark s +# 4 <$> const(IV 1) s +# 5 <$> const(IV 10) s +# 6 <$> gv(*_) s +# 7 <{> enteriter(next->d last->g redo->8) lKS +# e <0> iter s +# f <|> and(other->8) K/1 +# 8 <0> pushmark s +# 9 <$> const(PV "foo ") s +# a <$> gvsv(*_) s +# b <2> concat[t1] sK/2 +# c <@> print vK +# d <0> unstack s +# goto e +# g <2> leaveloop K/2 +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +pass("GREP: SAMPLES FROM PERLDOC -F GREP"); + +checkOptree ( name => '@foo = grep(!/^\#/, @bar)', + code => '@foo = grep(!/^\#/, @bar)', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 496 (eval 20):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*bar] s +# 5 <1> rv2av[t4] lKM/1 +# 6 <@> grepstart lK +# 7 <|> grepwhile(other->8)[t5] lK +# 8 </> match(/"^#"/) s/RTIME +# 9 <1> not sK/1 +# goto 7 +# a <0> pushmark s +# b <#> gv[*foo] s +# c <1> rv2av[t2] lKRM*/1 +# d <2> aassign[t6] KS/COMMON +# e <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 496 (eval 20):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*bar) s +# 5 <1> rv2av[t2] lKM/1 +# 6 <@> grepstart lK +# 7 <|> grepwhile(other->8)[t3] lK +# 8 </> match(/"^\\#"/) s/RTIME +# 9 <1> not sK/1 +# goto 7 +# a <0> pushmark s +# b <$> gv(*foo) s +# c <1> rv2av[t1] lKRM*/1 +# d <2> aassign[t4] KS/COMMON +# e <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +pass("MAP: SAMPLES FROM PERLDOC -F MAP"); + +checkOptree ( name => '%h = map { getkey($_) => $_ } @a', + code => '%h = map { getkey($_) => $_ } @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 501 (eval 22):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*a] s +# 5 <1> rv2av[t8] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t9] lK +# 8 <0> enter l +# 9 <;> nextstate(main 500 (eval 22):1) v +# a <0> pushmark s +# b <0> pushmark s +# c <#> gvsv[*_] s +# d <#> gv[*getkey] s/EARLYCV +# e <1> entersub[t5] lKS/TARG,1 +# f <#> gvsv[*_] s +# g <@> list lK +# h <@> leave lKP +# goto 7 +# i <0> pushmark s +# j <#> gv[*h] s +# k <1> rv2hv[t2] lKRM*/1 +# l <2> aassign[t10] KS/COMMON +# m <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 501 (eval 22):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> enter l +# 9 <;> nextstate(main 500 (eval 22):1) v +# a <0> pushmark s +# b <0> pushmark s +# c <$> gvsv(*_) s +# d <$> gv(*getkey) s/EARLYCV +# e <1> entersub[t2] lKS/TARG,1 +# f <$> gvsv(*_) s +# g <@> list lK +# h <@> leave lKP +# goto 7 +# i <0> pushmark s +# j <$> gv(*h) s +# k <1> rv2hv[t1] lKRM*/1 +# l <2> aassign[t5] KS/COMMON +# m <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', + code => '%h=(); for $_(@a){$h{getkey($_)} = $_}', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 505 (eval 24):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*h] s +# 5 <1> rv2hv[t2] lKRM*/1 +# 6 <2> aassign[t3] vKS +# 7 <;> nextstate(main 506 (eval 24):1) v +# 8 <0> pushmark sM +# 9 <#> gv[*a] s +# a <1> rv2av[t6] sKRM/1 +# b <#> gv[*_] s +# c <1> rv2gv sKRM/1 +# d <{> enteriter(next->o last->r redo->e) lKS +# p <0> iter s +# q <|> and(other->e) K/1 +# e <;> nextstate(main 505 (eval 24):1) v +# f <#> gvsv[*_] s +# g <#> gv[*h] s +# h <1> rv2hv sKR/1 +# i <0> pushmark s +# j <#> gvsv[*_] s +# k <#> gv[*getkey] s/EARLYCV +# l <1> entersub[t10] sKS/TARG,1 +# m <2> helem sKRM*/2 +# n <2> sassign vKS/2 +# o <0> unstack s +# goto p +# r <2> leaveloop K/2 +# s <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 505 (eval 24):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*h) s +# 5 <1> rv2hv[t1] lKRM*/1 +# 6 <2> aassign[t2] vKS +# 7 <;> nextstate(main 506 (eval 24):1) v +# 8 <0> pushmark sM +# 9 <$> gv(*a) s +# a <1> rv2av[t3] sKRM/1 +# b <$> gv(*_) s +# c <1> rv2gv sKRM/1 +# d <{> enteriter(next->o last->r redo->e) lKS +# p <0> iter s +# q <|> and(other->e) K/1 +# e <;> nextstate(main 505 (eval 24):1) v +# f <$> gvsv(*_) s +# g <$> gv(*h) s +# h <1> rv2hv sKR/1 +# i <0> pushmark s +# j <$> gvsv(*_) s +# k <$> gv(*getkey) s/EARLYCV +# l <1> entersub[t4] sKS/TARG,1 +# m <2> helem sKRM*/2 +# n <2> sassign vKS/2 +# o <0> unstack s +# goto p +# r <2> leaveloop K/2 +# s <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'map $_+42, 10..20', + code => 'map $_+42, 10..20', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 497 (eval 20):1) v +# 2 <0> pushmark s +# 3 <$> const[AV ] s +# 4 <1> rv2av lKPM/1 +# 5 <@> mapstart K +# 6 <|> mapwhile(other->7)[t7] K +# 7 <#> gvsv[*_] s +# 8 <$> const[IV 42] s +# 9 <2> add[t2] sK/2 +# goto 6 +# a <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 511 (eval 26):1) v +# 2 <0> pushmark s +# 3 <$> const(AV ) s +# 4 <1> rv2av lKPM/1 +# 5 <@> mapstart K +# 6 <|> mapwhile(other->7)[t4] K +# 7 <$> gvsv(*_) s +# 8 <$> const(IV 42) s +# 9 <2> add[t1] sK/2 +# goto 6 +# a <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +pass("CONSTANTS"); + +checkOptree ( name => '-e use constant j => qq{junk}; print j', + prog => 'use constant j => qq{junk}; print j', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <0> enter +# 2 <;> nextstate(main 71 -e:1) v +# 3 <0> pushmark s +# 4 <$> const[PV "junk"] s +# 5 <@> print vK +# 6 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 71 -e:1) v +# 3 <0> pushmark s +# 4 <$> const(PV "junk") s +# 5 <@> print vK +# 6 <@> leave[1 ref] vKP/REFC +EONT_EONT + +} # skip + +__END__ + +####################################################################### + +checkOptree ( name => '-exec sub a { print (shift) ? "foo" : "bar" }', + code => sub { print (shift) ? "foo" : "bar" }, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); + insert threaded reference here +EOT_EOT + insert non-threaded reference here +EONT_EONT + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_sort.t b/gnu/usr.bin/perl/ext/B/t/optree_sort.t new file mode 100755 index 00000000000..b7615d941fc --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_sort.t @@ -0,0 +1,297 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} +use OptreeCheck; +use Config; +plan tests => 11; + +SKIP: { +skip "no perlio in this build", 11 unless $Config::Config{useperlio}; + +pass("SORT OPTIMIZATION"); + +checkOptree ( name => 'sub {sort @a}', + code => sub {sort @a}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 424 optree_sort.t:14) v +# 2 <0> pushmark s +# 3 <#> gv[*a] s +# 4 <1> rv2av[t2] lK/1 +# 5 <@> sort K +# 6 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 424 optree_sort.t:14) v +# 2 <0> pushmark s +# 3 <$> gv(*a) s +# 4 <1> rv2av[t1] lK/1 +# 5 <@> sort K +# 6 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sort @a', + prog => 'sort @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> pushmark s +4 <#> gv[*a] s +5 <1> rv2av[t2] lK/1 +6 <@> sort vK +7 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t1] lK/1 +# 6 <@> sort vK +# 7 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'sub {@a = sort @a}', + code => sub {@a = sort @a}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -438 optree.t:244) v +2 <0> pushmark s +3 <0> pushmark s +4 <#> gv[*a] s +5 <1> rv2av[t4] lK/1 +6 <@> sort lK +7 <0> pushmark s +8 <#> gv[*a] s +9 <1> rv2av[t2] lKRM*/1 +a <2> aassign[t\d+] KS/COMMON +b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 65 optree.t:311) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t2] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <$> gv(*a) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t3] KS/COMMON +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '@a = sort @a', + prog => '@a = sort @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> pushmark s +4 <0> pushmark s +5 <#> gv[*a] s +6 <1> rv2av[t4] lKRM*/1 +7 <@> sort lK/INPLACE +8 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> gv(*a) s +# 6 <1> rv2av[t2] lKRM*/1 +# 7 <@> sort lK/INPLACE +# 8 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'sub {@a = sort @a; reverse @a}', + code => sub {@a = sort @a; reverse @a}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -438 optree.t:286) v +2 <0> pushmark s +3 <0> pushmark s +4 <#> gv[*a] s +5 <1> rv2av[t4] lKRM*/1 +6 <@> sort lK/INPLACE +7 <;> nextstate(main -438 optree.t:288) v +8 <0> pushmark s +9 <#> gv[*a] s +a <1> rv2av[t7] lK/1 +b <@> reverse[t8] K/1 +c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 66 optree.t:345) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t2] lKRM*/1 +# 6 <@> sort lK/INPLACE +# 7 <;> nextstate(main 66 optree.t:346) v +# 8 <0> pushmark s +# 9 <$> gv(*a) s +# a <1> rv2av[t4] lK/1 +# b <@> reverse[t5] K/1 +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '@a = sort @a; reverse @a', + prog => '@a = sort @a; reverse @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> pushmark s +4 <0> pushmark s +5 <#> gv[*a] s +6 <1> rv2av[t4] lKRM*/1 +7 <@> sort lK/INPLACE +8 <;> nextstate(main 1 -e:1) v +9 <0> pushmark s +a <#> gv[*a] s +b <1> rv2av[t7] lK/1 +c <@> reverse[t8] vK/1 +d <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> gv(*a) s +# 6 <1> rv2av[t2] lKRM*/1 +# 7 <@> sort lK/INPLACE +# 8 <;> nextstate(main 1 -e:1) v +# 9 <0> pushmark s +# a <$> gv(*a) s +# b <1> rv2av[t4] lK/1 +# c <@> reverse[t5] vK/1 +# d <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'sub {my @a; @a = sort @a}', + code => sub {my @a; @a = sort @a}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -437 optree.t:254) v +2 <0> padav[@a:-437,-436] vM/LVINTRO +3 <;> nextstate(main -436 optree.t:256) v +4 <0> pushmark s +5 <0> pushmark s +6 <0> padav[@a:-437,-436] l +7 <@> sort lK +8 <0> pushmark s +9 <0> padav[@a:-437,-436] lRM* +a <2> aassign[t\d+] KS/COMMON +b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 427 optree_sort.t:172) v +# 2 <0> padav[@a:427,428] vM/LVINTRO +# 3 <;> nextstate(main 428 optree_sort.t:173) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <0> padav[@a:427,428] l +# 7 <@> sort lK +# 8 <0> pushmark s +# 9 <0> padav[@a:427,428] lRM* +# a <2> aassign[t2] KS/COMMON +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'my @a; @a = sort @a', + prog => 'my @a; @a = sort @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> padav[@a:1,2] vM/LVINTRO +4 <;> nextstate(main 2 -e:1) v +5 <0> pushmark s +6 <0> pushmark s +7 <0> padav[@a:1,2] lRM* +8 <@> sort lK/INPLACE +9 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> padav[@a:1,2] vM/LVINTRO +# 4 <;> nextstate(main 2 -e:1) v +# 5 <0> pushmark s +# 6 <0> pushmark s +# 7 <0> padav[@a:1,2] lRM* +# 8 <@> sort lK/INPLACE +# 9 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}', + code => sub {my @a; @a = sort @a; push @a, 1}, + bcopts => '-exec', + debug => 0, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -437 optree.t:325) v +2 <0> padav[@a:-437,-436] vM/LVINTRO +3 <;> nextstate(main -436 optree.t:325) v +4 <0> pushmark s +5 <0> pushmark s +6 <0> padav[@a:-437,-436] lRM* +7 <@> sort lK/INPLACE +8 <;> nextstate(main -436 optree.t:325) v +9 <0> pushmark s +a <0> padav[@a:-437,-436] lRM +b <$> const[IV 1] s +c <@> push[t3] sK/2 +d <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 429 optree_sort.t:219) v +# 2 <0> padav[@a:429,430] vM/LVINTRO +# 3 <;> nextstate(main 430 optree_sort.t:220) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <0> padav[@a:429,430] lRM* +# 7 <@> sort lK/INPLACE +# 8 <;> nextstate(main 430 optree_sort.t:220) v +# 9 <0> pushmark s +# a <0> padav[@a:429,430] lRM +# b <$> const(IV 1) s +# c <@> push[t3] sK/2 +# d <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {my @a; @a = sort @a; 1}', + code => sub {my @a; @a = sort @a; 1}, + bcopts => '-exec', + debug => 0, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -437 optree.t:325) v +2 <0> padav[@a:-437,-436] vM/LVINTRO +3 <;> nextstate(main -436 optree.t:325) v +4 <0> pushmark s +5 <0> pushmark s +6 <0> padav[@a:-437,-436] lRM* +7 <@> sort lK/INPLACE +8 <;> nextstate(main -436 optree.t:346) v +9 <$> const[IV 1] s +a <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 431 optree_sort.t:250) v +# 2 <0> padav[@a:431,432] vM/LVINTRO +# 3 <;> nextstate(main 432 optree_sort.t:251) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <0> padav[@a:431,432] lRM* +# 7 <@> sort lK/INPLACE +# 8 <;> nextstate(main 432 optree_sort.t:251) v +# 9 <$> const(IV 1) s +# a <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +} #skip + +__END__ + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_specials.t b/gnu/usr.bin/perl/ext/B/t/optree_specials.t new file mode 100755 index 00000000000..75d2a8ab1a0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_specials.t @@ -0,0 +1,272 @@ +#!./perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} + +# import checkOptree(), and %gOpts (containing test state) +use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! +use Config; + +plan tests => 6; + +require_ok("B::Concise"); + +my $out = runperl( + switches => ["-MO=Concise,BEGIN,CHECK,INIT,END,-exec"], + prog => q{$a=$b && print q/foo/}, + stderr => 1 ); + +#print "out:$out\n"; + +my $src = q[our ($beg, $chk, $init, $end) = qq{'foo'}; BEGIN { $beg++ } CHECK { $chk++ } INIT { $init++ } END { $end++ }]; + + + +checkOptree ( name => 'BEGIN', + bcopts => 'BEGIN', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# BEGIN 1: +# b <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->b +# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->2 +# 3 <1> require sK/1 ->4 +# 2 <$> const[PV "strict.pm"] s/BARE ->3 +# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->5 +# - <@> lineseq K ->- +# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 ->6 +# a <1> entersub[t1] KS*/TARG,2 ->b +# 6 <0> pushmark s ->7 +# 7 <$> const[PV "strict"] sM ->8 +# 8 <$> const[PV "refs"] sM ->9 +# 9 <$> method_named[PVIV 1520340202] ->a +# BEGIN 2: +# m <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->m +# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->d +# e <1> require sK/1 ->f +# d <$> const[PV "warnings.pm"] s/BARE ->e +# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->g +# - <@> lineseq K ->- +# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 ->h +# l <1> entersub[t1] KS*/TARG,2 ->m +# h <0> pushmark s ->i +# i <$> const[PV "warnings"] sM ->j +# j <$> const[PV "qw"] sM ->k +# k <$> method_named[PVIV 1520340202] ->l +# BEGIN 3: +# q <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->q +# n <;> nextstate(main 2 -e:3) v ->o +# p <1> postinc[t3] sK/1 ->q +# - <1> ex-rv2sv sKRM/1 ->p +# o <#> gvsv[*beg] s ->p +EOT_EOT +# BEGIN 1: +# b <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->b +# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->2 +# 3 <1> require sK/1 ->4 +# 2 <$> const(PV "strict.pm") s/BARE ->3 +# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->5 +# - <@> lineseq K ->- +# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 ->6 +# a <1> entersub[t1] KS*/TARG,2 ->b +# 6 <0> pushmark s ->7 +# 7 <$> const(PV "strict") sM ->8 +# 8 <$> const(PV "refs") sM ->9 +# 9 <$> method_named(PVIV 1520340202) ->a +# BEGIN 2: +# m <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->m +# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->d +# e <1> require sK/1 ->f +# d <$> const(PV "warnings.pm") s/BARE ->e +# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->g +# - <@> lineseq K ->- +# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 ->h +# l <1> entersub[t1] KS*/TARG,2 ->m +# h <0> pushmark s ->i +# i <$> const(PV "warnings") sM ->j +# j <$> const(PV "qw") sM ->k +# k <$> method_named(PVIV 1520340202) ->l +# BEGIN 3: +# q <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->q +# n <;> nextstate(main 2 -e:3) v ->o +# p <1> postinc[t2] sK/1 ->q +# - <1> ex-rv2sv sKRM/1 ->p +# o <$> gvsv(*beg) s ->p +EONT_EONT + + +checkOptree ( name => 'END', + bcopts => 'END', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# END 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 5 -e:6) v ->2 +# 3 <1> postinc[t3] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <#> gvsv[*end] s ->3 +EOT_EOT +# END 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 5 -e:6) v ->2 +# 3 <1> postinc[t2] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <$> gvsv(*end) s ->3 +EONT_EONT + + +checkOptree ( name => 'CHECK', + bcopts => 'CHECK', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# CHECK 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 3 -e:4) v ->2 +# 3 <1> postinc[t3] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <#> gvsv[*chk] s ->3 +EOT_EOT +# CHECK 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 3 -e:4) v ->2 +# 3 <1> postinc[t2] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <$> gvsv(*chk) s ->3 +EONT_EONT + + +checkOptree ( name => 'INIT', + bcopts => 'INIT', + #todo => 'get working', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# INIT 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 4 -e:5) v ->2 +# 3 <1> postinc[t3] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <#> gvsv[*init] s ->3 +EOT_EOT +# INIT 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 4 -e:5) v ->2 +# 3 <1> postinc[t2] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <$> gvsv(*init) s ->3 +EONT_EONT + + +checkOptree ( name => 'all of BEGIN END INIT CHECK -exec', + bcopts => [qw/ BEGIN END INIT CHECK -exec /], + #todo => 'get working', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# BEGIN 1: +# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 +# 2 <$> const[PV "strict.pm"] s/BARE +# 3 <1> require sK/1 +# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 +# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 +# 6 <0> pushmark s +# 7 <$> const[PV "strict"] sM +# 8 <$> const[PV "refs"] sM +# 9 <$> method_named[PVIV 1520340202] +# a <1> entersub[t1] KS*/TARG,2 +# b <1> leavesub[1 ref] K/REFC,1 +# BEGIN 2: +# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 +# d <$> const[PV "warnings.pm"] s/BARE +# e <1> require sK/1 +# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 +# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 +# h <0> pushmark s +# i <$> const[PV "warnings"] sM +# j <$> const[PV "qw"] sM +# k <$> method_named[PVIV 1520340202] +# l <1> entersub[t1] KS*/TARG,2 +# m <1> leavesub[1 ref] K/REFC,1 +# BEGIN 3: +# n <;> nextstate(main 2 -e:3) v +# o <#> gvsv[*beg] s +# p <1> postinc[t3] sK/1 +# q <1> leavesub[1 ref] K/REFC,1 +# END 1: +# r <;> nextstate(main 5 -e:6) v +# s <#> gvsv[*end] s +# t <1> postinc[t3] sK/1 +# u <1> leavesub[1 ref] K/REFC,1 +# INIT 1: +# v <;> nextstate(main 4 -e:5) v +# w <#> gvsv[*init] s +# x <1> postinc[t3] sK/1 +# y <1> leavesub[1 ref] K/REFC,1 +# CHECK 1: +# z <;> nextstate(main 3 -e:4) v +# 10 <#> gvsv[*chk] s +# 11 <1> postinc[t3] sK/1 +# 12 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# BEGIN 1: +# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 +# 2 <$> const(PV "strict.pm") s/BARE +# 3 <1> require sK/1 +# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 +# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 +# 6 <0> pushmark s +# 7 <$> const(PV "strict") sM +# 8 <$> const(PV "refs") sM +# 9 <$> method_named(PVIV 1520340202) +# a <1> entersub[t1] KS*/TARG,2 +# b <1> leavesub[1 ref] K/REFC,1 +# BEGIN 2: +# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 +# d <$> const(PV "warnings.pm") s/BARE +# e <1> require sK/1 +# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 +# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 +# h <0> pushmark s +# i <$> const(PV "warnings") sM +# j <$> const(PV "qw") sM +# k <$> method_named(PVIV 1520340202) +# l <1> entersub[t1] KS*/TARG,2 +# m <1> leavesub[1 ref] K/REFC,1 +# BEGIN 3: +# n <;> nextstate(main 2 -e:3) v +# o <$> gvsv(*beg) s +# p <1> postinc[t2] sK/1 +# q <1> leavesub[1 ref] K/REFC,1 +# END 1: +# r <;> nextstate(main 5 -e:6) v +# s <$> gvsv(*end) s +# t <1> postinc[t2] sK/1 +# u <1> leavesub[1 ref] K/REFC,1 +# INIT 1: +# v <;> nextstate(main 4 -e:5) v +# w <$> gvsv(*init) s +# x <1> postinc[t2] sK/1 +# y <1> leavesub[1 ref] K/REFC,1 +# CHECK 1: +# z <;> nextstate(main 3 -e:4) v +# 10 <$> gvsv(*chk) s +# 11 <1> postinc[t2] sK/1 +# 12 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_varinit.t b/gnu/usr.bin/perl/ext/B/t/optree_varinit.t new file mode 100755 index 00000000000..d58135bb231 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_varinit.t @@ -0,0 +1,381 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} +use OptreeCheck; +use Config; +plan tests => 22; +SKIP: { +skip "no perlio in this build", 22 unless $Config::Config{useperlio}; + +pass("OPTIMIZER TESTS - VAR INITIALIZATION"); + +checkOptree ( name => 'sub {my $a}', + bcopts => '-exec', + code => sub {my $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 45 optree.t:23) v +# 2 <0> padsv[$a:45,46] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 45 optree.t:23) v +# 2 <0> padsv[$a:45,46] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '-exec sub {my $a}', + bcopts => '-exec', + code => sub {my $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 49 optree.t:52) v +# 2 <0> padsv[$a:49,50] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 49 optree.t:45) v +# 2 <0> padsv[$a:49,50] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {our $a}', + bcopts => '-exec', + code => sub {our $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 21 optree.t:47) v +2 <#> gvsv[*a] s/OURINTR +3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 51 optree.t:56) v +# 2 <$> gvsv(*a) s/OURINTR +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {local $a}', + bcopts => '-exec', + code => sub {local $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 23 optree.t:57) v +2 <#> gvsv[*a] s/LVINTRO +3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 53 optree.t:67) v +# 2 <$> gvsv(*a) s/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'my $a', + prog => 'my $a', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 3 <0> padsv[$a:1,2] vM/LVINTRO ->4 +EOT_EOT +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 3 <0> padsv[$a:1,2] vM/LVINTRO ->4 +EONT_EONT + +checkOptree ( name => 'our $a', + prog => 'our $a', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +4 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +- <1> ex-rv2sv vK/17 ->4 +3 <#> gvsv[*a] s/OURINTR ->4 +EOT_EOT +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# - <1> ex-rv2sv vK/17 ->4 +# 3 <$> gvsv(*a) s/OURINTR ->4 +EONT_EONT + +checkOptree ( name => 'local $a', + prog => 'local $a', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +4 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +- <1> ex-rv2sv vKM/129 ->4 +3 <#> gvsv[*a] s/LVINTRO ->4 +EOT_EOT +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# - <1> ex-rv2sv vKM/129 ->4 +# 3 <$> gvsv(*a) s/LVINTRO ->4 +EONT_EONT + +pass("MY, OUR, LOCAL, BOTH SUB AND MAIN, = undef"); + +checkOptree ( name => 'sub {my $a=undef}', + code => sub {my $a=undef}, + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +3 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->3 +1 <;> nextstate(main 24 optree.t:99) v ->2 +2 <0> padsv[$a:24,25] sRM*/LVINTRO ->3 +EOT_EOT +# 3 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->3 +# 1 <;> nextstate(main 54 optree.t:149) v ->2 +# 2 <0> padsv[$a:54,55] sRM*/LVINTRO ->3 +EONT_EONT + +checkOptree ( name => 'sub {our $a=undef}', + code => sub {our $a=undef}, + note => 'the global must be reset', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +5 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->5 +1 <;> nextstate(main 26 optree.t:109) v ->2 +4 <2> sassign sKS/2 ->5 +2 <0> undef s ->3 +- <1> ex-rv2sv sKRM*/17 ->4 +3 <#> gvsv[*a] s/OURINTR ->4 +EOT_EOT +# 5 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->5 +# 1 <;> nextstate(main 446 optree_varinit.t:137) v ->2 +# 4 <2> sassign sKS/2 ->5 +# 2 <0> undef s ->3 +# - <1> ex-rv2sv sKRM*/17 ->4 +# 3 <$> gvsv(*a) s/OURINTR ->4 +EONT_EONT + +checkOptree ( name => 'sub {local $a=undef}', + code => sub {local $a=undef}, + note => 'local not used enough to bother', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +5 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->5 +1 <;> nextstate(main 28 optree.t:122) v ->2 +4 <2> sassign sKS/2 ->5 +2 <0> undef s ->3 +- <1> ex-rv2sv sKRM*/129 ->4 +3 <#> gvsv[*a] s/LVINTRO ->4 +EOT_EOT +# 5 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->5 +# 1 <;> nextstate(main 58 optree.t:141) v ->2 +# 4 <2> sassign sKS/2 ->5 +# 2 <0> undef s ->3 +# - <1> ex-rv2sv sKRM*/129 ->4 +# 3 <$> gvsv(*a) s/LVINTRO ->4 +EONT_EONT + +checkOptree ( name => 'my $a=undef', + prog => 'my $a=undef', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +4 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +3 <0> padsv[$a:1,2] vRM*/LVINTRO ->4 +EOT_EOT +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 3 <0> padsv[$a:1,2] vRM*/LVINTRO ->4 +EONT_EONT + +checkOptree ( name => 'our $a=undef', + prog => 'our $a=undef', + note => 'global must be reassigned', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +6 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +5 <2> sassign vKS/2 ->6 +3 <0> undef s ->4 +- <1> ex-rv2sv sKRM*/17 ->5 +4 <#> gvsv[*a] s/OURINTR ->5 +EOT_EOT +# 6 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 5 <2> sassign vKS/2 ->6 +# 3 <0> undef s ->4 +# - <1> ex-rv2sv sKRM*/17 ->5 +# 4 <$> gvsv(*a) s/OURINTR ->5 +EONT_EONT + +checkOptree ( name => 'local $a=undef', + prog => 'local $a=undef', + note => 'locals are rare, probly not worth doing', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +6 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +5 <2> sassign vKS/2 ->6 +3 <0> undef s ->4 +- <1> ex-rv2sv sKRM*/129 ->5 +4 <#> gvsv[*a] s/LVINTRO ->5 +EOT_EOT +# 6 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 5 <2> sassign vKS/2 ->6 +# 3 <0> undef s ->4 +# - <1> ex-rv2sv sKRM*/129 ->5 +# 4 <$> gvsv(*a) s/LVINTRO ->5 +EONT_EONT + +checkOptree ( name => 'sub {my $a=()}', + code => sub {my $a=()}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -439 optree.t:105) v +2 <0> stub sP +3 <0> padsv[$a:-439,-438] sRM*/LVINTRO +4 <2> sassign sKS/2 +5 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 438 optree_varinit.t:247) v +# 2 <0> stub sP +# 3 <0> padsv[$a:438,439] sRM*/LVINTRO +# 4 <2> sassign sKS/2 +# 5 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {our $a=()}', + code => sub {our $a=()}, + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 31 optree.t:177) v +2 <0> stub sP +3 <#> gvsv[*a] s/OURINTR +4 <2> sassign sKS/2 +5 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 440 optree_varinit.t:262) v +# 2 <0> stub sP +# 3 <$> gvsv(*a) s/OURINTR +# 4 <2> sassign sKS/2 +# 5 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {local $a=()}', + code => sub {local $a=()}, + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 33 optree.t:190) v +2 <0> stub sP +3 <#> gvsv[*a] s/LVINTRO +4 <2> sassign sKS/2 +5 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 63 optree.t:225) v +# 2 <0> stub sP +# 3 <$> gvsv(*a) s/LVINTRO +# 4 <2> sassign sKS/2 +# 5 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'my $a=()', + prog => 'my $a=()', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> stub sP +4 <0> padsv[$a:1,2] sRM*/LVINTRO +5 <2> sassign vKS/2 +6 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> stub sP +# 4 <0> padsv[$a:1,2] sRM*/LVINTRO +# 5 <2> sassign vKS/2 +# 6 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'our $a=()', + prog => 'our $a=()', + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> stub sP +4 <#> gvsv[*a] s/OURINTR +5 <2> sassign vKS/2 +6 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> stub sP +# 4 <$> gvsv(*a) s/OURINTR +# 5 <2> sassign vKS/2 +# 6 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'local $a=()', + prog => 'local $a=()', + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> stub sP +4 <#> gvsv[*a] s/LVINTRO +5 <2> sassign vKS/2 +6 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> stub sP +# 4 <$> gvsv(*a) s/LVINTRO +# 5 <2> sassign vKS/2 +# 6 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'my ($a,$b)=()', + prog => 'my ($a,$b)=()', + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <0> pushmark sRM*/128 +# 5 <0> padsv[$a:1,2] lRM*/LVINTRO +# 6 <0> padsv[$b:1,2] lRM*/LVINTRO +# 7 <2> aassign[t3] vKS +# 8 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <0> pushmark sRM*/128 +# 5 <0> padsv[$a:1,2] lRM*/LVINTRO +# 6 <0> padsv[$b:1,2] lRM*/LVINTRO +# 7 <2> aassign[t3] vKS +# 8 <@> leave[1 ref] vKP/REFC +EONT_EONT + +} #skip + +__END__ + diff --git a/gnu/usr.bin/perl/ext/B/t/showlex.t b/gnu/usr.bin/perl/ext/B/t/showlex.t index 501a00bf257..9ac528818e1 100644 --- a/gnu/usr.bin/perl/ext/B/t/showlex.t +++ b/gnu/usr.bin/perl/ext/B/t/showlex.t @@ -12,18 +12,18 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } + require './test.pl'; } -$| = 1; +$| = 1; use warnings; use strict; use Config; +use B::Showlex (); -print "1..1\n"; +plan tests => 15; -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } +my $verbose = @ARGV; # set if ANY ARGS my $a; my $Is_VMS = $^O eq 'VMS'; @@ -35,9 +35,87 @@ my $redir = $Is_MacOS ? "" : "2>&1"; my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; if ($is_thread) { - print "# use5005threads: test $test skipped\n"; + ok "# use5005threads: test skipped\n"; } else { $a = `$^X $path "-MO=Showlex" -e "my \@one" $redir`; - print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@one.*sv_undef.*AV/s; + like ($a, qr/sv_undef.*PVNV.*\@one.*sv_undef.*AV/s, + "canonical usage works"); +} + +# v1.01 tests + +my ($na,$nb,$nc); # holds regex-strs +my ($out, $newlex); # output, option-flag + +sub padrep { + my ($varname,$newlex) = @_; + return ($newlex) + ? 'PVNV \(0x[0-9a-fA-F]+\) "\\'.$varname.'" = ' + : "PVNV \\\(0x[0-9a-fA-F]+\\\) \\$varname\n"; +} + +for $newlex ('', '-newlex') { + + $out = runperl ( switches => ["-MO=Showlex,$newlex"], + prog => 'my ($a,$b)', stderr => 1 ); + $na = padrep('$a',$newlex); + $nb = padrep('$b',$newlex); + like ($out, qr/1: $na/ms, 'found $a in "my ($a,$b)"'); + like ($out, qr/2: $nb/ms, 'found $b in "my ($a,$b)"'); + + print $out if $verbose; + +SKIP: { + skip "no perlio in this build", 5 + unless $Config::Config{useperlio}; + + our $buf = 'arb startval'; + my $ak = B::Showlex::walk_output (\$buf); + + my $walker = B::Showlex::compile( $newlex, sub{my($foo,$bar)} ); + $walker->(); + $na = padrep('$foo',$newlex); + $nb = padrep('$bar',$newlex); + like ($buf, qr/1: $na/ms, 'found $foo in "sub { my ($foo,$bar) }"'); + like ($buf, qr/2: $nb/ms, 'found $bar in "sub { my ($foo,$bar) }"'); + + print $buf if $verbose; + + $ak = B::Showlex::walk_output (\$buf); + + my $src = 'sub { my ($scalar,@arr,%hash) }'; + my $sub = eval $src; + $walker = B::Showlex::compile($sub); + $walker->(); + $na = padrep('$scalar',$newlex); + $nb = padrep('@arr',$newlex); + $nc = padrep('%hash',$newlex); + like ($buf, qr/1: $na/ms, 'found $scalar in "'. $src .'"'); + like ($buf, qr/2: $nb/ms, 'found @arr in "'. $src .'"'); + like ($buf, qr/3: $nc/ms, 'found %hash in "'. $src .'"'); + + print $buf if $verbose; + + # fibonacci function under test + my $asub = sub { + my ($self,%props)=@_; + my $total; + { # inner block vars + my (@fib)=(1,2); + for (my $i=2; $i<10; $i++) { + $fib[$i] = $fib[$i-2] + $fib[$i-1]; + } + for my $i(0..10) { + $total += $i; + } + } + }; + $walker = B::Showlex::compile($asub, $newlex, -nosp); + $walker->(); + print $buf if $verbose; + + $walker = B::Concise::compile($asub, '-exec'); + $walker->(); + +} } -ok; diff --git a/gnu/usr.bin/perl/ext/Cwd/t/win32.t b/gnu/usr.bin/perl/ext/Cwd/t/win32.t new file mode 100755 index 00000000000..f5fa20e1022 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Cwd/t/win32.t @@ -0,0 +1,29 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + if ($ENV{PERL_CORE}) { + @INC = '../lib'; + } +} + +use Test::More; +if( $^O eq 'MSWin32' ) { + plan tests => 3; +} else { + plan skip_all => 'this is not win32'; +} + +use Cwd; +ok 1; + +my $cdir = getdcwd('C:'); +like $cdir, qr{^C:}; + +my $ddir = getdcwd('D:'); +if (defined $ddir) { + like $ddir, qr{^D:}; +} else { + # May not have a D: drive mounted + ok 1; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/HACKERS b/gnu/usr.bin/perl/ext/Devel/PPPort/HACKERS new file mode 100644 index 00000000000..1eaa1abe559 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/HACKERS @@ -0,0 +1,234 @@ +=head1 NAME + +HACKERS - Devel::PPPort internals for hackers + +=head1 SYNOPSIS + +So you probably want to hack C<Devel::PPPort>? + +Well, here's some information to get you started with what's +lying around in this distribution. + +=head1 DESCRIPTION + +=head2 How to build 87 versions of Perl + +C<Devel::PPPort> supports Perl versions between 5.003 and bleadperl. +To guarantee this support, I need some of these versions on my +machine. I currently have 87 different Perl version/configuration +combinations installed on my laptop. + +As many of the old Perl distributions need patching to compile +cleanly on newer systems (and because building 87 Perls by hand +just isn't fun), I wrote a tool to build all the different +versions and configurations. You can find it in F<devel/buildperl.pl>. +It can currently build the following Perl releases: + + 5.003 + 5.004 - 5.004_05 + 5.005 - 5.005_04 + 5.6.x + 5.7.x + 5.8.x + 5.9.x + +=head2 Fully automatic API checks + +Knowing which parts of the API are not backwards compatible and +probably need C<Devel::PPPort> support is another problem that's +not easy to deal with manually. If you run + + perl Makefile.PL --with-apicheck + +a C file is generated by F<parts/apicheck.pl> that is compiled +and linked with C<Devel::PPPort>. This C file has the purpose of +using each of the public API functions/macros once. + +The required information is derived from C<parts/embed.fnc> (just +a copy of bleadperl's C<embed.fnc>) and C<parts/apidoc.fnc> (which +is generated by F<devel/mkapidoc.sh> and simply collects the rest +of the apidoc entries spread over the Perl source code). +The generated C file C<apicheck.c> is currently about 500k in size +and takes quite a while to compile. + +Usually, C<apicheck.c> won't compile with older perls. And even if +it compiles, there's still a good chance of the dynamic linker +failing at C<make test> time. But that's on purpose! + +We can use these failures to find changes in the API automatically. +The two Perl scripts F<devel/mktodo> and F<devel/mktodo.pl> +repeatedly run C<Devel::PPPort> with the apicheck code through +all different versions of perl. Scanning the output of the compiler +and the dynamic linker for errors, the files in F<parts/todo/> are +generated. These files list all parts of the public API that don't +work with less than a certain version of Perl. + +This information is in turn used by F<parts/apicheck.pl> to mask +API calls in the generated C file for these versions, so the +process can be stopped by the time F<apicheck.c> compiles cleanly +and the dynamic linker is happy. (Actually, this process generates +false positives, so each API call is checked once more afterwards.) + +Running C<devel/mktodo> takes a couple of hours. + +When running C<devel/mktodo> with the C<--base> option, it will +generate the I<baseline> todo files by disabling all functionality +provided by C<Devel::PPPort>. These are required for implementing +the C<--compat-version> option of the C<ppport.h> script. The +baseline todo files hold the information about which version of +Perl lacks a certain part of the API. + +However, only the documented public API can be checked this way. +And since C<Devel::PPPort> provides more macros, these would not be +affected by C<--compat-version>. It's the job of F<devel/scanprov> +to figure out the baseline information for all remaining provided +macros by scanning the include files in the F<CORE> directory of +various Perl versions. + +It's not very often that one has to regenerate the baseline and +todo files, and the process hasn't been automated yet, but it's +basically only the following steps: + +=over 4 + +=item * + +You need a whole bunch of different Perls. The more, the better. +You can use F<devel/buildperl.pl> to build them. I keep my perls +in F</tmp/perl>, so most of the tools take this as a default. + +=item * + +Remove all existing todo files in the F<parts/base> and +F<parts/todo> directories. + +=item * + +Update the API information. Copy the latest F<embed.fnc> file from +bleadperl to the F<parts> directory and run F<devel/mkapidoc.sh> to +collect the remaining information in F<parts/apidoc.fnc>. + +=item * + +Build the new baseline by running + + perl devel/mktodo --base + +in the root directory of the distribution. When it's finished, +move all files from the F<parts/todo> directory to F<parts/base>. + +=item * + +Build the new todo files by running + + perl devel/mktodo + +in the root directory of the distribution. + +=item * + +Finally, add the remaining baseline information by running + + perl devel/scanprov + +=back + +=head2 Implementation + +Residing in F<parts/inc/> is the "heart" of C<Devel::PPPort>. Each +of the files implements a part of the supported API, along with +hints, dependency information, XS code and tests. +The files are in a POD-like format that is parsed using the +functions in F<parts/ppptools.pl>. + +The scripts F<PPPort_pm.PL>, F<PPPort_xs.PL> and F<mktests.PL> all +use the information in F<parts/inc/> to generate the main module +F<PPPort.pm>, the XS code in F<PPPort.xs> and various test files +in F<t/>. + +All of these files could be generated on the fly while building +C<Devel::PPPort>, but not having the tests in C<t/> and not having +F<PPPort.xs> will confuse Configure and TEST/harness in the core. +Not having F<PPPort.pm> will be bad for viewing the docs on +C<search.cpan.org>. So unfortunately, it's unavoidable to put +some redundancy into the package. + +=head2 Adding stuff to Devel::PPPort + +First, check if the code you plan to add fits into one of the +existing files in F<parts/inc/>. If not, just start a new one and +remember to include it from within F<PPPort_pm.PL>. + +Each file holds all relevant data for implementing a certain part +of the API: + +=over 2 + +=item * + +A list of the provided API in the C<=provides> section. + +=item * + +The implementation to add to F<ppport.h> in the C<=implementation> +section. + +=item * + +The code required to add to PPPort.xs for testing the implementation. +This code goes into the C<=xshead>, C<=xsinit>, C<=xsmisc>, C<=xsboot> +and C<=xsubs> section. Have a look at the template in F<PPPort_xs.PL> +to see where the code ends up. + +=item * + +The tests in the C<=tests> section. Remember not to use any fancy +modules or syntax elements, as the test code should be able to run +with Perl 5.003, which, for example, doesn't support C<my> in +C<for>-loops: + + for my $x (1, 2, 3) { } # won't work + +You can use C<ok()> to report success or failure. + +=back + +It's usually the best approach to just copy an existing file and +use it as a template. + +=head2 Testing + +To automatically test C<Devel::PPPort> with lots of different Perl +versions, you can use the F<soak> script. Just pass it a list of +all Perl binaries you want to test. + +=head2 Special Makefile targets + +You can use + + make regen + +to regenerate all of the autogenerated files. To get rid of +all generated files (except for parts/todo/*), use + + make purge_all + +That's it. + +=head1 COPYRIGHT + +Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<ppport.h>. + +=cut + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/MANIFEST.SKIP b/gnu/usr.bin/perl/ext/Devel/PPPort/MANIFEST.SKIP new file mode 100644 index 00000000000..a6d2883e265 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/MANIFEST.SKIP @@ -0,0 +1,16 @@ +^Makefile$ +~$ +\.old(?:\..*)?$ +\.swp$ +\.o$ +\.bs$ +\.bak$ +\.orig$ +\.cache\.cm$ +^blib +^pm_to_blib +^backup +^parts/todo- +^ppport\.h$ +^PPPort\.c$ +Devel-PPPort.*\.tar\.gz$ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/META.yml b/gnu/usr.bin/perl/ext/Devel/PPPort/META.yml new file mode 100644 index 00000000000..c0e2f441901 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/META.yml @@ -0,0 +1,10 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: Devel-PPPort +version: 3.03 +version_from: PPPort_pm.PL +installdirs: perl +requires: + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_pm.PL b/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_pm.PL new file mode 100644 index 00000000000..e057f2ac3c3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_pm.PL @@ -0,0 +1,580 @@ +################################################################################ +# +# PPPort_pm.PL -- generate PPPort.pm +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +$^W = 1; +require "parts/ppptools.pl"; + +my $INCLUDE = 'parts/inc'; +my $DPPP = 'DPPP_'; + +my %embed = map { ( $_->{name} => $_ ) } + parse_embed(qw(parts/embed.fnc parts/apidoc.fnc)); + +my(%provides, %prototypes, %explicit); + +my $data = do { local $/; <DATA> }; +$data =~ s{^\%(include)\s+(\w+)((?:[^\S\r\n]+.*?)?)\s*$} + {eval "$1('$2', $3)" or die $@}gem; + +$data = expand($data); + +my @api = sort { lc $a cmp lc $b } keys %provides; + +$data =~ s{^(.*)__PROVIDED_API__(\s*?)^} + {join '', map "$1$_\n", @api}gem; + +{ + my $len = 0; + for (keys %explicit) { + length > $len and $len = length; + } + my $format = sprintf "%%-%ds %%-%ds %%-%ds", $len+2, $len+5, $len+12; + $len = 3*$len + 23; + +$data =~ s/^(.*)__EXPLICIT_API__(\s*?)^/ + sprintf("$1$format\n", 'Function', 'Static Request', 'Global Request') . + $1 . '-'x$len . "\n" . + join('', map { sprintf "$1$format\n", "$_()", "NEED_$_", "NEED_${_}_GLOBAL" } + sort keys %explicit) + /gem; +} + +my %raw_base = %{&parse_todo('parts/base')}; +my %raw_todo = %{&parse_todo('parts/todo')}; + +my %todo; +for (keys %raw_todo) { + push @{$todo{$raw_todo{$_}}}, $_; +} + +# check consistency +for (@api) { + if (exists $raw_todo{$_}) { + if ($raw_base{$_} eq $raw_todo{$_}) { + warn "$INCLUDE/$provides{$_} provides $_, which is still marked " + . "todo for " . format_version($raw_todo{$_}) . "\n"; + } + else { + check(2, "$_ was ported back to " . format_version($raw_todo{$_}) . + " (baseline revision: " . format_version($raw_base{$_}) . ")."); + } + } +} + +my @perl_api; +for (keys %provides) { + next if exists $embed{$_}; + push @perl_api, $_; + check(2, "No API definition for provided element $_ found."); +} + +push @perl_api, keys %embed; + +for (@perl_api) { + if (exists $provides{$_} && !exists $raw_base{$_}) { + check(2, "Mmmh, $_ doesn't seem to need backporting."); + } + my $line = "$_|" . (exists $provides{$_} && exists $raw_base{$_} ? $raw_base{$_} : '') . '|'; + $line .= ($raw_todo{$_} || '') . '|'; + $line .= 'p' if exists $provides{$_}; + if (exists $embed{$_}) { + my $e = $embed{$_}; + if (exists $e->{flags}{p}) { + my $args = $e->{args}; + $line .= 'v' if @$args && $args->[-1][0] eq '...'; + } + $line .= 'n' if exists $e->{flags}{n}; + } + $_ = $line; +} + +$data =~ s/^([\t ]*)__PERL_API__(\s*?)$/ + join "\n", map "$1$_", sort @perl_api + /gem; + +my @todo; +for (reverse sort keys %todo) { + my $ver = format_version($_); + my $todo = "=item perl $ver\n\n"; + for (sort @{$todo{$_}}) { + $todo .= " $_\n"; + } + push @todo, $todo; +} + +$data =~ s{^__UNSUPPORTED_API__(\s*?)^} + {join "\n", @todo}gem; + +$data =~ s{__MIN_PERL__}{5.003}g; +$data =~ s{__MAX_PERL__}{5.9.2}g; + +open FH, ">PPPort.pm" or die "PPPort.pm: $!\n"; +print FH $data; +close FH; + +exit 0; + +sub include +{ + my($file, $opt) = @_; + + print "including $file\n"; + + my $data = parse_partspec("$INCLUDE/$file"); + + for (@{$data->{provides}}) { + if (exists $provides{$_}) { + if ($provides{$_} ne $file) { + warn "$file: $_ already provided by $provides{$_}\n"; + } + } + else { + $provides{$_} = $file; + } + } + + for (keys %{$data->{prototypes}}) { + $prototypes{$_} = $data->{prototypes}{$_}; + $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg; + } + + my $out = $data->{implementation}; + + if (exists $opt->{indent}) { + $out =~ s/^/$opt->{indent}/gm; + } + + return $out; +} + +sub expand +{ + my $code = shift; + $code =~ s{^(\s*#\s*(?:el)?if\s+)(.*)$}{$1.expand_pp_expressions($2)}gem; + $code =~ s{^\s* + __UNDEFINED__ + \s+ + ( + ( \w+ ) + (?: \( [^)]* \) )? + ) + [^\r\n\S]* + ( + (?:[^\r\n\\]|\\[^\r\n])* + (?: + \\ + (?:\r\n|[\r\n]) + (?:[^\r\n\\]|\\[^\r\n])* + )* + ) + \s*$} + {expand_undefined($2, $1, $3)}gemx; + return $code; +} + +sub expand_undefined +{ + my($macro, $withargs, $def) = @_; + my $rv = "#ifndef $macro\n# define "; + + if (defined $def) { + $rv .= sprintf "%-30s %s", $withargs, $def; + } + else { + $rv .= $withargs; + } + + $rv .= "\n#endif\n"; + + return $rv; +} + +sub expand_pp_expressions +{ + my $pp = shift; + $pp =~ s/\{([^\}]+)\}/expand_pp_expr($1)/ge; + return $pp; +} + +sub expand_pp_expr +{ + my $expr = shift; + + if ($expr =~ /^\s*need\s*(\w+)\s*$/i) { + my $func = $1; + my $e = $embed{$func} or die "unknown API function '$func' in NEED\n"; + my $proto = make_prototype($e); + if (exists $prototypes{$func}) { + if (compare_prototypes($proto, $prototypes{$func})) { + check(1, "differing prototypes for $func:\n API: $proto\n PPP: $prototypes{$func}"); + $proto = $prototypes{$func}; + } + } + else { + warn "found no prototype for $func\n";; + } + + $explicit{$func} = 1; + + $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/; + my $embed = make_embed($e); + + return "defined(NEED_$func)\n" + . "static $proto;\n" + . "static\n" + . "#else\n" + . "extern $proto;\n" + . "#endif\n" + . "\n" + . "$embed\n" + . "\n" + . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)"; + } + + die "cannot expand preprocessor expression '$expr'\n"; +} + +sub make_embed +{ + my $f = shift; + my $n = $f->{name}; + my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} }; + + if ($f->{flags}{n}) { + if ($f->{flags}{p}) { + return "#define $n $DPPP(my_$n)\n" . + "#define Perl_$n $DPPP(my_$n)"; + } + else { + return "#define $n $DPPP(my_$n)"; + } + } + else { + my $undef = <<UNDEF; +#ifdef $n +# undef $n +#endif +UNDEF + if ($f->{flags}{p}) { + if ($f->{flags}{f}) { + return "#define Perl_$n $DPPP(my_$n)"; + } + else { + return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" . + "#define Perl_$n $DPPP(my_$n)"; + } + } + else { + return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)"; + } + } +} + +sub check +{ + my $level = shift; + + if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) { + print STDERR @_, "\n"; + } +} + +__DATA__ +################################################################################ +# +# !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!! +# +################################################################################ +# +# Perl/Pollution/Portability +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +=head1 NAME + +Devel::PPPort - Perl/Pollution/Portability + +=head1 SYNOPSIS + + Devel::PPPort::WriteFile(); # defaults to ./ppport.h + Devel::PPPort::WriteFile('someheader.h'); + +=head1 DESCRIPTION + +Perl's API has changed over time, gaining new features, new functions, +increasing its flexibility, and reducing the impact on the C namespace +environment (reduced pollution). The header file written by this module, +typically F<ppport.h>, attempts to bring some of the newer Perl API +features to older versions of Perl, so that you can worry less about +keeping track of old releases, but users can still reap the benefit. + +C<Devel::PPPort> contains a single function, called C<WriteFile>. Its +only purpose is to write the F<ppport.h> C header file. This file +contains a series of macros and, if explicitly requested, functions that +allow XS modules to be built using older versions of Perl. Currently, +Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported. + +This module is used by C<h2xs> to write the file F<ppport.h>. + +=head2 Why use ppport.h? + +You should use F<ppport.h> in modern code so that your code will work +with the widest range of Perl interpreters possible, without significant +additional work. + +You should attempt older code to fully use F<ppport.h>, because the +reduced pollution of newer Perl versions is an important thing. It's so +important that the old polluting ways of original Perl modules will not be +supported very far into the future, and your module will almost certainly +break! By adapting to it now, you'll gain compatibility and a sense of +having done the electronic ecology some good. + +=head2 How to use ppport.h + +Don't direct the users of your module to download C<Devel::PPPort>. +They are most probably no XS writers. Also, don't make F<ppport.h> +optional. Rather, just take the most recent copy of F<ppport.h> that +you can find (e.g. by generating it with the latest C<Devel::PPPort> +release from CPAN), copy it into your project, adjust your project to +use it, and distribute the header along with your module. + +=head2 Running ppport.h + +But F<ppport.h> is more than just a C header. It's also a Perl script +that can check your source code. It will suggest hints and portability +notes, and can even make suggestions on how to change your code. You +can run it like any other Perl program: + + perl ppport.h + +It also has embedded documentation, so you can use + + perldoc ppport.h + +to find out more about how to use it. + +=head1 FUNCTIONS + +=head2 WriteFile + +C<WriteFile> takes one optional argument. When called with one +argument, it expects to be passed a filename. When called with +no arguments, it defaults to the filename F<ppport.h>. + +The function returns a true value if the file was written successfully. +Otherwise it returns a false value. + +=head1 COMPATIBILITY + +F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__ +in threaded and non-threaded configurations. + +=head2 Provided Perl compatibility API + +The header file written by this module, typically F<ppport.h>, provides +access to the following elements of the Perl API that is not available +in older Perl releases: + + __PROVIDED_API__ + +=head2 Perl API not supported by ppport.h + +There is still a big part of the API not supported by F<ppport.h>. +Either because it doesn't make sense to back-port that part of the API, +or simply because it hasn't been implemented yet. Patches welcome! + +Here's a list of the currently unsupported API, and also the version of +Perl below which it is unsupported: + +=over 4 + +__UNSUPPORTED_API__ + +=back + +=head1 BUGS + +If you find any bugs, C<Devel::PPPort> doesn't seem to build on your +system or any of its tests fail, please use the CPAN Request Tracker +at L<http://rt.cpan.org/> to create a ticket for the module. + +=head1 AUTHORS + +=over 2 + +=item * + +Version 1.x of Devel::PPPort was written by Kenneth Albanowski. + +=item * + +Version 2.x was ported to the Perl core by Paul Marquess. + +=item * + +Version 3.x was ported back to CPAN by Marcus Holland-Moritz. + +=back + +=head1 COPYRIGHT + +Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<h2xs>, L<ppport.h>. + +=cut + +package Devel::PPPort; + +require DynaLoader; +use strict; +use vars qw($VERSION @ISA $data); + +$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; + +@ISA = qw(DynaLoader); + +bootstrap Devel::PPPort; + +{ + $data = do { local $/; <DATA> }; + my $now = localtime; + my $pkg = 'Devel::PPPort'; + $data =~ s/__PERL_VERSION__/$]/g; + $data =~ s/__VERSION__/$VERSION/g; + $data =~ s/__DATE__/$now/g; + $data =~ s/__PKG__/$pkg/g; + $data =~ s/^POD\s//gm; +} + +sub WriteFile +{ + my $file = shift || 'ppport.h'; + my $copy = $data; + $copy =~ s/\bppport\.h\b/$file/g; + + open F, ">$file" or return undef; + print F $copy; + close F; + + return 1; +} + +1; + +__DATA__ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version __VERSION__ + + Automatically created by __PKG__ running under + perl __PERL_VERSION__ on __DATE__. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +%include ppphdoc { indent => 'POD ' } + +%include ppphbin + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +%include version + +%include limits + +%include uv + +%include misc + +%include threads + +%include mPUSH + +%include call + +%include newRV + +%include newCONSTSUB + +%include MY_CXT + +%include format + +%include SvPV + +%include sv_xpvf + +%include magic + +%include cop + +%include grok + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_xs.PL b/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_xs.PL new file mode 100644 index 00000000000..66e570e8ae5 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_xs.PL @@ -0,0 +1,132 @@ +################################################################################ +# +# PPPort_xs.PL -- generate PPPort.xs +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +$^W = 1; +require "parts/ppptools.pl"; + +my %SECTION = ( + xshead => { code => '', header => "/* ---- from __FILE__ ---- */" }, + xsinit => { code => '', header => "/* ---- from __FILE__ ---- */" }, + xsmisc => { code => '', header => "/* ---- from __FILE__ ---- */" }, + xsboot => { code => '', header => "/* ---- from __FILE__ ---- */", indent => "\t" }, + xsubs => { code => '', header => "##".('-' x 70)."\n## XSUBs from __FILE__\n##".('-' x 70)."\n" }, +); + +if (exists $ENV{PERL_NO_GET_CONTEXT} && $ENV{PERL_NO_GET_CONTEXT}) { +$SECTION{xshead}{code} .= <<END; +#define PERL_NO_GET_CONTEXT +END +} + +my $file; +my $sec; + +for $file (glob 'parts/inc/*') { + my $spec = parse_partspec($file); + + my $msg = 0; + for $sec (keys %SECTION) { + if (exists $spec->{$sec}) { + $msg++ or print "adding XS code from $file\n"; + if (exists $SECTION{$sec}{header}) { + my $header = $SECTION{$sec}{header}; + $header =~ s/__FILE__/$file/g; + $SECTION{$sec}{code} .= $header . "\n"; + } + $SECTION{$sec}{code} .= $spec->{$sec} . "\n"; + } + } +} + +my $data = do { local $/; <DATA> }; + +for $sec (keys %SECTION) { + my $code = $SECTION{$sec}{code}; + if (exists $SECTION{$sec}{indent}) { + $code =~ s/^/$SECTION{$sec}{indent}/gm; + } + $code =~ s/[\r\n]+$//; + $data =~ s/^__\U$sec\E__$/$code/m; +} + +open FH, ">PPPort.xs" or die "PPPort.xs: $!\n"; +print FH $data; +close FH; + +exit 0; + +__DATA__ +/******************************************************************************* +* +* !!!!! Do NOT edit this file directly! -- Edit PPPort_xs.PL instead. !!!!! +* +******************************************************************************** +* +* Perl/Pollution/Portability +* +******************************************************************************** +* +* $Revision: 1.1 $ +* $Author: millert $ +* $Date: 2005/01/15 21:16:45 $ +* +******************************************************************************** +* +* Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +* Version 2.x, Copyright (C) 2001, Paul Marquess. +* Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +* +* This program is free software; you can redistribute it and/or +* modify it under the same terms as Perl itself. +* +*******************************************************************************/ + +/* ========== BEGIN XSHEAD ================================================== */ + +__XSHEAD__ + +/* =========== END XSHEAD =================================================== */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* ========== BEGIN XSINIT ================================================== */ + +__XSINIT__ + +/* =========== END XSINIT =================================================== */ + +#include "ppport.h" + +/* ========== BEGIN XSMISC ================================================== */ + +__XSMISC__ + +/* =========== END XSMISC =================================================== */ + +MODULE = Devel::PPPort PACKAGE = Devel::PPPort + +BOOT: +__XSBOOT__ + +__XSUBS__ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/apicheck_c.PL b/gnu/usr.bin/perl/ext/Devel/PPPort/apicheck_c.PL new file mode 100644 index 00000000000..0fde44da03f --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/apicheck_c.PL @@ -0,0 +1,25 @@ +################################################################################ +# +# apicheck_c.PL -- generate apicheck.c +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +$out = 'apicheck.c'; +print "creating $out\n"; +system $^X, 'parts/apicheck.pl', $out + and die "couldn't create $out\n"; diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/buildperl.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/buildperl.pl new file mode 100644 index 00000000000..34db953f89b --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/buildperl.pl @@ -0,0 +1,317 @@ +#!/usr/bin/perl -w +################################################################################ +# +# buildperl.pl -- build various versions of perl automatically +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +use Getopt::Long; +use Pod::Usage; +use File::Find; +use File::Path; +use Data::Dumper; +use IO::File; +use Cwd; + +my %opt = ( + prefix => '/tmp/perl/install/<config>/<perl>', + build => '/tmp/perl/build/<config>', + source => '/tmp/perl/source', + force => 0, +); + +my %config = ( + default => { + config_args => '-des', + }, + thread => { + config_args => '-des -Dusethreads', + masked_versions => [ qr/^perl5\.00[01234]/ ], + }, + thread5005 => { + config_args => '-des -Duse5005threads', + masked_versions => [ qr/^perl5\.00[012345]|^perl-5.(9|\d\d)/ ], + }, + debug => { + config_args => '-des -Doptimize=-g', + }, +); + +my @patch = ( + { + perl => [ + qr/^perl5\.00[01234]/, + qw/ + perl5.005 + perl5.005_01 + perl5.005_02 + perl5.005_03 + /, + ], + subs => [ + [ \&patch_db, 1 ], + ], + }, + { + perl => [ + qw/ + perl-5.6.0 + perl-5.6.1 + perl-5.7.0 + perl-5.7.1 + perl-5.7.2 + perl-5.7.3 + perl-5.8.0 + /, + ], + subs => [ + [ \&patch_db, 3 ], + ], + }, + { + perl => [ + qr/^perl5\.004_0[1234]/, + ], + subs => [ + [ \&patch_doio ], + ], + }, +); + +my(%perl, @perls); + +GetOptions(\%opt, qw( + config=s@ + prefix=s + source=s + perl=s@ + force +)) or pod2usage(2); + +if (exists $opt{config}) { + for my $cfg (@{$opt{config}}) { + exists $config{$cfg} or die "Unknown configuration: $cfg\n"; + } +} +else { + $opt{config} = [sort keys %config]; +} + +find(sub { + /^(perl-?(5\..*))\.tar.gz$/ or return; + $perl{$1} = { version => $2, source => $File::Find::name }; +}, $opt{source}); + +if (exists $opt{perl}) { + for my $perl (@{$opt{perl}}) { + my $p = $perl; + exists $perl{$p} or $p = "perl$perl"; + exists $perl{$p} or $p = "perl-$perl"; + exists $perl{$p} or die "Cannot find perl: $perl\n"; + push @perls, $p; + } +} +else { + @perls = sort keys %perl; +} + +$ENV{PATH} = "~/bin:$ENV{PATH}"; # use ccache + +my %current; + +for my $cfg (@{$opt{config}}) { + for my $perl (@perls) { + my $config = $config{$cfg}; + %current = (config => $cfg, perl => $perl); + + if (is($config->{masked_versions}, $perl)) { + print STDERR "skipping $perl for configuration $cfg (masked)\n"; + next; + } + + if (-d expand($opt{prefix}) and !$opt{force}) { + print STDERR "skipping $perl for configuration $cfg (already installed)\n"; + next; + } + + my $cwd = cwd; + + my $build = expand($opt{build}); + -d $build or mkpath($build); + chdir $build or die "chdir $build: $!\n"; + + print STDERR "building $perl with configuration $cfg\n"; + buildperl($perl, $config); + + chdir $cwd or die "chdir $cwd: $!\n"; + } +} + +sub expand +{ + my $in = shift; + $in =~ s/(<(\w+)>)/exists $current{$2} ? $current{$2} : $1/eg; + return $in; +} + +sub is +{ + my($s1, $s2) = @_; + + defined $s1 != defined $s2 and return 0; + + ref $s2 and ($s1, $s2) = ($s2, $s1); + + if (ref $s1) { + if (ref $s1 eq 'ARRAY') { + is($_, $s2) and return 1 for @$s1; + return 0; + } + return $s2 =~ $s1; + } + + return $s1 eq $s2; +} + +sub buildperl +{ + my($perl, $cfg) = @_; + + my $d = extract_source($perl{$perl}); + chdir $d or die "chdir $d: $!\n"; + + patch_source($perl); + + build_and_install($perl{$perl}); +} + +sub extract_source +{ + my $perl = shift; + my $target = "perl-$perl->{version}"; + + for my $dir ("perl$perl->{version}", "perl-$perl->{version}") { + if (-d $dir) { + print "removing old build directory $dir\n"; + rmtree($dir); + } + } + + print "extracting $perl->{source}\n"; + + run_or_die("tar xzf $perl->{source}"); + + if ($perl->{version} !~ /^\d+\.\d+\.\d+/ && -d "perl-$perl->{version}") { + $target = "perl$perl->{version}"; + rename "perl-$perl->{version}", $target or die "rename: $!\n"; + } + + -d $target or die "$target not found\n"; + + return $target; +} + +sub patch_source +{ + my $perl = shift; + + for my $p (@patch) { + if (is($p->{perl}, $perl)) { + for my $s (@{$p->{subs}}) { + my($sub, @args) = @$s; + $sub->(@args); + } + } + } +} + +sub build_and_install +{ + my $perl = shift; + my $prefix = expand($opt{prefix}); + + print "building perl $perl->{version} ($current{config})\n"; + + run_or_die("./Configure $config{$current{config}}{config_args} -Dusedevel -Uinstallusrbinperl -Dprefix=$prefix"); + run_or_die("sed -i -e '/^.*<built-in>/d' -e '/^.*<command line>/d' makefile x2p/makefile"); + run_or_die("make all"); + # run("make test"); + run_or_die("make install"); +} + +sub patch_db +{ + my $ver = shift; + print "patching DB_File\n"; + run_or_die("sed -i -e 's/<db.h>/<db$ver\\/db.h>/' ext/DB_File/DB_File.xs"); +} + +sub patch_doio +{ + patch('doio.c', <<'END'); +--- doio.c.org 2004-06-07 23:14:45.000000000 +0200 ++++ doio.c 2003-11-04 08:03:03.000000000 +0100 +@@ -75,6 +75,16 @@ + # endif + #endif + ++#if _SEM_SEMUN_UNDEFINED ++union semun ++{ ++ int val; ++ struct semid_ds *buf; ++ unsigned short int *array; ++ struct seminfo *__buf; ++}; ++#endif ++ + bool + do_open(gv,name,len,as_raw,rawmode,rawperm,supplied_fp) + GV *gv; +END +} + +sub patch +{ + my($file, $patch) = @_; + print "patching $file\n"; + my $diff = "$file.diff"; + write_or_die($diff, $patch); + run_or_die("patch -s -p0 <$diff"); + unlink $diff or die "unlink $diff: $!\n"; +} + +sub write_or_die +{ + my($file, $data) = @_; + my $fh = new IO::File ">$file" or die "$file: $!\n"; + $fh->print($data); +} + +sub run_or_die +{ + # print "[running @_]\n"; + system "@_" and die "@_: $?\n"; +} + +sub run +{ + # print "[running @_]\n"; + system "@_" and warn "@_: $?\n"; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mkapidoc.sh b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mkapidoc.sh new file mode 100644 index 00000000000..25d67a73dba --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mkapidoc.sh @@ -0,0 +1,70 @@ +#!/bin/bash +################################################################################ +# +# mkapidoc.sh -- generate apidoc.fnc from scanning the Perl source +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +function isperlroot +{ + [ -f "$1/embed.fnc" ] && [ -f "$1/perl.h" ] +} + +function usage +{ + echo "USAGE: $0 [perlroot] [output-file] [embed.fnc]" + exit 0 +} + +if [ -z "$1" ]; then + if isperlroot "../../.."; then + PERLROOT=../../.. + else + PERLROOT=. + fi +else + PERLROOT=$1 +fi + +if [ -z "$2" ]; then + if [ -f "parts/apidoc.fnc" ]; then + OUTPUT="parts/apidoc.fnc" + else + usage + fi +else + OUTPUT=$2 +fi + +if [ -z "$3" ]; then + if [ -f "parts/embed.fnc" ]; then + EMBED="parts/embed.fnc" + else + usage + fi +else + EMBED=$3 +fi + +if isperlroot $PERLROOT; then + grep -hr '=for apidoc' $PERLROOT | sed -e 's/=for apidoc //' | grep '|' | sort | uniq \ + | perl -e'$f=pop;open(F,$f)||die"$f:$!";while(<F>){(split/\|/)[2]=~/(\w+)/;$h{$1}++} + while(<>){(split/\|/)[2]=~/(\w+)/;$h{$1}||print}' $EMBED >$OUTPUT +else + usage +fi diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo new file mode 100644 index 00000000000..dbcdf9653e9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo @@ -0,0 +1,60 @@ +#!/usr/bin/perl -w +################################################################################ +# +# mktodo -- generate baseline and todo files by running mktodo.pl +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +use Getopt::Long; + +my %opt = ( + base => 0, +); + +GetOptions(\%opt, qw( + base + )) or die; + +# my $outdir = $opt{base} ? 'parts/base' : 'parts/todo'; +my $outdir = 'parts/todo'; + +# for (glob "$outdir/*") { +# unlink or die "$_: $!\n"; +# } + +my $install = '/tmp/perl/install/default'; +# my $install = '/tmp/perl/install/thread'; + +my @perls = sort { $b->{version} <=> $a->{version} } + map { { version => `$_ -e 'printf "%.6f", \$]'`, path => $_ } } + ('bleadperl', glob "$install/*/bin/perl5.*"); + +for (1 .. $#perls) { + $perls[$_]{todo} = $perls[$_-1]{version}; +} + +shift @perls; + +for (@perls) { + my $todo = do { my $v = $_->{todo}; $v =~ s/\D+//g; $v }; + -e "$outdir/$todo" and next; + my @args = ('--perl', $_->{path}, '--todo', "$outdir/$todo", '--version', "$_->{todo}"); + push @args, '--base' if $opt{base}; + system 'devel/mktodo.pl', @args and die "system(@args): [$!] [$?]\n"; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo.pl new file mode 100644 index 00000000000..b3bb9f2d79d --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo.pl @@ -0,0 +1,210 @@ +#!/usr/bin/perl -w +################################################################################ +# +# mktodo.pl -- generate baseline and todo files +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +use Getopt::Long; +use Data::Dumper; +use IO::File; +use IO::Select; + +my %opt = ( + debug => 0, + base => 0, +); + +print "\n$0 @ARGV\n\n"; + +GetOptions(\%opt, qw( + perl=s todo=s version=s debug base + )) or die; + +my $fullperl = `which $opt{perl}`; +chomp $fullperl; + +regen_all(); + +my %sym; +for (`nm $fullperl`) { + chomp; + /\s+T\s+(\w+)\s*$/ and $sym{$1}++; +} +keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n"; + +my %all = %{load_todo($opt{todo}, $opt{version})}; +my @recheck; + +for (;;) { + my $retry = 1; + regen_apicheck(); +retry: + my $r = run(qw(make test)); + $r->{didnotrun} and die "couldn't run make test: $!\n"; + $r->{status} == 0 and last; + my(@new, @tmp, %seen); + for my $l (@{$r->{stderr}}) { + if ($l =~ /_DPPP_test_(\w+)/) { + if (!$seen{$1}++) { + my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; + if (@s) { + push @tmp, [$1, "E (@s)"]; + } + else { + push @new, [$1, "E"]; + } + } + } + if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) { + if (!$seen{$1}++) { + my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; + push @new, [$1, @s ? "U (@s)" : "U"]; + } + } + } + @new = grep !$all{$_->[0]}, @new; + unless (@new) { + @new = grep !$all{$_->[0]}, @tmp; + # TODO: @recheck was here, find a better way to get recheck syms + # * we definitely don't have to check (U) symbols + # * try to grep out warnings before making symlist ? + } + unless (@new) { + if ($retry > 0) { + $retry--; + regen_all(); + goto retry; + } + print Dumper($r); + die "no new TODO symbols found..."; + } + push @recheck, map { $_->[0] } @new; + for (@new) { + printf "[$opt{version}] new symbol: %-30s # %s\n", @$_; + $all{$_->[0]} = $_->[1]; + } + write_todo($opt{todo}, $opt{version}, \%all); +} + +for my $sym (@recheck) { + my $cur = delete $all{$sym}; + printf "[$opt{version}] chk symbol: %-30s # %s\n", $sym, $cur; + write_todo($opt{todo}, $opt{version}, \%all); + regen_all(); + my $r = run(qw(make test)); + $r->{didnotrun} and die "couldn't run make test: $!\n"; + if ($r->{status} == 0) { + printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur; + } + else { + $all{$sym} = $cur; + } +} + +write_todo($opt{todo}, $opt{version}, \%all); + +run(qw(make realclean)); + +exit 0; + +sub regen_all +{ + my @mf_arg = qw( --with-apicheck OPTIMIZE=-O0 ); + push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base}; + + # just to be sure + run(qw(make realclean)); + run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0 + or die "cannot run Makefile.PL: $!\n"; +} + +sub regen_apicheck +{ + unlink qw(apicheck.c apicheck.o); + system "$fullperl apicheck_c.PL >/dev/null"; +} + +sub load_todo +{ + my($file, $expver) = @_; + + if (-e $file) { + my $f = new IO::File $file or die "cannot open $file: $!\n"; + my $ver = <$f>; + chomp $ver; + if ($ver eq $expver) { + my %sym; + while (<$f>) { + chomp; + /^(\w+)\s+#\s+(.*)/ or goto nuke_file; + exists $sym{$1} and goto nuke_file; + $sym{$1} = $2; + } + return \%sym; + } + +nuke_file: + undef $f; + unlink $file or die "cannot remove $file: $!\n"; + } + + return {}; +} + +sub write_todo +{ + my($file, $ver, $sym) = @_; + my $f; + + $f = new IO::File ">$file" or die "cannot open $file: $!\n"; + $f->print("$ver\n"); + + for (sort keys %$sym) { + $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_}); + } +} + +sub run +{ + my $prog = shift; + my @args = @_; + + # print "[$prog @args]\n"; + + system "$prog @args >tmp.out 2>tmp.err"; + + my $out = new IO::File "tmp.out" || die "tmp.out: $!\n"; + my $err = new IO::File "tmp.err" || die "tmp.err: $!\n"; + + my %rval = ( + status => $? >> 8, + stdout => [<$out>], + stderr => [<$err>], + didnotrun => 0, + ); + + unlink "tmp.out", "tmp.err"; + + $? & 128 and $rval{core} = 1; + $? & 127 and $rval{signal} = $? & 127; + + \%rval; +} + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/scanprov b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/scanprov new file mode 100644 index 00000000000..d53fb60cd6f --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/scanprov @@ -0,0 +1,77 @@ +#!/usr/bin/perl -w +################################################################################ +# +# scanprov -- scan Perl headers for provided macros +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +require 'parts/ppptools.pl'; + +die "Usage: $0 [check|write]\n" unless @ARGV && $ARGV[0] =~ /^(check|write)$/; +my $mode = $1; + +my %embed = map { ( $_->{name} => 1 ) } + parse_embed(qw(parts/embed.fnc parts/apidoc.fnc)); + +my @provided = grep { !exists $embed{$_} } + map { /^(\w+)/ ? $1 : () } + `$^X ppport.h --list-provided`; + +my $install = '/tmp/perl/install/default'; + +my @perls = sort { $b->{version} <=> $a->{version} } + map { { version => `$_ -e 'printf "%.6f", \$]'`, path => $_ } } + ('bleadperl', glob "$install/*/bin/perl5.*"); + +for (1 .. $#perls) { + $perls[$_]{todo} = $perls[$_-1]{version}; +} + +shift @perls; + +my %v; + +for my $p (@perls) { + print "checking perl $p->{version}...\n"; + my $archlib = `$p->{path} -MConfig -l -e 'print \$Config{archlib}'`; + chomp $archlib; + local @ARGV = glob "$archlib/CORE/*.h"; + my %sym; + while (<>) { $sym{$_}++ for /(\w+)/g; } + @provided = map { $sym{$_} or $v{$p->{todo}}{$_}++; $sym{$_} ? $_ : () } @provided; +} + +my $out = 'parts/base'; +my $todo = parse_todo($out); + +for my $v (keys %v) { + my @new = sort grep { !exists $todo->{$_} } keys %{$v{$v}}; + @new or next; + my $file = $v; + $file =~ s/\.//g; + $file = "$out/$file"; + -e $file or die "non-existent: $file\n"; + print "-- $file --\n"; + $mode eq 'write' and (open F, ">>$file" or die "$file: $!\n"); + for (@new) { + print "adding $_\n"; + $mode eq 'write' and printf F "%-30s # added by $0\n", $_; + } + $mode eq 'write' and close F; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/mktests.PL b/gnu/usr.bin/perl/ext/Devel/PPPort/mktests.PL new file mode 100644 index 00000000000..7c7a5f163b2 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/mktests.PL @@ -0,0 +1,94 @@ +################################################################################ +# +# mktests.PL -- generate test files for Devel::PPPort +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +$^W = 1; +require "parts/ppptools.pl"; + +my $template = do { local $/; <DATA> }; + +my $file; +for $file (glob 'parts/inc/*') { + my($testfile) = $file =~ /(\w+)$/; + $testfile = "t/$testfile.t"; + + my $spec = parse_partspec($file); + my $plan = 0; + + if (exists $spec->{tests}) { + exists $spec->{OPTIONS}{tests} && + exists $spec->{OPTIONS}{tests}{plan} + or die "No plan for tests in $file\n"; + + print "generating $testfile\n"; + + my $tmpl = $template; + $tmpl =~ s/__SOURCE__/$file/mg; + $tmpl =~ s/__PLAN__/$spec->{OPTIONS}{tests}{plan}/mg; + $tmpl =~ s/^__TESTS__$/$spec->{tests}/mg; + + open FH, ">$testfile" or die "$testfile: $!\n"; + print FH $tmpl; + close FH; + } +} + +exit 0; + +__DATA__ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or __SOURCE__ instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..__PLAN__\n"; + } + else { + plan(tests => __PLAN__); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +__TESTS__ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apicheck.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apicheck.pl new file mode 100644 index 00000000000..9219805f7d7 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apicheck.pl @@ -0,0 +1,299 @@ +#!/usr/bin/perl -w +################################################################################ +# +# apicheck.pl -- generate C source for automated API check +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +require 'parts/ppptools.pl'; + +if (@ARGV) { + open OUT, ">$ARGV[0]" or die "$ARGV[0]: $!\n"; +} +else { + *OUT = \*STDOUT; +} + +my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc )); + +my %todo = %{&parse_todo}; + +my %tmap = ( + void => 'int', +); + +my %amap = ( + SP => 'SP', + type => 'int', + cast => 'int', +); + +my %void = ( + void => 1, + Free_t => 1, + Signal_t => 1, +); + +my %castvoid = ( + map { ($_ => 1) } qw( + Nullav + Nullcv + Nullhv + Nullch + Nullsv + HEf_SVKEY + SP + MARK + SVt_PV + SVt_IV + SVt_NV + SVt_PVMG + SVt_PVAV + SVt_PVHV + SVt_PVCV + SvUOK + G_SCALAR + G_ARRAY + G_VOID + G_DISCARD + G_EVAL + G_NOARGS + XS_VERSION + ), +); + +my %ignorerv = ( + map { ($_ => 1) } qw( + newCONSTSUB + ), +); + +my %stack = ( + ORIGMARK => ['dORIGMARK;'], + POPpx => ['STRLEN n_a;'], + POPpbytex => ['STRLEN n_a;'], + PUSHp => ['dTARG;'], + PUSHn => ['dTARG;'], + PUSHi => ['dTARG;'], + PUSHu => ['dTARG;'], + XPUSHp => ['dTARG;'], + XPUSHn => ['dTARG;'], + XPUSHi => ['dTARG;'], + XPUSHu => ['dTARG;'], + UNDERBAR => ['dUNDERBAR;'], +); + +my %postcode = ( + dSP => "some_global_var = !sp;", + dMARK => "some_global_var = !mark;", + dORIGMARK => "some_global_var = !origmark;", + dAX => "some_global_var = !ax;", + dITEMS => "some_global_var = !items;", + dXSARGS => "some_global_var = ax && items;", + NEWSV => "some_global_var = !arg1;", + New => "some_global_var = !arg1;", + Newc => "some_global_var = !arg1;", + Newz => "some_global_var = !arg1;", + dUNDERBAR => "(void) UNDERBAR;", +); + +my %ignore = ( + map { ($_ => 1) } qw( + svtype + items + ix + dXSI32 + XS + CLASS + THIS + RETVAL + StructCopy + ), +); + +print OUT <<HEAD; +/* + * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + * This file is built by $0. + * Any changes made here will be lost! + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef DPPP_APICHECK_NO_PPPORT_H + +#define NEED_eval_pv +#define NEED_grok_bin +#define NEED_grok_hex +#define NEED_grok_number +#define NEED_grok_numeric_radix +#define NEED_grok_oct +#define NEED_newCONSTSUB +#define NEED_newRV_noinc +#define NEED_sv_2pv_nolen +#define NEED_sv_2pvbyte +#define NEED_sv_catpvf_mg +#define NEED_sv_catpvf_mg_nocontext +#define NEED_sv_setpvf_mg +#define NEED_sv_setpvf_mg_nocontext +#define NEED_vnewSVpvf + + +#include "ppport.h" + +#endif + +static int some_global_var; + +static int VARarg1; +static char *VARarg2; +static double VARarg3; + +HEAD + +my $f; +for $f (@f) { + $ignore{$f->{name}} and next; + $f->{flags}{A} or next; # only public API members + + $ignore{$f->{name}} = 1; # ignore duplicates + + my $Perl_ = $f->{flags}{p} ? 'Perl_' : ''; + + my $stack = ''; + my @arg; + my $aTHX = ''; + + my $i = 1; + my $ca; + my $varargs = 0; + for $ca (@{$f->{args}}) { + my $a = $ca->[0]; + if ($a eq '...') { + $varargs = 1; + push @arg, qw(VARarg1 VARarg2 VARarg3); + last; + } + my($n, $p, $d) = $a =~ /^(\w+(?:\s+\w+)*)\s*(\**)((?:\[[^\]]*\])*)$/ or die; + if (exists $amap{$n}) { + push @arg, $amap{$n}; + next; + } + $n = $tmap{$n} || $n; + my $v = 'arg' . $i++; + push @arg, $v; + $stack .= " static $n $p$v$d;\n"; + } + + unless ($f->{flags}{n} || $f->{flags}{'m'}) { + $stack = " dTHX;\n$stack"; + $aTHX = @arg ? 'aTHX_ ' : 'aTHX'; + } + + if ($stack{$f->{name}}) { + my $s = ''; + for (@{$stack{$f->{name}}}) { + $s .= " $_\n"; + } + $stack = "$s$stack"; + } + + my $args = join ', ', @arg; + my $rvt = $f->{ret} || 'void'; + my $ret; + if ($void{$rvt}) { + $ret = $castvoid{$f->{name}} ? '(void) ' : ''; + } + else { + $ret = $ignorerv{$f->{name}} ? '(void) ' : "return "; + } + my $aTHX_args = "$aTHX$args"; + + my $post = ''; + if ($postcode{$f->{name}}) { + $post = $postcode{$f->{name}}; + $post =~ s/^/ /g; + $post = "\n$post"; + } + + unless ($f->{flags}{'m'} and @arg == 0) { + $args = "($args)"; + $aTHX_args = "($aTHX_args)"; + } + + print OUT <<HEAD; +/****************************************************************************** +* +* $f->{name} +* +******************************************************************************/ + +HEAD + + if ($todo{$f->{name}}) { + my($ver,$sub) = $todo{$f->{name}} =~ /^5\.(\d{3})(\d{3})$/ or die; + for ($ver, $sub) { + s/^0+(\d)/$1/ + } + if ($ver < 6 && $sub > 0) { + $sub =~ s/0$// or die; + } + print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n"; + } + + my $final = $varargs + ? "$Perl_$f->{name}$aTHX_args" + : "$f->{name}$args"; + + $f->{cond} and print OUT "#if $f->{cond}\n"; + + print OUT <<END; +$rvt _DPPP_test_$f->{name} (void) +{ + dXSARGS; +$stack +#ifdef $f->{name} + if (some_global_var) + { + $ret$f->{name}$args;$post + } +#endif + + some_global_var = items && ax; + + { +#ifdef $f->{name} + $ret$final;$post +#else + $ret$Perl_$f->{name}$aTHX_args;$post +#endif + } +} +END + + $f->{cond} and print OUT "#endif\n"; + $todo{$f->{name}} and print OUT "#endif\n"; + + print OUT "\n"; +} + +@ARGV and close OUT; + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apidoc.fnc b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apidoc.fnc new file mode 100644 index 00000000000..0e67f047d41 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apidoc.fnc @@ -0,0 +1,267 @@ +Am|bool|isALNUM|char ch +Am|bool|isALPHA|char ch +Am|bool|isDIGIT|char ch +Am|bool|isLOWER|char ch +Am|bool|isSPACE|char ch +Am|bool|isUPPER|char ch +Am|bool|strEQ|char* s1|char* s2 +Am|bool|strGE|char* s1|char* s2 +Am|bool|strGT|char* s1|char* s2 +Am|bool|strLE|char* s1|char* s2 +Am|bool|strLT|char* s1|char* s2 +Am|bool|strNE|char* s1|char* s2 +Am|bool|strnEQ|char* s1|char* s2|STRLEN len +Am|bool|strnNE|char* s1|char* s2|STRLEN len +Am|bool|SvIOK_notUV|SV* sv +Am|bool|SvIOKp|SV* sv +Am|bool|SvIOK|SV* sv +Am|bool|SvIOK_UV|SV* sv +Am|bool|SvIsCOW_shared_hash|SV* sv +Am|bool|SvIsCOW|SV* sv +Am|bool|SvNIOKp|SV* sv +Am|bool|SvNIOK|SV* sv +Am|bool|SvNOKp|SV* sv +Am|bool|SvNOK|SV* sv +Am|bool|SvOK|SV* sv +Am|bool|SvOOK|SV* sv +Am|bool|SvPOKp|SV* sv +Am|bool|SvPOK|SV* sv +Am|bool|SvROK|SV* sv +Am|bool|SvTAINTED|SV* sv +Am|bool|SvTRUE|SV* sv +Am|bool|SvUTF8|SV* sv +Am|bool|SvVOK|SV* sv +Am|char*|HePV|HE* he|STRLEN len +Am|char*|HvNAME|HV* stash +Am|char*|SvEND|SV* sv +Am|char *|SvGROW|SV* sv|STRLEN len +Am|char*|SvPVbyte_force|SV* sv|STRLEN len +Am|char*|SvPVbyte_nolen|SV* sv +Am|char*|SvPVbyte|SV* sv|STRLEN len +Am|char*|SvPVbytex_force|SV* sv|STRLEN len +Am|char*|SvPVbytex|SV* sv|STRLEN len +Am|char*|SvPV_force_nomg|SV* sv|STRLEN len +Am|char*|SvPV_force|SV* sv|STRLEN len +Am|char*|SvPV_nolen|SV* sv +Am|char*|SvPV_nomg|SV* sv|STRLEN len +Am|char*|SvPV|SV* sv|STRLEN len +Am|char*|SvPVutf8_force|SV* sv|STRLEN len +Am|char*|SvPVutf8_nolen|SV* sv +Am|char*|SvPVutf8|SV* sv|STRLEN len +Am|char*|SvPVutf8x_force|SV* sv|STRLEN len +Am|char*|SvPVutf8x|SV* sv|STRLEN len +Am|char*|SvPVX|SV* sv +Am|char*|SvPVx|SV* sv|STRLEN len +Am|char|toLOWER|char ch +Am|char|toUPPER|char ch +Am|HV*|CvSTASH|CV* cv +Am|HV*|SvSTASH|SV* sv +Am|int|AvFILL|AV* av +Am|IV|SvIV_nomg|SV* sv +Am|IV|SvIV|SV* sv +Am|IV|SvIVx|SV* sv +Am|IV|SvIVX|SV* sv +Amn|char*|CLASS +Amn|char*|POPp +Amn|char*|POPpbytex +Amn|char*|POPpx +Amn|HV*|PL_modglobal +Amn|I32|ax +Amn|I32|items +Amn|I32|ix +Amn|IV|POPi +Amn|long|POPl +Amn|NV|POPn +Amn|STRLEN|PL_na +Amn|SV|PL_sv_no +Amn|SV|PL_sv_undef +Amn|SV|PL_sv_yes +Amn|SV*|POPs +Amn|U32|GIMME +Amn|U32|GIMME_V +Am|NV|SvNV|SV* sv +Am|NV|SvNVx|SV* sv +Am|NV|SvNVX|SV* sv +Amn|(whatever)|RETVAL +Amn|(whatever)|THIS +Ams||dAX +Ams||dITEMS +Ams||dMARK +Ams||dORIGMARK +Ams||dSP +Ams||dUNDERBAR +Ams||dXSARGS +Ams||dXSI32 +Ams||ENTER +Ams||FREETMPS +Ams||LEAVE +Ams||PUTBACK +Ams||SAVETMPS +Ams||SPAGAIN +Am|STRLEN|HeKLEN|HE* he +Am|STRLEN|SvCUR|SV* sv +Am|STRLEN|SvLEN|SV* sv +Am|SV*|GvSV|GV* gv +Am|SV*|HeSVKEY_force|HE* he +Am|SV*|HeSVKEY|HE* he +Am|SV*|HeSVKEY_set|HE* he|SV* sv +Am|SV*|HeVAL|HE* he +Am|SV*|newRV_inc|SV* sv +Am|SV*|NEWSV|int id|STRLEN len +Am|SV*|ST|int ix +Am|SV*|SvREFCNT_inc|SV* sv +Am|SV*|SvRV|SV* sv +Am|svtype|SvTYPE|SV* sv +Ams||XSRETURN_EMPTY +Ams||XSRETURN_NO +Ams||XSRETURN_UNDEF +Ams||XSRETURN_YES +Ams||XS_VERSION_BOOTCHECK +Am|U32|HeHASH|HE* he +Am|U32|SvREFCNT|SV* sv +AmU||G_ARRAY +AmU||G_DISCARD +AmU||G_EVAL +AmU||G_NOARGS +AmU||G_SCALAR +AmU||G_VOID +AmU||HEf_SVKEY +AmU||MARK +AmU||newXSproto|char* name|XSUBADDR_t f|char* filename|const char *proto +AmU||Nullav +AmU||Nullch +AmU||Nullcv +AmU||Nullhv +AmU||Nullsv +AmU||ORIGMARK +AmU||SP +AmU||SVt_IV +AmU||SVt_NV +AmU||SVt_PV +AmU||SVt_PVAV +AmU||SVt_PVCV +AmU||SVt_PVHV +AmU||SVt_PVMG +AmU||svtype +AmU||UNDERBAR +Am|UV|SvUV_nomg|SV* sv +Am|UV|SvUV|SV* sv +Am|UV|SvUVx|SV* sv +Am|UV|SvUVX|SV* sv +AmU||XS +AmU||XS_VERSION +Am|void *|CopyD|void* src|void* dest|int nitems|type +Am|void|Copy|void* src|void* dest|int nitems|type +Am|void|EXTEND|SP|int nitems +Am|void*|HeKEY|HE* he +Am|void *|MoveD|void* src|void* dest|int nitems|type +Am|void|Move|void* src|void* dest|int nitems|type +Am|void|mPUSHi|IV iv +Am|void|mPUSHn|NV nv +Am|void|mPUSHp|char* str|STRLEN len +Am|void|mPUSHu|UV uv +Am|void|mXPUSHi|IV iv +Am|void|mXPUSHn|NV nv +Am|void|mXPUSHp|char* str|STRLEN len +Am|void|mXPUSHu|UV uv +Am|void|Newc|int id|void* ptr|int nitems|type|cast +Am|void|New|int id|void* ptr|int nitems|type +Am|void|Newz|int id|void* ptr|int nitems|type +Am|void|Poison|void* dest|int nitems|type +Am|void|PUSHi|IV iv +Am|void|PUSHMARK|SP +Am|void|PUSHmortal +Am|void|PUSHn|NV nv +Am|void|PUSHp|char* str|STRLEN len +Am|void|PUSHs|SV* sv +Am|void|PUSHu|UV uv +Am|void|Renewc|void* ptr|int nitems|type|cast +Am|void|Renew|void* ptr|int nitems|type +Am|void|Safefree|void* ptr +Am|void|StructCopy|type src|type dest|type +Am|void|sv_catpvn_nomg|SV* sv|const char* ptr|STRLEN len +Am|void|sv_catsv_nomg|SV* dsv|SV* ssv +Am|void|SvCUR_set|SV* sv|STRLEN len +Am|void|SvGETMAGIC|SV* sv +Am|void|SvIOK_off|SV* sv +Am|void|SvIOK_only|SV* sv +Am|void|SvIOK_only_UV|SV* sv +Am|void|SvIOK_on|SV* sv +Am|void|SvLOCK|SV* sv +Am|void|SvNIOK_off|SV* sv +Am|void|SvNOK_off|SV* sv +Am|void|SvNOK_only|SV* sv +Am|void|SvNOK_on|SV* sv +Am|void|SvPOK_off|SV* sv +Am|void|SvPOK_only|SV* sv +Am|void|SvPOK_only_UTF8|SV* sv +Am|void|SvPOK_on|SV* sv +Am|void|SvREFCNT_dec|SV* sv +Am|void|SvROK_off|SV* sv +Am|void|SvROK_on|SV* sv +Am|void|SvSetMagicSV_nosteal|SV* dsv|SV* ssv +Am|void|SvSETMAGIC|SV* sv +Am|void|SvSetMagicSV|SV* dsb|SV* ssv +Am|void|sv_setsv_nomg|SV* dsv|SV* ssv +Am|void|SvSetSV_nosteal|SV* dsv|SV* ssv +Am|void|SvSetSV|SV* dsb|SV* ssv +Am|void|SvSHARE|SV* sv +Am|void|SvTAINTED_off|SV* sv +Am|void|SvTAINTED_on|SV* sv +Am|void|SvTAINT|SV* sv +Am|void|SvUNLOCK|SV* sv +Am|void|SvUOK|SV* sv +Am|void|SvUPGRADE|SV* sv|svtype type +Am|void|SvUTF8_off|SV *sv +Am|void|SvUTF8_on|SV *sv +Am|void|XPUSHi|IV iv +Am|void|XPUSHmortal +Am|void|XPUSHn|NV nv +Am|void|XPUSHp|char* str|STRLEN len +Am|void|XPUSHs|SV* sv +Am|void|XPUSHu|UV uv +Am|void|XSRETURN|int nitems +Am|void|XSRETURN_IV|IV iv +Am|void|XSRETURN_NV|NV nv +Am|void|XSRETURN_PV|char* str +Am|void|XSRETURN_UV|IV uv +Am|void|XST_mIV|int pos|IV iv +Am|void|XST_mNO|int pos +Am|void|XST_mNV|int pos|NV nv +Am|void|XST_mPV|int pos|char* str +Am|void|XST_mUNDEF|int pos +Am|void|XST_mYES|int pos +Am|void *|ZeroD|void* dest|int nitems|type +Am|void|Zero|void* dest|int nitems|type +m|AV *|CvPADLIST|CV *cv +m|bool|CvWEAKOUTSIDE|CV *cv +m|char *|PAD_COMPNAME_PV|PADOFFSET po +m|HV *|PAD_COMPNAME_OURSTASH|PADOFFSET po +m|HV *|PAD_COMPNAME_TYPE|PADOFFSET po +mn|bool|PL_dowarn +mn|GV *|PL_DBsub +mn|GV*|PL_last_in_gv +mn|SV *|PL_DBsingle +mn|SV *|PL_DBtrace +mn|SV*|PL_ofs_sv +mn|SV*|PL_rs +ms||djSP +m|STRLEN|PAD_COMPNAME_GEN|PADOFFSET po +m|SV *|CX_CURPAD_SV|struct context|PADOFFSET po +m|SV *|PAD_BASE_SV |PADLIST padlist|PADOFFSET po +m|SV *|PAD_SETSV |PADOFFSET po|SV* sv +m|SV *|PAD_SVl |PADOFFSET po +m|U32|PAD_COMPNAME_FLAGS|PADOFFSET po +mU||LVRET +m|void|CX_CURPAD_SAVE|struct context +m|void|PAD_CLONE_VARS|PerlInterpreter *proto_perl \ +m|void|PAD_DUP|PADLIST dstpad|PADLIST srcpad|CLONE_PARAMS* param +m|void|PAD_RESTORE_LOCAL|PAD *opad +m|void|PAD_SAVE_LOCAL|PAD *opad|PAD *npad +m|void|PAD_SAVE_SETNULLPAD +m|void|PAD_SET_CUR_NOSAVE |PADLIST padlist|I32 n +m|void|PAD_SET_CUR |PADLIST padlist|I32 n +m|void|PAD_SV |PADOFFSET po +m|void|SAVECLEARSV |SV **svp +m|void|SAVECOMPPAD +m|void|SAVEPADSV |PADOFFSET po diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004000 new file mode 100644 index 00000000000..795d0cbc01c --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004000 @@ -0,0 +1,48 @@ +5.004000 +GIMME_V # E +G_VOID # E +HEf_SVKEY # E +HeHASH # U +HeKEY # E +HeKLEN # U +HePV # E +HeSVKEY # E +HeSVKEY_force # E +HeSVKEY_set # E +HeVAL # E +PUSHu # U +SvSetMagicSV # U +SvSetMagicSV_nosteal # U +SvSetSV_nosteal # U +SvTAINTED # U +SvTAINTED_off # U +SvTAINTED_on # U +SvUV # U +SvUVX # U +SvUVx # U +XPUSHu # U +my_memcmp # U +newRV_inc # E +sv_2uv # U +PERL_INT_MAX # added by devel/scanprov +PERL_INT_MIN # added by devel/scanprov +PERL_LONG_MAX # added by devel/scanprov +PERL_LONG_MIN # added by devel/scanprov +PERL_QUAD_MAX # added by devel/scanprov +PERL_QUAD_MIN # added by devel/scanprov +PERL_SHORT_MAX # added by devel/scanprov +PERL_SHORT_MIN # added by devel/scanprov +PERL_UCHAR_MAX # added by devel/scanprov +PERL_UCHAR_MIN # added by devel/scanprov +PERL_UINT_MAX # added by devel/scanprov +PERL_UINT_MIN # added by devel/scanprov +PERL_ULONG_MAX # added by devel/scanprov +PERL_ULONG_MIN # added by devel/scanprov +PERL_UQUAD_MAX # added by devel/scanprov +PERL_UQUAD_MIN # added by devel/scanprov +PERL_USHORT_MAX # added by devel/scanprov +PERL_USHORT_MIN # added by devel/scanprov +SvUVXx # added by devel/scanprov +boolSV # added by devel/scanprov +memEQ # added by devel/scanprov +memNE # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004010 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004010 new file mode 100644 index 00000000000..8c298666039 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004010 @@ -0,0 +1 @@ +5.004010 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004020 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004020 new file mode 100644 index 00000000000..4b43fdf8e46 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004020 @@ -0,0 +1 @@ +5.004020 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004030 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004030 new file mode 100644 index 00000000000..e45facbb1f9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004030 @@ -0,0 +1 @@ +5.004030 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004040 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004040 new file mode 100644 index 00000000000..69ccd5d62c5 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004040 @@ -0,0 +1 @@ +5.004040 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004050 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004050 new file mode 100644 index 00000000000..4b43177c8ca --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004050 @@ -0,0 +1,29 @@ +5.004050 +PL_na # E +PL_sv_no # E +PL_sv_undef # E +PL_sv_yes # E +SvGETMAGIC # U +AvFILLp # added by devel/scanprov +DEFSV # added by devel/scanprov +ERRSV # added by devel/scanprov +PL_compiling # added by devel/scanprov +PL_curcop # added by devel/scanprov +PL_curstash # added by devel/scanprov +PL_defgv # added by devel/scanprov +PL_dirty # added by devel/scanprov +PL_perldb # added by devel/scanprov +PL_rsfp # added by devel/scanprov +PL_rsfp_filters # added by devel/scanprov +PL_stdingv # added by devel/scanprov +SAVE_DEFSV # added by devel/scanprov +dTHR # added by devel/scanprov +PL_debstash # added by devel/scanprov +PL_diehook # added by devel/scanprov +PL_errgv # added by devel/scanprov +PL_perl_destruct_level # added by devel/scanprov +PL_stack_base # added by devel/scanprov +PL_stack_sp # added by devel/scanprov +PL_sv_arenaroot # added by devel/scanprov +PL_tainted # added by devel/scanprov +PL_tainting # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005000 new file mode 100644 index 00000000000..f0bfeed5a2e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005000 @@ -0,0 +1,10 @@ +5.005000 +PL_modglobal # E +NOOP # added by devel/scanprov +PL_Sv # added by devel/scanprov +PL_copline # added by devel/scanprov +PL_hexdigit # added by devel/scanprov +PL_hints # added by devel/scanprov +END_EXTERN_C # added by devel/scanprov +EXTERN_C # added by devel/scanprov +START_EXTERN_C # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005010 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005010 new file mode 100644 index 00000000000..deebff5bf8a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005010 @@ -0,0 +1 @@ +5.005010 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005020 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005020 new file mode 100644 index 00000000000..d19ff2ae09e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005020 @@ -0,0 +1 @@ +5.005020 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005030 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005030 new file mode 100644 index 00000000000..3a7d375072b --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005030 @@ -0,0 +1,2 @@ +5.005030 +POPpx # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005040 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005040 new file mode 100644 index 00000000000..8a165c20337 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005040 @@ -0,0 +1 @@ +5.005040 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006000 new file mode 100644 index 00000000000..6705683ed3a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006000 @@ -0,0 +1,504 @@ +5.006000 +Gv_AMupdate # E (Perl_Gv_AMupdate) +POPn # E +PUSHn # E +SvIOK_UV # U +SvIOK_notUV # U +SvIOK_only_UV # U +SvNV # E +SvNVX # E +SvNVx # E +SvPOK_only_UTF8 # U +SvPV_nolen # E +SvPVbyte # E +SvPVbyte_nolen # E +SvPVbytex # E +SvPVbytex_force # E +SvPVutf8 # E +SvPVutf8_force # E +SvPVutf8_nolen # E +SvPVutf8x # E +SvPVutf8x_force # E +SvUTF8 # U +SvUTF8_off # U +SvUTF8_on # U +XPUSHn # E +XSRETURN_NV # E +XST_mNV # E +amagic_call # E (Perl_amagic_call) +av_clear # E (Perl_av_clear) +av_delete # E +av_exists # E +av_extend # E (Perl_av_extend) +av_fetch # E (Perl_av_fetch) +av_fill # E (Perl_av_fill) +av_len # E (Perl_av_len) +av_make # E (Perl_av_make) +av_pop # E (Perl_av_pop) +av_push # E (Perl_av_push) +av_shift # E (Perl_av_shift) +av_store # E (Perl_av_store) +av_undef # E (Perl_av_undef) +av_unshift # E (Perl_av_unshift) +block_gimme # E (Perl_block_gimme) +call_argv # E (perl_call_argv) +call_atexit # E +call_list # E (Perl_call_list) +call_method # E (perl_call_method) +call_pv # E (perl_call_pv) +call_sv # E (perl_call_sv) +cast_i32 # E (cast_i32) +cast_iv # E (cast_iv) +cast_ulong # E +cast_uv # E (cast_uv) +croak # E (Perl_croak) +cv_const_sv # E (Perl_cv_const_sv) +cv_undef # E (Perl_cv_undef) +cx_dump # E (Perl_cx_dump) +debop # E (Perl_debop) +debprofdump # E (Perl_debprofdump) +delimcpy # E (Perl_delimcpy) +die # E (Perl_die) +do_binmode # E (Perl_do_binmode) +do_close # E (Perl_do_close) +do_gv_dump # E +do_gvgv_dump # E +do_hv_dump # E +do_join # E (Perl_do_join) +do_magic_dump # E +do_op_dump # E +do_open # E (Perl_do_open) +do_open9 # E +do_pmop_dump # E +do_sprintf # E (Perl_do_sprintf) +do_sv_dump # E +dounwind # E (Perl_dounwind) +dowantarray # E (Perl_dowantarray) +dump_all # E +dump_eval # E +dump_form # E +dump_indent # E +dump_packsubs # E +dump_sub # E +dump_vindent # E +eval_pv # E (perl_eval_pv) +eval_sv # E (perl_eval_sv) +fbm_compile # E (Perl_fbm_compile) +fbm_instr # E (Perl_fbm_instr) +filter_add # E (Perl_filter_add) +filter_del # E (Perl_filter_del) +filter_read # E (Perl_filter_read) +form # E (Perl_form) +free_tmps # E (Perl_free_tmps) +get_av # E (perl_get_av) +get_context # E +get_cv # E (perl_get_cv) +get_hv # E (perl_get_hv) +get_op_descs # E (Perl_get_op_descs) +get_op_names # E (Perl_get_op_names) +get_ppaddr # E +get_sv # E (perl_get_sv) +get_vtbl # E (Perl_get_vtbl) +gp_free # E (Perl_gp_free) +gp_ref # E (Perl_gp_ref) +gv_AVadd # E (Perl_gv_AVadd) +gv_HVadd # E (Perl_gv_HVadd) +gv_IOadd # E (Perl_gv_IOadd) +gv_autoload4 # E (Perl_gv_autoload4) +gv_check # E (Perl_gv_check) +gv_dump # E +gv_efullname # E (Perl_gv_efullname) +gv_efullname3 # E (Perl_gv_efullname3) +gv_fetchfile # E (Perl_gv_fetchfile) +gv_fetchmeth # E (Perl_gv_fetchmeth) +gv_fetchmethod # E (Perl_gv_fetchmethod) +gv_fetchmethod_autoload # E (Perl_gv_fetchmethod_autoload) +gv_fetchpv # E (Perl_gv_fetchpv) +gv_fullname # E (Perl_gv_fullname) +gv_fullname3 # E (Perl_gv_fullname3) +gv_init # E (Perl_gv_init) +gv_stashpv # E (Perl_gv_stashpv) +gv_stashpvn # E (Perl_gv_stashpvn) +gv_stashsv # E (Perl_gv_stashsv) +hv_clear # E (Perl_hv_clear) +hv_delayfree_ent # E (Perl_hv_delayfree_ent) +hv_delete # E (Perl_hv_delete) +hv_delete_ent # E (Perl_hv_delete_ent) +hv_exists # E (Perl_hv_exists) +hv_exists_ent # E (Perl_hv_exists_ent) +hv_fetch # E (Perl_hv_fetch) +hv_fetch_ent # E (Perl_hv_fetch_ent) +hv_free_ent # E (Perl_hv_free_ent) +hv_iterinit # E (Perl_hv_iterinit) +hv_iterkey # E (Perl_hv_iterkey) +hv_iterkeysv # E (Perl_hv_iterkeysv) +hv_iternext # E (Perl_hv_iternext) +hv_iternextsv # E (Perl_hv_iternextsv) +hv_iterval # E (Perl_hv_iterval) +hv_ksplit # E (Perl_hv_ksplit) +hv_magic # E (Perl_hv_magic) +hv_store # E (Perl_hv_store) +hv_store_ent # E (Perl_hv_store_ent) +hv_undef # E (Perl_hv_undef) +ibcmp # E (Perl_ibcmp) +ibcmp_locale # E (Perl_ibcmp_locale) +init_i18nl10n # E (perl_init_i18nl10n) +init_i18nl14n # E (perl_init_i18nl14n) +init_stacks # E (Perl_init_stacks) +instr # E (Perl_instr) +is_uni_alnum # E +is_uni_alnum_lc # E +is_uni_alnumc # E +is_uni_alnumc_lc # E +is_uni_alpha # E +is_uni_alpha_lc # E +is_uni_ascii # E +is_uni_ascii_lc # E +is_uni_cntrl # E +is_uni_cntrl_lc # E +is_uni_digit # E +is_uni_digit_lc # E +is_uni_graph # E +is_uni_graph_lc # E +is_uni_idfirst # E +is_uni_idfirst_lc # E +is_uni_lower # E +is_uni_lower_lc # E +is_uni_print # E +is_uni_print_lc # E +is_uni_punct # E +is_uni_punct_lc # E +is_uni_space # E +is_uni_space_lc # E +is_uni_upper # E +is_uni_upper_lc # E +is_uni_xdigit # E +is_uni_xdigit_lc # E +is_utf8_alnum # E +is_utf8_alnumc # E +is_utf8_alpha # E +is_utf8_ascii # E +is_utf8_char # E +is_utf8_cntrl # E +is_utf8_digit # E +is_utf8_graph # E +is_utf8_idfirst # E +is_utf8_lower # E +is_utf8_mark # E +is_utf8_print # E +is_utf8_punct # E +is_utf8_space # E +is_utf8_upper # E +is_utf8_xdigit # E +leave_scope # E (Perl_leave_scope) +load_module # E +looks_like_number # E (Perl_looks_like_number) +magic_dump # E +markstack_grow # E (Perl_markstack_grow) +mess # E (Perl_mess) +mg_clear # E (Perl_mg_clear) +mg_copy # E (Perl_mg_copy) +mg_find # E (Perl_mg_find) +mg_free # E (Perl_mg_free) +mg_get # E (Perl_mg_get) +mg_length # E (Perl_mg_length) +mg_magical # E (Perl_mg_magical) +mg_set # E (Perl_mg_set) +mg_size # E (Perl_mg_size) +moreswitches # E (Perl_moreswitches) +my_atof # E +my_exit # E (Perl_my_exit) +my_failure_exit # E (Perl_my_failure_exit) +my_fflush_all # E +my_lstat # E (Perl_my_lstat) +my_pclose # E (Perl_my_pclose) +my_popen # E (Perl_my_popen) +my_setenv # E (Perl_my_setenv) +my_stat # E (Perl_my_stat) +newANONATTRSUB # E +newANONHASH # E (Perl_newANONHASH) +newANONLIST # E (Perl_newANONLIST) +newANONSUB # E (Perl_newANONSUB) +newASSIGNOP # E (Perl_newASSIGNOP) +newATTRSUB # E +newAV # E (Perl_newAV) +newAVREF # E (Perl_newAVREF) +newBINOP # E (Perl_newBINOP) +newCONDOP # E (Perl_newCONDOP) +newCONSTSUB # E (Perl_newCONSTSUB) +newCVREF # E (Perl_newCVREF) +newFORM # E (Perl_newFORM) +newFOROP # E (Perl_newFOROP) +newGVOP # E (Perl_newGVOP) +newGVREF # E (Perl_newGVREF) +newGVgen # E (Perl_newGVgen) +newHV # E (Perl_newHV) +newHVREF # E (Perl_newHVREF) +newHVhv # E (Perl_newHVhv) +newIO # E (Perl_newIO) +newLISTOP # E (Perl_newLISTOP) +newLOGOP # E (Perl_newLOGOP) +newLOOPEX # E (Perl_newLOOPEX) +newLOOPOP # E (Perl_newLOOPOP) +newMYSUB # E +newNULLLIST # E (Perl_newNULLLIST) +newOP # E (Perl_newOP) +newPADOP # E +newPMOP # E (Perl_newPMOP) +newPROG # E (Perl_newPROG) +newPVOP # E (Perl_newPVOP) +newRANGE # E (Perl_newRANGE) +newRV # E (Perl_newRV) +newRV_noinc # E (Perl_newRV_noinc) +newSLICEOP # E (Perl_newSLICEOP) +newSTATEOP # E (Perl_newSTATEOP) +newSUB # E (Perl_newSUB) +newSV # E (Perl_newSV) +newSVOP # E (Perl_newSVOP) +newSVREF # E (Perl_newSVREF) +newSViv # E (Perl_newSViv) +newSVnv # E (Perl_newSVnv) +newSVpv # E (Perl_newSVpv) +newSVpvf # E (Perl_newSVpvf) +newSVpvn # E (Perl_newSVpvn) +newSVrv # E (Perl_newSVrv) +newSVsv # E (Perl_newSVsv) +newSVuv # E +newUNOP # E (Perl_newUNOP) +newWHILEOP # E (Perl_newWHILEOP) +newXS # E (Perl_newXS) +newXSproto # E +new_collate # E (perl_new_collate) +new_ctype # E (perl_new_ctype) +new_numeric # E (perl_new_numeric) +new_stackinfo # E (Perl_new_stackinfo) +ninstr # E (Perl_ninstr) +op_dump # E +op_free # E (Perl_op_free) +pad_sv # E (Perl_pad_sv) +perl_parse # E (perl_parse) +pmflag # E (Perl_pmflag) +pmop_dump # E +pop_scope # E (Perl_pop_scope) +pregcomp # E (Perl_pregcomp) +pregexec # E (Perl_pregexec) +pregfree # E (Perl_pregfree) +push_scope # E (Perl_push_scope) +pv_display # E +re_intuit_start # E +re_intuit_string # E +regdump # E (Perl_regdump) +regexec_flags # E (Perl_regexec_flags) +reginitcolors # E +regnext # E (Perl_regnext) +repeatcpy # E (Perl_repeatcpy) +require_pv # E (perl_require_pv) +rninstr # E (Perl_rninstr) +rsignal # E (Perl_rsignal) +rsignal_state # E (Perl_rsignal_state) +runops_debug # E (Perl_runops_debug) +runops_standard # E (Perl_runops_standard) +safesyscalloc # E +safesysfree # U +safesysmalloc # E +safesysrealloc # E +save_I16 # E (Perl_save_I16) +save_I32 # E (Perl_save_I32) +save_I8 # E +save_aelem # E (Perl_save_aelem) +save_alloc # E +save_aptr # E (Perl_save_aptr) +save_ary # E (Perl_save_ary) +save_clearsv # E (Perl_save_clearsv) +save_delete # E (Perl_save_delete) +save_destructor # E (Perl_save_destructor) +save_destructor_x # E +save_freepv # E (Perl_save_freepv) +save_freesv # E (Perl_save_freesv) +save_generic_svref # E (Perl_save_generic_svref) +save_gp # E (Perl_save_gp) +save_hash # E (Perl_save_hash) +save_helem # E (Perl_save_helem) +save_hints # E (Perl_save_hints) +save_hptr # E (Perl_save_hptr) +save_int # E (Perl_save_int) +save_item # E (Perl_save_item) +save_iv # E (Perl_save_iv) +save_list # E (Perl_save_list) +save_long # E (Perl_save_long) +save_nogv # E (Perl_save_nogv) +save_pptr # E (Perl_save_pptr) +save_re_context # E +save_scalar # E (Perl_save_scalar) +save_sptr # E (Perl_save_sptr) +save_svref # E (Perl_save_svref) +save_threadsv # E (Perl_save_threadsv) +save_vptr # E +savepv # E (Perl_savepv) +savepvn # E (Perl_savepvn) +savestack_grow # E (Perl_savestack_grow) +scan_bin # E +scan_hex # E (Perl_scan_hex) +scan_oct # E (Perl_scan_oct) +screaminstr # E (Perl_screaminstr) +set_context # U +set_numeric_local # E (perl_set_numeric_local) +set_numeric_radix # E +set_numeric_standard # E (perl_set_numeric_standard) +stack_grow # E (Perl_stack_grow) +start_subparse # E (Perl_start_subparse) +str_to_version # E +sv_2bool # E (Perl_sv_2bool) +sv_2cv # E (Perl_sv_2cv) +sv_2io # E (Perl_sv_2io) +sv_2mortal # E (Perl_sv_2mortal) +sv_2nv # E (Perl_sv_2nv) +sv_2pv_nolen # E +sv_2pvbyte # E +sv_2pvbyte_nolen # E +sv_2pvutf8 # E +sv_2pvutf8_nolen # E +sv_backoff # E (Perl_sv_backoff) +sv_bless # E (Perl_sv_bless) +sv_catpv # E (Perl_sv_catpv) +sv_catpv_mg # E (Perl_sv_catpv_mg) +sv_catpvf # E (Perl_sv_catpvf) +sv_catpvf_mg # E (Perl_sv_catpvf_mg) +sv_catpvn_mg # E (Perl_sv_catpvn_mg) +sv_catsv_mg # E (Perl_sv_catsv_mg) +sv_chop # E (Perl_sv_chop) +sv_clear # E (Perl_sv_clear) +sv_cmp # E (Perl_sv_cmp) +sv_cmp_locale # E (Perl_sv_cmp_locale) +sv_collxfrm # E (Perl_sv_collxfrm) +sv_dec # E (Perl_sv_dec) +sv_derived_from # E (Perl_sv_derived_from) +sv_dump # E (Perl_sv_dump) +sv_eq # E (Perl_sv_eq) +sv_force_normal # E +sv_free # E (Perl_sv_free) +sv_gets # E (Perl_sv_gets) +sv_grow # E (Perl_sv_grow) +sv_inc # E (Perl_sv_inc) +sv_insert # E (Perl_sv_insert) +sv_isa # E (Perl_sv_isa) +sv_isobject # E (Perl_sv_isobject) +sv_iv # E (Perl_sv_iv) +sv_len # E (Perl_sv_len) +sv_len_utf8 # E +sv_magic # E (Perl_sv_magic) +sv_mortalcopy # E (Perl_sv_mortalcopy) +sv_newmortal # E (Perl_sv_newmortal) +sv_newref # E (Perl_sv_newref) +sv_nv # E (Perl_sv_nv) +sv_peek # E (Perl_sv_peek) +sv_pos_b2u # E +sv_pos_u2b # E +sv_pv # E +sv_pvbyte # E +sv_pvbyten # E +sv_pvbyten_force # E +sv_pvn # E (Perl_sv_pvn) +sv_pvutf8 # E +sv_pvutf8n # E +sv_pvutf8n_force # E +sv_reftype # E (Perl_sv_reftype) +sv_replace # E (Perl_sv_replace) +sv_report_used # E (Perl_sv_report_used) +sv_reset # E (Perl_sv_reset) +sv_rvweaken # E +sv_setiv # E (Perl_sv_setiv) +sv_setiv_mg # E (Perl_sv_setiv_mg) +sv_setnv # E (Perl_sv_setnv) +sv_setnv_mg # E (Perl_sv_setnv_mg) +sv_setpv # E (Perl_sv_setpv) +sv_setpv_mg # E (Perl_sv_setpv_mg) +sv_setpvf # E (Perl_sv_setpvf) +sv_setpvf_mg # E (Perl_sv_setpvf_mg) +sv_setpvn # E (Perl_sv_setpvn) +sv_setpvn_mg # E (Perl_sv_setpvn_mg) +sv_setref_iv # E (Perl_sv_setref_iv) +sv_setref_nv # E (Perl_sv_setref_nv) +sv_setref_pv # E (Perl_sv_setref_pv) +sv_setref_pvn # E (Perl_sv_setref_pvn) +sv_setsv_mg # E (Perl_sv_setsv_mg) +sv_setuv # E (Perl_sv_setuv) +sv_setuv_mg # E (Perl_sv_setuv_mg) +sv_taint # E (Perl_sv_taint) +sv_tainted # E (Perl_sv_tainted) +sv_true # E (Perl_sv_true) +sv_unmagic # E (Perl_sv_unmagic) +sv_unref # E (Perl_sv_unref) +sv_untaint # E (Perl_sv_untaint) +sv_upgrade # E (Perl_sv_upgrade) +sv_usepvn # E (Perl_sv_usepvn) +sv_usepvn_mg # E (Perl_sv_usepvn_mg) +sv_utf8_decode # E +sv_utf8_downgrade # E +sv_utf8_encode # E +sv_uv # E (Perl_sv_uv) +sv_vcatpvf # E +sv_vcatpvf_mg # E +sv_vcatpvfn # E (Perl_sv_vcatpvfn) +sv_vsetpvf # E +sv_vsetpvf_mg # E +sv_vsetpvfn # E (Perl_sv_vsetpvfn) +swash_init # E +taint_env # E (Perl_taint_env) +taint_proper # E (Perl_taint_proper) +tmps_grow # E +to_uni_lower_lc # E +to_uni_title_lc # E +to_uni_upper_lc # E +unsharepvn # E (Perl_unsharepvn) +utf8_distance # E +utf8_hop # E +vcroak # E +vform # E +vload_module # E +vmess # E +vnewSVpvf # E +vwarn # E +vwarner # E +warn # E (Perl_warn) +warner # E +whichsig # E (Perl_whichsig) +CopFILE # added by devel/scanprov +CopFILEAV # added by devel/scanprov +CopFILEGV # added by devel/scanprov +CopFILEGV_set # added by devel/scanprov +CopFILESV # added by devel/scanprov +CopFILE_set # added by devel/scanprov +CopSTASH # added by devel/scanprov +CopSTASHPV # added by devel/scanprov +CopSTASHPV_set # added by devel/scanprov +CopSTASH_eq # added by devel/scanprov +CopSTASH_set # added by devel/scanprov +INT2PTR # added by devel/scanprov +IVSIZE # added by devel/scanprov +IVTYPE # added by devel/scanprov +IVdf # added by devel/scanprov +NUM2PTR # added by devel/scanprov +NVTYPE # added by devel/scanprov +PERL_REVISION # added by devel/scanprov +PERL_SUBVERSION # added by devel/scanprov +PERL_VERSION # added by devel/scanprov +PTR2IV # added by devel/scanprov +PTR2NV # added by devel/scanprov +PTR2UV # added by devel/scanprov +PTRV # added by devel/scanprov +UVSIZE # added by devel/scanprov +UVTYPE # added by devel/scanprov +UVof # added by devel/scanprov +UVuf # added by devel/scanprov +UVxf # added by devel/scanprov +aTHX # added by devel/scanprov +aTHX_ # added by devel/scanprov +dNOOP # added by devel/scanprov +dTHX # added by devel/scanprov +dTHXa # added by devel/scanprov +dTHXoa # added by devel/scanprov +pTHX # added by devel/scanprov +pTHX_ # added by devel/scanprov +PL_no_modify # added by devel/scanprov +PL_ppaddr # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006001 new file mode 100644 index 00000000000..eaebd5662a2 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006001 @@ -0,0 +1,13 @@ +5.006001 +apply_attrs_string # U +bytes_to_utf8 # E +gv_efullname4 # U +gv_fullname4 # U +is_utf8_string # U +save_generic_pvref # U +utf16_to_utf8 # E (Perl_utf16_to_utf8) +utf16_to_utf8_reversed # E (Perl_utf16_to_utf8_reversed) +utf8_to_bytes # E +NVef # added by devel/scanprov +NVff # added by devel/scanprov +NVgf # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006002 new file mode 100644 index 00000000000..dfe09ce2c59 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006002 @@ -0,0 +1 @@ +5.006002 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007000 new file mode 100644 index 00000000000..49d08465db8 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007000 @@ -0,0 +1 @@ +5.007000 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007001 new file mode 100644 index 00000000000..4c436af970d --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007001 @@ -0,0 +1,27 @@ +5.007001 +POPpbytex # E +SvUOK # U +bytes_from_utf8 # E +csighandler # U +despatch_signals # U +do_openn # U +gv_handler # E +is_lvalue_sub # U +my_popen_list # E +newSVpvn_share # E +save_mortalizesv # U +save_padsv # U +scan_num # E (Perl_scan_num) +sv_force_normal_flags # U +sv_setref_uv # E +sv_unref_flags # U +sv_utf8_upgrade # E (Perl_sv_utf8_upgrade) +utf8_length # U +utf8_to_uvchr # U +utf8_to_uvuni # U +utf8n_to_uvchr # U +utf8n_to_uvuni # U +uvchr_to_utf8 # E +uvuni_to_utf8 # E +PTR2ul # added by devel/scanprov +UVXf # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007002 new file mode 100644 index 00000000000..8efc9784ef5 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007002 @@ -0,0 +1,71 @@ +5.007002 +SvPV_force_nomg # E +SvPV_nomg # E +calloc # E +dAX # E +dITEMS # E +getcwd_sv # U +grok_number # U +grok_numeric_radix # U +init_tm # U +malloc # E +mfree # U +mini_mktime # U +my_atof2 # E +my_strftime # E +op_null # U +realloc # E +sv_2pv_flags # E +sv_catpvn_flags # U +sv_catpvn_nomg # U +sv_catsv_flags # U +sv_catsv_nomg # U +sv_pvn_force_flags # E +sv_setsv_flags # U +sv_setsv_nomg # U +sv_utf8_upgrade_flags # U +swash_fetch # E (Perl_swash_fetch) +GROK_NUMERIC_RADIX # added by devel/scanprov +IN_LOCALE # added by devel/scanprov +IN_LOCALE_COMPILETIME # added by devel/scanprov +IN_LOCALE_RUNTIME # added by devel/scanprov +IS_NUMBER_GREATER_THAN_UV_MAX # added by devel/scanprov +IS_NUMBER_INFINITY # added by devel/scanprov +IS_NUMBER_IN_UV # added by devel/scanprov +IS_NUMBER_NEG # added by devel/scanprov +IS_NUMBER_NOT_INT # added by devel/scanprov +PERL_MAGIC_arylen # added by devel/scanprov +PERL_MAGIC_backref # added by devel/scanprov +PERL_MAGIC_bm # added by devel/scanprov +PERL_MAGIC_collxfrm # added by devel/scanprov +PERL_MAGIC_dbfile # added by devel/scanprov +PERL_MAGIC_dbline # added by devel/scanprov +PERL_MAGIC_defelem # added by devel/scanprov +PERL_MAGIC_env # added by devel/scanprov +PERL_MAGIC_envelem # added by devel/scanprov +PERL_MAGIC_ext # added by devel/scanprov +PERL_MAGIC_fm # added by devel/scanprov +PERL_MAGIC_glob # added by devel/scanprov +PERL_MAGIC_isa # added by devel/scanprov +PERL_MAGIC_isaelem # added by devel/scanprov +PERL_MAGIC_mutex # added by devel/scanprov +PERL_MAGIC_nkeys # added by devel/scanprov +PERL_MAGIC_overload # added by devel/scanprov +PERL_MAGIC_overload_elem # added by devel/scanprov +PERL_MAGIC_overload_table # added by devel/scanprov +PERL_MAGIC_pos # added by devel/scanprov +PERL_MAGIC_qr # added by devel/scanprov +PERL_MAGIC_regdata # added by devel/scanprov +PERL_MAGIC_regdatum # added by devel/scanprov +PERL_MAGIC_regex_global # added by devel/scanprov +PERL_MAGIC_sig # added by devel/scanprov +PERL_MAGIC_sigelem # added by devel/scanprov +PERL_MAGIC_substr # added by devel/scanprov +PERL_MAGIC_sv # added by devel/scanprov +PERL_MAGIC_taint # added by devel/scanprov +PERL_MAGIC_tied # added by devel/scanprov +PERL_MAGIC_tiedelem # added by devel/scanprov +PERL_MAGIC_tiedscalar # added by devel/scanprov +PERL_MAGIC_uvar # added by devel/scanprov +PERL_MAGIC_vec # added by devel/scanprov +PERL_UNUSED_DECL # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007003 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007003 new file mode 100644 index 00000000000..2d4166822eb --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007003 @@ -0,0 +1,86 @@ +5.007003 +PerlIO_clearerr # E (PerlIO_clearerr) +PerlIO_close # E (PerlIO_close) +PerlIO_eof # E (PerlIO_eof) +PerlIO_error # E (PerlIO_error) +PerlIO_fileno # E (PerlIO_fileno) +PerlIO_fill # E (PerlIO_fill) +PerlIO_flush # E (PerlIO_flush) +PerlIO_get_base # E (PerlIO_get_base) +PerlIO_get_bufsiz # E (PerlIO_get_bufsiz) +PerlIO_get_cnt # E (PerlIO_get_cnt) +PerlIO_get_ptr # E (PerlIO_get_ptr) +PerlIO_read # E (PerlIO_read) +PerlIO_seek # E (PerlIO_seek) +PerlIO_set_cnt # E (PerlIO_set_cnt) +PerlIO_set_ptrcnt # E (PerlIO_set_ptrcnt) +PerlIO_setlinebuf # E (PerlIO_setlinebuf) +PerlIO_stderr # E (PerlIO_stderr) +PerlIO_stdin # E (PerlIO_stdin) +PerlIO_stdout # E (PerlIO_stdout) +PerlIO_tell # E (PerlIO_tell) +PerlIO_unread # E (PerlIO_unread) +PerlIO_write # E (PerlIO_write) +SvLOCK # E +SvSHARE # E +SvUNLOCK # E +atfork_lock # E +atfork_unlock # E +custom_op_desc # E +custom_op_name # E +deb # U +debstack # U +debstackptrs # U +grok_bin # E +grok_hex # E +grok_oct # E +gv_fetchmeth_autoload # E +ibcmp_utf8 # E +my_fork # E +my_socketpair # E +pack_cat # E +perl_destruct # E (perl_destruct) +pv_uni_display # E +regclass_swash # E (Perl_regclass_swash) +save_shared_pvref # E +savesharedpv # E +sortsv # E +sv_copypv # E +sv_magicext # E +sv_nolocking # E +sv_nosharing # E +sv_nounlocking # E +sv_pvn_nomg # E +sv_recode_to_utf8 # E +sv_uni_display # E +to_uni_fold # E +to_uni_lower # E (Perl_to_uni_lower) +to_uni_title # E (Perl_to_uni_title) +to_uni_upper # E (Perl_to_uni_upper) +to_utf8_case # E +to_utf8_fold # E +to_utf8_lower # E (Perl_to_utf8_lower) +to_utf8_title # E (Perl_to_utf8_title) +to_utf8_upper # E (Perl_to_utf8_upper) +unpack_str # E +uvchr_to_utf8_flags # E +uvuni_to_utf8_flags # E +vdeb # U +IS_NUMBER_NAN # added by devel/scanprov +MY_CXT # added by devel/scanprov +MY_CXT_INIT # added by devel/scanprov +PERL_MAGIC_shared # added by devel/scanprov +PERL_MAGIC_shared_scalar # added by devel/scanprov +PERL_MAGIC_uvar_elem # added by devel/scanprov +PERL_SCAN_ALLOW_UNDERSCORES # added by devel/scanprov +PERL_SCAN_DISALLOW_PREFIX # added by devel/scanprov +PERL_SCAN_GREATER_THAN_UV_MAX # added by devel/scanprov +START_MY_CXT # added by devel/scanprov +_aMY_CXT # added by devel/scanprov +_pMY_CXT # added by devel/scanprov +aMY_CXT # added by devel/scanprov +aMY_CXT_ # added by devel/scanprov +dMY_CXT # added by devel/scanprov +dMY_CXT_SV # added by devel/scanprov +pMY_CXT # added by devel/scanprov +pMY_CXT_ # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008000 new file mode 100644 index 00000000000..5af2a55ce05 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008000 @@ -0,0 +1,6 @@ +5.008000 +Poison # E +hv_iternext_flags # E +hv_store_flags # E +is_utf8_idcont # U +nothreadhook # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008001 new file mode 100644 index 00000000000..cc274f482ab --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008001 @@ -0,0 +1,20 @@ +5.008001 +SvVOK # U +XSRETURN_UV # U +doing_taint # U +is_utf8_string_loc # U +packlist # U +save_bool # U +savestack_grow_cnt # U +scan_vstring # E +sv_cat_decode # U +sv_compile_2op # E (Perl_sv_compile_2op) +sv_setpviv # U +sv_setpviv_mg # U +unpackstring # U +IN_PERL_COMPILETIME # added by devel/scanprov +PERL_MAGIC_utf8 # added by devel/scanprov +PERL_MAGIC_vstring # added by devel/scanprov +PERL_SCAN_SILENT_ILLDIGIT # added by devel/scanprov +XST_mUV # added by devel/scanprov +PERL_GCC_BRACE_GROUPS_FORBIDDEN # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008002 new file mode 100644 index 00000000000..63aac525fed --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008002 @@ -0,0 +1 @@ +5.008002 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008003 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008003 new file mode 100644 index 00000000000..50c6ce1aa14 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008003 @@ -0,0 +1,3 @@ +5.008003 +SvIsCOW # U +SvIsCOW_shared_hash # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008004 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008004 new file mode 100644 index 00000000000..bb7bcdf66ac --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008004 @@ -0,0 +1 @@ +5.008004 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008005 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008005 new file mode 100644 index 00000000000..7bd2029f4b3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008005 @@ -0,0 +1 @@ +5.008005 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009000 new file mode 100644 index 00000000000..8b45dc7ba02 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009000 @@ -0,0 +1,7 @@ +5.009000 +new_version # E +save_set_svflags # U +upg_version # E +vcmp # U +vnumify # E +vstringify # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009001 new file mode 100644 index 00000000000..335f490f8da --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009001 @@ -0,0 +1,9 @@ +5.009001 +SvIV_nomg # U +SvUV_nomg # U +hv_assert # U +hv_clear_placeholders # U +hv_scalar # E +scan_version # E (Perl_scan_version) +sv_2iv_flags # U +sv_2uv_flags # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009002 new file mode 100644 index 00000000000..2b66b272cc1 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009002 @@ -0,0 +1,21 @@ +5.009002 +CopyD # E +MoveD # E +PUSHmortal # E +SvPVbyte_force # E +UNDERBAR # E +XPUSHmortal # E +ZeroD # E +dUNDERBAR # E +find_rundefsvoffset # U +mPUSHi # U +mPUSHn # U +mPUSHp # U +mPUSHu # U +mXPUSHi # U +mXPUSHn # U +mXPUSHp # U +mXPUSHu # U +vnormal # E +PERL_BCDVERSION # added by devel/scanprov +MY_CXT_CLONE # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/embed.fnc b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/embed.fnc new file mode 100644 index 00000000000..8ca6b0e85a5 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/embed.fnc @@ -0,0 +1,1487 @@ +: Lines are of the form: +: flags|return_type|function_name|arg1|arg2|...|argN +: +: A line may be continued on another by ending it with a backslash. +: Leading and trailing whitespace will be ignored in each component. +: +: flags are single letters with following meanings: +: A member of public API +: m Implemented as a macro - no export, no +: proto, no #define +: d function has documentation with its source +: s static function, should have an S_ prefix in +: source file; for macros (m), suffix the usage +: example with a semicolon +: n has no implicit interpreter/thread context argument +: p function has a Perl_ prefix +: f function takes printf style format string, varargs +: r function never returns +: o has no compatibility macro (#define foo Perl_foo) +: x not exported +: X explicitly exported +: M may change +: E visible to extensions included in the Perl core +: b binary backward compatibility; function is a macro +: but has also Perl_ implementation (which is exported) +: U suppress usage example in autogenerated documentation +: +: Individual flags may be separated by whitespace. +: +: New global functions should be added at the end for binary compatibility +: in some configurations. + +START_EXTERN_C + +#if defined(PERL_IMPLICIT_SYS) +Ano |PerlInterpreter* |perl_alloc_using \ + |struct IPerlMem* m|struct IPerlMem* ms \ + |struct IPerlMem* mp|struct IPerlEnv* e \ + |struct IPerlStdIO* io|struct IPerlLIO* lio \ + |struct IPerlDir* d|struct IPerlSock* s \ + |struct IPerlProc* p +#endif +Anod |PerlInterpreter* |perl_alloc +Anod |void |perl_construct |PerlInterpreter* interp +Anod |int |perl_destruct |PerlInterpreter* interp +Anod |void |perl_free |PerlInterpreter* interp +Anod |int |perl_run |PerlInterpreter* interp +Anod |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \ + |int argc|char** argv|char** env +Anp |bool |doing_taint |int argc|char** argv|char** env +#if defined(USE_ITHREADS) +Anod |PerlInterpreter*|perl_clone|PerlInterpreter* interp|UV flags +# if defined(PERL_IMPLICIT_SYS) +Ano |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ + |struct IPerlMem* m|struct IPerlMem* ms \ + |struct IPerlMem* mp|struct IPerlEnv* e \ + |struct IPerlStdIO* io|struct IPerlLIO* lio \ + |struct IPerlDir* d|struct IPerlSock* s \ + |struct IPerlProc* p +# endif +#endif + +Anop |Malloc_t|malloc |MEM_SIZE nbytes +Anop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size +Anop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes +Anop |Free_t |mfree |Malloc_t where +#if defined(MYMALLOC) +np |MEM_SIZE|malloced_size |void *p +#endif + +Anp |void* |get_context +Anp |void |set_context |void *thx + +END_EXTERN_C + +/* functions with flag 'n' should come before here */ +START_EXTERN_C +# include "pp_proto.h" +Ap |SV* |amagic_call |SV* left|SV* right|int method|int dir +Ap |bool |Gv_AMupdate |HV* stash +Ap |CV* |gv_handler |HV* stash|I32 id +p |OP* |append_elem |I32 optype|OP* head|OP* tail +p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last +p |I32 |apply |I32 type|SV** mark|SV** sp +ApM |void |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len +Apd |void |av_clear |AV* ar +Apd |SV* |av_delete |AV* ar|I32 key|I32 flags +Apd |bool |av_exists |AV* ar|I32 key +Apd |void |av_extend |AV* ar|I32 key +p |AV* |av_fake |I32 size|SV** svp +Apd |SV** |av_fetch |AV* ar|I32 key|I32 lval +Apd |void |av_fill |AV* ar|I32 fill +Apd |I32 |av_len |AV* ar +Apd |AV* |av_make |I32 size|SV** svp +Apd |SV* |av_pop |AV* ar +Apd |void |av_push |AV* ar|SV* val +p |void |av_reify |AV* ar +Apd |SV* |av_shift |AV* ar +Apd |SV** |av_store |AV* ar|I32 key|SV* val +Apd |void |av_undef |AV* ar +Apd |void |av_unshift |AV* ar|I32 num +p |OP* |bind_match |I32 type|OP* left|OP* pat +p |OP* |block_end |I32 floor|OP* seq +Ap |I32 |block_gimme +p |int |block_start |int full +p |void |boot_core_UNIVERSAL +p |void |boot_core_PerlIO +Ap |void |call_list |I32 oldscope|AV* av_list +p |bool |cando |Mode_t mode|Uid_t effective|Stat_t* statbufp +Ap |U32 |cast_ulong |NV f +Ap |I32 |cast_i32 |NV f +Ap |IV |cast_iv |NV f +Ap |UV |cast_uv |NV f +#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) +Ap |I32 |my_chsize |int fd|Off_t length +#endif +p |OP* |convert |I32 optype|I32 flags|OP* o +Afprd |void |croak |const char* pat|... +Apr |void |vcroak |const char* pat|va_list* args +#if defined(PERL_IMPLICIT_CONTEXT) +Afnrp |void |croak_nocontext|const char* pat|... +Afnp |OP* |die_nocontext |const char* pat|... +Afnp |void |deb_nocontext |const char* pat|... +Afnp |char* |form_nocontext |const char* pat|... +Anp |void |load_module_nocontext|U32 flags|SV* name|SV* ver|... +Afnp |SV* |mess_nocontext |const char* pat|... +Afnp |void |warn_nocontext |const char* pat|... +Afnp |void |warner_nocontext|U32 err|const char* pat|... +Afnp |SV* |newSVpvf_nocontext|const char* pat|... +Afnp |void |sv_catpvf_nocontext|SV* sv|const char* pat|... +Afnp |void |sv_setpvf_nocontext|SV* sv|const char* pat|... +Afnp |void |sv_catpvf_mg_nocontext|SV* sv|const char* pat|... +Afnp |void |sv_setpvf_mg_nocontext|SV* sv|const char* pat|... +Afnp |int |fprintf_nocontext|PerlIO* stream|const char* fmt|... +Afnp |int |printf_nocontext|const char* fmt|... +#endif +p |void |cv_ckproto |CV* cv|GV* gv|char* p +pd |CV* |cv_clone |CV* proto +Apd |SV* |cv_const_sv |CV* cv +p |SV* |op_const_sv |OP* o|CV* cv +Apd |void |cv_undef |CV* cv +Ap |void |cx_dump |PERL_CONTEXT* cs +Ap |SV* |filter_add |filter_t funcp|SV* datasv +Ap |void |filter_del |filter_t funcp +Ap |I32 |filter_read |int idx|SV* buffer|int maxlen +Ap |char** |get_op_descs +Ap |char** |get_op_names +p |char* |get_no_modify +p |U32* |get_opargs +Ap |PPADDR_t*|get_ppaddr +Ep |I32 |cxinc +Afp |void |deb |const char* pat|... +Ap |void |vdeb |const char* pat|va_list* args +Ap |void |debprofdump +Ap |I32 |debop |OP* o +Ap |I32 |debstack +Ap |I32 |debstackptrs +Ap |char* |delimcpy |char* to|char* toend|char* from \ + |char* fromend|int delim|I32* retlen +p |void |deprecate |char* s +p |void |deprecate_old |char* s +Afp |OP* |die |const char* pat|... +p |OP* |vdie |const char* pat|va_list* args +p |OP* |die_where |char* message|STRLEN msglen +Ap |void |dounwind |I32 cxix +p |bool |do_aexec |SV* really|SV** mark|SV** sp +p |bool |do_aexec5 |SV* really|SV** mark|SV** sp|int fd|int flag +Ap |int |do_binmode |PerlIO *fp|int iotype|int mode +p |void |do_chop |SV* asv|SV* sv +Ap |bool |do_close |GV* gv|bool not_implicit +p |bool |do_eof |GV* gv +p |bool |do_exec |char* cmd +#if defined(WIN32) +Ap |int |do_aspawn |SV* really|SV** mark|SV** sp +Ap |int |do_spawn |char* cmd +Ap |int |do_spawn_nowait|char* cmd +#endif +#if !defined(WIN32) +p |bool |do_exec3 |char* cmd|int fd|int flag +#endif +p |void |do_execfree +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) +p |I32 |do_ipcctl |I32 optype|SV** mark|SV** sp +p |I32 |do_ipcget |I32 optype|SV** mark|SV** sp +p |I32 |do_msgrcv |SV** mark|SV** sp +p |I32 |do_msgsnd |SV** mark|SV** sp +p |I32 |do_semop |SV** mark|SV** sp +p |I32 |do_shmio |I32 optype|SV** mark|SV** sp +#endif +Ap |void |do_join |SV* sv|SV* del|SV** mark|SV** sp +p |OP* |do_kv +Ap |bool |do_open |GV* gv|char* name|I32 len|int as_raw \ + |int rawmode|int rawperm|PerlIO* supplied_fp +Ap |bool |do_open9 |GV *gv|char *name|I32 len|int as_raw \ + |int rawmode|int rawperm|PerlIO *supplied_fp \ + |SV *svs|I32 num +Ap |bool |do_openn |GV *gv|char *name|I32 len|int as_raw \ + |int rawmode|int rawperm|PerlIO *supplied_fp \ + |SV **svp|I32 num +p |void |do_pipe |SV* sv|GV* rgv|GV* wgv +p |bool |do_print |SV* sv|PerlIO* fp +p |OP* |do_readline +p |I32 |do_chomp |SV* sv +p |bool |do_seek |GV* gv|Off_t pos|int whence +Ap |void |do_sprintf |SV* sv|I32 len|SV** sarg +p |Off_t |do_sysseek |GV* gv|Off_t pos|int whence +p |Off_t |do_tell |GV* gv +p |I32 |do_trans |SV* sv +p |UV |do_vecget |SV* sv|I32 offset|I32 size +p |void |do_vecset |SV* sv +p |void |do_vop |I32 optype|SV* sv|SV* left|SV* right +p |OP* |dofile |OP* term +Ap |I32 |dowantarray +Ap |void |dump_all +Ap |void |dump_eval +#if defined(DUMP_FDS) +Ap |void |dump_fds |char* s +#endif +Ap |void |dump_form |GV* gv +Ap |void |gv_dump |GV* gv +Ap |void |op_dump |OP* arg +Ap |void |pmop_dump |PMOP* pm +Ap |void |dump_packsubs |HV* stash +Ap |void |dump_sub |GV* gv +Apd |void |fbm_compile |SV* sv|U32 flags +Apd |char* |fbm_instr |unsigned char* big|unsigned char* bigend \ + |SV* littlesv|U32 flags +p |char* |find_script |char *scriptname|bool dosearch \ + |char **search_ext|I32 flags +p |OP* |force_list |OP* arg +p |OP* |fold_constants |OP* arg +Afpd |char* |form |const char* pat|... +Ap |char* |vform |const char* pat|va_list* args +Ap |void |free_tmps +p |OP* |gen_constant_list|OP* o +#if !defined(HAS_GETENV_LEN) +p |char* |getenv_len |const char* key|unsigned long *len +#endif +Ap |void |gp_free |GV* gv +Ap |GP* |gp_ref |GP* gp +Ap |GV* |gv_AVadd |GV* gv +Ap |GV* |gv_HVadd |GV* gv +Ap |GV* |gv_IOadd |GV* gv +Ap |GV* |gv_autoload4 |HV* stash|const char* name|STRLEN len \ + |I32 method +Ap |void |gv_check |HV* stash +Ap |void |gv_efullname |SV* sv|GV* gv +Ap |void |gv_efullname3 |SV* sv|GV* gv|const char* prefix +Ap |void |gv_efullname4 |SV* sv|GV* gv|const char* prefix|bool keepmain +Ap |GV* |gv_fetchfile |const char* name +Apd |GV* |gv_fetchmeth |HV* stash|const char* name|STRLEN len \ + |I32 level +Apd |GV* |gv_fetchmeth_autoload |HV* stash|const char* name|STRLEN len \ + |I32 level +Apd |GV* |gv_fetchmethod |HV* stash|const char* name +Apd |GV* |gv_fetchmethod_autoload|HV* stash|const char* name \ + |I32 autoload +Ap |GV* |gv_fetchpv |const char* name|I32 add|I32 sv_type +Ap |void |gv_fullname |SV* sv|GV* gv +Ap |void |gv_fullname3 |SV* sv|GV* gv|const char* prefix +Ap |void |gv_fullname4 |SV* sv|GV* gv|const char* prefix|bool keepmain +Ap |void |gv_init |GV* gv|HV* stash|const char* name \ + |STRLEN len|int multi +Apd |HV* |gv_stashpv |const char* name|I32 create +Ap |HV* |gv_stashpvn |const char* name|U32 namelen|I32 create +Apd |HV* |gv_stashsv |SV* sv|I32 create +Apd |void |hv_clear |HV* tb +Ap |void |hv_delayfree_ent|HV* hv|HE* entry +Apd |SV* |hv_delete |HV* tb|const char* key|I32 klen|I32 flags +Apd |SV* |hv_delete_ent |HV* tb|SV* key|I32 flags|U32 hash +Apd |bool |hv_exists |HV* tb|const char* key|I32 klen +Apd |bool |hv_exists_ent |HV* tb|SV* key|U32 hash +Apd |SV** |hv_fetch |HV* tb|const char* key|I32 klen|I32 lval +Apd |HE* |hv_fetch_ent |HV* tb|SV* key|I32 lval|U32 hash +Ap |void |hv_free_ent |HV* hv|HE* entry +Apd |I32 |hv_iterinit |HV* tb +Apd |char* |hv_iterkey |HE* entry|I32* retlen +Apd |SV* |hv_iterkeysv |HE* entry +Apd |HE* |hv_iternext |HV* tb +Apd |SV* |hv_iternextsv |HV* hv|char** key|I32* retlen +ApMd |HE* |hv_iternext_flags|HV* tb|I32 flags +Apd |SV* |hv_iterval |HV* tb|HE* entry +Ap |void |hv_ksplit |HV* hv|IV newmax +Apd |void |hv_magic |HV* hv|GV* gv|int how +Apd |SV** |hv_store |HV* tb|const char* key|I32 klen|SV* val \ + |U32 hash +Apd |HE* |hv_store_ent |HV* tb|SV* key|SV* val|U32 hash +ApM |SV** |hv_store_flags |HV* tb|const char* key|I32 klen|SV* val \ + |U32 hash|int flags +Apd |void |hv_undef |HV* tb +Ap |I32 |ibcmp |const char* a|const char* b|I32 len +Ap |I32 |ibcmp_locale |const char* a|const char* b|I32 len +Apd |I32 |ibcmp_utf8 |const char* a|char **pe1|UV l1|bool u1|const char* b|char **pe2|UV l2|bool u2 +p |bool |ingroup |Gid_t testgid|Uid_t effective +p |void |init_argv_symbols|int|char ** +p |void |init_debugger +Ap |void |init_stacks +Ap |void |init_tm |struct tm *ptm +pd |U32 |intro_my +Ap |char* |instr |const char* big|const char* little +p |bool |io_close |IO* io|bool not_implicit +p |OP* |invert |OP* cmd +dp |bool |is_gv_magical |char *name|STRLEN len|U32 flags +Ap |I32 |is_lvalue_sub +Ap |U32 |to_uni_upper_lc|U32 c +Ap |U32 |to_uni_title_lc|U32 c +Ap |U32 |to_uni_lower_lc|U32 c +Ap |bool |is_uni_alnum |UV c +Ap |bool |is_uni_alnumc |UV c +Ap |bool |is_uni_idfirst |UV c +Ap |bool |is_uni_alpha |UV c +Ap |bool |is_uni_ascii |UV c +Ap |bool |is_uni_space |UV c +Ap |bool |is_uni_cntrl |UV c +Ap |bool |is_uni_graph |UV c +Ap |bool |is_uni_digit |UV c +Ap |bool |is_uni_upper |UV c +Ap |bool |is_uni_lower |UV c +Ap |bool |is_uni_print |UV c +Ap |bool |is_uni_punct |UV c +Ap |bool |is_uni_xdigit |UV c +Ap |UV |to_uni_upper |UV c|U8 *p|STRLEN *lenp +Ap |UV |to_uni_title |UV c|U8 *p|STRLEN *lenp +Ap |UV |to_uni_lower |UV c|U8 *p|STRLEN *lenp +Ap |UV |to_uni_fold |UV c|U8 *p|STRLEN *lenp +Ap |bool |is_uni_alnum_lc|UV c +Ap |bool |is_uni_alnumc_lc|UV c +Ap |bool |is_uni_idfirst_lc|UV c +Ap |bool |is_uni_alpha_lc|UV c +Ap |bool |is_uni_ascii_lc|UV c +Ap |bool |is_uni_space_lc|UV c +Ap |bool |is_uni_cntrl_lc|UV c +Ap |bool |is_uni_graph_lc|UV c +Ap |bool |is_uni_digit_lc|UV c +Ap |bool |is_uni_upper_lc|UV c +Ap |bool |is_uni_lower_lc|UV c +Ap |bool |is_uni_print_lc|UV c +Ap |bool |is_uni_punct_lc|UV c +Ap |bool |is_uni_xdigit_lc|UV c +Apd |STRLEN |is_utf8_char |U8 *p +Apd |bool |is_utf8_string |U8 *s|STRLEN len +Apd |bool |is_utf8_string_loc|U8 *s|STRLEN len|U8 **p +Ap |bool |is_utf8_alnum |U8 *p +Ap |bool |is_utf8_alnumc |U8 *p +Ap |bool |is_utf8_idfirst|U8 *p +Ap |bool |is_utf8_idcont |U8 *p +Ap |bool |is_utf8_alpha |U8 *p +Ap |bool |is_utf8_ascii |U8 *p +Ap |bool |is_utf8_space |U8 *p +Ap |bool |is_utf8_cntrl |U8 *p +Ap |bool |is_utf8_digit |U8 *p +Ap |bool |is_utf8_graph |U8 *p +Ap |bool |is_utf8_upper |U8 *p +Ap |bool |is_utf8_lower |U8 *p +Ap |bool |is_utf8_print |U8 *p +Ap |bool |is_utf8_punct |U8 *p +Ap |bool |is_utf8_xdigit |U8 *p +Ap |bool |is_utf8_mark |U8 *p +p |OP* |jmaybe |OP* arg +p |I32 |keyword |char* d|I32 len +Ap |void |leave_scope |I32 base +p |void |lex_end +p |void |lex_start |SV* line +Ap |void |op_null |OP* o +p |void |op_clear |OP* o +p |OP* |linklist |OP* o +p |OP* |list |OP* o +p |OP* |listkids |OP* o +Apd |void |load_module|U32 flags|SV* name|SV* ver|... +Ap |void |vload_module|U32 flags|SV* name|SV* ver|va_list* args +p |OP* |localize |OP* arg|I32 lexical +Apd |I32 |looks_like_number|SV* sv +Apd |UV |grok_bin |char* start|STRLEN* len|I32* flags|NV *result +Apd |UV |grok_hex |char* start|STRLEN* len|I32* flags|NV *result +Apd |int |grok_number |const char *pv|STRLEN len|UV *valuep +Apd |bool |grok_numeric_radix|const char **sp|const char *send +Apd |UV |grok_oct |char* start|STRLEN* len|I32* flags|NV *result +p |int |magic_clearenv |SV* sv|MAGIC* mg +p |int |magic_clear_all_env|SV* sv|MAGIC* mg +p |int |magic_clearpack|SV* sv|MAGIC* mg +p |int |magic_clearsig |SV* sv|MAGIC* mg +p |int |magic_existspack|SV* sv|MAGIC* mg +p |int |magic_freeregexp|SV* sv|MAGIC* mg +p |int |magic_freeovrld|SV* sv|MAGIC* mg +p |int |magic_get |SV* sv|MAGIC* mg +p |int |magic_getarylen|SV* sv|MAGIC* mg +p |int |magic_getdefelem|SV* sv|MAGIC* mg +p |int |magic_getglob |SV* sv|MAGIC* mg +p |int |magic_getnkeys |SV* sv|MAGIC* mg +p |int |magic_getpack |SV* sv|MAGIC* mg +p |int |magic_getpos |SV* sv|MAGIC* mg +p |int |magic_getsig |SV* sv|MAGIC* mg +p |int |magic_getsubstr|SV* sv|MAGIC* mg +p |int |magic_gettaint |SV* sv|MAGIC* mg +p |int |magic_getuvar |SV* sv|MAGIC* mg +p |int |magic_getvec |SV* sv|MAGIC* mg +p |U32 |magic_len |SV* sv|MAGIC* mg +p |int |magic_nextpack |SV* sv|MAGIC* mg|SV* key +p |U32 |magic_regdata_cnt|SV* sv|MAGIC* mg +p |int |magic_regdatum_get|SV* sv|MAGIC* mg +p |int |magic_regdatum_set|SV* sv|MAGIC* mg +p |int |magic_set |SV* sv|MAGIC* mg +p |int |magic_setamagic|SV* sv|MAGIC* mg +p |int |magic_setarylen|SV* sv|MAGIC* mg +p |int |magic_setbm |SV* sv|MAGIC* mg +p |int |magic_setdbline|SV* sv|MAGIC* mg +#if defined(USE_LOCALE_COLLATE) +p |int |magic_setcollxfrm|SV* sv|MAGIC* mg +#endif +p |int |magic_setdefelem|SV* sv|MAGIC* mg +p |int |magic_setenv |SV* sv|MAGIC* mg +p |int |magic_setfm |SV* sv|MAGIC* mg +p |int |magic_setisa |SV* sv|MAGIC* mg +p |int |magic_setglob |SV* sv|MAGIC* mg +p |int |magic_setmglob |SV* sv|MAGIC* mg +p |int |magic_setnkeys |SV* sv|MAGIC* mg +p |int |magic_setpack |SV* sv|MAGIC* mg +p |int |magic_setpos |SV* sv|MAGIC* mg +p |int |magic_setregexp|SV* sv|MAGIC* mg +p |int |magic_setsig |SV* sv|MAGIC* mg +p |int |magic_setsubstr|SV* sv|MAGIC* mg +p |int |magic_settaint |SV* sv|MAGIC* mg +p |int |magic_setuvar |SV* sv|MAGIC* mg +p |int |magic_setvec |SV* sv|MAGIC* mg +p |int |magic_setutf8 |SV* sv|MAGIC* mg +p |int |magic_set_all_env|SV* sv|MAGIC* mg +p |U32 |magic_sizepack |SV* sv|MAGIC* mg +p |int |magic_wipepack |SV* sv|MAGIC* mg +p |void |magicname |char* sym|char* name|I32 namlen +Ap |void |markstack_grow +#if defined(USE_LOCALE_COLLATE) +p |char* |mem_collxfrm |const char* s|STRLEN len|STRLEN* xlen +#endif +Afp |SV* |mess |const char* pat|... +Ap |SV* |vmess |const char* pat|va_list* args +p |void |qerror |SV* err +Apd |void |sortsv |SV ** array|size_t num_elts|SVCOMPARE_t cmp +Apd |int |mg_clear |SV* sv +Apd |int |mg_copy |SV* sv|SV* nsv|const char* key|I32 klen +Apd |MAGIC* |mg_find |SV* sv|int type +Apd |int |mg_free |SV* sv +Apd |int |mg_get |SV* sv +Apd |U32 |mg_length |SV* sv +Apd |void |mg_magical |SV* sv +Apd |int |mg_set |SV* sv +Ap |I32 |mg_size |SV* sv +Ap |void |mini_mktime |struct tm *pm +p |OP* |mod |OP* o|I32 type +p |int |mode_from_discipline|SV* discp +Ap |char* |moreswitches |char* s +p |OP* |my |OP* o +Ap |NV |my_atof |const char *s +#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) +Anp |char* |my_bcopy |const char* from|char* to|I32 len +#endif +#if !defined(HAS_BZERO) && !defined(HAS_MEMSET) +Anp |char* |my_bzero |char* loc|I32 len +#endif +Apr |void |my_exit |U32 status +Apr |void |my_failure_exit +Ap |I32 |my_fflush_all +Anp |Pid_t |my_fork +Anp |void |atfork_lock +Anp |void |atfork_unlock +Ap |I32 |my_lstat +#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) +Anp |I32 |my_memcmp |const char* s1|const char* s2|I32 len +#endif +#if !defined(HAS_MEMSET) +Anp |void* |my_memset |char* loc|I32 ch|I32 len +#endif +Ap |I32 |my_pclose |PerlIO* ptr +Ap |PerlIO*|my_popen |char* cmd|char* mode +Ap |PerlIO*|my_popen_list |char* mode|int n|SV ** args +Ap |void |my_setenv |char* nam|char* val +Ap |I32 |my_stat +Ap |char * |my_strftime |char *fmt|int sec|int min|int hour|int mday|int mon|int year|int wday|int yday|int isdst +#if defined(MYSWAP) +Ap |short |my_swap |short s +Ap |long |my_htonl |long l +Ap |long |my_ntohl |long l +#endif +p |void |my_unexec +Ap |OP* |newANONLIST |OP* o +Ap |OP* |newANONHASH |OP* o +Ap |OP* |newANONSUB |I32 floor|OP* proto|OP* block +Ap |OP* |newASSIGNOP |I32 flags|OP* left|I32 optype|OP* right +Ap |OP* |newCONDOP |I32 flags|OP* expr|OP* trueop|OP* falseop +Apd |CV* |newCONSTSUB |HV* stash|char* name|SV* sv +Ap |void |newFORM |I32 floor|OP* o|OP* block +Ap |OP* |newFOROP |I32 flags|char* label|line_t forline \ + |OP* sclr|OP* expr|OP*block|OP*cont +Ap |OP* |newLOGOP |I32 optype|I32 flags|OP* left|OP* right +Ap |OP* |newLOOPEX |I32 type|OP* label +Ap |OP* |newLOOPOP |I32 flags|I32 debuggable|OP* expr|OP* block +Ap |OP* |newNULLLIST +Ap |OP* |newOP |I32 optype|I32 flags +Ap |void |newPROG |OP* o +Ap |OP* |newRANGE |I32 flags|OP* left|OP* right +Ap |OP* |newSLICEOP |I32 flags|OP* subscript|OP* listop +Ap |OP* |newSTATEOP |I32 flags|char* label|OP* o +Ap |CV* |newSUB |I32 floor|OP* o|OP* proto|OP* block +Apd |CV* |newXS |char* name|XSUBADDR_t f|char* filename +Apd |AV* |newAV +Ap |OP* |newAVREF |OP* o +Ap |OP* |newBINOP |I32 type|I32 flags|OP* first|OP* last +Ap |OP* |newCVREF |I32 flags|OP* o +Ap |OP* |newGVOP |I32 type|I32 flags|GV* gv +Ap |GV* |newGVgen |char* pack +Ap |OP* |newGVREF |I32 type|OP* o +Ap |OP* |newHVREF |OP* o +Apd |HV* |newHV +Ap |HV* |newHVhv |HV* hv +Ap |IO* |newIO +Ap |OP* |newLISTOP |I32 type|I32 flags|OP* first|OP* last +Ap |OP* |newPADOP |I32 type|I32 flags|SV* sv +Ap |OP* |newPMOP |I32 type|I32 flags +Ap |OP* |newPVOP |I32 type|I32 flags|char* pv +Ap |SV* |newRV |SV* pref +Apd |SV* |newRV_noinc |SV *sv +Apd |SV* |newSV |STRLEN len +Ap |OP* |newSVREF |OP* o +Ap |OP* |newSVOP |I32 type|I32 flags|SV* sv +Apd |SV* |newSViv |IV i +Apd |SV* |newSVuv |UV u +Apd |SV* |newSVnv |NV n +Apd |SV* |newSVpv |const char* s|STRLEN len +Apd |SV* |newSVpvn |const char* s|STRLEN len +Apd |SV* |newSVpvn_share |const char* s|I32 len|U32 hash +Afpd |SV* |newSVpvf |const char* pat|... +Ap |SV* |vnewSVpvf |const char* pat|va_list* args +Apd |SV* |newSVrv |SV* rv|const char* classname +Apd |SV* |newSVsv |SV* old +Ap |OP* |newUNOP |I32 type|I32 flags|OP* first +Ap |OP* |newWHILEOP |I32 flags|I32 debuggable|LOOP* loop \ + |I32 whileline|OP* expr|OP* block|OP* cont + +Ap |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems +Ap |char* |scan_vstring |char *vstr|SV *sv +Apd |char* |scan_version |char *vstr|SV *sv|bool qv +Apd |SV* |new_version |SV *ver +Apd |SV* |upg_version |SV *ver +Apd |SV* |vnumify |SV *vs +Apd |SV* |vnormal |SV *vs +Apd |SV* |vstringify |SV *vs +Apd |int |vcmp |SV *lvs|SV *rvs +p |PerlIO*|nextargv |GV* gv +Ap |char* |ninstr |const char* big|const char* bigend \ + |const char* little|const char* lend +p |OP* |oopsCV |OP* o +Ap |void |op_free |OP* arg +p |void |package |OP* o +pd |PADOFFSET|pad_alloc |I32 optype|U32 tmptype +p |PADOFFSET|allocmy |char* name +pd |PADOFFSET|pad_findmy |char* name +Ap |PADOFFSET|find_rundefsvoffset | +p |OP* |oopsAV |OP* o +p |OP* |oopsHV |OP* o +pd |void |pad_leavemy +Apd |SV* |pad_sv |PADOFFSET po +pd |void |pad_free |PADOFFSET po +pd |void |pad_reset +pd |void |pad_swipe |PADOFFSET po|bool refadjust +p |void |peep |OP* o +dopM |PerlIO*|start_glob |SV* pattern|IO *io +#if defined(USE_REENTRANT_API) +Ap |void |reentrant_size +Ap |void |reentrant_init +Ap |void |reentrant_free +Anp |void* |reentrant_retry|const char*|... +#endif +Ap |void |call_atexit |ATEXIT_t fn|void *ptr +Apd |I32 |call_argv |const char* sub_name|I32 flags|char** argv +Apd |I32 |call_method |const char* methname|I32 flags +Apd |I32 |call_pv |const char* sub_name|I32 flags +Apd |I32 |call_sv |SV* sv|I32 flags +Ap |void |despatch_signals +Apd |SV* |eval_pv |const char* p|I32 croak_on_error +Apd |I32 |eval_sv |SV* sv|I32 flags +Apd |SV* |get_sv |const char* name|I32 create +Apd |AV* |get_av |const char* name|I32 create +Apd |HV* |get_hv |const char* name|I32 create +Apd |CV* |get_cv |const char* name|I32 create +Ap |int |init_i18nl10n |int printwarn +Ap |int |init_i18nl14n |int printwarn +Ap |void |new_collate |char* newcoll +Ap |void |new_ctype |char* newctype +Ap |void |new_numeric |char* newcoll +Ap |void |set_numeric_local +Ap |void |set_numeric_radix +Ap |void |set_numeric_standard +Apd |void |require_pv |const char* pv +Apd |void |pack_cat |SV *cat|char *pat|char *patend|SV **beglist|SV **endlist|SV ***next_in_list|U32 flags +Apd |void |packlist |SV *cat|char *pat|char *patend|SV **beglist|SV **endlist +p |void |pidgone |Pid_t pid|int status +Ap |void |pmflag |U32* pmfl|int ch +p |OP* |pmruntime |OP* pm|OP* expr|OP* repl +p |OP* |pmtrans |OP* o|OP* expr|OP* repl +Ap |void |pop_scope +p |OP* |prepend_elem |I32 optype|OP* head|OP* tail +Ap |void |push_scope +p |OP* |ref |OP* o|I32 type +p |OP* |refkids |OP* o|I32 type +Ap |void |regdump |regexp* r +Ap |SV* |regclass_swash |struct regnode *n|bool doinit|SV **listsvp|SV **altsvp +Ap |I32 |pregexec |regexp* prog|char* stringarg \ + |char* strend|char* strbeg|I32 minend \ + |SV* screamer|U32 nosave +Ap |void |pregfree |struct regexp* r +Ap |regexp*|pregcomp |char* exp|char* xend|PMOP* pm +Ap |char* |re_intuit_start|regexp* prog|SV* sv|char* strpos \ + |char* strend|U32 flags \ + |struct re_scream_pos_data_s *data +Ap |SV* |re_intuit_string|regexp* prog +Ap |I32 |regexec_flags |regexp* prog|char* stringarg \ + |char* strend|char* strbeg|I32 minend \ + |SV* screamer|void* data|U32 flags +Ap |regnode*|regnext |regnode* p +Ep |void |regprop |SV* sv|regnode* o +Ap |void |repeatcpy |char* to|const char* from|I32 len|I32 count +Ap |char* |rninstr |const char* big|const char* bigend \ + |const char* little|const char* lend +Ap |Sighandler_t|rsignal |int i|Sighandler_t t +p |int |rsignal_restore|int i|Sigsave_t* t +p |int |rsignal_save |int i|Sighandler_t t1|Sigsave_t* t2 +Ap |Sighandler_t|rsignal_state|int i +p |void |rxres_free |void** rsp +p |void |rxres_restore |void** rsp|REGEXP* prx +p |void |rxres_save |void** rsp|REGEXP* prx +#if !defined(HAS_RENAME) +p |I32 |same_dirent |char* a|char* b +#endif +Apd |char* |savepv |const char* pv +Apd |char* |savesharedpv |const char* pv +Apd |char* |savepvn |const char* pv|I32 len +Ap |void |savestack_grow +Ap |void |savestack_grow_cnt |I32 need +Ap |void |save_aelem |AV* av|I32 idx|SV **sptr +Ap |I32 |save_alloc |I32 size|I32 pad +Ap |void |save_aptr |AV** aptr +Ap |AV* |save_ary |GV* gv +Ap |void |save_bool |bool* boolp +Ap |void |save_clearsv |SV** svp +Ap |void |save_delete |HV* hv|char* key|I32 klen +Ap |void |save_destructor|DESTRUCTORFUNC_NOCONTEXT_t f|void* p +Ap |void |save_destructor_x|DESTRUCTORFUNC_t f|void* p +Ap |void |save_freesv |SV* sv +p |void |save_freeop |OP* o +Ap |void |save_freepv |char* pv +Ap |void |save_generic_svref|SV** sptr +Ap |void |save_generic_pvref|char** str +Ap |void |save_shared_pvref|char** str +Ap |void |save_gp |GV* gv|I32 empty +Ap |HV* |save_hash |GV* gv +Ap |void |save_helem |HV* hv|SV *key|SV **sptr +Ap |void |save_hints +Ap |void |save_hptr |HV** hptr +Ap |void |save_I16 |I16* intp +Ap |void |save_I32 |I32* intp +Ap |void |save_I8 |I8* bytep +Ap |void |save_int |int* intp +Ap |void |save_item |SV* item +Ap |void |save_iv |IV* iv +Ap |void |save_list |SV** sarg|I32 maxsarg +Ap |void |save_long |long* longp +Ap |void |save_mortalizesv|SV* sv +Ap |void |save_nogv |GV* gv +p |void |save_op +Ap |SV* |save_scalar |GV* gv +Ap |void |save_pptr |char** pptr +Ap |void |save_vptr |void* pptr +Ap |void |save_re_context +Ap |void |save_padsv |PADOFFSET off +Ap |void |save_sptr |SV** sptr +Ap |SV* |save_svref |SV** sptr +Ap |SV** |save_threadsv |PADOFFSET i +p |OP* |sawparens |OP* o +p |OP* |scalar |OP* o +p |OP* |scalarkids |OP* o +p |OP* |scalarseq |OP* o +p |OP* |scalarvoid |OP* o +Apd |NV |scan_bin |char* start|STRLEN len|STRLEN* retlen +Apd |NV |scan_hex |char* start|STRLEN len|STRLEN* retlen +Ap |char* |scan_num |char* s|YYSTYPE *lvalp +Apd |NV |scan_oct |char* start|STRLEN len|STRLEN* retlen +p |OP* |scope |OP* o +Ap |char* |screaminstr |SV* bigsv|SV* littlesv|I32 start_shift \ + |I32 end_shift|I32 *state|I32 last +#if !defined(VMS) +p |I32 |setenv_getix |char* nam +#endif +p |void |setdefout |GV* gv +p |HEK* |share_hek |const char* sv|I32 len|U32 hash +np |Signal_t |sighandler |int sig +Anp |Signal_t |csighandler |int sig +Ap |SV** |stack_grow |SV** sp|SV**p|int n +Ap |I32 |start_subparse |I32 is_format|U32 flags +p |void |sub_crush_depth|CV* cv +Apd |bool |sv_2bool |SV* sv +Apd |CV* |sv_2cv |SV* sv|HV** st|GV** gvp|I32 lref +Apd |IO* |sv_2io |SV* sv +Amb |IV |sv_2iv |SV* sv +Apd |IV |sv_2iv_flags |SV* sv|I32 flags +Apd |SV* |sv_2mortal |SV* sv +Apd |NV |sv_2nv |SV* sv +Amb |char* |sv_2pv |SV* sv|STRLEN* lp +Apd |char* |sv_2pvutf8 |SV* sv|STRLEN* lp +Apd |char* |sv_2pvbyte |SV* sv|STRLEN* lp +Ap |char* |sv_pvn_nomg |SV* sv|STRLEN* lp +Amb |UV |sv_2uv |SV* sv +Apd |UV |sv_2uv_flags |SV* sv|I32 flags +Apd |IV |sv_iv |SV* sv +Apd |UV |sv_uv |SV* sv +Apd |NV |sv_nv |SV* sv +Apd |char* |sv_pvn |SV *sv|STRLEN *len +Apd |char* |sv_pvutf8n |SV *sv|STRLEN *len +Apd |char* |sv_pvbyten |SV *sv|STRLEN *len +Apd |I32 |sv_true |SV *sv +pd |void |sv_add_arena |char* ptr|U32 size|U32 flags +Apd |int |sv_backoff |SV* sv +Apd |SV* |sv_bless |SV* sv|HV* stash +Afpd |void |sv_catpvf |SV* sv|const char* pat|... +Ap |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args +Apd |void |sv_catpv |SV* sv|const char* ptr +Amdb |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len +Amdb |void |sv_catsv |SV* dsv|SV* ssv +Apd |void |sv_chop |SV* sv|char* ptr +pd |I32 |sv_clean_all +pd |void |sv_clean_objs +Apd |void |sv_clear |SV* sv +Apd |I32 |sv_cmp |SV* sv1|SV* sv2 +Apd |I32 |sv_cmp_locale |SV* sv1|SV* sv2 +#if defined(USE_LOCALE_COLLATE) +Apd |char* |sv_collxfrm |SV* sv|STRLEN* nxp +#endif +Ap |OP* |sv_compile_2op |SV* sv|OP** startp|char* code|PAD** padp +Apd |int |getcwd_sv |SV* sv +Apd |void |sv_dec |SV* sv +Ap |void |sv_dump |SV* sv +Apd |bool |sv_derived_from|SV* sv|const char* name +Apd |I32 |sv_eq |SV* sv1|SV* sv2 +Apd |void |sv_free |SV* sv +poMX |void |sv_free2 |SV* sv +pd |void |sv_free_arenas +Apd |char* |sv_gets |SV* sv|PerlIO* fp|I32 append +Apd |char* |sv_grow |SV* sv|STRLEN newlen +Apd |void |sv_inc |SV* sv +Apd |void |sv_insert |SV* bigsv|STRLEN offset|STRLEN len \ + |char* little|STRLEN littlelen +Apd |int |sv_isa |SV* sv|const char* name +Apd |int |sv_isobject |SV* sv +Apd |STRLEN |sv_len |SV* sv +Apd |STRLEN |sv_len_utf8 |SV* sv +Apd |void |sv_magic |SV* sv|SV* obj|int how|const char* name \ + |I32 namlen +Apd |MAGIC *|sv_magicext |SV* sv|SV* obj|int how|MGVTBL *vtbl \ + | const char* name|I32 namlen +Apd |SV* |sv_mortalcopy |SV* oldsv +Apd |SV* |sv_newmortal +Apd |SV* |sv_newref |SV* sv +Ap |char* |sv_peek |SV* sv +Apd |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp +Apd |void |sv_pos_b2u |SV* sv|I32* offsetp +Amdb |char* |sv_pvn_force |SV* sv|STRLEN* lp +Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp +Apd |char* |sv_pvbyten_force|SV* sv|STRLEN* lp +Apd |char* |sv_recode_to_utf8 |SV* sv|SV *encoding +Apd |bool |sv_cat_decode |SV* dsv|SV *encoding|SV *ssv|int *offset \ + |char* tstr|int tlen +Apd |char* |sv_reftype |SV* sv|int ob +Apd |void |sv_replace |SV* sv|SV* nsv +Apd |void |sv_report_used +Apd |void |sv_reset |char* s|HV* stash +Afpd |void |sv_setpvf |SV* sv|const char* pat|... +Ap |void |sv_vsetpvf |SV* sv|const char* pat|va_list* args +Apd |void |sv_setiv |SV* sv|IV num +Apdb |void |sv_setpviv |SV* sv|IV num +Apd |void |sv_setuv |SV* sv|UV num +Apd |void |sv_setnv |SV* sv|NV num +Apd |SV* |sv_setref_iv |SV* rv|const char* classname|IV iv +Apd |SV* |sv_setref_uv |SV* rv|const char* classname|UV uv +Apd |SV* |sv_setref_nv |SV* rv|const char* classname|NV nv +Apd |SV* |sv_setref_pv |SV* rv|const char* classname|void* pv +Apd |SV* |sv_setref_pvn |SV* rv|const char* classname|char* pv \ + |STRLEN n +Apd |void |sv_setpv |SV* sv|const char* ptr +Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len +Amdb |void |sv_setsv |SV* dsv|SV* ssv +Apd |void |sv_taint |SV* sv +Apd |bool |sv_tainted |SV* sv +Apd |int |sv_unmagic |SV* sv|int type +Apd |void |sv_unref |SV* sv +Apd |void |sv_unref_flags |SV* sv|U32 flags +Apd |void |sv_untaint |SV* sv +Apd |bool |sv_upgrade |SV* sv|U32 mt +Apd |void |sv_usepvn |SV* sv|char* ptr|STRLEN len +Apd |void |sv_vcatpvfn |SV* sv|const char* pat|STRLEN patlen \ + |va_list* args|SV** svargs|I32 svmax \ + |bool *maybe_tainted +Apd |void |sv_vsetpvfn |SV* sv|const char* pat|STRLEN patlen \ + |va_list* args|SV** svargs|I32 svmax \ + |bool *maybe_tainted +Ap |NV |str_to_version |SV *sv +Ap |SV* |swash_init |char* pkg|char* name|SV* listsv \ + |I32 minbits|I32 none +Ap |UV |swash_fetch |SV *sv|U8 *ptr|bool do_utf8 +Ap |void |taint_env +Ap |void |taint_proper |const char* f|const char* s +Apd |UV |to_utf8_case |U8 *p|U8* ustrp|STRLEN *lenp \ + |SV **swash|char *normal|char *special +Apd |UV |to_utf8_lower |U8 *p|U8* ustrp|STRLEN *lenp +Apd |UV |to_utf8_upper |U8 *p|U8* ustrp|STRLEN *lenp +Apd |UV |to_utf8_title |U8 *p|U8* ustrp|STRLEN *lenp +Apd |UV |to_utf8_fold |U8 *p|U8* ustrp|STRLEN *lenp +#if defined(UNLINK_ALL_VERSIONS) +Ap |I32 |unlnk |char* f +#endif +Apd |I32 |unpack_str |char *pat|char *patend|char *s|char *strbeg|char *strend|char **new_s|I32 ocnt|U32 flags +Apd |I32 |unpackstring |char *pat|char *patend|char *s|char *strend|U32 flags +Ap |void |unsharepvn |const char* sv|I32 len|U32 hash +p |void |unshare_hek |HEK* hek +p |void |utilize |int aver|I32 floor|OP* version|OP* idop|OP* arg +Ap |U8* |utf16_to_utf8 |U8* p|U8 *d|I32 bytelen|I32 *newlen +Ap |U8* |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen +Adp |STRLEN |utf8_length |U8* s|U8 *e +Apd |IV |utf8_distance |U8 *a|U8 *b +Apd |U8* |utf8_hop |U8 *s|I32 off +ApMd |U8* |utf8_to_bytes |U8 *s|STRLEN *len +ApMd |U8* |bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8 +ApMd |U8* |bytes_to_utf8 |U8 *s|STRLEN *len +Apd |UV |utf8_to_uvchr |U8 *s|STRLEN* retlen +Apd |UV |utf8_to_uvuni |U8 *s|STRLEN* retlen +Adp |UV |utf8n_to_uvchr |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags +Adp |UV |utf8n_to_uvuni |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags +Apd |U8* |uvchr_to_utf8 |U8 *d|UV uv +Ap |U8* |uvuni_to_utf8 |U8 *d|UV uv +Ap |U8* |uvchr_to_utf8_flags |U8 *d|UV uv|UV flags +Apd |U8* |uvuni_to_utf8_flags |U8 *d|UV uv|UV flags +Apd |char* |pv_uni_display |SV *dsv|U8 *spv|STRLEN len \ + |STRLEN pvlim|UV flags +Apd |char* |sv_uni_display |SV *dsv|SV *ssv|STRLEN pvlim|UV flags +p |void |vivify_defelem |SV* sv +p |void |vivify_ref |SV* sv|U32 to_what +p |I32 |wait4pid |Pid_t pid|int* statusp|int flags +p |U32 |parse_unicode_opts|char **popt +p |U32 |seed +p |UV |get_hash_seed +p |void |report_evil_fh |GV *gv|IO *io|I32 op +pd |void |report_uninit |SV* uninit_sv +Afpd |void |warn |const char* pat|... +Ap |void |vwarn |const char* pat|va_list* args +Afp |void |warner |U32 err|const char* pat|... +Ap |void |vwarner |U32 err|const char* pat|va_list* args +p |void |watch |char** addr +Ap |I32 |whichsig |char* sig +p |void |write_to_stderr|const char* message|int msglen +p |int |yyerror |char* s +p |int |yylex +p |int |yyparse +p |int |yywarn |char* s +#if defined(MYMALLOC) +Ap |void |dump_mstats |char* s +Ap |int |get_mstats |perl_mstats_t *buf|int buflen|int level +#endif +Anp |Malloc_t|safesysmalloc |MEM_SIZE nbytes +Anp |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size +Anp |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes +Anp |Free_t |safesysfree |Malloc_t where +#if defined(PERL_GLOBAL_STRUCT) +Ap |struct perl_vars *|GetVars +#endif +Ap |int |runops_standard +Ap |int |runops_debug +Afpd |void |sv_catpvf_mg |SV *sv|const char* pat|... +Ap |void |sv_vcatpvf_mg |SV* sv|const char* pat|va_list* args +Apd |void |sv_catpv_mg |SV *sv|const char *ptr +Apd |void |sv_catpvn_mg |SV *sv|const char *ptr|STRLEN len +Apd |void |sv_catsv_mg |SV *dstr|SV *sstr +Afpd |void |sv_setpvf_mg |SV *sv|const char* pat|... +Ap |void |sv_vsetpvf_mg |SV* sv|const char* pat|va_list* args +Apd |void |sv_setiv_mg |SV *sv|IV i +Apdb |void |sv_setpviv_mg |SV *sv|IV iv +Apd |void |sv_setuv_mg |SV *sv|UV u +Apd |void |sv_setnv_mg |SV *sv|NV num +Apd |void |sv_setpv_mg |SV *sv|const char *ptr +Apd |void |sv_setpvn_mg |SV *sv|const char *ptr|STRLEN len +Apd |void |sv_setsv_mg |SV *dstr|SV *sstr +Apd |void |sv_usepvn_mg |SV *sv|char *ptr|STRLEN len +Ap |MGVTBL*|get_vtbl |int vtbl_id +Ap |char* |pv_display |SV *dsv|char *pv|STRLEN cur|STRLEN len \ + |STRLEN pvlim +Afp |void |dump_indent |I32 level|PerlIO *file|const char* pat|... +Ap |void |dump_vindent |I32 level|PerlIO *file|const char* pat \ + |va_list *args +Ap |void |do_gv_dump |I32 level|PerlIO *file|char *name|GV *sv +Ap |void |do_gvgv_dump |I32 level|PerlIO *file|char *name|GV *sv +Ap |void |do_hv_dump |I32 level|PerlIO *file|char *name|HV *sv +Ap |void |do_magic_dump |I32 level|PerlIO *file|MAGIC *mg|I32 nest \ + |I32 maxnest|bool dumpops|STRLEN pvlim +Ap |void |do_op_dump |I32 level|PerlIO *file|OP *o +Ap |void |do_pmop_dump |I32 level|PerlIO *file|PMOP *pm +Ap |void |do_sv_dump |I32 level|PerlIO *file|SV *sv|I32 nest \ + |I32 maxnest|bool dumpops|STRLEN pvlim +Ap |void |magic_dump |MAGIC *mg +#if defined(PERL_FLEXIBLE_EXCEPTIONS) +Ap |void* |default_protect|volatile JMPENV *je|int *excpt \ + |protect_body_t body|... +Ap |void* |vdefault_protect|volatile JMPENV *je|int *excpt \ + |protect_body_t body|va_list *args +#endif +Ap |void |reginitcolors +Apd |char* |sv_2pv_nolen |SV* sv +Apd |char* |sv_2pvutf8_nolen|SV* sv +Apd |char* |sv_2pvbyte_nolen|SV* sv +Amdb |char* |sv_pv |SV *sv +Amdb |char* |sv_pvutf8 |SV *sv +Amdb |char* |sv_pvbyte |SV *sv +Amdb |STRLEN |sv_utf8_upgrade|SV *sv +ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok +Apd |void |sv_utf8_encode |SV *sv +ApdM |bool |sv_utf8_decode |SV *sv +Apd |void |sv_force_normal|SV *sv +Apd |void |sv_force_normal_flags|SV *sv|U32 flags +Ap |void |tmps_grow |I32 n +Apd |SV* |sv_rvweaken |SV *sv +p |int |magic_killbackrefs|SV *sv|MAGIC *mg +Ap |OP* |newANONATTRSUB |I32 floor|OP *proto|OP *attrs|OP *block +Ap |CV* |newATTRSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block +Ap |void |newMYSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block +p |OP * |my_attrs |OP *o|OP *attrs +p |void |boot_core_xsutils +#if defined(USE_ITHREADS) +Ap |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max|CLONE_PARAMS* param +Ap |PERL_SI*|si_dup |PERL_SI* si|CLONE_PARAMS* param +Ap |ANY* |ss_dup |PerlInterpreter* proto_perl|CLONE_PARAMS* param +Ap |void* |any_dup |void* v|PerlInterpreter* proto_perl +Ap |HE* |he_dup |HE* e|bool shared|CLONE_PARAMS* param +Ap |REGEXP*|re_dup |REGEXP* r|CLONE_PARAMS* param +Ap |PerlIO*|fp_dup |PerlIO* fp|char type|CLONE_PARAMS* param +Ap |DIR* |dirp_dup |DIR* dp +Ap |GP* |gp_dup |GP* gp|CLONE_PARAMS* param +Ap |MAGIC* |mg_dup |MAGIC* mg|CLONE_PARAMS* param +Ap |SV* |sv_dup |SV* sstr|CLONE_PARAMS* param +#if defined(HAVE_INTERP_INTERN) +Ap |void |sys_intern_dup |struct interp_intern* src \ + |struct interp_intern* dst +#endif +Ap |PTR_TBL_t*|ptr_table_new +Ap |void* |ptr_table_fetch|PTR_TBL_t *tbl|void *sv +Ap |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv +Ap |void |ptr_table_split|PTR_TBL_t *tbl +Ap |void |ptr_table_clear|PTR_TBL_t *tbl +Ap |void |ptr_table_free|PTR_TBL_t *tbl +#endif +#if defined(HAVE_INTERP_INTERN) +Ap |void |sys_intern_clear +Ap |void |sys_intern_init +#endif + +Ap |char * |custom_op_name |OP* op +Ap |char * |custom_op_desc |OP* op + +#if defined(PERL_COPY_ON_WRITE) +pMX |int |sv_release_IVX |SV *sv +#endif + +Adp |void |sv_nosharing |SV * +Adp |void |sv_nolocking |SV * +Adp |void |sv_nounlocking |SV * +Adp |int |nothreadhook + +END_EXTERN_C + +#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) +s |I32 |do_trans_simple |SV *sv +s |I32 |do_trans_count |SV *sv +s |I32 |do_trans_complex |SV *sv +s |I32 |do_trans_simple_utf8 |SV *sv +s |I32 |do_trans_count_utf8 |SV *sv +s |I32 |do_trans_complex_utf8 |SV *sv +#endif + +#if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) +s |void |gv_init_sv |GV *gv|I32 sv_type +s |void |require_errno |GV *gv +#endif + +#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) +s |void |hsplit |HV *hv +s |void |hfreeentries |HV *hv +s |void |more_he +s |HE* |new_he +s |void |del_he |HE *p +s |HEK* |save_hek_flags |const char *str|I32 len|U32 hash|int flags +s |void |hv_magic_check |HV *hv|bool *needs_copy|bool *needs_store +s |void |unshare_hek_or_pvn|HEK* hek|const char* sv|I32 len|U32 hash +s |HEK* |share_hek_flags|const char* sv|I32 len|U32 hash|int flags +s |void |hv_notallowed |int flags|const char *key|I32 klen|const char *msg +#endif + +#if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) +s |void |save_magic |I32 mgs_ix|SV *sv +s |int |magic_methpack |SV *sv|MAGIC *mg|char *meth +s |int |magic_methcall |SV *sv|MAGIC *mg|char *meth|I32 f \ + |int n|SV *val +#endif + +#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) +s |I32 |list_assignment|OP *o +s |void |bad_type |I32 n|char *t|char *name|OP *kid +s |void |cop_free |COP *cop +s |OP* |modkids |OP *o|I32 type +s |void |no_bareword_allowed|OP *o +s |OP* |no_fh_allowed |OP *o +s |OP* |scalarboolean |OP *o +s |OP* |too_few_arguments|OP *o|char* name +s |OP* |too_many_arguments|OP *o|char* name +s |OP* |newDEFSVOP +s |OP* |new_logop |I32 type|I32 flags|OP **firstp|OP **otherp +s |void |simplify_sort |OP *o +s |bool |is_handle_constructor |OP *o|I32 argnum +s |char* |gv_ename |GV *gv +s |bool |scalar_mod_type|OP *o|I32 type +s |OP * |my_kid |OP *o|OP *attrs|OP **imopsp +s |OP * |dup_attrlist |OP *o +s |void |apply_attrs |HV *stash|SV *target|OP *attrs|bool for_my +s |void |apply_attrs_my |HV *stash|OP *target|OP *attrs|OP **imopsp +#endif +#if defined(PL_OP_SLAB_ALLOC) +Ap |void* |Slab_Alloc |int m|size_t sz +Ap |void |Slab_Free |void *op +#endif + +#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) +s |void |find_beginning +s |void |forbid_setid |char * +s |void |incpush |char *|int|int|int +s |void |init_interp +s |void |init_ids +s |void |init_lexer +s |void |init_main_stash +s |void |init_perllib +s |void |init_postdump_symbols|int|char **|char ** +s |void |init_predump_symbols +rs |void |my_exit_jump +s |void |nuke_stacks +s |void |open_script |char *|bool|SV * +s |void |usage |char * +s |void |validate_suid |char *|char* +# if defined(IAMSUID) +s |int |fd_on_nosuid_fs|int fd +# endif +s |void* |parse_body |char **env|XSINIT_t xsinit +s |void* |run_body |I32 oldscope +s |void |call_body |OP *myop|int is_eval +s |void* |call_list_body |CV *cv +#if defined(PERL_FLEXIBLE_EXCEPTIONS) +s |void* |vparse_body |va_list args +s |void* |vrun_body |va_list args +s |void* |vcall_body |va_list args +s |void* |vcall_list_body|va_list args +#endif +#endif + +#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) +s |SV* |refto |SV* sv +#endif + +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +s |I32 |unpack_rec |tempsym_t* symptr|char *s|char *strbeg|char *strend|char **new_s +s |SV ** |pack_rec |SV *cat|tempsym_t* symptr|SV **beglist|SV **endlist +s |SV* |mul128 |SV *sv|U8 m +s |I32 |measure_struct |tempsym_t* symptr +s |char * |group_end |char *pat|char *patend|char ender +s |char * |get_num |char *ppat|I32 * +s |bool |next_symbol |tempsym_t* symptr +s |void |doencodes |SV* sv|char* s|I32 len +s |SV* |is_an_int |char *s|STRLEN l +s |int |div128 |SV *pnum|bool *done +#endif + +#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) +s |OP* |docatch |OP *o +s |void* |docatch_body +#if defined(PERL_FLEXIBLE_EXCEPTIONS) +s |void* |vdocatch_body |va_list args +#endif +s |OP* |dofindlabel |OP *o|char *label|OP **opstack|OP **oplimit +s |OP* |doparseform |SV *sv +sn |bool |num_overflow |NV value|I32 fldsize|I32 frcsize +s |I32 |dopoptoeval |I32 startingblock +s |I32 |dopoptolabel |char *label +s |I32 |dopoptoloop |I32 startingblock +s |I32 |dopoptosub |I32 startingblock +s |I32 |dopoptosub_at |PERL_CONTEXT* cxstk|I32 startingblock +s |void |save_lines |AV *array|SV *sv +s |OP* |doeval |int gimme|OP** startop|CV* outside|U32 seq +s |PerlIO *|doopen_pm |const char *name|const char *mode +s |bool |path_is_absolute|char *name +#endif + +#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) +s |void |do_oddball |HV *hash|SV **relem|SV **firstrelem +s |CV* |get_db_sub |SV **svp|CV *cv +s |SV* |method_common |SV* meth|U32* hashp +#endif + +#if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT) +s |OP* |doform |CV *cv|GV *gv|OP *retop +s |int |emulate_eaccess|const char* path|Mode_t mode +# if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) +s |int |dooneliner |char *cmd|char *filename +# endif +#endif + +#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) +Es |regnode*|reg |struct RExC_state_t*|I32|I32 * +Es |regnode*|reganode |struct RExC_state_t*|U8|U32 +Es |regnode*|regatom |struct RExC_state_t*|I32 * +Es |regnode*|regbranch |struct RExC_state_t*|I32 *|I32 +Es |void |reguni |struct RExC_state_t*|UV|char *|STRLEN* +Es |regnode*|regclass |struct RExC_state_t* +Es |I32 |regcurly |char * +Es |regnode*|reg_node |struct RExC_state_t*|U8 +Es |regnode*|regpiece |struct RExC_state_t*|I32 * +Es |void |reginsert |struct RExC_state_t*|U8|regnode * +Es |void |regoptail |struct RExC_state_t*|regnode *|regnode * +Es |void |regtail |struct RExC_state_t*|regnode *|regnode * +Es |char*|regwhite |char *|char * +Es |char*|nextchar |struct RExC_state_t* +# ifdef DEBUGGING +Es |regnode*|dumpuntil |regnode *start|regnode *node \ + |regnode *last|SV* sv|I32 l +Es |void |put_byte |SV* sv|int c +# endif +Es |void |scan_commit |struct RExC_state_t*|struct scan_data_t *data +Es |void |cl_anything |struct RExC_state_t*|struct regnode_charclass_class *cl +Es |int |cl_is_anything |struct regnode_charclass_class *cl +Es |void |cl_init |struct RExC_state_t*|struct regnode_charclass_class *cl +Es |void |cl_init_zero |struct RExC_state_t*|struct regnode_charclass_class *cl +Es |void |cl_and |struct regnode_charclass_class *cl \ + |struct regnode_charclass_class *and_with +Es |void |cl_or |struct RExC_state_t*|struct regnode_charclass_class *cl \ + |struct regnode_charclass_class *or_with +Es |I32 |study_chunk |struct RExC_state_t*|regnode **scanp|I32 *deltap \ + |regnode *last|struct scan_data_t *data \ + |U32 flags +Es |I32 |add_data |struct RExC_state_t*|I32 n|char *s +rs |void|re_croak2 |const char* pat1|const char* pat2|... +Es |I32 |regpposixcc |struct RExC_state_t*|I32 value +Es |void |checkposixcc |struct RExC_state_t* +#endif + +#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) +Es |I32 |regmatch |regnode *prog +Es |I32 |regrepeat |regnode *p|I32 max +Es |I32 |regrepeat_hard |regnode *p|I32 max|I32 *lp +Es |I32 |regtry |regexp *prog|char *startpos +Es |bool |reginclass |regnode *n|U8 *p|STRLEN *lenp|bool do_utf8sv_is_utf8 +Es |CHECKPOINT|regcppush |I32 parenfloor +Es |char*|regcppop +Es |char*|regcp_set_to |I32 ss +Es |void |cache_re |regexp *prog +Es |U8* |reghop |U8 *pos|I32 off +Es |U8* |reghop3 |U8 *pos|I32 off|U8 *lim +Es |U8* |reghopmaybe |U8 *pos|I32 off +Es |U8* |reghopmaybe3 |U8 *pos|I32 off|U8 *lim +Es |char* |find_byclass |regexp * prog|regnode *c|char *s|char *strend|char *startpos|I32 norun +Es |void |to_utf8_substr |regexp * prog +Es |void |to_byte_substr |regexp * prog +#endif + +#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT) +s |CV* |deb_curcv |I32 ix +s |void |debprof |OP *o +#endif + +#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) +s |SV* |save_scalar_at |SV **sptr +#endif + +#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +s |IV |asIV |SV* sv +s |UV |asUV |SV* sv +s |SV* |more_sv +s |void |more_xiv +s |void |more_xnv +s |void |more_xpv +s |void |more_xpviv +s |void |more_xpvnv +s |void |more_xpvcv +s |void |more_xpvav +s |void |more_xpvhv +s |void |more_xpvmg +s |void |more_xpvlv +s |void |more_xpvbm +s |void |more_xrv +s |XPVIV* |new_xiv +s |XPVNV* |new_xnv +s |XPV* |new_xpv +s |XPVIV* |new_xpviv +s |XPVNV* |new_xpvnv +s |XPVCV* |new_xpvcv +s |XPVAV* |new_xpvav +s |XPVHV* |new_xpvhv +s |XPVMG* |new_xpvmg +s |XPVLV* |new_xpvlv +s |XPVBM* |new_xpvbm +s |XRV* |new_xrv +s |void |del_xiv |XPVIV* p +s |void |del_xnv |XPVNV* p +s |void |del_xpv |XPV* p +s |void |del_xpviv |XPVIV* p +s |void |del_xpvnv |XPVNV* p +s |void |del_xpvcv |XPVCV* p +s |void |del_xpvav |XPVAV* p +s |void |del_xpvhv |XPVHV* p +s |void |del_xpvmg |XPVMG* p +s |void |del_xpvlv |XPVLV* p +s |void |del_xpvbm |XPVBM* p +s |void |del_xrv |XRV* p +s |void |sv_unglob |SV* sv +s |void |not_a_number |SV *sv +s |I32 |visit |SVFUNC_t f|U32 flags|U32 mask +s |void |sv_add_backref |SV *tsv|SV *sv +s |void |sv_del_backref |SV *sv +# ifdef DEBUGGING +s |void |del_sv |SV *p +# endif +# if !defined(NV_PRESERVES_UV) +s |int |sv_2iuv_non_preserve |SV *sv|I32 numtype +# endif +s |I32 |expect_number |char** pattern +# +# if defined(USE_ITHREADS) +s |SV* |gv_share |SV *sv|CLONE_PARAMS *param +# endif +s |bool |utf8_mg_pos |SV *sv|MAGIC **mgp|STRLEN **cachep|I32 i|I32 *offsetp|I32 uoff|U8 **sp|U8 *start|U8 *send +s |bool |utf8_mg_pos_init |SV *sv|MAGIC **mgp|STRLEN **cachep|I32 i|I32 *offsetp|U8 *s|U8 *start +#if defined(PERL_COPY_ON_WRITE) +sM |void |sv_release_COW |SV *sv|char *pvx|STRLEN cur|STRLEN len \ + |U32 hash|SV *after +#endif +#endif + +#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) +s |void |check_uni +s |void |force_next |I32 type +s |char* |force_version |char *start|int guessing +s |char* |force_word |char *start|int token|int check_keyword \ + |int allow_pack|int allow_tick +s |SV* |tokeq |SV *sv +s |int |pending_ident +s |char* |scan_const |char *start +s |char* |scan_formline |char *s +s |char* |scan_heredoc |char *s +s |char* |scan_ident |char *s|char *send|char *dest \ + |STRLEN destlen|I32 ck_uni +s |char* |scan_inputsymbol|char *start +s |char* |scan_pat |char *start|I32 type +s |char* |scan_str |char *start|int keep_quoted|int keep_delims +s |char* |scan_subst |char *start +s |char* |scan_trans |char *start +s |char* |scan_word |char *s|char *dest|STRLEN destlen \ + |int allow_package|STRLEN *slp +s |char* |skipspace |char *s +s |char* |swallow_bom |U8 *s +s |void |checkcomma |char *s|char *name|char *what +s |void |force_ident |char *s|int kind +s |void |incline |char *s +s |int |intuit_method |char *s|GV *gv +s |int |intuit_more |char *s +s |I32 |lop |I32 f|int x|char *s +s |void |missingterm |char *s +s |void |no_op |char *what|char *s +s |void |set_csh +s |I32 |sublex_done +s |I32 |sublex_push +s |I32 |sublex_start +s |char * |filter_gets |SV *sv|PerlIO *fp|STRLEN append +s |HV * |find_in_my_stash|char *pkgname|I32 len +s |SV* |new_constant |char *s|STRLEN len|const char *key|SV *sv \ + |SV *pv|const char *type +# if defined(DEBUGGING) +s |void |tokereport |char *thing|char *s|I32 rv +# endif +s |int |ao |int toketype +s |void |depcom +s |char* |incl_perldb +#if 0 +s |I32 |utf16_textfilter|int idx|SV *sv|int maxlen +s |I32 |utf16rev_textfilter|int idx|SV *sv|int maxlen +#endif +# if defined(PERL_CR_FILTER) +s |I32 |cr_textfilter |int idx|SV *sv|int maxlen +# endif +#endif + +#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) +s |SV*|isa_lookup |HV *stash|const char *name|HV *name_stash|int len|int level +#endif + +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) +s |char* |stdize_locale |char* locs +#endif + +#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +s |COP* |closest_cop |COP *cop|OP *o +s |SV* |mess_alloc +#endif + +#if defined(PERL_IN_NUMERIC_C) || defined(PERL_DECL_PROT) +sn |NV|mulexp10 |NV value|I32 exponent +#endif + +START_EXTERN_C + +Apd |void |sv_setsv_flags |SV* dsv|SV* ssv|I32 flags +Apd |void |sv_catpvn_flags|SV* sv|const char* ptr|STRLEN len|I32 flags +Apd |void |sv_catsv_flags |SV* dsv|SV* ssv|I32 flags +Apd |STRLEN |sv_utf8_upgrade_flags|SV *sv|I32 flags +Apd |char* |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags +Apd |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags +Apd |void |sv_copypv |SV* dsv|SV* ssv +Ap |char* |my_atof2 |const char *s|NV* value +Apn |int |my_socketpair |int family|int type|int protocol|int fd[2] +#ifdef PERL_COPY_ON_WRITE +pMXE |SV* |sv_setsv_cow |SV* dsv|SV* ssv +#endif + +#if defined(USE_PERLIO) && !defined(USE_SFIO) +Ap |int |PerlIO_close |PerlIO * +Ap |int |PerlIO_fill |PerlIO * +Ap |int |PerlIO_fileno |PerlIO * +Ap |int |PerlIO_eof |PerlIO * +Ap |int |PerlIO_error |PerlIO * +Ap |int |PerlIO_flush |PerlIO * +Ap |void |PerlIO_clearerr |PerlIO * +Ap |void |PerlIO_set_cnt |PerlIO *|int +Ap |void |PerlIO_set_ptrcnt |PerlIO *|STDCHAR *|int +Ap |void |PerlIO_setlinebuf |PerlIO * +Ap |SSize_t|PerlIO_read |PerlIO *|void *|Size_t +Ap |SSize_t|PerlIO_write |PerlIO *|const void *|Size_t +Ap |SSize_t|PerlIO_unread |PerlIO *|const void *|Size_t +Ap |Off_t |PerlIO_tell |PerlIO * +Ap |int |PerlIO_seek |PerlIO *|Off_t|int + +Ap |STDCHAR *|PerlIO_get_base |PerlIO * +Ap |STDCHAR *|PerlIO_get_ptr |PerlIO * +Ap |int |PerlIO_get_bufsiz |PerlIO * +Ap |int |PerlIO_get_cnt |PerlIO * + +Ap |PerlIO *|PerlIO_stdin +Ap |PerlIO *|PerlIO_stdout +Ap |PerlIO *|PerlIO_stderr +#endif /* PERLIO_LAYERS */ + +p |void |deb_stack_all +#ifdef PERL_IN_DEB_C +s |void |deb_stack_n |SV** stack_base|I32 stack_min \ + |I32 stack_max|I32 mark_min|I32 mark_max +#endif + +pd |PADLIST*|pad_new |int flags +pd |void |pad_undef |CV* cv +pd |PADOFFSET|pad_add_name |char *name\ + |HV* typestash|HV* ourstash \ + |bool clone +pd |PADOFFSET|pad_add_anon |SV* sv|OPCODE op_type +pd |void |pad_check_dup |char* name|bool is_our|HV* ourstash +#ifdef DEBUGGING +pd |void |pad_setsv |PADOFFSET po|SV* sv +#endif +pd |void |pad_block_start|int full +pd |void |pad_tidy |padtidy_type type +pd |void |do_dump_pad |I32 level|PerlIO *file \ + |PADLIST *padlist|int full +pd |void |pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv + +pd |void |pad_push |PADLIST *padlist|int depth|int has_args + +#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) +sd |PADOFFSET|pad_findlex |char *name|CV* cv|U32 seq|int warn \ + |SV** out_capture|SV** out_name_sv \ + |int *out_flags +# if defined(DEBUGGING) +sd |void |cv_dump |CV *cv|char *title +# endif +#endif +pd |CV* |find_runcv |U32 *db_seqp +p |void |free_tied_hv_pool +#if defined(DEBUGGING) +p |int |get_debug_opts |char **s +#endif +Ap |void |save_set_svflags|SV* sv|U32 mask|U32 val +Apod |void |hv_assert |HV* tb + +#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) +sM |SV* |hv_delete_common|HV* tb|SV* key_sv|const char* key|STRLEN klen|int k_flags|I32 d_flags|U32 hash +sM |HE* |hv_fetch_common|HV* tb|SV* key_sv|const char* key|STRLEN klen|int flags|int action|SV* val|U32 hash +#endif + +Apd |void |hv_clear_placeholders|HV* hb + +Apd |SV* |hv_scalar |HV* hv| +p |SV* |magic_scalarpack|HV* hv|MAGIC* mg +#ifdef PERL_IN_SV_C +sMd |SV* |find_uninit_var|OP* obase|SV* uninit_sv|bool top +#endif + +#ifdef PERL_NEED_MY_HTOLE16 +np |U16 |my_htole16 |U16 n +#endif +#ifdef PERL_NEED_MY_LETOH16 +np |U16 |my_letoh16 |U16 n +#endif +#ifdef PERL_NEED_MY_HTOBE16 +np |U16 |my_htobe16 |U16 n +#endif +#ifdef PERL_NEED_MY_BETOH16 +np |U16 |my_betoh16 |U16 n +#endif +#ifdef PERL_NEED_MY_HTOLE32 +np |U32 |my_htole32 |U32 n +#endif +#ifdef PERL_NEED_MY_LETOH32 +np |U32 |my_letoh32 |U32 n +#endif +#ifdef PERL_NEED_MY_HTOBE32 +np |U32 |my_htobe32 |U32 n +#endif +#ifdef PERL_NEED_MY_BETOH32 +np |U32 |my_betoh32 |U32 n +#endif +#ifdef PERL_NEED_MY_HTOLE64 +np |U64 |my_htole64 |U64 n +#endif +#ifdef PERL_NEED_MY_LETOH64 +np |U64 |my_letoh64 |U64 n +#endif +#ifdef PERL_NEED_MY_HTOBE64 +np |U64 |my_htobe64 |U64 n +#endif +#ifdef PERL_NEED_MY_BETOH64 +np |U64 |my_betoh64 |U64 n +#endif + +#ifdef PERL_NEED_MY_HTOLES +np |short |my_htoles |short n +#endif +#ifdef PERL_NEED_MY_LETOHS +np |short |my_letohs |short n +#endif +#ifdef PERL_NEED_MY_HTOBES +np |short |my_htobes |short n +#endif +#ifdef PERL_NEED_MY_BETOHS +np |short |my_betohs |short n +#endif +#ifdef PERL_NEED_MY_HTOLEI +np |int |my_htolei |int n +#endif +#ifdef PERL_NEED_MY_LETOHI +np |int |my_letohi |int n +#endif +#ifdef PERL_NEED_MY_HTOBEI +np |int |my_htobei |int n +#endif +#ifdef PERL_NEED_MY_BETOHI +np |int |my_betohi |int n +#endif +#ifdef PERL_NEED_MY_HTOLEL +np |long |my_htolel |long n +#endif +#ifdef PERL_NEED_MY_LETOHL +np |long |my_letohl |long n +#endif +#ifdef PERL_NEED_MY_HTOBEL +np |long |my_htobel |long n +#endif +#ifdef PERL_NEED_MY_BETOHL +np |long |my_betohl |long n +#endif + +np |void |my_swabn |void* ptr|int n + +END_EXTERN_C diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/MY_CXT b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/MY_CXT new file mode 100644 index 00000000000..601ed14e96f --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/MY_CXT @@ -0,0 +1,192 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +START_MY_CXT +dMY_CXT_SV +dMY_CXT +MY_CXT_INIT +MY_CXT_CLONE +MY_CXT +pMY_CXT +pMY_CXT_ +_pMY_CXT +aMY_CXT +aMY_CXT_ +_aMY_CXT + +=implementation + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +=xsmisc + +#define MY_CXT_KEY "Devel::PPPort::_guts" XS_VERSION + +typedef struct { + /* Put Global Data in here */ + int dummy; +} my_cxt_t; + +START_MY_CXT + +=xsboot + +{ + MY_CXT_INIT; + /* If any of the fields in the my_cxt_t struct need + * to be initialised, do it here. + */ + MY_CXT.dummy = 42; +} + +=xsubs + +int +MY_CXT_1() + CODE: + dMY_CXT; + RETVAL = MY_CXT.dummy == 42; + ++MY_CXT.dummy; + OUTPUT: + RETVAL + +int +MY_CXT_2() + CODE: + dMY_CXT; + RETVAL = MY_CXT.dummy == 43; + OUTPUT: + RETVAL + +int +MY_CXT_CLONE() + CODE: + MY_CXT_CLONE; + RETVAL = 42; + OUTPUT: + RETVAL + +=tests plan => 3 + +ok(&Devel::PPPort::MY_CXT_1()); +ok(&Devel::PPPort::MY_CXT_2()); +ok(&Devel::PPPort::MY_CXT_CLONE()); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/SvPV b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/SvPV new file mode 100644 index 00000000000..711955f67f3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/SvPV @@ -0,0 +1,140 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +SvPV_nolen +sv_2pv_nolen +SvPVbyte +sv_2pvbyte +sv_pvn +sv_pvn_force + +=implementation + +#ifndef SvPV_nolen + +#if { NEED sv_2pv_nolen } + +char * +sv_2pv_nolen(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() macro instead of sv_2pv_nolen(). + */ + +/* SvPV_nolen depends on sv_2pv_nolen */ +#define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) + +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if { VERSION < 5.7.0 } + +#if { NEED sv_2pvbyte } + +char * +sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +/* SvPVbyte depends on sv_2pvbyte */ +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif + +/* sv_2pvbyte_nolen depends on sv_2pv_nolen */ +__UNDEFINED__ sv_2pvbyte_nolen sv_2pv_nolen + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ +__UNDEFINED__ sv_pvn(sv, len) SvPV(sv, len) + +/* Hint: sv_pvn + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ +__UNDEFINED__ sv_pvn_force(sv, len) SvPV_force(sv, len) + +=xsinit + +#define NEED_sv_2pv_nolen +#define NEED_sv_2pvbyte + +=xsubs + +IV +SvPVbyte(sv) + SV *sv + PREINIT: + STRLEN len; + const char *str; + CODE: + str = SvPVbyte(sv, len); + RETVAL = strEQ(str, "mhx") ? len : -1; + OUTPUT: + RETVAL + +IV +SvPV_nolen(sv) + SV *sv + PREINIT: + const char *str; + CODE: + str = SvPV_nolen(sv); + RETVAL = strEQ(str, "mhx") ? 3 : 0; + OUTPUT: + RETVAL + +=tests plan => 2 + +ok(&Devel::PPPort::SvPVbyte("mhx"), 3); +ok(&Devel::PPPort::SvPVbyte("mhx"), 3); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/call b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/call new file mode 100644 index 00000000000..2ff01353d6a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/call @@ -0,0 +1,239 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:45 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +eval_pv +eval_sv +call_sv +call_pv +call_argv +call_method + +=implementation + +/* Replace: 1 */ +__UNDEFINED__ call_sv perl_call_sv +__UNDEFINED__ call_pv perl_call_pv +__UNDEFINED__ call_argv perl_call_argv +__UNDEFINED__ call_method perl_call_method + +__UNDEFINED__ eval_sv perl_eval_sv +/* Replace: 0 */ + +/* Replace perl_eval_pv with eval_pv */ +/* eval_pv depends on eval_sv */ + +#ifndef eval_pv +#if { NEED eval_pv } + +SV* +eval_pv(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +=xsinit + +#define NEED_eval_pv + +=xsubs + +I32 +G_SCALAR() + CODE: + RETVAL = G_SCALAR; + OUTPUT: + RETVAL + +I32 +G_ARRAY() + CODE: + RETVAL = G_ARRAY; + OUTPUT: + RETVAL + +I32 +G_DISCARD() + CODE: + RETVAL = G_DISCARD; + OUTPUT: + RETVAL + +void +eval_sv(sv, flags) + SV* sv + I32 flags + PREINIT: + I32 i; + PPCODE: + PUTBACK; + i = eval_sv(sv, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +eval_pv(p, croak_on_error) + char* p + I32 croak_on_error + PPCODE: + PUTBACK; + EXTEND(SP, 1); + PUSHs(eval_pv(p, croak_on_error)); + +void +call_sv(sv, flags, ...) + SV* sv + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_sv(sv, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +call_pv(subname, flags, ...) + char* subname + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_pv(subname, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +call_argv(subname, flags, ...) + char* subname + I32 flags + PREINIT: + I32 i; + char *args[8]; + PPCODE: + if (items > 8) /* play safe */ + XSRETURN_UNDEF; + for (i=2; i<items; i++) + args[i-2] = SvPV_nolen(ST(i)); + args[items-2] = NULL; + PUTBACK; + i = call_argv(subname, flags, args); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +call_method(methname, flags, ...) + char* methname + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_method(methname, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +=tests plan => 44 + +sub eq_array +{ + my($a, $b) = @_; + join(':', @$a) eq join(':', @$b); +} + +sub f +{ + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +my $obj = bless [], 'Foo'; + +sub Foo::meth +{ + return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; + shift; + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +my $test; + +for $test ( + # flags args expected description + [ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], + [ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], + [ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], + [ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ], + [ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ], + [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ], +) +{ + my ($flags, $args, $expected, $description) = @$test; + print "# --- $description ---\n"; + ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected)); +}; + +ok(&Devel::PPPort::eval_pv('f()', 0), 'y'); +ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y'); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/cop b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/cop new file mode 100644 index 00000000000..fef50dbc41c --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/cop @@ -0,0 +1,84 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:45 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ + +=implementation + +#ifdef USE_ITHREADS + +__UNDEFINED__ CopFILE(c) ((c)->cop_file) +__UNDEFINED__ CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +__UNDEFINED__ CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +__UNDEFINED__ CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +__UNDEFINED__ CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +__UNDEFINED__ CopSTASHPV(c) ((c)->cop_stashpv) +__UNDEFINED__ CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +__UNDEFINED__ CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +__UNDEFINED__ CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +__UNDEFINED__ CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) + +#else + +__UNDEFINED__ CopFILEGV(c) ((c)->cop_filegv) +__UNDEFINED__ CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +__UNDEFINED__ CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +__UNDEFINED__ CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +__UNDEFINED__ CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +__UNDEFINED__ CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +__UNDEFINED__ CopSTASH(c) ((c)->cop_stash) +__UNDEFINED__ CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +__UNDEFINED__ CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +__UNDEFINED__ CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +__UNDEFINED__ CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) + +#endif /* USE_ITHREADS */ + +=xsubs + +char * +CopSTASHPV() + CODE: + RETVAL = CopSTASHPV(PL_curcop); + OUTPUT: + RETVAL + +char * +CopFILE() + CODE: + RETVAL = CopFILE(PL_curcop); + OUTPUT: + RETVAL + +=tests plan => 2 + +my $package; +{ + package MyPackage; + $package = &Devel::PPPort::CopSTASHPV(); +} +print "# $package\n"; +ok($package, "MyPackage"); + +my $file = &Devel::PPPort::CopFILE(); +print "# $file\n"; +ok($file =~ /cop/i); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/format b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/format new file mode 100644 index 00000000000..e6f52a87131 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/format @@ -0,0 +1,54 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:45 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +/^#\s*define\s+(\w+)/ + +=implementation + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/grok b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/grok new file mode 100644 index 00000000000..07850cf1202 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/grok @@ -0,0 +1,680 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +grok_hex +grok_oct +grok_bin +grok_numeric_radix +grok_number +__UNDEFINED__ + +=implementation + +__UNDEFINED__ IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +__UNDEFINED__ IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +__UNDEFINED__ IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +__UNDEFINED__ IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) + +__UNDEFINED__ IS_NUMBER_IN_UV 0x01 +__UNDEFINED__ IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +__UNDEFINED__ IS_NUMBER_NOT_INT 0x04 +__UNDEFINED__ IS_NUMBER_NEG 0x08 +__UNDEFINED__ IS_NUMBER_INFINITY 0x10 +__UNDEFINED__ IS_NUMBER_NAN 0x20 + +/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ +__UNDEFINED__ GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) + +__UNDEFINED__ PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +__UNDEFINED__ PERL_SCAN_SILENT_ILLDIGIT 0x04 +__UNDEFINED__ PERL_SCAN_ALLOW_UNDERSCORES 0x01 +__UNDEFINED__ PERL_SCAN_DISALLOW_PREFIX 0x02 + +#ifndef grok_numeric_radix +#if { NEED grok_numeric_radix } +bool +grok_numeric_radix(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif /* PERL_VERSION */ +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +/* grok_number depends on grok_numeric_radix */ + +#ifndef grok_number +#if { NEED grok_number } +int +grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if { NEED grok_bin } +UV +grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if { NEED grok_hex } +UV +grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if { NEED grok_oct } +UV +grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +=xsinit + +#define NEED_grok_number +#define NEED_grok_numeric_radix +#define NEED_grok_bin +#define NEED_grok_hex +#define NEED_grok_oct + +=xsubs + +UV +grok_number(string) + SV *string + PREINIT: + const char *pv; + STRLEN len; + CODE: + pv = SvPV(string, len); + if (!grok_number(pv, len, &RETVAL)) + XSRETURN_UNDEF; + OUTPUT: + RETVAL + +UV +grok_bin(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = grok_bin(pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +grok_hex(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = grok_hex(pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +grok_oct(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = grok_oct(pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +Perl_grok_number(string) + SV *string + PREINIT: + const char *pv; + STRLEN len; + CODE: + pv = SvPV(string, len); + if (!Perl_grok_number(aTHX_ pv, len, &RETVAL)) + XSRETURN_UNDEF; + OUTPUT: + RETVAL + +UV +Perl_grok_bin(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = Perl_grok_bin(aTHX_ pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +Perl_grok_hex(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = Perl_grok_hex(aTHX_ pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +Perl_grok_oct(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = Perl_grok_oct(aTHX_ pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +=tests plan => 10 + +ok(&Devel::PPPort::grok_number("42"), 42); +ok(!defined(&Devel::PPPort::grok_number("A"))); +ok(&Devel::PPPort::grok_bin("10000001"), 129); +ok(&Devel::PPPort::grok_hex("deadbeef"), 0xdeadbeef); +ok(&Devel::PPPort::grok_oct("377"), 255); + +ok(&Devel::PPPort::Perl_grok_number("42"), 42); +ok(!defined(&Devel::PPPort::Perl_grok_number("A"))); +ok(&Devel::PPPort::Perl_grok_bin("10000001"), 129); +ok(&Devel::PPPort::Perl_grok_hex("deadbeef"), 0xdeadbeef); +ok(&Devel::PPPort::Perl_grok_oct("377"), 255); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/limits b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/limits new file mode 100644 index 00000000000..9fa7284d201 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/limits @@ -0,0 +1,331 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +PERL_UCHAR_MIN +PERL_UCHAR_MAX +PERL_USHORT_MIN +PERL_USHORT_MAX +PERL_SHORT_MAX +PERL_SHORT_MIN +PERL_UINT_MAX +PERL_UINT_MIN +PERL_INT_MAX +PERL_INT_MIN +PERL_ULONG_MAX +PERL_ULONG_MIN +PERL_LONG_MAX +PERL_LONG_MIN +PERL_UQUAD_MAX +PERL_UQUAD_MIN +PERL_QUAD_MAX +PERL_QUAD_MIN +IVSIZE +UVSIZE +IVTYPE +UVTYPE + +=implementation + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray + __UNDEFINED__ IVTYPE int + __UNDEFINED__ IV_MIN PERL_INT_MIN + __UNDEFINED__ IV_MAX PERL_INT_MAX + __UNDEFINED__ UV_MIN PERL_UINT_MIN + __UNDEFINED__ UV_MAX PERL_UINT_MAX +# ifdef INTSIZE + __UNDEFINED__ IVSIZE INTSIZE +# endif +# else +# if defined(convex) || defined(uts) + __UNDEFINED__ IVTYPE long long + __UNDEFINED__ IV_MIN PERL_QUAD_MIN + __UNDEFINED__ IV_MAX PERL_QUAD_MAX + __UNDEFINED__ UV_MIN PERL_UQUAD_MIN + __UNDEFINED__ UV_MAX PERL_UQUAD_MAX +# ifdef LONGLONGSIZE + __UNDEFINED__ IVSIZE LONGLONGSIZE +# endif +# else + __UNDEFINED__ IVTYPE long + __UNDEFINED__ IV_MIN PERL_LONG_MIN + __UNDEFINED__ IV_MAX PERL_LONG_MAX + __UNDEFINED__ UV_MIN PERL_ULONG_MIN + __UNDEFINED__ UV_MAX PERL_ULONG_MAX +# ifdef LONGSIZE + __UNDEFINED__ IVSIZE LONGSIZE +# endif +# endif +# endif + __UNDEFINED__ IVSIZE 8 + __UNDEFINED__ PERL_QUAD_MIN IV_MIN + __UNDEFINED__ PERL_QUAD_MAX IV_MAX + __UNDEFINED__ PERL_UQUAD_MIN UV_MIN + __UNDEFINED__ PERL_UQUAD_MAX UV_MAX +#else + __UNDEFINED__ IVTYPE long + __UNDEFINED__ IV_MIN PERL_LONG_MIN + __UNDEFINED__ IV_MAX PERL_LONG_MAX + __UNDEFINED__ UV_MIN PERL_ULONG_MIN + __UNDEFINED__ UV_MAX PERL_ULONG_MAX +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif + +__UNDEFINED__ UVTYPE unsigned IVTYPE +__UNDEFINED__ UVSIZE IVSIZE + +=xsubs + +IV +iv_size() + CODE: + RETVAL = IVSIZE == sizeof(IV); + OUTPUT: + RETVAL + +IV +uv_size() + CODE: + RETVAL = UVSIZE == sizeof(UV); + OUTPUT: + RETVAL + +IV +iv_type() + CODE: + RETVAL = sizeof(IVTYPE) == sizeof(IV); + OUTPUT: + RETVAL + +IV +uv_type() + CODE: + RETVAL = sizeof(UVTYPE) == sizeof(UV); + OUTPUT: + RETVAL + +=tests plan => 4 + +ok(&Devel::PPPort::iv_size()); +ok(&Devel::PPPort::uv_size()); +ok(&Devel::PPPort::iv_type()); +ok(&Devel::PPPort::uv_type()); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/mPUSH b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/mPUSH new file mode 100644 index 00000000000..c36a260523a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/mPUSH @@ -0,0 +1,117 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ + +=implementation + +__UNDEFINED__ PUSHmortal PUSHs(sv_newmortal()) +__UNDEFINED__ mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) +__UNDEFINED__ mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) +__UNDEFINED__ mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) +__UNDEFINED__ mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) + +__UNDEFINED__ XPUSHmortal XPUSHs(sv_newmortal()) +__UNDEFINED__ mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END +__UNDEFINED__ mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END +__UNDEFINED__ mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END +__UNDEFINED__ mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END + +=xsubs + +void +mPUSHp() + PPCODE: + EXTEND(SP, 3); + mPUSHp("one", 3); + mPUSHp("two", 3); + mPUSHp("three", 5); + XSRETURN(3); + +void +mPUSHn() + PPCODE: + EXTEND(SP, 3); + mPUSHn(0.5); + mPUSHn(-0.25); + mPUSHn(0.125); + XSRETURN(3); + +void +mPUSHi() + PPCODE: + EXTEND(SP, 3); + mPUSHi(-1); + mPUSHi(2); + mPUSHi(-3); + XSRETURN(3); + +void +mPUSHu() + PPCODE: + EXTEND(SP, 3); + mPUSHu(1); + mPUSHu(2); + mPUSHu(3); + XSRETURN(3); + +void +mXPUSHp() + PPCODE: + mXPUSHp("one", 3); + mXPUSHp("two", 3); + mXPUSHp("three", 5); + XSRETURN(3); + +void +mXPUSHn() + PPCODE: + mXPUSHn(0.5); + mXPUSHn(-0.25); + mXPUSHn(0.125); + XSRETURN(3); + +void +mXPUSHi() + PPCODE: + mXPUSHi(-1); + mXPUSHi(2); + mXPUSHi(-3); + XSRETURN(3); + +void +mXPUSHu() + PPCODE: + mXPUSHu(1); + mXPUSHu(2); + mXPUSHu(3); + XSRETURN(3); + +=tests plan => 8 + +ok(join(':', &Devel::PPPort::mPUSHp()), "one:two:three"); +ok(join(':', &Devel::PPPort::mPUSHn()), "0.5:-0.25:0.125"); +ok(join(':', &Devel::PPPort::mPUSHi()), "-1:2:-3"); +ok(join(':', &Devel::PPPort::mPUSHu()), "1:2:3"); + +ok(join(':', &Devel::PPPort::mXPUSHp()), "one:two:three"); +ok(join(':', &Devel::PPPort::mXPUSHn()), "0.5:-0.25:0.125"); +ok(join(':', &Devel::PPPort::mXPUSHi()), "-1:2:-3"); +ok(join(':', &Devel::PPPort::mXPUSHu()), "1:2:3"); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/magic b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/magic new file mode 100644 index 00000000000..57ea3f26ec0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/magic @@ -0,0 +1,290 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ +/sv_\w+_mg/ + +=implementation + +__UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END + +__UNDEFINED__ PERL_MAGIC_sv '\0' +__UNDEFINED__ PERL_MAGIC_overload 'A' +__UNDEFINED__ PERL_MAGIC_overload_elem 'a' +__UNDEFINED__ PERL_MAGIC_overload_table 'c' +__UNDEFINED__ PERL_MAGIC_bm 'B' +__UNDEFINED__ PERL_MAGIC_regdata 'D' +__UNDEFINED__ PERL_MAGIC_regdatum 'd' +__UNDEFINED__ PERL_MAGIC_env 'E' +__UNDEFINED__ PERL_MAGIC_envelem 'e' +__UNDEFINED__ PERL_MAGIC_fm 'f' +__UNDEFINED__ PERL_MAGIC_regex_global 'g' +__UNDEFINED__ PERL_MAGIC_isa 'I' +__UNDEFINED__ PERL_MAGIC_isaelem 'i' +__UNDEFINED__ PERL_MAGIC_nkeys 'k' +__UNDEFINED__ PERL_MAGIC_dbfile 'L' +__UNDEFINED__ PERL_MAGIC_dbline 'l' +__UNDEFINED__ PERL_MAGIC_mutex 'm' +__UNDEFINED__ PERL_MAGIC_shared 'N' +__UNDEFINED__ PERL_MAGIC_shared_scalar 'n' +__UNDEFINED__ PERL_MAGIC_collxfrm 'o' +__UNDEFINED__ PERL_MAGIC_tied 'P' +__UNDEFINED__ PERL_MAGIC_tiedelem 'p' +__UNDEFINED__ PERL_MAGIC_tiedscalar 'q' +__UNDEFINED__ PERL_MAGIC_qr 'r' +__UNDEFINED__ PERL_MAGIC_sig 'S' +__UNDEFINED__ PERL_MAGIC_sigelem 's' +__UNDEFINED__ PERL_MAGIC_taint 't' +__UNDEFINED__ PERL_MAGIC_uvar 'U' +__UNDEFINED__ PERL_MAGIC_uvar_elem 'u' +__UNDEFINED__ PERL_MAGIC_vstring 'V' +__UNDEFINED__ PERL_MAGIC_vec 'v' +__UNDEFINED__ PERL_MAGIC_utf8 'w' +__UNDEFINED__ PERL_MAGIC_substr 'x' +__UNDEFINED__ PERL_MAGIC_defelem 'y' +__UNDEFINED__ PERL_MAGIC_glob '*' +__UNDEFINED__ PERL_MAGIC_arylen '#' +__UNDEFINED__ PERL_MAGIC_pos '.' +__UNDEFINED__ PERL_MAGIC_backref '<' +__UNDEFINED__ PERL_MAGIC_ext '~' + +/* That's the best we can do... */ +__UNDEFINED__ SvPV_force_nomg SvPV_force +__UNDEFINED__ SvPV_nomg SvPV +__UNDEFINED__ sv_catpvn_nomg sv_catpvn +__UNDEFINED__ sv_catsv_nomg sv_catsv +__UNDEFINED__ sv_setsv_nomg sv_setsv +__UNDEFINED__ sv_pvn_nomg sv_pvn +__UNDEFINED__ SvIV_nomg SvIV +__UNDEFINED__ SvUV_nomg SvUV + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +=xsubs + +void +sv_catpv_mg(sv, string) + SV *sv; + char *string; + CODE: + sv_catpv_mg(sv, string); + +void +sv_catpvn_mg(sv, sv2) + SV *sv; + SV *sv2; + PREINIT: + char *str; + STRLEN len; + CODE: + str = SvPV(sv2, len); + sv_catpvn_mg(sv, str, len); + +void +sv_catsv_mg(sv, sv2) + SV *sv; + SV *sv2; + CODE: + sv_catsv_mg(sv, sv2); + +void +sv_setiv_mg(sv, iv) + SV *sv; + IV iv; + CODE: + sv_setiv_mg(sv, iv); + +void +sv_setnv_mg(sv, nv) + SV *sv; + NV nv; + CODE: + sv_setnv_mg(sv, nv); + +void +sv_setpv_mg(sv, pv) + SV *sv; + char *pv; + CODE: + sv_setpv_mg(sv, pv); + +void +sv_setpvn_mg(sv, sv2) + SV *sv; + SV *sv2; + PREINIT: + char *str; + STRLEN len; + CODE: + str = SvPV(sv2, len); + sv_setpvn_mg(sv, str, len); + +void +sv_setsv_mg(sv, sv2) + SV *sv; + SV *sv2; + CODE: + sv_setsv_mg(sv, sv2); + +void +sv_setuv_mg(sv, uv) + SV *sv; + UV uv; + CODE: + sv_setuv_mg(sv, uv); + +void +sv_usepvn_mg(sv, sv2) + SV *sv; + SV *sv2; + PREINIT: + char *str, *copy; + STRLEN len; + CODE: + str = SvPV(sv2, len); + New(42, copy, len+1, char); + Copy(str, copy, len+1, char); + sv_usepvn_mg(sv, copy, len); + +=tests plan => 10 + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo'; +$h{bar} = ''; + +&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar'); +ok($h{foo}, 'foobar'); + +&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz'); +ok($h{bar}, 'baz'); + +&Devel::PPPort::sv_catsv_mg($h{foo}, '42'); +ok($h{foo}, 'foobar42'); + +&Devel::PPPort::sv_setiv_mg($h{bar}, 42); +ok($h{bar}, 42); + +&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159); +ok(abs($h{PI} - 3.14159) < 0.01); + +&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx'); +ok($h{mhx}, 'mhx'); + +&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus'); +ok($h{mhx}, 'Marcus'); + +&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV'); +ok($h{sv}, 'SV'); + +&Devel::PPPort::sv_setuv_mg($h{sv}, 4711); +ok($h{sv}, 4711); + +&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl'); +ok($h{sv}, 'Perl'); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/misc b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/misc new file mode 100644 index 00000000000..b89a29abd4b --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/misc @@ -0,0 +1,385 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ +PERL_UNUSED_DECL +PERL_GCC_BRACE_GROUPS_FORBIDDEN +NVTYPE +INT2PTR +PTRV +NUM2PTR +PTR2IV +PTR2UV +PTR2NV +PTR2ul +START_EXTERN_C +END_EXTERN_C +EXTERN_C +STMT_START +STMT_END +/PL_\w+/ + +=implementation + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_na na +# define PL_no_modify no_modify +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_ppaddr ppaddr +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +/* Replace: 0 */ +#endif + +#ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +#else +# define PERL_UNUSED_DECL +#endif + +__UNDEFINED__ NOOP (void)0 +__UNDEFINED__ dNOOP extern int Perl___notused PERL_UNUSED_DECL + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR + +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif + +# define NUM2PTR(any,d) (any)(PTRV)(d) +# define PTR2IV(p) INT2PTR(IV,p) +# define PTR2UV(p) INT2PTR(UV,p) +# define PTR2NV(p) NUM2PTR(NV,p) + +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif + +#endif /* !INT2PTR */ + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#undef STMT_START +#undef STMT_END +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif + +__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) + +/* DEFSV appears first in 5.004_56 */ +__UNDEFINED__ DEFSV GvSV(PL_defgv) +__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) + +/* Older perls (<=5.003) lack AvFILLp */ +__UNDEFINED__ AvFILLp AvFILL + +__UNDEFINED__ ERRSV get_sv("@",FALSE) + +__UNDEFINED__ newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ + +__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create) + +/* Replace: 1 */ +__UNDEFINED__ get_cv perl_get_cv +__UNDEFINED__ get_sv perl_get_sv +__UNDEFINED__ get_av perl_get_av +__UNDEFINED__ get_hv perl_get_hv +/* Replace: 0 */ + +#ifdef HAS_MEMCMP +__UNDEFINED__ memNE(s1,s2,l) (memcmp(s1,s2,l)) +__UNDEFINED__ memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#else +__UNDEFINED__ memNE(s1,s2,l) (bcmp(s1,s2,l)) +__UNDEFINED__ memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +__UNDEFINED__ MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +__UNDEFINED__ CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#ifdef HAS_MEMSET +__UNDEFINED__ ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#else +__UNDEFINED__ ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d) +#endif + +__UNDEFINED__ Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t)) + +__UNDEFINED__ dUNDERBAR dNOOP +__UNDEFINED__ UNDERBAR DEFSV + +__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1 +__UNDEFINED__ dITEMS I32 items = SP - MARK + +=xsubs + +int +gv_stashpvn(name, create) + char *name + I32 create + CODE: + RETVAL = gv_stashpvn(name, strlen(name), create) != NULL; + OUTPUT: + RETVAL + +int +get_sv(name, create) + char *name + I32 create + CODE: + RETVAL = get_sv(name, create) != NULL; + OUTPUT: + RETVAL + +int +get_av(name, create) + char *name + I32 create + CODE: + RETVAL = get_av(name, create) != NULL; + OUTPUT: + RETVAL + +int +get_hv(name, create) + char *name + I32 create + CODE: + RETVAL = get_hv(name, create) != NULL; + OUTPUT: + RETVAL + +int +get_cv(name, create) + char *name + I32 create + CODE: + RETVAL = get_cv(name, create) != NULL; + OUTPUT: + RETVAL + +void +newSVpvn() + PPCODE: + XPUSHs(newSVpvn("test", 4)); + XPUSHs(newSVpvn("test", 2)); + XPUSHs(newSVpvn("test", 0)); + XPUSHs(newSVpvn(NULL, 2)); + XPUSHs(newSVpvn(NULL, 0)); + XSRETURN(5); + +SV * +PL_sv_undef() + CODE: + RETVAL = newSVsv(&PL_sv_undef); + OUTPUT: + RETVAL + +SV * +PL_sv_yes() + CODE: + RETVAL = newSVsv(&PL_sv_yes); + OUTPUT: + RETVAL + +SV * +PL_sv_no() + CODE: + RETVAL = newSVsv(&PL_sv_no); + OUTPUT: + RETVAL + +int +PL_na(string) + char *string + CODE: + PL_na = strlen(string); + RETVAL = PL_na; + OUTPUT: + RETVAL + +SV* +boolSV(value) + int value + CODE: + RETVAL = newSVsv(boolSV(value)); + OUTPUT: + RETVAL + +SV* +DEFSV() + CODE: + RETVAL = newSVsv(DEFSV); + OUTPUT: + RETVAL + +int +ERRSV() + CODE: + RETVAL = SvTRUE(ERRSV); + OUTPUT: + RETVAL + +SV* +UNDERBAR() + CODE: + { + dUNDERBAR; + RETVAL = newSVsv(UNDERBAR); + } + OUTPUT: + RETVAL + +=tests plan => 31 + +use vars qw($my_sv @my_av %my_hv); + +my @s = &Devel::PPPort::newSVpvn(); +ok(@s == 5); +ok($s[0], "test"); +ok($s[1], "te"); +ok($s[2], ""); +ok(!defined($s[3])); +ok(!defined($s[4])); + +ok(!defined(&Devel::PPPort::PL_sv_undef())); +ok(&Devel::PPPort::PL_sv_yes()); +ok(!&Devel::PPPort::PL_sv_no()); +ok(&Devel::PPPort::PL_na("abcd"), 4); + +ok(&Devel::PPPort::boolSV(1)); +ok(!&Devel::PPPort::boolSV(0)); + +$_ = "Fred"; +ok(&Devel::PPPort::DEFSV(), "Fred"); +ok(&Devel::PPPort::UNDERBAR(), "Fred"); + +eval { 1 }; +ok(!&Devel::PPPort::ERRSV()); +eval { cannot_call_this_one() }; +ok(&Devel::PPPort::ERRSV()); + +ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0)); +ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0)); +ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1)); + +$my_sv = 1; +ok(&Devel::PPPort::get_sv('my_sv', 0)); +ok(!&Devel::PPPort::get_sv('not_my_sv', 0)); +ok(&Devel::PPPort::get_sv('not_my_sv', 1)); + +@my_av = (1); +ok(&Devel::PPPort::get_av('my_av', 0)); +ok(!&Devel::PPPort::get_av('not_my_av', 0)); +ok(&Devel::PPPort::get_av('not_my_av', 1)); + +%my_hv = (a=>1); +ok(&Devel::PPPort::get_hv('my_hv', 0)); +ok(!&Devel::PPPort::get_hv('not_my_hv', 0)); +ok(&Devel::PPPort::get_hv('not_my_hv', 1)); + +sub my_cv { 1 }; +ok(&Devel::PPPort::get_cv('my_cv', 0)); +ok(!&Devel::PPPort::get_cv('not_my_cv', 0)); +ok(&Devel::PPPort::get_cv('not_my_cv', 1)); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newCONSTSUB b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newCONSTSUB new file mode 100644 index 00000000000..f4bd221d5ae --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newCONSTSUB @@ -0,0 +1,107 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +newCONSTSUB + +=implementation + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if { VERSION < 5.004_63 } && { VERSION != 5.004_05 } +#if { NEED newCONSTSUB } + +void +newCONSTSUB(HV *stash, char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if { VERSION < 5.003_22 } + start_subparse(), +#elif { VERSION == 5.003_22 } + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +=xsinit + +#define NEED_newCONSTSUB + +=xsmisc + +void call_newCONSTSUB_1(void) +{ +#ifdef PERL_NO_GET_CONTEXT + dTHX; +#endif + newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1)); +} + +extern void call_newCONSTSUB_2(void); +extern void call_newCONSTSUB_3(void); + +=xsubs + +void +call_newCONSTSUB_1() + +void +call_newCONSTSUB_2() + +void +call_newCONSTSUB_3() + +=tests plan => 3 + +&Devel::PPPort::call_newCONSTSUB_1(); +ok(&Devel::PPPort::test_value_1(), 1); + +&Devel::PPPort::call_newCONSTSUB_2(); +ok(&Devel::PPPort::test_value_2(), 2); + +&Devel::PPPort::call_newCONSTSUB_3(); +ok(&Devel::PPPort::test_value_3(), 3); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newRV b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newRV new file mode 100644 index 00000000000..4e49f692739 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newRV @@ -0,0 +1,74 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +newRV_inc +newRV_noinc + +=implementation + +__UNDEFINED__ newRV_inc(sv) newRV(sv) /* Replace */ + +#ifndef newRV_noinc +#if { NEED newRV_noinc } +SV * +newRV_noinc(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +=xsinit + +#define NEED_newRV_noinc + +=xsubs + +U32 +newRV_inc_REFCNT() + PREINIT: + SV *sv, *rv; + CODE: + sv = newSViv(42); + rv = newRV_inc(sv); + SvREFCNT_dec(sv); + RETVAL = SvREFCNT(sv); + sv_2mortal(rv); + OUTPUT: + RETVAL + +U32 +newRV_noinc_REFCNT() + PREINIT: + SV *sv, *rv; + CODE: + sv = newSViv(42); + rv = newRV_noinc(sv); + RETVAL = SvREFCNT(sv); + sv_2mortal(rv); + OUTPUT: + RETVAL + +=tests plan => 2 + +ok(&Devel::PPPort::newRV_inc_REFCNT, 1); +ok(&Devel::PPPort::newRV_noinc_REFCNT, 1); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphbin b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphbin new file mode 100644 index 00000000000..e531fcfb3a9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphbin @@ -0,0 +1,662 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +=implementation + +=cut + +use strict; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! hints! changes! cplusplus + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +usage() if $opt{help}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +# Never use C comments in this file!!!!! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +my @files; + +if (@ARGV) { + @files = map { glob $_ } @ARGV; +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /\.(xs|c|h|cc)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob $_ } qw(*.xs *.c *.h *.cc); + } + my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files; + @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files; +} + +unless (@files) { + die "No input files given!\n"; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +__PERL_API__ +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %depends); +my $replace = 0; +my $hint = ''; + +while (<DATA>) { + if ($hint) { + if (m{^\s*\*\s(.*?)\s*$}) { + $hints{$hint} ||= ''; # suppress warning with older perls + $hints{$hint} .= "$1\n"; + } + else { + $hint = ''; + } + } + $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # temporarily remove C comments from the code + my @ccom; + $c =~ s{ + ( + [^"'/]+ + | + (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+ + | + (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+ + ) + | + (/ (?: + \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / + | + /[^\r\n]* + )) + }{ + defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce"; + }egsx; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/); + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + if (exists $need{$_}) { + $file{needs}{$_} = 'static'; + } + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { + warning("Possibly wrong #define $1 in $filename"); + } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses}}) { + next unless $file{uses}{$func}; # if it's only a dependency + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + elsif (exists $replace{$func}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + else { + diag("Uses $func"); + } + hint($func); + } + + for $func (sort keys %{$file{uses_todo}}) { + warning("Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo})); + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + +####################################################################### + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and can_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; + +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub can_use +{ + eval "use @_;"; + return $@ eq ''; +} + +sub rec_depend +{ + my $func = shift; + my %seen; + return () unless exists $depends{$func}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +sub hint +{ + $opt{quiet} and return; + $opt{hints} or return; + my $func = shift; + exists $hints{$func} or return; + $given_hints{$func}++ and return; + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphdoc b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphdoc new file mode 100644 index 00000000000..5d868f0ad69 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphdoc @@ -0,0 +1,286 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +=dontwarn + +NEED_function +NEED_function_GLOBAL +DPPP_NAMESPACE + +=implementation + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version __VERSION__ + +=head1 SYNOPSIS + + perl ppport.h [options] [files] + + --help show short help + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + + --list-provided list provided API + --list-unsupported list unsupported API + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to __MIN_PERL__, and has been tested up to __MAX_PERL__. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version __MIN_PERL__. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +up to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions that were not present in earlier +versions of Perl, and that can't be provided using a macro, you have +to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions will be marked C<explicit> in the list shown by +C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions, you want either C<static> or global variants. + +For a C<static> function, use: + + #define NEED_function + +For a global function, use: + + #define NEED_function_GLOBAL + +Note that you mustn't have more than one global request for one +function in your project. + + __EXPLICIT_API__ + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions using the C<DPPP_NAMESPACE> macro. +Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphtest b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphtest new file mode 100644 index 00000000000..dd3f164dbdc --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphtest @@ -0,0 +1,576 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=tests plan => 134 + +use File::Path qw/rmtree mkpath/; +use Config; + +my $tmp = 'ppptmp'; +my $inc = ''; +my $perl = find_perl(); + +rmtree($tmp) if -d $tmp; +mkpath($tmp) or die "mkpath $tmp: $!\n"; +chdir($tmp) or die "chdir $tmp: $!\n"; + +if ($ENV{'PERL_CORE'}) { + if (-d '../../lib') { + $inc = $^O eq 'VMS' ? '-"I../../lib"' : '-I../../lib'; + unshift @INC, '../../lib'; + } +} +if ($perl =~ m!^\./!) { + $perl = ".$perl"; +} + +END { + chdir('..') if !-d $tmp && -d "../$tmp"; + rmtree($tmp) if -d $tmp; +} + +ok(&Devel::PPPort::WriteFile("ppport.h")); + +sub ppport +{ + my @args = @_; + print "# *** running $perl $inc ppport.h @args ***\n"; + my $out = join '', `$perl $inc ppport.h @args`; + my $copy = $out; + $copy =~ s/^/# | /mg; + print "$copy\n"; + return $out; +} + +sub matches +{ + my($str, $re, $mod) = @_; + my @n; + eval "\@n = \$str =~ /$re/g$mod;"; + if ($@) { + my $err = $@; + $err =~ s/^/# *** /mg; + print "# *** ERROR ***\n$err\n"; + } + return $@ ? -42 : scalar @n; +} + +sub eq_files +{ + my($f1, $f2) = @_; + return 0 unless -e $f1 && -e $f2; + local *F; + for ($f1, $f2) { + print "# File: $_\n"; + unless (open F, $_) { + print "# couldn't open $_: $!\n"; + return 0; + } + $_ = do { local $/; <F> }; + close F; + my $copy = $_; + $copy =~ s/^/# | /mg; + print "$copy\n"; + } + return $f1 eq $f2; +} + +my @tests; + +for (split /\s*={70,}\s*/, do { local $/; <DATA> }) { + s/^\s+//; s/\s+$//; + my($c, %f); + ($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/; + push @tests, { code => $c, files => \%f }; +} + +my $t; +for $t (@tests) { + my $f; + for $f (keys %{$t->{files}}) { + my @f = split /\//, $f; + if (@f > 1) { + pop @f; + my $path = join '/', @f; + mkpath($path) or die "mkpath('$path'): $!\n"; + } + my $txt = $t->{files}{$f}; + local *F; + open F, ">$f" or die "open $f: $!\n"; + print F "$txt\n"; + close F; + $txt =~ s/^/# | /mg; + print "# *** writing $f ***\n$txt\n"; + } + + eval $t->{code}; + if ($@) { + my $err = $@; + $err =~ s/^/# *** /mg; + print "# *** ERROR ***\n$err\n"; + } + ok($@, ''); + + for (keys %{$t->{files}}) { + unlink $_ or die "unlink('$_'): $!\n"; + } +} + +sub find_perl +{ + my $perl = $^X; + + return $perl if $^O eq 'VMS'; + + my $exe = $Config{'_exe'} || ''; + + if ($perl =~ /^perl\Q$exe\E$/i) { + $perl = "perl$exe"; + eval "require File::Spec"; + if ($@) { + $perl = "./$perl"; + } else { + $perl = File::Spec->catfile(File::Spec->curdir(), $perl); + } + } + + if ($perl !~ /\Q$exe\E$/i) { + $perl .= $exe; + } + + warn "find_perl: cannot find $perl from $^X" unless -f $perl; + + return $perl; +} + +__DATA__ + +my $o = ppport(qw(--help)); +ok($o =~ /^Usage:.*ppport\.h/m); +ok($o =~ /--help/m); + +$o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*test\.xs/mi); +ok($o =~ /analyzing.*test\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok(matches($o, 'analyzing', 'mi'), 1); +ok($o =~ /Uses Perl_newSViv instead of newSViv/); + +$o = ppport(qw(--quiet --nochanges)); +ok($o =~ /^\s*$/); + +---------------------------- test.xs ------------------------------------------ + +Perl_newSViv(); + +=============================================================================== + +# check if C and C++ comments are filtered correctly + +my $o = ppport(qw(--copy=a)); +ok($o =~ /^scanning.*MyExt\.xs/mi); +ok($o =~ /analyzing.*MyExt\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Uses grok_bin/m); +ok($o !~ /^Uses newSVpv/m); +ok($o =~ /Uses 1 C\+\+ style comment/m); +ok(eq_files('MyExt.xsa', 'MyExt.ra')); + +# check if C++ are left untouched with --cplusplus + +$o = ppport(qw(--copy=b --cplusplus)); +ok($o =~ /^scanning.*MyExt\.xs/mi); +ok($o =~ /analyzing.*MyExt\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Uses grok_bin/m); +ok($o !~ /^Uses newSVpv/m); +ok($o !~ /Uses \d+ C\+\+ style comment/m); +ok(eq_files('MyExt.xsb', 'MyExt.rb')); + +unlink qw(MyExt.xsa MyExt.xsb); + +---------------------------- MyExt.xs ----------------------------------------- + +newSVuv(); + // newSVpv(); + XPUSHs(foo); +/* grok_bin(); */ + +---------------------------- MyExt.ra ----------------------------------------- + +#include "ppport.h" +newSVuv(); + /* newSVpv(); */ + XPUSHs(foo); +/* grok_bin(); */ + +---------------------------- MyExt.rb ----------------------------------------- + +#include "ppport.h" +newSVuv(); + // newSVpv(); + XPUSHs(foo); +/* grok_bin(); */ + +=============================================================================== + +my $o = ppport(qw(--nochanges file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o =~ /^Uses newCONSTSUB/m); +ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m); +ok($o =~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --nohints file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o =~ /^Uses newCONSTSUB/m); +ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m); +ok($o !~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --nohints --nodiag file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o !~ /^Uses newCONSTSUB/m); +ok($o !~ /^Uses SvPV_nolen/m); +ok($o !~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --quiet file1.xs)); +ok($o =~ /^\s*$/); + +$o = ppport(qw(--nochanges file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o =~ /^Uses mXPUSHp/m); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --nohints file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o =~ /^Uses mXPUSHp/m); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --nohints --nodiag file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o !~ /^Uses mXPUSHp/m); +ok($o !~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --quiet file2.xs)); +ok($o =~ /^\s*$/); + +---------------------------- file1.xs ----------------------------------------- + +#define NEED_newCONSTSUB +#define NEED_sv_2pv_nolen +#include "ppport.h" + +newCONSTSUB(); +SvPV_nolen(); + +---------------------------- file2.xs ----------------------------------------- + +mXPUSHp(foo); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*FooBar\.xs/mi); +ok($o =~ /analyzing.*FooBar\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o !~ /^Looks good/m); +ok($o =~ /^Uses grok_bin/m); + +---------------------------- FooBar.xs ---------------------------------------- + +newSViv(); +XPUSHs(foo); +grok_bin(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*First\.xs/mi); +ok($o =~ /analyzing.*First\.xs/mi); +ok($o =~ /^scanning.*second\.h/mi); +ok($o =~ /analyzing.*second\.h/mi); +ok($o =~ /^scanning.*sub.*third\.c/mi); +ok($o =~ /analyzing.*sub.*third\.c/mi); +ok($o !~ /^scanning.*foobar/mi); +ok(matches($o, '^scanning', 'mi'), 3); + +---------------------------- First.xs ----------------------------------------- + +one + +---------------------------- foobar.xyz --------------------------------------- + +two + +---------------------------- second.h ----------------------------------------- + +three + +---------------------------- sub/third.c -------------------------------------- + +four + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i); + +---------------------------- test.xs ------------------------------------------ + +#define NEED_foobar + +=============================================================================== + +# And now some complex "real-world" example + +my $o = ppport(qw(--copy=f)); +for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) { + ok($o =~ /^scanning.*\Q$_\E/mi); + ok($o =~ /analyzing.*\Q$_\E/i); +} +ok(matches($o, '^scanning', 'mi'), 6); + +ok(matches($o, '^Writing copy of', 'mi'), 5); +ok(!-e "mod5.cf"); + +for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) { + ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi); + ok(-e "${_}f"); + ok(eq_files("${_}f", "${_}r")); + unlink "${_}f"; +} + +---------------------------- main.xs ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_newCONSTSUB +#define NEED_grok_hex_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_hex(); +Perl_grok_bin(aTHX_ foo, bar); + +/* some comment */ + +perl_eval_pv(); +grok_bin(); +Perl_grok_bin(bar, sv_no); + +---------------------------- mod1.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_grok_bin_GLOBAL +#define NEED_newCONSTSUB +#include "ppport.h" + +newCONSTSUB(); +grok_bin(); +{ + Perl_croak ("foo"); + Perl_sv_catpvf(); /* I know it's wrong ;-) */ +} + +---------------------------- mod2.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_eval_pv +#include "ppport.h" + +newSViv(); + +/* + eval_pv(); +*/ + +---------------------------- mod3.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +grok_oct(); +eval_pv(); + +---------------------------- mod4.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +START_MY_CXT; + +---------------------------- mod5.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" +call_pv(); + +---------------------------- main.xsr ----------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_eval_pv_GLOBAL +#define NEED_grok_hex +#define NEED_newCONSTSUB_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_hex(); +grok_bin(foo, bar); + +/* some comment */ + +eval_pv(); +grok_bin(); +grok_bin(bar, PL_sv_no); + +---------------------------- mod1.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_grok_bin_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_bin(); +{ + Perl_croak (aTHX_ "foo"); + Perl_sv_catpvf(aTHX); /* I know it's wrong ;-) */ +} + +---------------------------- mod2.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + + +newSViv(); + +/* + eval_pv(); +*/ + +---------------------------- mod3.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#define NEED_grok_oct +#include "ppport.h" + +grok_oct(); +eval_pv(); + +---------------------------- mod4.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + +START_MY_CXT; + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Uses grok_hex/m); +ok($o !~ /Looks good/m); + +$o = ppport(qw(--nochanges --compat-version=5.8.0)); +ok($o !~ /Uses grok_hex/m); +ok($o =~ /Looks good/m); + +---------------------------- FooBar.xs ---------------------------------------- + +grok_hex(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Uses SvPVutf8_force, which may not be portable/m); + +$o = ppport(qw(--nochanges --compat-version=5.6.0)); +ok($o !~ /Uses SvPVutf8_force/m); + +---------------------------- FooBar.xs ---------------------------------------- + +SvPVutf8_force(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o !~ /potentially required change/); +ok(matches($o, '^Looks good', 'mi'), 2); + +---------------------------- FooBar.xs ---------------------------------------- + +#define NEED_grok_numeric_radix +#define NEED_grok_number +#include "ppport.h" + +GROK_NUMERIC_RADIX(); +grok_number(); + +---------------------------- foo.c -------------------------------------------- + +#include "ppport.h" + +call_pv(); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/sv_xpvf b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/sv_xpvf new file mode 100644 index 00000000000..27028dbc656 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/sv_xpvf @@ -0,0 +1,327 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +vnewSVpvf +sv_vcatpvf +sv_vsetpvf + +sv_catpvf_mg +sv_catpvf_mg_nocontext +sv_vcatpvf_mg + +sv_setpvf_mg +sv_setpvf_mg_nocontext +sv_vsetpvf_mg + +=implementation + +#if { VERSION >= 5.004 } && !defined(vnewSVpvf) +#if { NEED vnewSVpvf } + +SV * +vnewSVpvf(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg) +#if { NEED sv_catpvf_mg } + +void +sv_catpvf_mg(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg_nocontext) +#if { NEED sv_catpvf_mg_nocontext } + +void +sv_catpvf_mg_nocontext(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg) +#if { NEED sv_setpvf_mg } + +void +sv_setpvf_mg(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg_nocontext) +#if { NEED sv_setpvf_mg_nocontext } + +void +sv_setpvf_mg_nocontext(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +=xsinit + +#define NEED_vnewSVpvf +#define NEED_sv_catpvf_mg +#define NEED_sv_catpvf_mg_nocontext +#define NEED_sv_setpvf_mg +#define NEED_sv_setpvf_mg_nocontext + +=xsmisc + +static SV * test_vnewSVpvf(pTHX_ const char *pat, ...) +{ + SV *sv; + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv = vnewSVpvf(pat, &args); +#else + sv = newSVpv(pat, 0); +#endif + va_end(args); + return sv; +} + +static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv_vcatpvf(sv, pat, &args); +#else + sv_catpv(sv, pat); +#endif + va_end(args); +} + +static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv_vsetpvf(sv, pat, &args); +#else + sv_setpv(sv, pat); +#endif + va_end(args); +} + +=xsubs + +SV * +vnewSVpvf() + CODE: + RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +SV * +sv_vcatpvf(sv) + SV *sv + CODE: + RETVAL = newSVsv(sv); + test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +SV * +sv_vsetpvf(sv) + SV *sv + CODE: + RETVAL = newSVsv(sv); + test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +void +sv_catpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + sv_catpvf_mg(sv, "%s-%d", "Perl", 42); +#endif + +void +Perl_sv_catpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43); +#endif + +void +sv_catpvf_mg_nocontext(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } +#ifdef PERL_IMPLICIT_CONTEXT + sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44); +#else + sv_catpvf_mg(sv, "%s-%d", "-Perl", 44); +#endif +#endif + +void +sv_setpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + sv_setpvf_mg(sv, "%s-%d", "mhx", 42); +#endif + +void +Perl_sv_setpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43); +#endif + +void +sv_setpvf_mg_nocontext(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } +#ifdef PERL_IMPLICIT_CONTEXT + sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44); +#else + sv_setpvf_mg(sv, "%s-%d", "bar", 44); +#endif +#endif + +=tests plan => 9 + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo-'; +$h{bar} = ''; + +ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); +ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); +ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); + +&Devel::PPPort::sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); + +&Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); + +&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); + +&Devel::PPPort::sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); + +&Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); + +&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); + + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/threads b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/threads new file mode 100644 index 00000000000..bd17dc31be0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/threads @@ -0,0 +1,57 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ + +=implementation + +__UNDEFINED__ dTHR dNOOP + +__UNDEFINED__ dTHX dNOOP +__UNDEFINED__ dTHXa(x) dNOOP + +__UNDEFINED__ pTHX void +__UNDEFINED__ pTHX_ +__UNDEFINED__ aTHX +__UNDEFINED__ aTHX_ + +__UNDEFINED__ dTHXoa(x) dTHXa(x) + +=xsubs + +IV +no_THX_arg(sv) + SV *sv + CODE: + RETVAL = 1 + sv_2iv(sv); + OUTPUT: + RETVAL + +void +with_THX_arg(error) + char *error + PPCODE: + Perl_croak(aTHX_ "%s", error); + +=tests plan => 2 + +ok(&Devel::PPPort::no_THX_arg("42"), 43); +eval { &Devel::PPPort::with_THX_arg("yes\n"); }; +ok($@ =~ /^yes/); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/uv b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/uv new file mode 100644 index 00000000000..69a35f2e3b3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/uv @@ -0,0 +1,130 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +sv_setuv +newSVuv +__UNDEFINED__ + +=implementation + +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif + +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif + +__UNDEFINED__ sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +__UNDEFINED__ SvUVX(sv) ((UV)SvIVX(sv)) +__UNDEFINED__ SvUVXx(sv) SvUVX(sv) +__UNDEFINED__ SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +__UNDEFINED__ SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +__UNDEFINED__ sv_uv(sv) SvUVx(sv) + +__UNDEFINED__ XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +__UNDEFINED__ XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END + +__UNDEFINED__ PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +__UNDEFINED__ XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END + +=xsubs + +SV * +sv_setuv(uv) + UV uv + CODE: + RETVAL = newSViv(1); + sv_setuv(RETVAL, uv); + OUTPUT: + RETVAL + +SV * +newSVuv(uv) + UV uv + CODE: + RETVAL = newSVuv(uv); + OUTPUT: + RETVAL + +UV +sv_2uv(sv) + SV *sv + CODE: + RETVAL = sv_2uv(sv); + OUTPUT: + RETVAL + +UV +SvUVx(sv) + SV *sv + CODE: + sv--; + RETVAL = SvUVx(++sv); + OUTPUT: + RETVAL + +void +XSRETURN_UV() + PPCODE: + XSRETURN_UV(42); + +void +PUSHu() + PREINIT: + dTARG; + PPCODE: + TARG = sv_newmortal(); + EXTEND(SP, 1); + PUSHu(42); + XSRETURN(1); + +void +XPUSHu() + PREINIT: + dTARG; + PPCODE: + TARG = sv_newmortal(); + XPUSHu(43); + XSRETURN(1); + +=tests plan => 10 + +ok(&Devel::PPPort::sv_setuv(42), 42); +ok(&Devel::PPPort::newSVuv(123), 123); +ok(&Devel::PPPort::sv_2uv("4711"), 4711); +ok(&Devel::PPPort::sv_2uv("1735928559"), 1735928559); +ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559); +ok(&Devel::PPPort::SvUVx(1735928559), 1735928559); +ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef); +ok(&Devel::PPPort::XSRETURN_UV(), 42); +ok(&Devel::PPPort::PUSHu(), 42); +ok(&Devel::PPPort::XPUSHu(), 43); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/version b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/version new file mode 100644 index 00000000000..8571d34273a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/version @@ -0,0 +1,56 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +PERL_REVISION +PERL_VERSION +PERL_SUBVERSION +PERL_BCDVERSION + +=dontwarn + +PERL_PATCHLEVEL_H_IMPLICIT + +=implementation + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/ppptools.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/ppptools.pl new file mode 100644 index 00000000000..1f89196f17c --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/ppptools.pl @@ -0,0 +1,375 @@ +################################################################################ +# +# ppptools.pl -- various utility functions +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +sub parse_todo +{ + my $dir = shift || 'parts/todo'; + local *TODO; + my %todo; + my $todo; + + for $todo (glob "$dir/*") { + open TODO, $todo or die "cannot open $todo: $!\n"; + my $perl = <TODO>; + chomp $perl; + while (<TODO>) { + chomp; + s/#.*//; + s/^\s+//; s/\s+$//; + /^\s*$/ and next; + /^\w+$/ or die "invalid identifier: $_\n"; + exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $perl)\n"; + $todo{$_} = $perl; + } + close TODO; + } + + return \%todo; +} + +sub expand_version +{ + my($op, $ver) = @_; + my($r, $v, $s) = parse_version($ver); + $r == 5 or die "only Perl revision 5 is supported\n"; + $op eq '==' and return "((PERL_VERSION == $v) && (PERL_SUBVERSION == $s))"; + $op eq '!=' and return "((PERL_VERSION != $v) || (PERL_SUBVERSION != $s))"; + $op =~ /([<>])/ and return "((PERL_VERSION $1 $v) || ((PERL_VERSION == $v) && (PERL_SUBVERSION $op $s)))"; + die "cannot expand version expression ($op $ver)\n"; +} + +sub parse_partspec +{ + my $file = shift; + my $section = 'implementation'; + my $vsec = join '|', qw( provides dontwarn implementation + xsubs xsinit xsmisc xshead xsboot tests ); + my(%data, %options); + local *F; + + open F, $file or die "$file: $!\n"; + while (<F>) { + /^##/ and next; + if (/^=($vsec)(?:\s+(.*))?/) { + $section = $1; + if (defined $2) { + my $opt = $2; + $options{$section} = eval "{ $opt }"; + $@ and die "Invalid options ($opt) in section $section of $file: $@\n"; + } + next; + } + push @{$data{$section}}, $_; + } + close F; + + for (keys %data) { + my @v = @{$data{$_}}; + shift @v while @v && $v[0] =~ /^\s*$/; + pop @v while @v && $v[-1] =~ /^\s*$/; + $data{$_} = join '', @v; + } + + unless (exists $data{provides}) { + $data{provides} = ($file =~ /(\w+)$/)[0]; + } + $data{provides} = [$data{provides} =~ /(\S+)/g]; + + if (exists $data{dontwarn}) { + $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g]; + } + + my @prov; + my %proto; + + if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) { + $data{implementation} = ''; + } + else { + $data{implementation} =~ /\S/ or die "Empty implementation in $file\n"; + + my $p; + + for $p (@{$data{provides}}) { + if ($p =~ m#^/.*/\w*$#) { + my @tmp = eval "\$data{implementation} =~ ${p}gm"; + $@ and die "invalid regex $p in $file\n"; + @tmp or warn "no matches for regex $p in $file\n"; + push @prov, do { my %h; grep !$h{$_}++, @tmp }; + } + elsif ($p eq '__UNDEFINED__') { + my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm; + @tmp or warn "no __UNDEFINED__ macros in $file\n"; + push @prov, @tmp; + } + else { + push @prov, $p; + } + } + + for (@prov) { + if ($data{implementation} !~ /\b\Q$_\E\b/) { + warn "$file claims to provide $_, but doesn't seem to do so\n"; + next; + } + + # scan for prototypes + my($proto) = $data{implementation} =~ / + ( ^ (?:[\w*]|[^\S\r\n])+ + [\r\n]*? + ^ \b$_\b \s* + \( [^{]* \) + ) + \s* \{ + /xm or next; + + $proto =~ s/^\s+//; + $proto =~ s/\s+$//; + $proto =~ s/\s+/ /g; + + exists $proto{$_} and warn "$file: duplicate prototype for $_\n"; + $proto{$_} = $proto; + } + } + + for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) { + if (exists $data{$section}) { + $data{$section} =~ s/\{\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*\}/expand_version($1, $2)/gei; + } + } + + $data{provides} = \@prov; + $data{prototypes} = \%proto; + $data{OPTIONS} = \%options; + + my %prov = map { ($_ => 1) } @prov; + my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : (); + my @maybeprov = do { my %h; + grep { + my($nop) = /^Perl_(.*)/; + not exists $prov{$_} || + exists $dontwarn{$_} || + (defined $nop && exists $prov{$nop} ) || + (defined $nop && exists $dontwarn{$nop}) || + $h{$_}++; + } + $data{implementation} =~ /^\s*#\s*define\s+(\w+)/g }; + + if (@maybeprov) { + warn "$file seems to provide these macros, but doesn't list them:\n " + . join("\n ", @maybeprov) . "\n"; + } + + return \%data; +} + +sub compare_prototypes +{ + my($p1, $p2) = @_; + for ($p1, $p2) { + s/^\s+//; + s/\s+$//; + s/\s+/ /g; + s/(\w)\s(\W)/$1$2/g; + s/(\W)\s(\w)/$1$2/g; + } + return $p1 cmp $p2; +} + +sub ppcond +{ + my $s = shift; + my @c; + my $p; + + for $p (@$s) { + push @c, map "!($_)", @{$p->{pre}}; + defined $p->{cur} and push @c, "($p->{cur})"; + } + + join " && ", @c; +} + +sub trim_arg +{ + my $in = shift; + + $in eq '...' and return ($in); + + local $_ = $in; + my $id; + + s/[*()]/ /g; + s/\[[^\]]*\]/ /g; + s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g; + s/^\s*//; s/\s*$//; + + if( /^\b(?:struct|union|enum)\s+\w+(?:\s+(\w+))?$/ ) { + defined $1 and $id = $1; + } + else { + if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) { + /^\s*(\w+)\s*$/ and $id = $1; + } + else { + /^\s*\w+\s+(\w+)\s*$/ and $id = $1; + } + } + + $_ = $in; + + defined $id and s/\b$id\b//; + + # these don't matter at all + s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g; + + s/(?=<\*)\s+(?=\*)//g; + s/\s*(\*+)\s*/ $1 /g; + s/^\s*//; s/\s*$//; + s/\s+/ /g; + + return ($_, $id); +} + +sub parse_embed +{ + my @files = @_; + my @func; + my @pps; + my $file; + local *FILE; + + for $file (@files) { + open FILE, $file or die "$file: $!\n"; + my($line, $l); + + while (defined($line = <FILE>)) { + while ($line =~ /\\$/ && defined($l = <FILE>)) { + $line =~ s/\\\s*//; + $line .= $l; + } + next if $line =~ /^\s*:/; + $line =~ s/^\s+|\s+$//gs; + my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/); + if (defined $dir and defined $args) { + for ($dir) { + /^ifdef$/ and do { push @pps, { pre => [], cur => "defined($args)" } ; last }; + /^ifndef$/ and do { push @pps, { pre => [], cur => "!defined($args)" } ; last }; + /^if$/ and do { push @pps, { pre => [], cur => $args } ; last }; + /^elif$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last }; + /^else$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last }; + /^endif$/ and do { pop @pps ; last }; + /^include$/ and last; + /^define$/ and last; + /^undef$/ and last; + warn "unhandled preprocessor directive: $dir\n"; + } + } + else { + my @e = split /\s*\|\s*/, $line; + if( @e >= 3 ) { + my($flags, $ret, $name, @args) = @e; + for (@args) { + $_ = [trim_arg($_)]; + } + ($ret) = trim_arg($ret); + push @func, { + name => $name, + flags => { map { $_, 1 } $flags =~ /./g }, + ret => $ret, + args => \@args, + cond => ppcond(\@pps), + }; + } + } + } + + close FILE; + } + + return @func; +} + +sub make_prototype +{ + my $f = shift; + my @args = map { "@$_" } @{$f->{args}}; + my $proto; + my $pTHX_ = exists $f->{flags}{n} ? "" : "pTHX_ "; + $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')'; + return $proto; +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + $s /= 10; + } + + return ($r, $v, $s); +} + +1; diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004000 new file mode 100644 index 00000000000..58f01f5f2f8 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004000 @@ -0,0 +1,65 @@ +5.004000 +GIMME_V # E +G_VOID # E +HEf_SVKEY # E +HeHASH # U +HeKEY # E +HeKLEN # U +HePV # E +HeSVKEY # E +HeSVKEY_force # E +HeSVKEY_set # E +HeVAL # E +SvSetMagicSV # U +SvSetMagicSV_nosteal # U +SvSetSV_nosteal # U +SvTAINTED # U +SvTAINTED_off # U +SvTAINTED_on # U +block_gimme # U +call_list # U +cv_const_sv # E +delimcpy # E +do_open # E (Perl_do_open) +form # E +gv_autoload4 # E +gv_efullname3 # U +gv_fetchmethod_autoload # E +gv_fullname3 # U +hv_delayfree_ent # U +hv_delete_ent # E +hv_exists_ent # U +hv_fetch_ent # E +hv_free_ent # U +hv_iterkeysv # E +hv_ksplit # U +hv_store_ent # E +ibcmp_locale # U +my_failure_exit # U +my_memcmp # U +my_pclose # E (Perl_my_pclose) +my_popen # E (Perl_my_popen) +newSVpvf # E +rsignal # E +rsignal_state # E +save_I16 # U +save_gp # U +start_subparse # E (Perl_start_subparse) +sv_catpvf # U +sv_catpvf_mg # U +sv_cmp_locale # U +sv_derived_from # U +sv_gets # E (Perl_sv_gets) +sv_setpvf # U +sv_setpvf_mg # U +sv_taint # U +sv_tainted # U +sv_untaint # U +sv_vcatpvf # U +sv_vcatpvf_mg # U +sv_vcatpvfn # U +sv_vsetpvf # U +sv_vsetpvf_mg # U +sv_vsetpvfn # U +unsharepvn # U +vnewSVpvf # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004010 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004010 new file mode 100644 index 00000000000..8c298666039 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004010 @@ -0,0 +1 @@ +5.004010 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004020 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004020 new file mode 100644 index 00000000000..4b43fdf8e46 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004020 @@ -0,0 +1 @@ +5.004020 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004030 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004030 new file mode 100644 index 00000000000..e45facbb1f9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004030 @@ -0,0 +1 @@ +5.004030 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004040 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004040 new file mode 100644 index 00000000000..9920f573c48 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004040 @@ -0,0 +1,2 @@ +5.004040 +newWHILEOP # E (Perl_newWHILEOP) diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004050 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004050 new file mode 100644 index 00000000000..f1c9f8942a7 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004050 @@ -0,0 +1,4 @@ +5.004050 +do_binmode # U +save_aelem # U +save_helem # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005000 new file mode 100644 index 00000000000..e0eecec5205 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005000 @@ -0,0 +1,27 @@ +5.005000 +PL_modglobal # E +cx_dump # U +debop # U +debprofdump # U +fbm_compile # E (Perl_fbm_compile) +fbm_instr # E (Perl_fbm_instr) +get_op_descs # E +get_op_names # E +init_stacks # U +mg_length # U +mg_size # U +newHVhv # E +new_stackinfo # E +regdump # U +regexec_flags # U +regnext # E (Perl_regnext) +runops_debug # U +runops_standard # U +save_hints # U +save_iv # U (save_iv) +save_threadsv # E +screaminstr # E (Perl_screaminstr) +sv_iv # U +sv_nv # U +sv_peek # U +sv_true # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005010 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005010 new file mode 100644 index 00000000000..deebff5bf8a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005010 @@ -0,0 +1 @@ +5.005010 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005020 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005020 new file mode 100644 index 00000000000..d19ff2ae09e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005020 @@ -0,0 +1 @@ +5.005020 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005030 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005030 new file mode 100644 index 00000000000..362e8f27738 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005030 @@ -0,0 +1,4 @@ +5.005030 +POPpx # E +get_vtbl # E +save_generic_svref # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005040 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005040 new file mode 100644 index 00000000000..8a165c20337 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005040 @@ -0,0 +1 @@ +5.005040 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006000 new file mode 100644 index 00000000000..b1e9b26ad0e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006000 @@ -0,0 +1,156 @@ +5.006000 +SvIOK_UV # U +SvIOK_notUV # U +SvIOK_only_UV # U +SvPOK_only_UTF8 # U +SvPVbyte_nolen # E +SvPVbytex # E +SvPVbytex_force # E +SvPVutf8 # E +SvPVutf8_force # E +SvPVutf8_nolen # E +SvPVutf8x # E +SvPVutf8x_force # E +SvUTF8 # U +SvUTF8_off # U +SvUTF8_on # U +av_delete # E +av_exists # U +call_atexit # E +cast_i32 # U (cast_i32) +cast_iv # U (cast_iv) +cast_ulong # U +cast_uv # U (cast_uv) +do_gv_dump # U +do_gvgv_dump # U +do_hv_dump # U +do_magic_dump # U +do_op_dump # U +do_open9 # U +do_pmop_dump # U +do_sv_dump # U +dump_all # U +dump_eval # U +dump_form # U +dump_indent # U +dump_packsubs # U +dump_sub # U +dump_vindent # U +get_context # E +get_ppaddr # E +gv_dump # U +init_i18nl10n # U (perl_init_i18nl10n) +init_i18nl14n # U (perl_init_i18nl14n) +is_uni_alnum # U +is_uni_alnum_lc # U +is_uni_alnumc # U +is_uni_alnumc_lc # U +is_uni_alpha # U +is_uni_alpha_lc # U +is_uni_ascii # U +is_uni_ascii_lc # U +is_uni_cntrl # U +is_uni_cntrl_lc # U +is_uni_digit # U +is_uni_digit_lc # U +is_uni_graph # U +is_uni_graph_lc # U +is_uni_idfirst # U +is_uni_idfirst_lc # U +is_uni_lower # U +is_uni_lower_lc # U +is_uni_print # U +is_uni_print_lc # U +is_uni_punct # U +is_uni_punct_lc # U +is_uni_space # U +is_uni_space_lc # U +is_uni_upper # U +is_uni_upper_lc # U +is_uni_xdigit # U +is_uni_xdigit_lc # U +is_utf8_alnum # U +is_utf8_alnumc # U +is_utf8_alpha # U +is_utf8_ascii # U +is_utf8_char # U +is_utf8_cntrl # U +is_utf8_digit # U +is_utf8_graph # U +is_utf8_idfirst # U +is_utf8_lower # U +is_utf8_mark # U +is_utf8_print # U +is_utf8_punct # U +is_utf8_space # U +is_utf8_upper # U +is_utf8_xdigit # U +load_module # U +magic_dump # U +mess # E (Perl_mess) +my_atof # U +my_fflush_all # U +newANONATTRSUB # E +newATTRSUB # E +newMYSUB # U +newPADOP # E +newXS # E (Perl_newXS) +newXSproto # E +new_collate # U (perl_new_collate) +new_ctype # U (perl_new_ctype) +new_numeric # U (perl_new_numeric) +op_dump # U +perl_parse # E (perl_parse) +pmop_dump # U +pv_display # E +re_intuit_start # E +re_intuit_string # E +reginitcolors # U +require_pv # U (perl_require_pv) +safesyscalloc # E +safesysfree # U +safesysmalloc # E +safesysrealloc # E +save_I8 # U +save_alloc # U +save_destructor # E (Perl_save_destructor) +save_destructor_x # E +save_re_context # U +save_vptr # U +scan_bin # U +set_context # U +set_numeric_local # U (perl_set_numeric_local) +set_numeric_radix # U +set_numeric_standard # U (perl_set_numeric_standard) +str_to_version # U +sv_2pvutf8 # E +sv_2pvutf8_nolen # E +sv_force_normal # U +sv_len_utf8 # U +sv_pos_b2u # U +sv_pos_u2b # U +sv_pv # E +sv_pvbyte # E +sv_pvbyten # E +sv_pvbyten_force # E +sv_pvutf8 # E +sv_pvutf8n # E +sv_pvutf8n_force # E +sv_rvweaken # E +sv_utf8_decode # U +sv_utf8_downgrade # U +sv_utf8_encode # U +swash_init # E +tmps_grow # U +to_uni_lower_lc # U +to_uni_title_lc # U +to_uni_upper_lc # U +utf8_distance # U +utf8_hop # E +vcroak # U +vform # E +vload_module # U +vmess # E +vwarn # U +vwarner # U +warner # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006001 new file mode 100644 index 00000000000..bb24f78e754 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006001 @@ -0,0 +1,10 @@ +5.006001 +apply_attrs_string # U +bytes_to_utf8 # E +gv_efullname4 # U +gv_fullname4 # U +is_utf8_string # U +save_generic_pvref # U +utf16_to_utf8 # E (Perl_utf16_to_utf8) +utf16_to_utf8_reversed # E (Perl_utf16_to_utf8_reversed) +utf8_to_bytes # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006002 new file mode 100644 index 00000000000..dfe09ce2c59 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006002 @@ -0,0 +1 @@ +5.006002 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007000 new file mode 100644 index 00000000000..49d08465db8 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007000 @@ -0,0 +1 @@ +5.007000 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007001 new file mode 100644 index 00000000000..b5039cef8da --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007001 @@ -0,0 +1,25 @@ +5.007001 +POPpbytex # E +SvUOK # U +bytes_from_utf8 # E +csighandler # U +despatch_signals # U +do_openn # U +gv_handler # E +is_lvalue_sub # U +my_popen_list # E +newSVpvn_share # E +save_mortalizesv # U +save_padsv # U +scan_num # E (Perl_scan_num) +sv_force_normal_flags # U +sv_setref_uv # E +sv_unref_flags # U +sv_utf8_upgrade # E (Perl_sv_utf8_upgrade) +utf8_length # U +utf8_to_uvchr # U +utf8_to_uvuni # U +utf8n_to_uvchr # U +utf8n_to_uvuni # U +uvchr_to_utf8 # E +uvuni_to_utf8 # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007002 new file mode 100644 index 00000000000..805bcae5cd4 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007002 @@ -0,0 +1,18 @@ +5.007002 +calloc # E +getcwd_sv # U +init_tm # U +malloc # E +mfree # U +mini_mktime # U +my_atof2 # E +my_strftime # E +op_null # U +realloc # E +sv_2pv_flags # E +sv_catpvn_flags # U +sv_catsv_flags # U +sv_pvn_force_flags # E +sv_setsv_flags # U +sv_utf8_upgrade_flags # U +swash_fetch # E (Perl_swash_fetch) diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007003 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007003 new file mode 100644 index 00000000000..a742bdcf3be --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007003 @@ -0,0 +1,64 @@ +5.007003 +PerlIO_clearerr # E (PerlIO_clearerr) +PerlIO_close # E (PerlIO_close) +PerlIO_eof # E (PerlIO_eof) +PerlIO_error # E (PerlIO_error) +PerlIO_fileno # E (PerlIO_fileno) +PerlIO_fill # E (PerlIO_fill) +PerlIO_flush # E (PerlIO_flush) +PerlIO_get_base # E (PerlIO_get_base) +PerlIO_get_bufsiz # E (PerlIO_get_bufsiz) +PerlIO_get_cnt # E (PerlIO_get_cnt) +PerlIO_get_ptr # E (PerlIO_get_ptr) +PerlIO_read # E (PerlIO_read) +PerlIO_seek # E (PerlIO_seek) +PerlIO_set_cnt # E (PerlIO_set_cnt) +PerlIO_set_ptrcnt # E (PerlIO_set_ptrcnt) +PerlIO_setlinebuf # E (PerlIO_setlinebuf) +PerlIO_stderr # E (PerlIO_stderr) +PerlIO_stdin # E (PerlIO_stdin) +PerlIO_stdout # E (PerlIO_stdout) +PerlIO_tell # E (PerlIO_tell) +PerlIO_unread # E (PerlIO_unread) +PerlIO_write # E (PerlIO_write) +SvLOCK # E +SvSHARE # E +SvUNLOCK # E +atfork_lock # E +atfork_unlock # E +custom_op_desc # E +custom_op_name # E +deb # U +debstack # U +debstackptrs # U +gv_fetchmeth_autoload # E +ibcmp_utf8 # E +my_fork # E +my_socketpair # E +pack_cat # E +perl_destruct # E (perl_destruct) +pv_uni_display # E +regclass_swash # E (Perl_regclass_swash) +save_shared_pvref # E +savesharedpv # E +sortsv # E +sv_copypv # E +sv_magicext # E +sv_nolocking # E +sv_nosharing # E +sv_nounlocking # E +sv_recode_to_utf8 # E +sv_uni_display # E +to_uni_fold # E +to_uni_lower # E (Perl_to_uni_lower) +to_uni_title # E (Perl_to_uni_title) +to_uni_upper # E (Perl_to_uni_upper) +to_utf8_case # E +to_utf8_fold # E +to_utf8_lower # E (Perl_to_utf8_lower) +to_utf8_title # E (Perl_to_utf8_title) +to_utf8_upper # E (Perl_to_utf8_upper) +unpack_str # E +uvchr_to_utf8_flags # E +uvuni_to_utf8_flags # E +vdeb # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008000 new file mode 100644 index 00000000000..461ce9cba79 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008000 @@ -0,0 +1,5 @@ +5.008000 +hv_iternext_flags # E +hv_store_flags # E +is_utf8_idcont # U +nothreadhook # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008001 new file mode 100644 index 00000000000..595263f05b9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008001 @@ -0,0 +1,13 @@ +5.008001 +SvVOK # U +doing_taint # U +is_utf8_string_loc # U +packlist # U +save_bool # U +savestack_grow_cnt # U +scan_vstring # E +sv_cat_decode # U +sv_compile_2op # E (Perl_sv_compile_2op) +sv_setpviv # U +sv_setpviv_mg # U +unpackstring # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008002 new file mode 100644 index 00000000000..63aac525fed --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008002 @@ -0,0 +1 @@ +5.008002 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008003 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008003 new file mode 100644 index 00000000000..50c6ce1aa14 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008003 @@ -0,0 +1,3 @@ +5.008003 +SvIsCOW # U +SvIsCOW_shared_hash # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008004 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008004 new file mode 100644 index 00000000000..bb7bcdf66ac --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008004 @@ -0,0 +1 @@ +5.008004 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008005 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008005 new file mode 100644 index 00000000000..7bd2029f4b3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008005 @@ -0,0 +1 @@ +5.008005 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009000 new file mode 100644 index 00000000000..8b45dc7ba02 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009000 @@ -0,0 +1,7 @@ +5.009000 +new_version # E +save_set_svflags # U +upg_version # E +vcmp # U +vnumify # E +vstringify # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009001 new file mode 100644 index 00000000000..19e05e4992e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009001 @@ -0,0 +1,7 @@ +5.009001 +hv_assert # U +hv_clear_placeholders # U +hv_scalar # E +scan_version # E (Perl_scan_version) +sv_2iv_flags # U +sv_2uv_flags # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009002 new file mode 100644 index 00000000000..90f6bbe3d00 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009002 @@ -0,0 +1,4 @@ +5.009002 +SvPVbyte_force # E +find_rundefsvoffset # U +vnormal # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/MY_CXT.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/MY_CXT.t new file mode 100755 index 00000000000..e9f1238307c --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/MY_CXT.t @@ -0,0 +1,41 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/MY_CXT instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..3\n"; + } + else { + plan(tests => 3); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::MY_CXT_1()); +ok(&Devel::PPPort::MY_CXT_2()); +ok(&Devel::PPPort::MY_CXT_CLONE()); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/SvPV.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/SvPV.t new file mode 100755 index 00000000000..5e6009c3a46 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/SvPV.t @@ -0,0 +1,40 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/SvPV instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::SvPVbyte("mhx"), 3); +ok(&Devel::PPPort::SvPVbyte("mhx"), 3); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/call.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/call.t new file mode 100755 index 00000000000..ffcfcc4b2dd --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/call.t @@ -0,0 +1,89 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/call instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..44\n"; + } + else { + plan(tests => 44); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +sub eq_array +{ + my($a, $b) = @_; + join(':', @$a) eq join(':', @$b); +} + +sub f +{ + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +my $obj = bless [], 'Foo'; + +sub Foo::meth +{ + return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; + shift; + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +my $test; + +for $test ( + # flags args expected description + [ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], + [ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], + [ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], + [ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ], + [ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ], + [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ], +) +{ + my ($flags, $args, $expected, $description) = @$test; + print "# --- $description ---\n"; + ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected)); +}; + +ok(&Devel::PPPort::eval_pv('f()', 0), 'y'); +ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y'); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/cop.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/cop.t new file mode 100755 index 00000000000..1bcc9996e36 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/cop.t @@ -0,0 +1,49 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/cop instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +my $package; +{ + package MyPackage; + $package = &Devel::PPPort::CopSTASHPV(); +} +print "# $package\n"; +ok($package, "MyPackage"); + +my $file = &Devel::PPPort::CopFILE(); +print "# $file\n"; +ok($file =~ /cop/i); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/grok.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/grok.t new file mode 100755 index 00000000000..8766b353d60 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/grok.t @@ -0,0 +1,49 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/grok instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..10\n"; + } + else { + plan(tests => 10); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::grok_number("42"), 42); +ok(!defined(&Devel::PPPort::grok_number("A"))); +ok(&Devel::PPPort::grok_bin("10000001"), 129); +ok(&Devel::PPPort::grok_hex("deadbeef"), 0xdeadbeef); +ok(&Devel::PPPort::grok_oct("377"), 255); + +ok(&Devel::PPPort::Perl_grok_number("42"), 42); +ok(!defined(&Devel::PPPort::Perl_grok_number("A"))); +ok(&Devel::PPPort::Perl_grok_bin("10000001"), 129); +ok(&Devel::PPPort::Perl_grok_hex("deadbeef"), 0xdeadbeef); +ok(&Devel::PPPort::Perl_grok_oct("377"), 255); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/limits.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/limits.t new file mode 100755 index 00000000000..1ccb8b1df03 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/limits.t @@ -0,0 +1,42 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/limits instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..4\n"; + } + else { + plan(tests => 4); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::iv_size()); +ok(&Devel::PPPort::uv_size()); +ok(&Devel::PPPort::iv_type()); +ok(&Devel::PPPort::uv_type()); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/mPUSH.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/mPUSH.t new file mode 100755 index 00000000000..66c62f9b612 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/mPUSH.t @@ -0,0 +1,47 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/mPUSH instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..8\n"; + } + else { + plan(tests => 8); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(join(':', &Devel::PPPort::mPUSHp()), "one:two:three"); +ok(join(':', &Devel::PPPort::mPUSHn()), "0.5:-0.25:0.125"); +ok(join(':', &Devel::PPPort::mPUSHi()), "-1:2:-3"); +ok(join(':', &Devel::PPPort::mPUSHu()), "1:2:3"); + +ok(join(':', &Devel::PPPort::mXPUSHp()), "one:two:three"); +ok(join(':', &Devel::PPPort::mXPUSHn()), "0.5:-0.25:0.125"); +ok(join(':', &Devel::PPPort::mXPUSHi()), "-1:2:-3"); +ok(join(':', &Devel::PPPort::mXPUSHu()), "1:2:3"); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/magic.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/magic.t new file mode 100755 index 00000000000..8f73dc69d1e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/magic.t @@ -0,0 +1,73 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/magic instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..10\n"; + } + else { + plan(tests => 10); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo'; +$h{bar} = ''; + +&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar'); +ok($h{foo}, 'foobar'); + +&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz'); +ok($h{bar}, 'baz'); + +&Devel::PPPort::sv_catsv_mg($h{foo}, '42'); +ok($h{foo}, 'foobar42'); + +&Devel::PPPort::sv_setiv_mg($h{bar}, 42); +ok($h{bar}, 42); + +&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159); +ok(abs($h{PI} - 3.14159) < 0.01); + +&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx'); +ok($h{mhx}, 'mhx'); + +&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus'); +ok($h{mhx}, 'Marcus'); + +&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV'); +ok($h{sv}, 'SV'); + +&Devel::PPPort::sv_setuv_mg($h{sv}, 4711); +ok($h{sv}, 4711); + +&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl'); +ok($h{sv}, 'Perl'); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/misc.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/misc.t new file mode 100755 index 00000000000..20f53a799bc --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/misc.t @@ -0,0 +1,88 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/misc instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..31\n"; + } + else { + plan(tests => 31); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use vars qw($my_sv @my_av %my_hv); + +my @s = &Devel::PPPort::newSVpvn(); +ok(@s == 5); +ok($s[0], "test"); +ok($s[1], "te"); +ok($s[2], ""); +ok(!defined($s[3])); +ok(!defined($s[4])); + +ok(!defined(&Devel::PPPort::PL_sv_undef())); +ok(&Devel::PPPort::PL_sv_yes()); +ok(!&Devel::PPPort::PL_sv_no()); +ok(&Devel::PPPort::PL_na("abcd"), 4); + +ok(&Devel::PPPort::boolSV(1)); +ok(!&Devel::PPPort::boolSV(0)); + +$_ = "Fred"; +ok(&Devel::PPPort::DEFSV(), "Fred"); +ok(&Devel::PPPort::UNDERBAR(), "Fred"); + +eval { 1 }; +ok(!&Devel::PPPort::ERRSV()); +eval { cannot_call_this_one() }; +ok(&Devel::PPPort::ERRSV()); + +ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0)); +ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0)); +ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1)); + +$my_sv = 1; +ok(&Devel::PPPort::get_sv('my_sv', 0)); +ok(!&Devel::PPPort::get_sv('not_my_sv', 0)); +ok(&Devel::PPPort::get_sv('not_my_sv', 1)); + +@my_av = (1); +ok(&Devel::PPPort::get_av('my_av', 0)); +ok(!&Devel::PPPort::get_av('not_my_av', 0)); +ok(&Devel::PPPort::get_av('not_my_av', 1)); + +%my_hv = (a=>1); +ok(&Devel::PPPort::get_hv('my_hv', 0)); +ok(!&Devel::PPPort::get_hv('not_my_hv', 0)); +ok(&Devel::PPPort::get_hv('not_my_hv', 1)); + +sub my_cv { 1 }; +ok(&Devel::PPPort::get_cv('my_cv', 0)); +ok(!&Devel::PPPort::get_cv('not_my_cv', 0)); +ok(&Devel::PPPort::get_cv('not_my_cv', 1)); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/newCONSTSUB.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/newCONSTSUB.t new file mode 100755 index 00000000000..c40fc49631b --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/newCONSTSUB.t @@ -0,0 +1,46 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/newCONSTSUB instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..3\n"; + } + else { + plan(tests => 3); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +&Devel::PPPort::call_newCONSTSUB_1(); +ok(&Devel::PPPort::test_value_1(), 1); + +&Devel::PPPort::call_newCONSTSUB_2(); +ok(&Devel::PPPort::test_value_2(), 2); + +&Devel::PPPort::call_newCONSTSUB_3(); +ok(&Devel::PPPort::test_value_3(), 3); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/newRV.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/newRV.t new file mode 100755 index 00000000000..e5baf9e8941 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/newRV.t @@ -0,0 +1,40 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/newRV instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::newRV_inc_REFCNT, 1); +ok(&Devel::PPPort::newRV_noinc_REFCNT, 1); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/ppphtest.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/ppphtest.t new file mode 100755 index 00000000000..e1cf0eddc32 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/ppphtest.t @@ -0,0 +1,594 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/ppphtest instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..134\n"; + } + else { + plan(tests => 134); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use File::Path qw/rmtree mkpath/; +use Config; + +my $tmp = 'ppptmp'; +my $inc = ''; +my $perl = find_perl(); + +rmtree($tmp) if -d $tmp; +mkpath($tmp) or die "mkpath $tmp: $!\n"; +chdir($tmp) or die "chdir $tmp: $!\n"; + +if ($ENV{'PERL_CORE'}) { + if (-d '../../lib') { + $inc = $^O eq 'VMS' ? '-"I../../lib"' : '-I../../lib'; + unshift @INC, '../../lib'; + } +} +if ($perl =~ m!^\./!) { + $perl = ".$perl"; +} + +END { + chdir('..') if !-d $tmp && -d "../$tmp"; + rmtree($tmp) if -d $tmp; +} + +ok(&Devel::PPPort::WriteFile("ppport.h")); + +sub ppport +{ + my @args = @_; + print "# *** running $perl $inc ppport.h @args ***\n"; + my $out = join '', `$perl $inc ppport.h @args`; + my $copy = $out; + $copy =~ s/^/# | /mg; + print "$copy\n"; + return $out; +} + +sub matches +{ + my($str, $re, $mod) = @_; + my @n; + eval "\@n = \$str =~ /$re/g$mod;"; + if ($@) { + my $err = $@; + $err =~ s/^/# *** /mg; + print "# *** ERROR ***\n$err\n"; + } + return $@ ? -42 : scalar @n; +} + +sub eq_files +{ + my($f1, $f2) = @_; + return 0 unless -e $f1 && -e $f2; + local *F; + for ($f1, $f2) { + print "# File: $_\n"; + unless (open F, $_) { + print "# couldn't open $_: $!\n"; + return 0; + } + $_ = do { local $/; <F> }; + close F; + my $copy = $_; + $copy =~ s/^/# | /mg; + print "$copy\n"; + } + return $f1 eq $f2; +} + +my @tests; + +for (split /\s*={70,}\s*/, do { local $/; <DATA> }) { + s/^\s+//; s/\s+$//; + my($c, %f); + ($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/; + push @tests, { code => $c, files => \%f }; +} + +my $t; +for $t (@tests) { + my $f; + for $f (keys %{$t->{files}}) { + my @f = split /\//, $f; + if (@f > 1) { + pop @f; + my $path = join '/', @f; + mkpath($path) or die "mkpath('$path'): $!\n"; + } + my $txt = $t->{files}{$f}; + local *F; + open F, ">$f" or die "open $f: $!\n"; + print F "$txt\n"; + close F; + $txt =~ s/^/# | /mg; + print "# *** writing $f ***\n$txt\n"; + } + + eval $t->{code}; + if ($@) { + my $err = $@; + $err =~ s/^/# *** /mg; + print "# *** ERROR ***\n$err\n"; + } + ok($@, ''); + + for (keys %{$t->{files}}) { + unlink $_ or die "unlink('$_'): $!\n"; + } +} + +sub find_perl +{ + my $perl = $^X; + + return $perl if $^O eq 'VMS'; + + my $exe = $Config{'_exe'} || ''; + + if ($perl =~ /^perl\Q$exe\E$/i) { + $perl = "perl$exe"; + eval "require File::Spec"; + if ($@) { + $perl = "./$perl"; + } else { + $perl = File::Spec->catfile(File::Spec->curdir(), $perl); + } + } + + if ($perl !~ /\Q$exe\E$/i) { + $perl .= $exe; + } + + warn "find_perl: cannot find $perl from $^X" unless -f $perl; + + return $perl; +} + +__DATA__ + +my $o = ppport(qw(--help)); +ok($o =~ /^Usage:.*ppport\.h/m); +ok($o =~ /--help/m); + +$o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*test\.xs/mi); +ok($o =~ /analyzing.*test\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok(matches($o, 'analyzing', 'mi'), 1); +ok($o =~ /Uses Perl_newSViv instead of newSViv/); + +$o = ppport(qw(--quiet --nochanges)); +ok($o =~ /^\s*$/); + +---------------------------- test.xs ------------------------------------------ + +Perl_newSViv(); + +=============================================================================== + +# check if C and C++ comments are filtered correctly + +my $o = ppport(qw(--copy=a)); +ok($o =~ /^scanning.*MyExt\.xs/mi); +ok($o =~ /analyzing.*MyExt\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Uses grok_bin/m); +ok($o !~ /^Uses newSVpv/m); +ok($o =~ /Uses 1 C\+\+ style comment/m); +ok(eq_files('MyExt.xsa', 'MyExt.ra')); + +# check if C++ are left untouched with --cplusplus + +$o = ppport(qw(--copy=b --cplusplus)); +ok($o =~ /^scanning.*MyExt\.xs/mi); +ok($o =~ /analyzing.*MyExt\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Uses grok_bin/m); +ok($o !~ /^Uses newSVpv/m); +ok($o !~ /Uses \d+ C\+\+ style comment/m); +ok(eq_files('MyExt.xsb', 'MyExt.rb')); + +unlink qw(MyExt.xsa MyExt.xsb); + +---------------------------- MyExt.xs ----------------------------------------- + +newSVuv(); + // newSVpv(); + XPUSHs(foo); +/* grok_bin(); */ + +---------------------------- MyExt.ra ----------------------------------------- + +#include "ppport.h" +newSVuv(); + /* newSVpv(); */ + XPUSHs(foo); +/* grok_bin(); */ + +---------------------------- MyExt.rb ----------------------------------------- + +#include "ppport.h" +newSVuv(); + // newSVpv(); + XPUSHs(foo); +/* grok_bin(); */ + +=============================================================================== + +my $o = ppport(qw(--nochanges file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o =~ /^Uses newCONSTSUB/m); +ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m); +ok($o =~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --nohints file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o =~ /^Uses newCONSTSUB/m); +ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m); +ok($o !~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --nohints --nodiag file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o !~ /^Uses newCONSTSUB/m); +ok($o !~ /^Uses SvPV_nolen/m); +ok($o !~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --quiet file1.xs)); +ok($o =~ /^\s*$/); + +$o = ppport(qw(--nochanges file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o =~ /^Uses mXPUSHp/m); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --nohints file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o =~ /^Uses mXPUSHp/m); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --nohints --nodiag file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o !~ /^Uses mXPUSHp/m); +ok($o !~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --quiet file2.xs)); +ok($o =~ /^\s*$/); + +---------------------------- file1.xs ----------------------------------------- + +#define NEED_newCONSTSUB +#define NEED_sv_2pv_nolen +#include "ppport.h" + +newCONSTSUB(); +SvPV_nolen(); + +---------------------------- file2.xs ----------------------------------------- + +mXPUSHp(foo); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*FooBar\.xs/mi); +ok($o =~ /analyzing.*FooBar\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o !~ /^Looks good/m); +ok($o =~ /^Uses grok_bin/m); + +---------------------------- FooBar.xs ---------------------------------------- + +newSViv(); +XPUSHs(foo); +grok_bin(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*First\.xs/mi); +ok($o =~ /analyzing.*First\.xs/mi); +ok($o =~ /^scanning.*second\.h/mi); +ok($o =~ /analyzing.*second\.h/mi); +ok($o =~ /^scanning.*sub.*third\.c/mi); +ok($o =~ /analyzing.*sub.*third\.c/mi); +ok($o !~ /^scanning.*foobar/mi); +ok(matches($o, '^scanning', 'mi'), 3); + +---------------------------- First.xs ----------------------------------------- + +one + +---------------------------- foobar.xyz --------------------------------------- + +two + +---------------------------- second.h ----------------------------------------- + +three + +---------------------------- sub/third.c -------------------------------------- + +four + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i); + +---------------------------- test.xs ------------------------------------------ + +#define NEED_foobar + +=============================================================================== + +# And now some complex "real-world" example + +my $o = ppport(qw(--copy=f)); +for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) { + ok($o =~ /^scanning.*\Q$_\E/mi); + ok($o =~ /analyzing.*\Q$_\E/i); +} +ok(matches($o, '^scanning', 'mi'), 6); + +ok(matches($o, '^Writing copy of', 'mi'), 5); +ok(!-e "mod5.cf"); + +for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) { + ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi); + ok(-e "${_}f"); + ok(eq_files("${_}f", "${_}r")); + unlink "${_}f"; +} + +---------------------------- main.xs ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_newCONSTSUB +#define NEED_grok_hex_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_hex(); +Perl_grok_bin(aTHX_ foo, bar); + +/* some comment */ + +perl_eval_pv(); +grok_bin(); +Perl_grok_bin(bar, sv_no); + +---------------------------- mod1.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_grok_bin_GLOBAL +#define NEED_newCONSTSUB +#include "ppport.h" + +newCONSTSUB(); +grok_bin(); +{ + Perl_croak ("foo"); + Perl_sv_catpvf(); /* I know it's wrong ;-) */ +} + +---------------------------- mod2.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_eval_pv +#include "ppport.h" + +newSViv(); + +/* + eval_pv(); +*/ + +---------------------------- mod3.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +grok_oct(); +eval_pv(); + +---------------------------- mod4.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +START_MY_CXT; + +---------------------------- mod5.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" +call_pv(); + +---------------------------- main.xsr ----------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_eval_pv_GLOBAL +#define NEED_grok_hex +#define NEED_newCONSTSUB_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_hex(); +grok_bin(foo, bar); + +/* some comment */ + +eval_pv(); +grok_bin(); +grok_bin(bar, PL_sv_no); + +---------------------------- mod1.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_grok_bin_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_bin(); +{ + Perl_croak (aTHX_ "foo"); + Perl_sv_catpvf(aTHX); /* I know it's wrong ;-) */ +} + +---------------------------- mod2.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + + +newSViv(); + +/* + eval_pv(); +*/ + +---------------------------- mod3.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#define NEED_grok_oct +#include "ppport.h" + +grok_oct(); +eval_pv(); + +---------------------------- mod4.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + +START_MY_CXT; + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Uses grok_hex/m); +ok($o !~ /Looks good/m); + +$o = ppport(qw(--nochanges --compat-version=5.8.0)); +ok($o !~ /Uses grok_hex/m); +ok($o =~ /Looks good/m); + +---------------------------- FooBar.xs ---------------------------------------- + +grok_hex(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Uses SvPVutf8_force, which may not be portable/m); + +$o = ppport(qw(--nochanges --compat-version=5.6.0)); +ok($o !~ /Uses SvPVutf8_force/m); + +---------------------------- FooBar.xs ---------------------------------------- + +SvPVutf8_force(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o !~ /potentially required change/); +ok(matches($o, '^Looks good', 'mi'), 2); + +---------------------------- FooBar.xs ---------------------------------------- + +#define NEED_grok_numeric_radix +#define NEED_grok_number +#include "ppport.h" + +GROK_NUMERIC_RADIX(); +grok_number(); + +---------------------------- foo.c -------------------------------------------- + +#include "ppport.h" + +call_pv(); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/sv_xpvf.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/sv_xpvf.t new file mode 100755 index 00000000000..33e203dde98 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/sv_xpvf.t @@ -0,0 +1,65 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/sv_xpvf instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..9\n"; + } + else { + plan(tests => 9); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo-'; +$h{bar} = ''; + +ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); +ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); +ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); + +&Devel::PPPort::sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); + +&Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); + +&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); + +&Devel::PPPort::sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); + +&Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); + +&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/testutil.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/t/testutil.pl new file mode 100644 index 00000000000..408553fd3bb --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/testutil.pl @@ -0,0 +1,32 @@ +{ + my $__ntest; + + sub ok ($;$$) { + local($\,$,); + my $ok = 0; + my $result = shift; + if (@_ == 0) { + $ok = $result; + } else { + $expected = shift; + if (!defined $expected) { + $ok = !defined $result; + } elsif (!defined $result) { + $ok = 0; + } elsif (ref($expected) eq 'Regexp') { + $ok = $result =~ /$expected/; + } else { + $ok = $result eq $expected; + } + } + ++$__ntest; + if ($ok) { + print "ok $__ntest\n" + } + else { + print "not ok $__ntest\n" + } + } +} + +1; diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/threads.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/threads.t new file mode 100755 index 00000000000..7243d8dda6e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/threads.t @@ -0,0 +1,41 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/threads instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::no_THX_arg("42"), 43); +eval { &Devel::PPPort::with_THX_arg("yes\n"); }; +ok($@ =~ /^yes/); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/uv.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/uv.t new file mode 100755 index 00000000000..1272be7733e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/uv.t @@ -0,0 +1,48 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/uv instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..10\n"; + } + else { + plan(tests => 10); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::sv_setuv(42), 42); +ok(&Devel::PPPort::newSVuv(123), 123); +ok(&Devel::PPPort::sv_2uv("4711"), 4711); +ok(&Devel::PPPort::sv_2uv("1735928559"), 1735928559); +ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559); +ok(&Devel::PPPort::SvUVx(1735928559), 1735928559); +ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef); +ok(&Devel::PPPort::XSRETURN_UV(), 42); +ok(&Devel::PPPort::PUSHu(), 42); +ok(&Devel::PPPort::XPUSHu(), 43); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/typemap b/gnu/usr.bin/perl/ext/Devel/PPPort/typemap new file mode 100644 index 00000000000..e472d7ea623 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/typemap @@ -0,0 +1,35 @@ +################################################################################ +# +# typemap -- XS type mappings not present in early perls +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +UV T_UV +NV T_NV + +INPUT +T_UV + $var = ($type)SvUV($arg) +T_NV + $var = ($type)SvNV($arg) + +OUTPUT +T_UV + sv_setuv($arg, (UV)$var); +T_NV + sv_setnv($arg, (NV)$var); diff --git a/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL b/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL index fdab9eededb..a795cfc822d 100644 --- a/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL +++ b/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL @@ -377,7 +377,8 @@ sub FIRSTKEY { sub EXISTS { my ($self, $errname) = @_; - my $proto = prototype($errname); + my $r = ref $errname; + my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef; defined($proto) && $proto eq ""; } diff --git a/gnu/usr.bin/perl/ext/Errno/t/Errno.t b/gnu/usr.bin/perl/ext/Errno/t/Errno.t index a879cf23ce9..a6b08e03f99 100644 --- a/gnu/usr.bin/perl/ext/Errno/t/Errno.t +++ b/gnu/usr.bin/perl/ext/Errno/t/Errno.t @@ -13,7 +13,7 @@ BEGIN { use Errno; -print "1..5\n"; +print "1..6\n"; print "not " unless @Errno::EXPORT_OK; print "ok 1\n"; @@ -53,3 +53,6 @@ if($s1 ne $s2) { } print "ok 5\n"; + +eval { exists $!{[]} }; +print $@ ? "not ok 6\n" : "ok 6\n"; diff --git a/gnu/usr.bin/perl/ext/Time/HiRes/ppport.h b/gnu/usr.bin/perl/ext/Time/HiRes/ppport.h new file mode 100644 index 00000000000..23d8894bdfd --- /dev/null +++ b/gnu/usr.bin/perl/ext/Time/HiRes/ppport.h @@ -0,0 +1,4812 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.03 + + Automatically created by Devel::PPPort running under + perl 5.008004 on Thu Sep 16 09:09:58 2004. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.03 + +=head1 SYNOPSIS + + perl ppport.h [options] [files] + + --help show short help + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + + --list-provided list provided API + --list-unsupported list unsupported API + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.9.2. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +up to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions that were not present in earlier +versions of Perl, and that can't be provided using a macro, you have +to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions will be marked C<explicit> in the list shown by +C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions, you want either C<static> or global variants. + +For a C<static> function, use: + + #define NEED_function + +For a global function, use: + + #define NEED_function_GLOBAL + +Note that you mustn't have more than one global request for one +function in your project. + + Function Static Request Global Request + ----------------------------------------------------------------------------------------- + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions using the C<DPPP_NAMESPACE> macro. +Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! hints! changes! cplusplus + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +usage() if $opt{help}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +# Never use C comments in this file!!!!! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +my @files; + +if (@ARGV) { + @files = map { glob $_ } @ARGV; +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /\.(xs|c|h|cc)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob $_ } qw(*.xs *.c *.h *.cc); + } + my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files; + @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files; +} + +unless (@files) { + die "No input files given!\n"; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +CLASS|||n +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSV||| +Gv_AMupdate||| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeVAL||5.004000| +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LVRET||| +MARK||| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NEWSV||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newc||| +Newz||| +New||| +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERL_BCDVERSION|5.009002||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.007002||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.007002||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.007002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SUBVERSION|5.006000||p +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_DECL|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||n +PL_Sv|5.005000||p +PL_compiling|5.004050||p +PL_copline|5.005000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_last_in_gv|||n +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofs_sv|||n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rsfp_filters|5.004050||p +PL_rsfp|5.004050||p +PL_rs|||n +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +ST||| +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN||| +SvLOCK||5.007003| +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX||| +SvPV_force_nomg|5.007002||p +SvPV_force||| +SvPV_nolen|5.006000||p +SvPV_nomg|5.007002||p +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc||| +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV||| +SvSETMAGIC||| +SvSHARE||5.007003| +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK||5.007001| +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +THIS|||n +UNDERBAR|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN||| +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XS||| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_pMY_CXT|5.007003||p +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_data||| +allocmy||| +amagic_call||| +any_dup||| +ao||| +append_elem||| +append_list||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +asIV||| +asUV||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_clear||| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fake||| +av_fetch||| +av_fill||| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_xsutils||| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +cache_re||| +call_argv|5.006000||p +call_atexit||5.006000| +call_body||| +call_list_body||| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_uni||| +checkcomma||| +checkposixcc||| +cl_and||| +cl_anything||| +cl_init_zero||| +cl_init||| +cl_is_anything||| +cl_or||| +closest_cop||| +convert||| +cop_free||| +cr_textfilter||| +croak_nocontext|||vn +croak|||v +csighandler||5.007001|n +custom_op_desc||5.007003| +custom_op_name||5.007003| +cv_ckproto||| +cv_clone||| +cv_const_sv||5.004000| +cv_dump||| +cv_undef||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dXSARGS||| +dXSI32||| +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +deb||5.007003|v +default_protect|||v +del_he||| +del_sv||| +del_xiv||| +del_xnv||| +del_xpvav||| +del_xpvbm||| +del_xpvcv||| +del_xpvhv||| +del_xpviv||| +del_xpvlv||| +del_xpvmg||| +del_xpvnv||| +del_xpv||| +del_xrv||| +delimcpy||5.004000| +depcom||| +deprecate_old||| +deprecate||| +despatch_signals||5.007001| +die_nocontext|||vn +die_where||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_chop||| +do_close||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_kv||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pipe||| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch_body||| +docatch||| +doencodes||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptosub||| +dounwind||| +dowantarray||| +dump_all||5.006000| +dump_eval||5.006000| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs||5.006000| +dump_sub||5.006000| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_eaccess||| +eval_pv|5.006000||p +eval_sv|5.006000||p +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +fd_on_nosuid_fs||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_beginning||| +find_byclass||| +find_in_my_stash||| +find_runcv||| +find_rundefsvoffset||5.009002| +find_script||| +find_uninit_var||| +fold_constants||| +forbid_setid||| +force_ident||| +force_list||| +force_next||| +force_version||| +force_word||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_av|5.006000||p +get_context||5.006000|n +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_autoload4||5.004000| +gv_check||| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpv||| +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_sv||| +gv_init||| +gv_share||| +gv_stashpvn|5.006000||p +gv_stashpv||| +gv_stashsv||| +he_dup||| +hfreeentries||| +hsplit||| +hv_assert||5.009001| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_common||| +hv_fetch_ent||5.004000| +hv_fetch||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_ksplit||5.004000| +hv_magic_check||| +hv_magic||| +hv_notallowed||| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_store||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incl_perldb||| +incline||| +incpush||| +ingroup||| +init_argv_symbols||| +init_debugger||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_lexer||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +instr||| +intro_my||| +intuit_method||| +intuit_more||| +invert||| +io_close||| +isALNUM||| +isALPHA||| +isDIGIT||| +isLOWER||| +isSPACE||| +isUPPER||| +is_an_int||| +is_gv_magical||| +is_handle_constructor||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.006000| +is_uni_alnumc||5.006000| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.006000| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_char||5.006000| +is_utf8_cntrl||5.006000| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loc||5.008001| +is_utf8_string||5.006001| +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +keyword||| +leave_scope||| +lex_end||| +lex_start||| +linklist||| +list_assignment||| +listkids||| +list||| +load_module_nocontext|||vn +load_module||5.006000|v +localize||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_clearenv||| +magic_clearpack||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freeovrld||| +magic_freeregexp||| +magic_getarylen||| +magic_getdefelem||| +magic_getglob||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall||| +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setbm||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_setfm||| +magic_setglob||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +magicname||| +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +measure_struct||| +memEQ|5.004000||p +memNE|5.004000||p +mem_collxfrm||| +mess_alloc||| +mess_nocontext|||vn +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find||| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +more_he||| +more_sv||| +more_xiv||| +more_xnv||| +more_xpvav||| +more_xpvbm||| +more_xpvcv||| +more_xpvhv||| +more_xpviv||| +more_xpvlv||| +more_xpvmg||| +more_xpvnv||| +more_xpv||| +more_xrv||| +moreswitches||| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat||| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_socketpair||5.007003|n +my_stat||| +my_strftime||5.007002| +my_swabn|||n +my_swap||| +my_unexec||| +my||| +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.006000||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMYSUB||5.006000| +newNULLLIST||| +newOP||| +newPADOP||5.006000| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.006000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSViv||| +newSVnv||| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_share||5.007001| +newSVpvn|5.006000||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP||| +newWHILEOP||5.004040| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_xiv||| +new_xnv||| +new_xpvav||| +new_xpvbm||| +new_xpvcv||| +new_xpvhv||| +new_xpviv||| +new_xpvlv||| +new_xpvmg||| +new_xpvnv||| +new_xpv||| +new_xrv||| +next_symbol||| +nextargv||| +nextchar||| +ninstr||| +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsCV||| +oopsHV||| +op_clear||| +op_const_sv||| +op_dump||5.006000| +op_free||| +op_null||5.007002| +open_script||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +pack_cat||5.007003| +pack_rec||| +package||| +packlist||5.008001| +pad_add_anon||| +pad_add_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_findlex||| +pad_findmy||| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||| +pad_undef||| +parse_body||| +parse_unicode_opts||| +path_is_absolute||| +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pmflag||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +pregcomp||| +pregexec||| +pregfree||| +prepend_elem||| +printf_nocontext|||vn +ptr_table_clear||| +ptr_table_fetch||| +ptr_table_free||| +ptr_table_new||| +ptr_table_split||| +ptr_table_store||| +push_scope||| +put_byte||| +pv_display||5.006000| +pv_uni_display||5.007003| +qerror||| +re_croak2||| +re_dup||| +re_intuit_start||5.006000| +re_intuit_string||5.006000| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +refkids||| +refto||| +ref||| +reg_node||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.007003| +regclass||| +regcp_set_to||| +regcppop||| +regcppush||| +regcurly||| +regdump||5.005000| +regexec_flags||5.005000| +reghop3||| +reghopmaybe3||| +reghopmaybe||| +reghop||| +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regoptail||| +regpiece||| +regpposixcc||| +regprop||| +regrepeat_hard||| +regrepeat||| +regtail||| +regtry||| +reguni||| +regwhite||| +reg||| +repeatcpy||| +report_evil_fh||| +report_uninit||| +require_errno||| +require_pv||5.006000| +rninstr||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +runops_debug||5.005000| +runops_standard||5.005000| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hek_flags||| +save_helem||5.004050| +save_hints||5.005000| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||| +save_padsv||5.007001| +save_pptr||| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_threadsv||5.005000| +save_vptr||5.006000| +savepvn||| +savepv||| +savesharedpv||5.007003| +savestack_grow_cnt||5.008001| +savestack_grow||| +sawparens||| +scalar_mod_type||| +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.008001| +scan_word||| +scope||| +screaminstr||5.005000| +seed||| +set_context||5.006000|n +set_csh||| +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +setenv_getix||| +share_hek_flags||| +share_hek||| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace||| +sortsv||5.007003| +ss_dup||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2nv||| +sv_2pv_flags||5.007002| +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen||| +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_mg|5.006000||p +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.006000||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.006000||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm||| +sv_compile_2op||5.008001| +sv_copypv||5.007003| +sv_dec||| +sv_del_backref||| +sv_derived_from||5.004000| +sv_dump||| +sv_dup||| +sv_eq||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_inc||| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_len_utf8||5.006000| +sv_len||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||5.007003| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u||5.006000| +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags||5.007002| +sv_pvn_force|||p +sv_pvn_nomg|5.007003||p +sv_pvn|5.006000||p +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_release_IVX||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.006000||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.006000||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.006000||p +sv_setpvn||| +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.006000||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.006000||p +sv_setuv|5.006000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_mg|5.006000||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.006000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +taint_env||| +taint_proper||| +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +tokeq||| +tokereport||| +too_few_arguments||| +too_many_arguments||| +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +upg_version||5.009000| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf16rev_textfilter||| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_pos_init||| +utf8_mg_pos||| +utf8_to_bytes||5.006001| +utf8_to_uvchr||5.007001| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +vcall_body||| +vcall_list_body||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vdefault_protect||| +vdie||| +vdocatch_body||| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module||5.006000| +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vparse_body||| +vrun_body||| +vstringify||5.009000| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warner_nocontext|||vn +warner||5.006000|v +warn|||v +watch||| +whichsig||| +write_to_stderr||| +yyerror||| +yylex||| +yyparse||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %depends); +my $replace = 0; +my $hint = ''; + +while (<DATA>) { + if ($hint) { + if (m{^\s*\*\s(.*?)\s*$}) { + $hints{$hint} ||= ''; # suppress warning with older perls + $hints{$hint} .= "$1\n"; + } + else { + $hint = ''; + } + } + $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # temporarily remove C comments from the code + my @ccom; + $c =~ s{ + ( + [^"'/]+ + | + (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+ + | + (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+ + ) + | + (/ (?: + \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / + | + /[^\r\n]* + )) + }{ + defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce"; + }egsx; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/); + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + if (exists $need{$_}) { + $file{needs}{$_} = 'static'; + } + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { + warning("Possibly wrong #define $1 in $filename"); + } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses}}) { + next unless $file{uses}{$func}; # if it's only a dependency + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + elsif (exists $replace{$func}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + else { + diag("Uses $func"); + } + hint($func); + } + + for $func (sort keys %{$file{uses_todo}}) { + warning("Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo})); + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and can_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; + +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub can_use +{ + eval "use @_;"; + return $@ eq ''; +} + +sub rec_depend +{ + my $func = shift; + my %seen; + return () unless exists $depends{$func}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +sub hint +{ + $opt{quiet} and return; + $opt{hints} or return; + my $func = shift; + exists $hints{$func} or return; + $given_hints{$func}++ and return; + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif + +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif + +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_na na +# define PL_no_modify no_modify +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_ppaddr ppaddr +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +/* Replace: 0 */ +#endif + +#ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +#else +# define PERL_UNUSED_DECL +#endif +#ifndef NOOP +# define NOOP (void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR + +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif + +# define NUM2PTR(any,d) (any)(PTRV)(d) +# define PTR2IV(p) INT2PTR(IV,p) +# define PTR2UV(p) INT2PTR(UV,p) +# define PTR2NV(p) NUM2PTR(NV,p) + +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif + +#endif /* !INT2PTR */ + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#undef STMT_START +#undef STMT_END +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d) +#endif + +#endif +#ifndef Poison +# define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t)) +#endif +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) +#endif +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ + +/* Replace perl_eval_pv with eval_pv */ +/* eval_pv depends on eval_sv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5)) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +void +DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))) + start_subparse(), +#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22)) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvPV_nolen + +#if defined(NEED_sv_2pv_nolen) +static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +static +#else +extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +#endif + +#ifdef sv_2pv_nolen +# undef sv_2pv_nolen +#endif +#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a) +#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen) + +#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) + +char * +DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() macro instead of sv_2pv_nolen(). + */ + +/* SvPV_nolen depends on sv_2pv_nolen */ +#define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) + +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0))) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +/* SvPVbyte depends on sv_2pvbyte */ +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif + +/* sv_2pvbyte_nolen depends on sv_2pv_nolen */ +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen sv_2pv_nolen +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ +#ifndef sv_pvn +# define sv_pvn(sv, len) SvPV(sv, len) +#endif + +/* Hint: sv_pvn + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ +#ifndef sv_pvn_force +# define sv_pvn_force(sv, len) SvPV_force(sv, len) +#endif + +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef SvPV_force_nomg +# define SvPV_force_nomg SvPV_force +#endif + +#ifndef SvPV_nomg +# define SvPV_nomg SvPV +#endif + +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif + +/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif /* PERL_VERSION */ +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +/* grok_number depends on grok_numeric_radix */ + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/gnu/usr.bin/perl/ext/XS/APItest/t/call.t b/gnu/usr.bin/perl/ext/XS/APItest/t/call.t new file mode 100755 index 00000000000..b4facd76f44 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS/APItest/t/call.t @@ -0,0 +1,174 @@ +#!perl -w + +# test the various call-into-perl-from-C functions +# DAPM Aug 2004 + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bXS\/APItest\b/) { + # Look, I'm using this fully-qualified variable more than once! + my $arch = $MacPerl::Architecture; + print "1..0 # Skip: XS::APItest was not built\n"; + exit 0; + } +} + +use warnings; +use strict; + +# Test::More doesn't have fresh_perl_is() yet +# use Test::More tests => 240; + +BEGIN { + require './test.pl'; + plan(240); + use_ok('XS::APItest') +}; + +######################### + +sub f { + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +sub d { + no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning + die "its_dead_jim\n"; +} + +my $obj = bless [], 'Foo'; + +sub Foo::meth { + return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; + shift; + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +sub Foo::d { + no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning + die "its_dead_jim\n"; +} + +for my $test ( + # flags args expected description + [ G_VOID, [ ], [ qw(z 1) ], '0 args, G_VOID' ], + [ G_VOID, [ qw(a p q) ], [ qw(z 1) ], '3 args, G_VOID' ], + [ G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], + [ G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], + [ G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], + [ G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ], + [ G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ], + [ G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ], +) +{ + my ($flags, $args, $expected, $description) = @$test; + + ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected), + "$description call_sv(\\&f)"); + + ok(eq_array( [ call_sv(*f, $flags, @$args) ], $expected), + "$description call_sv(*f)"); + + ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected), + "$description call_sv('f')"); + + ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected), + "$description call_pv('f')"); + + ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ], + $expected), "$description eval_sv('f(args)')"); + + ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected), + "$description call_method('meth')"); + + for my $keep (0, G_KEEPERR) { + my $desc = $description . ($keep ? ' G_KEEPERR' : ''); + my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n" + : "its_dead_jim\n"; + $@ = "before\n"; + ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_sv('d')"); + is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_pv('d')"); + is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ eval_sv('d()', $flags|$keep) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc eval_sv('d()')"); + is($@, $exp_err, "$desc eval_sv('d()') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_method('d')"); + is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@"); + } + + ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ], + $expected), "$description G_NOARGS call_sv('f')"); + + ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ], + $expected), "$description G_NOARGS call_pv('f')"); + + ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ], + $expected), "$description G_NOARGS eval_sv('f(@_)')"); + + # XXX call_method(G_NOARGS) isn't tested: I'm assuming + # it's not a sensible combination. DAPM. + + ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_sv('d') }"); + + ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }"); + + ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ], + [ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1), + "its_dead_jim\n", '' ]), + "$description eval { eval_sv('d') }"); + + ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_method('d') }"); + +}; + +is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)"); +is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)"); +is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)"); +is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@"); +is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }"); +is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@"); + +# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up +# a new jump level but before pushing an eval context, leading to +# stack corruption + +fresh_perl_is(<<'EOF', "x=2", { switches => ['-T'] }, 'eval_sv() taint'); +use XS::APItest; + +my $x = 0; +sub f { + eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; }; + $x++; + $a <=> $b; +} + +eval { my @a = sort f 2, 1; $x++}; +print "x=$x\n"; +EOF + |