In perl.git, the branch smoke-me/jkeenan/133543-my-false-conditional has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/e3832c1629fcb4ec897e557a74551e2791e2c8f8?hp=c5941fb0024f03fd78e1822edeba718226a87903> discards c5941fb0024f03fd78e1822edeba718226a87903 (commit) discards 3dc9e310219a210aad9a0cadbd4c9b9f691fcbf5 (commit) discards b64ae69c805142045058865fb3977524d435ef12 (commit) - Log ----------------------------------------------------------------- commit e3832c1629fcb4ec897e557a74551e2791e2c8f8 Author: James E Keenan <jkee...@cpan.org> Date: Wed Sep 26 10:18:39 2018 -0400 Make new tests more self-documenting. commit eeedcee62710395f67c9b9f64f706c130014d6d9 Author: James E Keenan <jkee...@cpan.org> Date: Tue Sep 25 15:55:10 2018 -0400 Test for expected error messages for my() in false conditional. For: RT 133543 commit 2e556caceb60a9bd1489f79b99a6bf89485b9ca6 Author: James E Keenan <jkee...@cpan.org> Date: Tue Sep 25 15:28:46 2018 -0400 Implement scheduled fatalization of my() in false conditional op.c: substitute exception for warning. Move documentation in perldiag from W to F. Remove tests for warnings for such statements. TODO: Create equivalent unit tests for fatal errors. TODO: What RT is this connected to? commit d2d5cab342a752fac08a346b4ab0606abfd2b86a Author: James E Keenan <jkee...@cpan.org> Date: Sun Sep 23 17:44:57 2018 -0400 Revert "postpone perl_parse() exit(0) bugfix" This reverts commit 857320cbf85e762add18885ae8a197b5e0c21b69. ----------------------------------------------------------------------- Summary of changes: AUTHORS | 2 +- MANIFEST | 20 +- Porting/Maintainers.pl | 8 - Porting/checkAUTHORS.pl | 3 +- Porting/release_managers_guide.pod | 22 -- cpan/B-Debug/Debug.pm | 478 --------------------------- cpan/B-Debug/t/debug.t | 105 ------ dist/Module-CoreList/lib/Module/CoreList.pm | 1 + dist/Time-HiRes/fallback/const-c.inc | 3 + ext/B/B.pm | 4 +- ext/B/B/Concise.pm | 4 +- ext/B/B/Terse.pm | 4 +- ext/arybase/arybase.pm | 98 ------ ext/arybase/arybase.xs | 496 ---------------------------- ext/arybase/ptable.h | 226 ------------- ext/arybase/t/aeach.t | 45 --- ext/arybase/t/aelem.t | 56 ---- ext/arybase/t/akeys.t | 25 -- ext/arybase/t/arybase.t | 37 --- ext/arybase/t/aslice.t | 27 -- ext/arybase/t/av2arylen.t | 26 -- ext/arybase/t/index.t | 23 -- ext/arybase/t/lslice.t | 23 -- ext/arybase/t/pos.t | 35 -- ext/arybase/t/scope.t | 44 --- ext/arybase/t/scope_0.pm | 6 - ext/arybase/t/splice.t | 65 ---- ext/arybase/t/substr.t | 22 -- feature.h | 7 - gv.c | 13 +- lib/.gitignore | 2 - lib/B/Deparse.pm | 31 +- lib/feature.pm | 31 +- lib/vars.pm | 4 +- lib/vars.t | 9 +- op.c | 7 +- pod/perldelta.pod | 11 +- pod/perldeprecation.pod | 6 +- pod/perldiag.pod | 58 ++-- pod/perlhacktips.pod | 2 +- pod/perlinterp.pod | 2 +- pod/perlvar.pod | 11 +- regen/feature.pl | 27 +- t/TEST | 3 +- t/lib/feature/bundle | 30 +- t/lib/feature/implicit | 32 -- t/lib/feature/removed | 10 + t/lib/warnings/op | 16 - t/op/array_base.t | 41 --- t/op/magic.t | 4 +- t/op/my.t | 8 +- t/porting/known_pod_issues.dat | 1 + t/uni/variables.t | 6 +- win32/config.gc | 2 +- win32/config_H.gc | 2 +- 55 files changed, 139 insertions(+), 2145 deletions(-) delete mode 100644 cpan/B-Debug/Debug.pm delete mode 100644 cpan/B-Debug/t/debug.t delete mode 100644 ext/arybase/arybase.pm delete mode 100644 ext/arybase/arybase.xs delete mode 100644 ext/arybase/ptable.h delete mode 100644 ext/arybase/t/aeach.t delete mode 100644 ext/arybase/t/aelem.t delete mode 100644 ext/arybase/t/akeys.t delete mode 100644 ext/arybase/t/arybase.t delete mode 100644 ext/arybase/t/aslice.t delete mode 100644 ext/arybase/t/av2arylen.t delete mode 100644 ext/arybase/t/index.t delete mode 100644 ext/arybase/t/lslice.t delete mode 100644 ext/arybase/t/pos.t delete mode 100644 ext/arybase/t/scope.t delete mode 100644 ext/arybase/t/scope_0.pm delete mode 100644 ext/arybase/t/splice.t delete mode 100644 ext/arybase/t/substr.t create mode 100644 t/lib/feature/removed delete mode 100644 t/op/array_base.t diff --git a/AUTHORS b/AUTHORS index 0cbcf5b6a5..6abc0549ff 100644 --- a/AUTHORS +++ b/AUTHORS @@ -1135,7 +1135,7 @@ Simon Leinen Simon Parsons <s.pars...@ftel.co.uk> Simon Schubert <corec...@fs.ei.tum.de> Sinan Unur <si...@unur.com> -Sisyphus <sisyph...@optusnet.com.au> +Sisyphus <sisyp...@cpan.org> Slaven Rezic <sla...@rezic.de> Smylers <smyl...@stripey.com> Solar Designer <so...@openwall.com> diff --git a/MANIFEST b/MANIFEST index 4b3af71131..bcfd99c65b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -139,8 +139,6 @@ cpan/AutoLoader/lib/AutoLoader.pm Autoloader base class cpan/AutoLoader/lib/AutoSplit.pm Split up autoload functions cpan/AutoLoader/t/01AutoLoader.t See if AutoLoader works cpan/AutoLoader/t/02AutoSplit.t See if AutoSplit works -cpan/B-Debug/Debug.pm Compiler Debug backend -cpan/B-Debug/t/debug.t See if B::Debug works cpan/bignum/lib/bigint.pm bigint cpan/bignum/lib/bignum.pm bignum cpan/bignum/lib/bigrat.pm bigrat @@ -3912,22 +3910,6 @@ ext/Amiga-Exec/Exec.xs Amiga::Exec extension ext/Amiga-Exec/Makefile.PL Amiga::Exec extension ext/Amiga-Exec/tagtypes.h Amiga::Exec extension ext/Amiga-Exec/typemap Amiga::Exec extension -ext/arybase/arybase.pm For $[ -ext/arybase/arybase.xs For $[ -ext/arybase/ptable.h For $[ -ext/arybase/t/aeach.t For $[ -ext/arybase/t/aelem.t For $[ -ext/arybase/t/akeys.t For $[ -ext/arybase/t/arybase.t For $[ -ext/arybase/t/aslice.t For $[ -ext/arybase/t/av2arylen.t For $[ -ext/arybase/t/index.t For $[ -ext/arybase/t/lslice.t For $[ -ext/arybase/t/pos.t For $[ -ext/arybase/t/scope.t For $[ -ext/arybase/t/scope_0.pm For $[ -ext/arybase/t/splice.t For $[ -ext/arybase/t/substr.t For $[ ext/attributes/attributes.pm For "sub foo : attrlist" ext/attributes/attributes.xs For "sub foo : attrlist" ext/B/B.pm Compiler backend support functions and methods @@ -5461,6 +5443,7 @@ t/lib/Devel/switchd_goto.pm Module for t/run/switchd.t t/lib/feature/bundle Tests for feature bundles t/lib/feature/implicit Tests for implicit loading of feature.pm t/lib/feature/nonesuch Tests for enabling/disabling nonexistent feature +t/lib/feature/removed Tests for enabling/disabling removed feature t/lib/feature/say Tests for enabling/disabling say feature t/lib/feature/switch Tests for enabling/disabling switch feature t/lib/h2ph.h Test header file for h2ph @@ -5599,7 +5582,6 @@ t/op/anonsub.t See if anonymous subroutines work t/op/append.t See if . works t/op/args.t See if operations on @_ work t/op/array.t See if array operations work -t/op/array_base.t Tests for the remnant of $[ t/op/assignwarn.t See if OP= operators warn correctly for undef targets t/op/attrhand.t See if attribute handlers work t/op/attrproto.t See if the prototype attribute works diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 5b0768da22..6d8a900136 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -179,13 +179,6 @@ use File::Glob qw(:case); 'EXCLUDED' => [qr{^t/release-.*\.t}], }, - 'B::Debug' => { - 'DISTRIBUTION' => 'RURBAN/B-Debug-1.26.tar.gz', - 'FILES' => q[cpan/B-Debug], - 'EXCLUDED' => ['t/pod.t'], - 'DEPRECATED' => '5.027003', - }, - 'base' => { 'DISTRIBUTION' => 'RJBS/base-2.23.tar.gz', 'FILES' => q[dist/base], @@ -1330,7 +1323,6 @@ use File::Glob qw(:case); ext/Win32CORE/ ext/XS-APItest/ ext/XS-Typemap/ - ext/arybase/ ext/attributes/ ext/mro/ ext/re/ diff --git a/Porting/checkAUTHORS.pl b/Porting/checkAUTHORS.pl index 800bbeb2ce..87509c6b0f 100755 --- a/Porting/checkAUTHORS.pl +++ b/Porting/checkAUTHORS.pl @@ -901,6 +901,8 @@ simon\100simon-cozens.org simon\100pembro4.pmb.ox.ac.uk + simon\100othersideofthe.earth.li + simon\100cozens.net + simon\100netthink.co.uk +sisyphus\100cpan.org sisyphus1\100optusnet.com.au ++ sisyphus359\100gmail.com lannings\100who.int lannings\100gmail.com + slanning\100cpan.org slaven\100rezic.de slaven.rezic\100berlin.de @@ -931,7 +933,6 @@ stef\100mongueurs.net stef\100payrard.net stevan\100cpan.org stevan.little\100gmail.com + stevan.little\100iinteractive.com sthoenna\100efn.org ysth\100raven.shiftboard.com -sisyphus1\100optusnet.com.au sisyphus\100cpan.org tassilo.parseval\100post.rwth-aachen.de tassilo.von.parseval\100rwth-aachen.de tchrist\100perl.com tchrist\100mox.perl.com diff --git a/Porting/release_managers_guide.pod b/Porting/release_managers_guide.pod index cd2042bc1d..2ab11d013f 100644 --- a/Porting/release_managers_guide.pod +++ b/Porting/release_managers_guide.pod @@ -173,12 +173,6 @@ which has a F<public_html> directory to share files with. If you use Dropbox, you can append "raw=1" as a parameter to their usual sharing link to allow direct download (albeit with redirects). -=head3 git clone of L<https://github.com/perlorg/perlweb> - -For updating the L<http://dev.perl.org> web pages, either a Github account or -sweet-talking somebody with a Github account into obedience is needed. This -is only needed on the day of the release or shortly afterwards. - =head3 Quotation for release announcement epigraph You will need a quotation to use as an epigraph to your release announcement. @@ -1530,22 +1524,6 @@ It should be visible at a URL like C<http://search.cpan.org/dist/perl-5.10.1/>. =back -=for checklist skip RC - -=head3 update dev.perl.org - -I<You MUST SKIP this step for a RC release> - -In your C<perlweb> repository, link to the new release. For a new -latest-maint release, edit F<docs/shared/tpl/stats.html>. Otherwise, -edit F<docs/dev/perl5/index.html>. - -Then make a pull request to Leo Lapworth. If this fails for some reason -and you cannot cajole anybody else into submitting that change, you can -mail Leo as last resort. - -This repository can be found on L<github|https://github.com/perlorg/perlweb>. - =head3 update release manager's guide Go over your notes from the release (you did take some, right?) and update diff --git a/cpan/B-Debug/Debug.pm b/cpan/B-Debug/Debug.pm deleted file mode 100644 index d121cbbcfa..0000000000 --- a/cpan/B-Debug/Debug.pm +++ /dev/null @@ -1,478 +0,0 @@ -package B::Debug; - -our $VERSION = '1.26'; -BEGIN { if ($] >= 5.027001) { require deprecate; import deprecate; } } - -use strict; -require 5.006; -use B qw(peekop walkoptree walkoptree_exec - main_start main_root cstring sv_undef SVf_NOK SVf_IOK); -use Config; -my (@optype, @specialsv_name); -require B; -if ($] < 5.009) { - require B::Asmdata; - B::Asmdata->import (qw(@optype @specialsv_name)); -} else { - B->import (qw(@optype @specialsv_name)); -} - -if ($] < 5.006002) { - eval q|sub B::GV::SAFENAME { - my $name = (shift())->NAME; - # The regex below corresponds to the isCONTROLVAR macro from toke.c - $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; - return $name; - }|; -} - -my ($have_B_Flags, $have_B_Flags_extra); -if (!$ENV{PERL_CORE}){ # avoid CORE test crashes - eval { require B::Flags and $have_B_Flags++ }; - $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03'; -} -my %done_gv; - -sub _printop { - my $op = shift; - my $addr = ${$op} ? $op->ppaddr : ''; - $addr =~ s/^PL_ppaddr// if $addr; - if (${$op}) { - return sprintf "0x%08x %6s %s", ${$op}, B::class($op), $addr; - } else { - return sprintf "0x%x %6s %s", ${$op}, '', $addr; - } -} - -sub B::OP::debug { - my ($op) = @_; - printf <<'EOT', B::class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name; -%s (0x%lx) - op_ppaddr %s - op_next %s - op_sibling %s - op_targ %d - op_type %d %s -EOT - if ($] > 5.009) { - printf <<'EOT', $op->opt; - op_opt %d -EOT - } else { - printf <<'EOT', $op->seq; - op_seq %d -EOT - } - if ($have_B_Flags) { - printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv; - op_flags %u %s - op_private %u %s -EOT - } else { - printf <<'EOT', $op->flags, $op->private; - op_flags %u - op_private %u -EOT - } - if ($op->can('rettype')) { - printf <<'EOT', $op->rettype; - op_rettype %u -EOT - } -} - -sub B::UNOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_first\t%s\n", _printop($op->first); -} - -sub B::BINOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_last \t%s\n", _printop($op->last); -} - -sub B::LOOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop); - op_redoop %s - op_nextop %s - op_lastop %s -EOT -} - -sub B::LOGOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_other\t%s\n", _printop($op->other); -} - -sub B::LISTOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf "\top_children\t%d\n", $op->children; -} - -sub B::PMOP::debug { - my ($op) = @_; - $op->B::LISTOP::debug(); - printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot; - printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; - printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005; - if ($Config{'useithreads'}) { - printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv); - printf "\top_pmoffset\t%d\n", $op->pmoffset; - } else { - printf "\top_pmstash\t%s\n", cstring($op->pmstash); - } - printf "\top_precomp\t%s\n", cstring($op->precomp); - printf "\top_pmflags\t0x%x\n", $op->pmflags; - printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009; - printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009; - printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009; - $op->pmreplroot->debug if $] < 5.008; -} - -sub B::COP::debug { - my ($op) = @_; - $op->B::OP::debug(); - my $warnings = ref $op->warnings ? ${$op->warnings} : 0; - printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings; - cop_label "%s" - cop_stashpv "%s" - cop_file "%s" - cop_seq %d - cop_arybase %d - cop_line %d - cop_warnings 0x%x -EOT - if ($] > 5.008 and $] < 5.011) { - my $cop_io = B::class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; - printf(" cop_io %s\n", cstring($cop_io)); - } -} - -sub B::SVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_sv\t\t0x%x\n", ${$op->sv}; - $op->sv->debug; -} - -sub B::METHOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - if (${$op->first}) { - printf "\top_first\t0x%x\n", ${$op->first}; - $op->first->debug; - } else { - printf "\top_meth_sv\t0x%x\n", ${$op->meth_sv}; - $op->meth_sv->debug; - } -} - -sub B::UNOP_AUX::debug { - my ($op) = @_; - $op->B::OP::debug(); - # string and perl5 aux_list needs the cv - # cperl has aux, Concise,-debug leaves it empty - if ($op->can('aux')) { - printf "\top_aux\t%s\n", cstring($op->aux); - } -} - -sub B::PVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_pv\t\t%s\n", cstring($op->pv); -} - -sub B::PADOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_padix\t%ld\n", $op->padix; -} - -sub B::NULL::debug { - my ($sv) = @_; - if ($$sv == ${sv_undef()}) { - print "&sv_undef\n"; - } else { - printf "NULL (0x%x)\n", $$sv; - } -} - -sub B::SV::debug { - my ($sv) = @_; - if (!$$sv) { - print B::class($sv), " = NULL\n"; - return; - } - printf <<'EOT', B::class($sv), $$sv, $sv->REFCNT; -%s (0x%x) - REFCNT %d -EOT - printf "\tFLAGS\t\t0x%x", $sv->FLAGS; - if ($have_B_Flags) { - printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv; - } - print "\n"; -} - -sub B::RV::debug { - my ($rv) = @_; - B::SV::debug($rv); - printf <<'EOT', ${$rv->RV}; - RV 0x%x -EOT - $rv->RV->debug; -} - -sub B::PV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - my $pv = $sv->PV(); - printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN; - xpv_pv %s - xpv_cur %d - xpv_len %d -EOT -} - -sub B::IV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK; -} - -sub B::NV::debug { - my ($sv) = @_; - $sv->B::IV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK; -} - -sub B::PVIV::debug { - my ($sv) = @_; - $sv->B::PV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK; -} - -sub B::PVNV::debug { - my ($sv) = @_; - $sv->B::PVIV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK; -} - -sub B::PVLV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txlv_targoff\t%d\n", $sv->TARGOFF; - printf "\txlv_targlen\t%u\n", $sv->TARGLEN; - printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); -} - -sub B::BM::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txbm_useful\t%d\n", $sv->USEFUL; - printf "\txbm_previous\t%u\n", $sv->PREVIOUS; - printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); -} - -sub B::CV::debug { - my ($cv) = @_; - $cv->B::PVNV::debug(); - my $stash = $cv->STASH; - my $start = $cv->START; - my $root = $cv->ROOT; - my $padlist = $cv->PADLIST; - my $file = $cv->FILE; - my $gv; - printf <<'EOT', $$stash, $$start, $$root; - STASH 0x%x - START 0x%x - ROOT 0x%x -EOT - if ($cv->can('NAME_HEK') && $cv->NAME_HEK) { - printf("\tNAME\t%%s\n", $cv->NAME_HEK); - } - elsif ( $]>5.017 && ($cv->FLAGS & 0x40000)) { #lexsub - printf("\tNAME\t%%s\n", $cv->NAME_HEK); - } else { - $gv = $cv->GV; - printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME); - } - printf <<'EOT', $file, $cv->DEPTH, $padlist, ${$cv->OUTSIDE}; - FILE %s - DEPTH %d - PADLIST 0x%x - OUTSIDE 0x%x -EOT - printf("\tOUTSIDE_SEQ\t%d\n", $cv->OUTSIDE_SEQ) if $] > 5.007; - if ($have_B_Flags) { - my $SVt_PVCV = $] < 5.010 ? 12 : 13; - printf("\tCvFLAGS\t0x%x\t%s\n", $cv->CvFLAGS, - $have_B_Flags_extra ? $cv->flagspv($SVt_PVCV) : $cv->flagspv); - } else { - printf("\tCvFLAGS\t0x%x\n", $cv->CvFLAGS); - } - printf("\tSIGOP\t0x%x\n", $cv->SIGOP) if $cv->can('SIGOP'); - $start->debug if $start; - $root->debug if $root; - $gv->debug if $gv; - $padlist->debug if $padlist; -} - -sub B::AV::debug { - my ($av) = @_; - $av->B::SV::debug; - _array_debug($av); -} - -sub _array_debug { - my ($av) = @_; - # tied arrays may leave out FETCHSIZE - my (@array) = eval { $av->ARRAY; }; - print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; - my $fill = eval { scalar(@array) }; - if ($Config{'useithreads'} && B::class($av) ne 'PADLIST') { - printf <<'EOT', $fill, $av->MAX, $av->OFF; - FILL %d - MAX %d - OFF %d -EOT - } else { - printf <<'EOT', $fill, $av->MAX; - FILL %d - MAX %d -EOT - } - if ($] < 5.009) { - if ($have_B_Flags) { - printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS, - $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv); - } else { - printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS); - } - } -} - -sub B::GV::debug { - my ($gv) = @_; - if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; - return; - } - my $sv = $gv->SV; - my $av = $gv->AV; - my $cv = $gv->CV; - $gv->B::SV::debug; - printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; - NAME %s - STASH %s (0x%x) - SV 0x%x - GvREFCNT %d - FORM 0x%x - AV 0x%x - HV 0x%x - EGV 0x%x - CV 0x%x - CVGEN %d - LINE %d - FILE %s -EOT - if ($have_B_Flags) { - my $SVt_PVGV = $] < 5.010 ? 13 : 9; - printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS, - $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv); - } else { - printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS); - } - $sv->debug if $sv; - $av->debug if $av; - $cv->debug if $cv; -} - -sub B::SPECIAL::debug { - my $sv = shift; - my $i = ref $sv ? $$sv : 0; - print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n"; -} - -sub B::PADLIST::debug { - my ($padlist) = @_; - printf <<'EOT', B::class($padlist), $$padlist, $padlist->REFCNT; -%s (0x%x) - REFCNT %d -EOT - _array_debug($padlist); -} - -sub compile { - my $order = shift; - B::clearsym(); - $DB::single = 1 if defined &DB::DB; - if ($order && $order eq "exec") { - return sub { walkoptree_exec(main_start, "debug") } - } else { - return sub { walkoptree(main_root, "debug") } - } -} - -1; - -__END__ - -=head1 NAME - -B::Debug - Walk Perl syntax tree, printing debug info about ops - -=head1 SYNOPSIS - - perl -MO=Debug foo.pl - perl -MO=Debug,-exec foo.pl - -=head1 DESCRIPTION - -See F<ext/B/README> and the newer L<B::Concise>. - -=head1 OPTIONS - -With option -exec, walks tree in execute order, -otherwise in basic order. - -=head1 AUTHOR - -Malcolm Beattie, C<retired> -Reini Urban C<rur...@cpan.org> - -=head1 LICENSE - -Copyright (c) 1996, 1997 Malcolm Beattie -Copyright (c) 2008, 2010, 2013, 2014 Reini Urban - - This program is free software; you can redistribute it and/or modify - it under the terms of either: - - a) the GNU General Public License as published by the Free - Software Foundation; either version 1, or (at your option) any - later version, or - - b) the "Artistic License" which comes with this kit. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either - the GNU General Public License or the Artistic License for more details. - - You should have received a copy of the Artistic License with this kit, - in the file named "Artistic". If not, you can get one from the Perl - distribution. You should also have received a copy of the GNU General - Public License, in the file named "Copying". If not, you can get one - from the Perl distribution or else write to the Free Software Foundation, - Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. - -=cut - diff --git a/cpan/B-Debug/t/debug.t b/cpan/B-Debug/t/debug.t deleted file mode 100644 index c362d7456d..0000000000 --- a/cpan/B-Debug/t/debug.t +++ /dev/null @@ -1,105 +0,0 @@ -#!./perl - -BEGIN { - delete $ENV{PERL_DL_NONLAZY} if $] < 5.005_58; #Perl_byterun problem - if ($ENV{PERL_CORE}){ - chdir('t') if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - } else { - unshift @INC, 't'; - } - require Config; - if (($Config::Config{'extensions'} !~ /\bB\b/) ){ - print "1..0 # Skip -- Perl configured without B module\n"; - exit 0; - } -} - -$| = 1; -use warnings; -use strict; -use Config; -use Test::More tests => 11; -use B; -use B::Debug; -use File::Spec; - -my $a; -my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X; - -local $ENV{PERL5LIB} = - join $Config{path_sep}, File::Spec->catfile("blib","lib"), @INC; -my $redir = $^O =~ /VMS|MSWin32|MacOS/ ? "" : "2>&1"; - -$a = `$X "-MO=Debug" -e 1 $redir`; -like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s); - - -$a = `$X "-MO=Terse" -e 1 $redir`; -like($a, qr/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s); - -$a = `$X "-MO=Terse" -ane "s/foo/bar/" $redir`; -$a =~ s/\(0x[^)]+\)//g; -$a =~ s/\[[^\]]+\]//g; -$a =~ s/-e syntax OK//; -$a =~ s/[^a-z ]+//g; -$a =~ s/\s+/ /g; -$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g; -$a =~ s/^\s+//; -$a =~ s/\s+$//; -$a =~ s/\s+nextstate$//; # if $] < 5.008001; # 5.8.0 adds it. 5.8.8 not anymore -my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; -if ($is_thread) { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null -threadsv readline gv lineseq nextstate aassign null pushmark split pushre -threadsv const null pushmark rvav gv nextstate subst const unstack -EOF -} elsif ($] >= 5.021005) { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null null -gvsv readline gv lineseq nextstate split pushre null -gvsv const nextstate subst const unstack -EOF -} else { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null null -gvsv readline gv lineseq nextstate aassign null pushmark split pushre null -gvsv const null pushmark rvav gv nextstate subst const unstack -EOF -} -$b=~s/\n/ /g; $b=~s/\s+/ /g; -$b =~ s/\s+$//; -$b =~ s/split pushre/split/ if $] >= 5.025006; - -is($a, $b); - -like(B::Debug::_printop(B::main_root), qr/LISTOP\s+\[OP_LEAVE\]/); -like(B::Debug::_printop(B::main_start), qr/OP\s+\[OP_ENTER\]/); - -$a = `$X "-MO=Debug" -e "B::main_root->debug" $redir`; -like($a, qr/op_next\s+0x0/m); -$a = `$X "-MO=Debug" -e "B::main_start->debug" $redir`; -like($a, qr/\[OP_ENTER\]/m); - -# pass missing FETCHSIZE, fixed with 1.06 -my $e = q(BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};print $a[1]); -$a = `$X "-MO=Debug" -e"$e" $redir`; -unlike($a, qr/locate object method "FETCHSIZE"/m); - -# NV assertion with CV, fixed with 1.13 -my $tmp = "tmp.pl"; -open TMP, ">", $tmp; -print TMP 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;'; -close TMP; -$a = `$X "-MO=Debug" $tmp $redir`; -ok(! $?); -unlike($a, qr/assertion "SvTYPE(sv) != SVt_PVCV" failed.*function: S_sv_2iuv_common/m); -unlike($a, qr/Use of uninitialized value in print/m); - -END { unlink $tmp if $tmp; } diff --git a/dist/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index b533b23c3d..fad2727b5c 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/dist/Module-CoreList/lib/Module/CoreList.pm @@ -16717,6 +16717,7 @@ sub is_core changed => { }, removed => { + arybase => '1', } }, ); diff --git a/dist/Time-HiRes/fallback/const-c.inc b/dist/Time-HiRes/fallback/const-c.inc index 2c29a0b141..99992d1762 100644 --- a/dist/Time-HiRes/fallback/const-c.inc +++ b/dist/Time-HiRes/fallback/const-c.inc @@ -361,6 +361,7 @@ constant_19 (pTHX_ const char *name, IV *iv_return) { *iv_return = CLOCK_UPTIME_COARSE; return PERL_constant_ISIV; #else + *iv_return = 0; return PERL_constant_NOTDEF; #endif } @@ -372,6 +373,7 @@ constant_19 (pTHX_ const char *name, IV *iv_return) { *iv_return = CLOCK_REALTIME_FAST; return PERL_constant_ISIV; #else + *iv_return = 0; return PERL_constant_NOTDEF; #endif } @@ -383,6 +385,7 @@ constant_19 (pTHX_ const char *name, IV *iv_return) { *iv_return = CLOCK_MONOTONIC_RAW; return PERL_constant_ISIV; #else + *iv_return = 0; return PERL_constant_NOTDEF; #endif } diff --git a/ext/B/B.pm b/ext/B/B.pm index ce061e4910..5ec8b8c788 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -20,7 +20,7 @@ sub import { # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.74'; + $B::VERSION = '1.75'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -1194,8 +1194,6 @@ The C<B::COP> class is used for "nextstate" and "dbstate" ops. As of Perl =item cop_seq -=item arybase - =item line =item warnings diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 9032e9b082..729fcd95f4 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "1.003"; +our $VERSION = "1.004"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -1284,7 +1284,7 @@ This is mainly a joke. =item B<-debug> -Use formatting conventions reminiscent of B<B::Debug>; these aren't +Use formatting conventions reminiscent of CPAN module B<B::Debug>; these aren't very concise at all. =item B<-env> diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index 681112e904..4401073f25 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -1,6 +1,6 @@ package B::Terse; -our $VERSION = '1.08'; +our $VERSION = '1.09'; use strict; use B qw(class @specialsv_name); @@ -73,7 +73,7 @@ B::Terse - Walk Perl syntax tree, printing terse info about ops =head1 DESCRIPTION This module prints the contents of the parse tree, but without as much -information as L<B::Debug>. For comparison, C<print "Hello, world."> +information as CPAN module B::Debug. For comparison, C<print "Hello, world."> produced 96 lines of output from B::Debug, but only 6 from B::Terse. This module is useful for people who are writing their own back end, diff --git a/ext/arybase/arybase.pm b/ext/arybase/arybase.pm deleted file mode 100644 index 5e34e29e8d..0000000000 --- a/ext/arybase/arybase.pm +++ /dev/null @@ -1,98 +0,0 @@ -package arybase; - -our $VERSION = "0.15"; - -require XSLoader; -XSLoader::load(); # This returns true, which makes require happy. - -__END__ - -=head1 NAME - -arybase - Set indexing base via $[ - -=head1 SYNOPSIS - - $[ = 1; - - @a = qw(Sun Mon Tue Wed Thu Fri Sat); - print $a[3], "\n"; # prints Tue - -=head1 DESCRIPTION - -This module implements Perl's C<$[> variable. You should not use it -directly. - -Assigning to C<$[> has the I<compile-time> effect of making the assigned -value, converted to an integer, the index of the first element in an array -and the first character in a substring, within the enclosing lexical scope. - -It can be written with or without C<local>: - - $[ = 1; - local $[ = 1; - -It only works if the assignment can be detected at compile time and the -value assigned is constant. - -It affects the following operations: - - $array[$element] - @array[@slice] - $#array - (list())[$slice] - splice @array, $index, ... - each @array - keys @array - - index $string, $substring # return value is affected - pos $string - substr $string, $offset, ... - -As with the default base of 0, negative bases count from the end of the -array or string, starting with -1. If C<$[> is a positive integer, indices -from C<$[-1> to 0 also count from the end. If C<$[> is negative (why would -you do that, though?), indices from C<$[> to 0 count from the beginning of -the string, but indices below C<$[> count from the end of the string as -though the base were 0. - -Prior to Perl 5.16, indices from 0 to C<$[-1> inclusive, for positive -values of C<$[>, behaved differently for different operations; negative -indices equal to or greater than a negative C<$[> likewise behaved -inconsistently. - -=head1 HISTORY - -Before Perl 5, C<$[> was a global variable that affected all array indices -and string offsets. - -Starting with Perl 5, it became a file-scoped compile-time directive, which -could be made lexically-scoped with C<local>. "File-scoped" means that the -C<$[> assignment could leak out of the block in which occurred: - - { - $[ = 1; - # ... array base is 1 here ... - } - # ... still 1, but not in other files ... - -In Perl 5.10, it became strictly lexical. The file-scoped behaviour was -removed (perhaps inadvertently, but what's done is done). - -In Perl 5.16, the implementation was moved into this module, and out of the -Perl core. The erratic behaviour that occurred with indices between -1 and -C<$[> was made consistent between operations, and, for negative bases, -indices from C<$[> to -1 inclusive were made consistent between operations. - -=head1 BUGS - -Error messages that mention array indices use the 0-based index. - -C<keys $arrayref> and C<each $arrayref> do not respect the current value of -C<$[>. - -=head1 SEE ALSO - -L<perlvar/"$[">, L<Array::Base> and L<String::Base>. - -=cut diff --git a/ext/arybase/arybase.xs b/ext/arybase/arybase.xs deleted file mode 100644 index 6c12d0515f..0000000000 --- a/ext/arybase/arybase.xs +++ /dev/null @@ -1,496 +0,0 @@ -#define PERL_NO_GET_CONTEXT /* we want efficiency */ -#define PERL_EXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include "feature.h" - -/* ... op => info map ................................................. */ - -typedef struct { - OP *(*old_pp)(pTHX); - IV base; -} ab_op_info; - -#define PTABLE_NAME ptable_map -#define PTABLE_VAL_FREE(V) PerlMemShared_free(V) -#include "ptable.h" -#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V)) - -STATIC ptable *ab_op_map = NULL; - -#ifdef USE_ITHREADS -STATIC perl_mutex ab_op_map_mutex; -#endif - -STATIC const ab_op_info *ab_map_fetch(const OP *o, ab_op_info *oi) { - const ab_op_info *val; - - MUTEX_LOCK(&ab_op_map_mutex); - - val = (ab_op_info *)ptable_fetch(ab_op_map, o); - if (val) { - *oi = *val; - val = oi; - } - - MUTEX_UNLOCK(&ab_op_map_mutex); - - return val; -} - -STATIC const ab_op_info *ab_map_store_locked( - pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), IV base -) { -#define ab_map_store_locked(O, PP, B) \ - ab_map_store_locked(aPTBLMS_ (O), (PP), (B)) - ab_op_info *oi; - - if (!(oi = (ab_op_info *)ptable_fetch(ab_op_map, o))) { - oi = (ab_op_info *)PerlMemShared_malloc(sizeof *oi); - ptable_map_store(ab_op_map, o, oi); - } - - oi->old_pp = old_pp; - oi->base = base; - return oi; -} - -STATIC void ab_map_store( - pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), IV base) -{ -#define ab_map_store(O, PP, B) ab_map_store(aPTBLMS_ (O),(PP),(B)) - - MUTEX_LOCK(&ab_op_map_mutex); - - ab_map_store_locked(o, old_pp, base); - - MUTEX_UNLOCK(&ab_op_map_mutex); -} - -STATIC void ab_map_delete(pTHX_ const OP *o) { -#define ab_map_delete(O) ab_map_delete(aTHX_ (O)) - MUTEX_LOCK(&ab_op_map_mutex); - - ptable_map_store(ab_op_map, o, NULL); - - MUTEX_UNLOCK(&ab_op_map_mutex); -} - -/* ... $[ Implementation .............................................. */ - -#define hintkey "$[" -#define hintkey_len (sizeof(hintkey)-1) - -STATIC SV * ab_hint(pTHX_ const bool create) { -#define ab_hint(c) ab_hint(aTHX_ c) - dVAR; - SV **val - = hv_fetch(GvHV(PL_hintgv), hintkey, hintkey_len, create); - if (!val) - return 0; - return *val; -} - -/* current base at compile time */ -STATIC IV current_base(pTHX) { -#define current_base() current_base(aTHX) - SV *hsv = ab_hint(0); - assert(FEATURE_ARYBASE_IS_ENABLED); - if (!hsv || !SvOK(hsv)) return 0; - return SvIV(hsv); -} - -STATIC void set_arybase_to(pTHX_ IV base) { -#define set_arybase_to(base) set_arybase_to(aTHX_ (base)) - dVAR; - SV *hsv = ab_hint(1); - sv_setiv_mg(hsv, base); -} - -#define old_ck(opname) STATIC OP *(*ab_old_ck_##opname)(pTHX_ OP *) = 0 -old_ck(sassign); -old_ck(aassign); -old_ck(aelem); -old_ck(aslice); -old_ck(lslice); -old_ck(av2arylen); -old_ck(splice); -old_ck(keys); -old_ck(each); -old_ck(substr); -old_ck(rindex); -old_ck(index); -old_ck(pos); - -STATIC bool ab_op_is_dollar_bracket(pTHX_ OP *o) { -#define ab_op_is_dollar_bracket(o) ab_op_is_dollar_bracket(aTHX_ (o)) - OP *c; - return o->op_type == OP_RV2SV && (o->op_flags & OPf_KIDS) - && (c = cUNOPx(o)->op_first) - && c->op_type == OP_GV - && GvSTASH(cGVOPx_gv(c)) == PL_defstash - && strEQ(GvNAME(cGVOPx_gv(c)), "["); -} - -STATIC void ab_neuter_dollar_bracket(pTHX_ OP *o) { -#define ab_neuter_dollar_bracket(o) ab_neuter_dollar_bracket(aTHX_ (o)) - OP *oldc, *newc; - /* - * Must replace the core's $[ with something that can accept assignment - * of non-zero value and can be local()ised. Simplest thing is a - * different global variable. - */ - oldc = cUNOPx(o)->op_first; - newc = newGVOP(OP_GV, 0, - gv_fetchpvs("arybase::leftbrack", GV_ADDMULTI, SVt_PVGV)); - /* replace oldc with newc */ - op_sibling_splice(o, NULL, 1, newc); - op_free(oldc); -} - -STATIC void ab_process_assignment(pTHX_ OP *left, OP *right) { -#define ab_process_assignment(l, r) \ - ab_process_assignment(aTHX_ (l), (r)) - if (ab_op_is_dollar_bracket(left) && right->op_type == OP_CONST) { - IV base = SvIV(cSVOPx_sv(right)); - set_arybase_to(base); - ab_neuter_dollar_bracket(left); - if (base) { - Perl_ck_warner_d(aTHX_ - packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated" - ", and will be fatal in Perl 5.30" - ); - } - } -} - -STATIC OP *ab_ck_sassign(pTHX_ OP *o) { - o = (*ab_old_ck_sassign)(aTHX_ o); - if (o->op_type == OP_SASSIGN && FEATURE_ARYBASE_IS_ENABLED) { - OP *right = cBINOPx(o)->op_first; - OP *left = OpSIBLING(right); - if (left) ab_process_assignment(left, right); - } - return o; -} - -STATIC OP *ab_ck_aassign(pTHX_ OP *o) { - o = (*ab_old_ck_aassign)(aTHX_ o); - if (o->op_type == OP_AASSIGN && FEATURE_ARYBASE_IS_ENABLED) { - OP *right = cBINOPx(o)->op_first; - OP *left = OpSIBLING(right); - left = OpSIBLING(cBINOPx(left)->op_first); - right = OpSIBLING(cBINOPx(right)->op_first); - ab_process_assignment(left, right); - } - return o; -} - -STATIC void -tie(pTHX_ SV * const sv, SV * const obj, HV *const stash) -{ - SV *rv = newSV_type(SVt_RV); - - SvRV_set(rv, obj ? SvREFCNT_inc_simple_NN(obj) : newSV(0)); - SvROK_on(rv); - sv_bless(rv, stash); - - sv_unmagic((SV *)sv, PERL_MAGIC_tiedscalar); - sv_magic((SV *)sv, rv, PERL_MAGIC_tiedscalar, NULL, 0); - SvREFCNT_dec(rv); /* As sv_magic increased it by one. */ -} - -/* This function converts from base-based to 0-based an index to be passed - as an argument. */ -static IV -adjust_index(IV index, IV base) -{ - if (index >= base || index > -1) return index-base; - return index; -} -/* This function converts from 0-based to base-based an index to - be returned. */ -static IV -adjust_index_r(IV index, IV base) -{ - return index + base; -} - -#define replace_sv(sv,base) \ - ((sv) = sv_2mortal(newSViv(adjust_index(SvIV(sv),base)))) -#define replace_sv_r(sv,base) \ - ((sv) = sv_2mortal(newSViv(adjust_index_r(SvIV(sv),base)))) - -static OP *ab_pp_basearg(pTHX) { - dVAR; dSP; - SV **firstp = NULL; - SV **svp; - UV count = 1; - ab_op_info oi; - Zero(&oi, 1, ab_op_info); - ab_map_fetch(PL_op, &oi); - - switch (PL_op->op_type) { - case OP_AELEM: - firstp = SP; - break; - case OP_ASLICE: - firstp = PL_stack_base + TOPMARK + 1; - count = SP-firstp; - break; - case OP_LSLICE: - firstp = PL_stack_base + *(PL_markstack_ptr-1)+1; - count = TOPMARK - *(PL_markstack_ptr-1); - if (GIMME_V != G_ARRAY) { - firstp += count-1; - count = 1; - } - break; - case OP_SPLICE: - if (SP - PL_stack_base - TOPMARK >= 2) - firstp = PL_stack_base + TOPMARK + 2; - else count = 0; - break; - case OP_SUBSTR: - firstp = SP-(PL_op->op_private & 7)+2; - break; - default: - DIE(aTHX_ - "panic: invalid op type for arybase.xs:ab_pp_basearg: %d", - PL_op->op_type); - } - svp = firstp; - while (count--) replace_sv(*svp,oi.base), svp++; - return (*oi.old_pp)(aTHX); -} - -static OP *ab_pp_av2arylen(pTHX) { - dSP; dVAR; - SV *sv; - ab_op_info oi; - OP *ret; - Zero(&oi, 1, ab_op_info); - ab_map_fetch(PL_op, &oi); - ret = (*oi.old_pp)(aTHX); - if (PL_op->op_flags & OPf_MOD || LVRET) { - sv = newSV(0); - tie(aTHX_ sv, TOPs, gv_stashpv("arybase::mg",1)); - SETs(sv); - } - else { - SvGETMAGIC(TOPs); - if (SvOK(TOPs)) replace_sv_r(TOPs, oi.base); - } - return ret; -} - -static OP *ab_pp_keys(pTHX) { - dVAR; dSP; - ab_op_info oi; - OP *retval; - const I32 offset = SP - PL_stack_base; - SV **svp; - Zero(&oi, 1, ab_op_info); - ab_map_fetch(PL_op, &oi); - retval = (*oi.old_pp)(aTHX); - if (GIMME_V == G_SCALAR) return retval; - SPAGAIN; - svp = PL_stack_base + offset; - while (svp <= SP) replace_sv_r(*svp,oi.base), ++svp; - return retval; -} - -static OP *ab_pp_each(pTHX) { - dVAR; dSP; - ab_op_info oi; - OP *retval; - const I32 offset = SP - PL_stack_base; - Zero(&oi, 1, ab_op_info); - ab_map_fetch(PL_op, &oi); - retval = (*oi.old_pp)(aTHX); - SPAGAIN; - if (GIMME_V == G_SCALAR) { - if (SvOK(TOPs)) replace_sv_r(TOPs,oi.base); - } - else if (offset < SP - PL_stack_base) replace_sv_r(TOPm1s,oi.base); - return retval; -} - -static OP *ab_pp_index(pTHX) { - dVAR; dSP; - ab_op_info oi; - OP *retval; - Zero(&oi, 1, ab_op_info); - ab_map_fetch(PL_op, &oi); - if (MAXARG == 3 && TOPs) replace_sv(TOPs,oi.base); - retval = (*oi.old_pp)(aTHX); - SPAGAIN; - replace_sv_r(TOPs,oi.base); - return retval; -} - -static OP *ab_ck_base(pTHX_ OP *o) -{ - OP * (*old_ck)(pTHX_ OP *o) = 0; - OP * (*new_pp)(pTHX) = ab_pp_basearg; - switch (o->op_type) { - case OP_AELEM : old_ck = ab_old_ck_aelem ; break; - case OP_ASLICE : old_ck = ab_old_ck_aslice ; break; - case OP_LSLICE : old_ck = ab_old_ck_lslice ; break; - case OP_AV2ARYLEN: old_ck = ab_old_ck_av2arylen; break; - case OP_SPLICE : old_ck = ab_old_ck_splice ; break; - case OP_KEYS : old_ck = ab_old_ck_keys ; break; - case OP_EACH : old_ck = ab_old_ck_each ; break; - case OP_SUBSTR : old_ck = ab_old_ck_substr ; break; - case OP_RINDEX : old_ck = ab_old_ck_rindex ; break; - case OP_INDEX : old_ck = ab_old_ck_index ; break; - case OP_POS : old_ck = ab_old_ck_pos ; break; - default: - DIE(aTHX_ - "panic: invalid op type for arybase.xs:ab_ck_base: %d", - PL_op->op_type); - } - o = (*old_ck)(aTHX_ o); - if (!FEATURE_ARYBASE_IS_ENABLED) return o; - /* We need two switch blocks, as the type may have changed. */ - switch (o->op_type) { - case OP_AELEM : - case OP_ASLICE : - case OP_LSLICE : - case OP_SPLICE : - case OP_SUBSTR : break; - case OP_POS : - case OP_AV2ARYLEN: new_pp = ab_pp_av2arylen ; break; - case OP_AKEYS : new_pp = ab_pp_keys ; break; - case OP_AEACH : new_pp = ab_pp_each ; break; - case OP_RINDEX : - case OP_INDEX : new_pp = ab_pp_index ; break; - default: return o; - } - { - IV const base = current_base(); - if (base) { - ab_map_store(o, o->op_ppaddr, base); - o->op_ppaddr = new_pp; - /* Break the aelemfast optimisation */ - if (o->op_type == OP_AELEM) { - OP *const first = cBINOPo->op_first; - OP *second = OpSIBLING(first); - OP *newop; - if (second->op_type == OP_CONST) { - /* cut out second arg and replace it with a new unop which is - * the parent of that arg */ - op_sibling_splice(o, first, 1, NULL); - newop = newUNOP(OP_NULL,0,second); - op_sibling_splice(o, first, 0, newop); - } - } - } - else ab_map_delete(o); - } - return o; -} - - -STATIC U32 ab_initialized = 0; - -/* --- XS ------------------------------------------------------------- */ - -MODULE = arybase PACKAGE = arybase -PROTOTYPES: DISABLE - -BOOT: -{ - if (!ab_initialized++) { - ab_op_map = ptable_new(); - MUTEX_INIT(&ab_op_map_mutex); -#define check(uc,lc,ck) \ - wrap_op_checker(OP_##uc, ab_ck_##ck, &ab_old_ck_##lc) - check(SASSIGN, sassign, sassign); - check(AASSIGN, aassign, aassign); - check(AELEM, aelem, base); - check(ASLICE, aslice, base); - check(LSLICE, lslice, base); - check(AV2ARYLEN,av2arylen,base); - check(SPLICE, splice, base); - check(KEYS, keys, base); - check(EACH, each, base); - check(SUBSTR, substr, base); - check(RINDEX, rindex, base); - check(INDEX, index, base); - check(POS, pos, base); - } -} - -void -_tie_it(SV *sv) - INIT: - GV * const gv = (GV *)sv; - CODE: - if (GvSV(gv)) - /* This is *our* scalar now! */ - sv_unmagic(GvSV(gv), PERL_MAGIC_sv); - tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv))); - -void -FETCH(...) - PREINIT: - SV *ret = FEATURE_ARYBASE_IS_ENABLED - ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) - : 0; - PPCODE: - if (!ret || !SvOK(ret)) mXPUSHi(0); - else XPUSHs(ret); - -void -STORE(SV *sv, IV newbase) - CODE: - PERL_UNUSED_VAR(sv); - if (FEATURE_ARYBASE_IS_ENABLED) { - SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0); - if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY; - Perl_croak(aTHX_ "That use of $[ is unsupported"); - } - else if (newbase) - Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); - - -MODULE = arybase PACKAGE = arybase::mg -PROTOTYPES: DISABLE - -void -FETCH(SV *sv) - PPCODE: - if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV) - Perl_croak(aTHX_ "Not a SCALAR reference"); - { - SV *base = FEATURE_ARYBASE_IS_ENABLED - ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) - : 0; - SvGETMAGIC(SvRV(sv)); - if (!SvOK(SvRV(sv))) XSRETURN_UNDEF; - mXPUSHi(adjust_index_r( - SvIV_nomg(SvRV(sv)), base&&SvOK(base)?SvIV(base):0 - )); - } - -void -STORE(SV *sv, SV *newbase) - CODE: - if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV) - Perl_croak(aTHX_ "Not a SCALAR reference"); - { - SV *base = FEATURE_ARYBASE_IS_ENABLED - ? cop_hints_fetch_pvs(PL_curcop, "$[", 0) - : 0; - SvGETMAGIC(newbase); - if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef); - else - sv_setiv_mg( - SvRV(sv), - adjust_index( - SvIV_nomg(newbase), base&&SvOK(base)?SvIV(base):0 - ) - ); - } diff --git a/ext/arybase/ptable.h b/ext/arybase/ptable.h deleted file mode 100644 index f7919befdf..0000000000 --- a/ext/arybase/ptable.h +++ /dev/null @@ -1,226 +0,0 @@ -/* This is a pointer table implementation essentially copied from the ptr_table - * implementation in perl's sv.c, except that it has been modified to use memory - * shared across threads. */ - -/* This header is designed to be included several times with different - * definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */ - -#undef pPTBLMS -#undef pPTBLMS_ -#undef aPTBLMS -#undef aPTBLMS_ - -/* Context for PerlMemShared_* functions */ - -#ifdef PERL_IMPLICIT_SYS -# define pPTBLMS pTHX -# define pPTBLMS_ pTHX_ -# define aPTBLMS aTHX -# define aPTBLMS_ aTHX_ -#else -# define pPTBLMS -# define pPTBLMS_ -# define aPTBLMS -# define aPTBLMS_ -#endif - -#ifndef pPTBL -# define pPTBL pPTBLMS -#endif -#ifndef pPTBL_ -# define pPTBL_ pPTBLMS_ -#endif -#ifndef aPTBL -# define aPTBL aPTBLMS -#endif -#ifndef aPTBL_ -# define aPTBL_ aPTBLMS_ -#endif - -#ifndef PTABLE_NAME -# define PTABLE_NAME ptable -#endif - -#ifndef PTABLE_VAL_FREE -# define PTABLE_VAL_FREE(V) -#endif - -#ifndef PTABLE_JOIN -# define PTABLE_PASTE(A, B) A ## B -# define PTABLE_JOIN(A, B) PTABLE_PASTE(A, B) -#endif - -#ifndef PTABLE_PREFIX -# define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X) -#endif - -#ifndef ptable_ent -typedef struct ptable_ent { - struct ptable_ent *next; - const void * key; - void * val; -} ptable_ent; -#define ptable_ent ptable_ent -#endif /* !ptable_ent */ - -#ifndef ptable -typedef struct ptable { - ptable_ent **ary; - UV max; - UV items; -} ptable; -#define ptable ptable -#endif /* !ptable */ - -#ifndef ptable_new -STATIC ptable *ptable_new(pPTBLMS) { -#define ptable_new() ptable_new(aPTBLMS) - ptable *t = (ptable *)PerlMemShared_malloc(sizeof *t); - t->max = 63; - t->items = 0; - t->ary = (ptable_ent **)PerlMemShared_calloc(t->max + 1, sizeof *t->ary); - return t; -} -#endif /* !ptable_new */ - -#ifndef PTABLE_HASH -# define PTABLE_HASH(ptr) \ - ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) -#endif - -#ifndef ptable_find -STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) { -#define ptable_find ptable_find - ptable_ent *ent; - const UV hash = PTABLE_HASH(key); - - ent = t->ary[hash & t->max]; - for (; ent; ent = ent->next) { - if (ent->key == key) - return ent; - } - - return NULL; -} -#endif /* !ptable_find */ - -#ifndef ptable_fetch -STATIC void *ptable_fetch(const ptable * const t, const void * const key) { -#define ptable_fetch ptable_fetch - const ptable_ent *const ent = ptable_find(t, key); - - return ent ? ent->val : NULL; -} -#endif /* !ptable_fetch */ - -#ifndef ptable_split -STATIC void ptable_split(pPTBLMS_ ptable * const t) { -#define ptable_split(T) ptable_split(aPTBLMS_ (T)) - ptable_ent **ary = t->ary; - const UV oldsize = t->max + 1; - UV newsize = oldsize * 2; - UV i; - - ary = (ptable_ent **)PerlMemShared_realloc(ary, newsize * sizeof(*ary)); - Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary)); - t->max = --newsize; - t->ary = ary; - - for (i = 0; i < oldsize; i++, ary++) { - ptable_ent **currentp, **entp, *ent; - if (!*ary) - continue; - currentp = ary + oldsize; - for (entp = ary, ent = *ary; ent; ent = *entp) { - if ((newsize & PTABLE_HASH(ent->key)) != i) { - *entp = ent->next; - ent->next = *currentp; - *currentp = ent; - continue; - } else - entp = &ent->next; - } - } -} -#endif /* !ptable_split */ - -STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) { - ptable_ent *ent = ptable_find(t, key); - - if (ent) { - void *oldval = ent->val; - PTABLE_VAL_FREE(oldval); - ent->val = val; - } else if (val) { - const UV i = PTABLE_HASH(key) & t->max; - ent = (ptable_ent *)PerlMemShared_malloc(sizeof *ent); - ent->key = key; - ent->val = val; - ent->next = t->ary[i]; - t->ary[i] = ent; - t->items++; - if (ent->next && t->items > t->max) - ptable_split(t); - } -} - -/* this function appears to be unused */ -#if 0 -#ifndef ptable_walk -STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) { -#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD)) - if (t && t->items) { - ptable_ent ** const array = t->ary; - UV i = t->max; - do { - ptable_ent *entry; - for (entry = array[i]; entry; entry = entry->next) - cb(aTHX_ entry, userdata); - } while (i--); - } -} -#endif /* !ptable_walk */ -#endif - -/* this function appears to be unused */ -#if 0 -STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { - if (t && t->items) { - ptable_ent ** const array = t->ary; - UV i = t->max; - - do { - ptable_ent *entry = array[i]; - while (entry) { - ptable_ent * const oentry = entry; - void *val = oentry->val; - entry = entry->next; - PTABLE_VAL_FREE(val); - PerlMemShared_free(oentry); - } - array[i] = NULL; - } while (i--); - - t->items = 0; - } -} -#endif - -/* this function appears to be unused */ -#if 0 -STATIC void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) { - if (!t) - return; - PTABLE_PREFIX(_clear)(aPTBL_ t); - PerlMemShared_free(t->ary); - PerlMemShared_free(t); -} -#endif - -#undef pPTBL -#undef pPTBL_ -#undef aPTBL -#undef aPTBL_ - -#undef PTABLE_NAME -#undef PTABLE_VAL_FREE diff --git a/ext/arybase/t/aeach.t b/ext/arybase/t/aeach.t deleted file mode 100644 index 241677acb0..0000000000 --- a/ext/arybase/t/aeach.t +++ /dev/null @@ -1,45 +0,0 @@ -use warnings; no warnings 'deprecated'; -use strict; - -BEGIN { - if("$]" < 5.011) { - require Test::More; - Test::More::plan(skip_all => "no array each on this Perl"); - } -} - -use Test::More tests => 2; - -our @activity; - -$[ = 3; - -our @t0 = qw(a b c); -@activity = (); -foreach(0..5) { - push @activity, [ each(@t0) ]; -} -is_deeply \@activity, [ - [ 3, "a" ], - [ 4, "b" ], - [ 5, "c" ], - [], - [ 3, "a" ], - [ 4, "b" ], -]; - -our @t1 = qw(a b c); -@activity = (); -foreach(0..5) { - push @activity, [ scalar each(@t1) ]; -} -is_deeply \@activity, [ - [ 3 ], - [ 4 ], - [ 5 ], - [ undef ], - [ 3 ], - [ 4 ], -]; - -1; diff --git a/ext/arybase/t/aelem.t b/ext/arybase/t/aelem.t deleted file mode 100644 index c26a2a80c3..0000000000 --- a/ext/arybase/t/aelem.t +++ /dev/null @@ -1,56 +0,0 @@ -use warnings; no warnings 'deprecated'; -use strict; - -use Test::More tests => 33; - -our @t = qw(a b c d e f); -our $r = \@t; -our($i3, $i4, $i8, $i9) = (3, 4, 8, 9); -our @i4 = (3, 3, 3, 3); - -$[ = 3; - -is $t[3], "a"; -is $t[4], "b"; -is $t[8], "f"; -is $t[9], undef; -is_deeply [ scalar $t[4] ], [ "b" ]; -is_deeply [ $t[4] ], [ "b" ]; - -is $t[2], 'f'; -is $t[-1], 'f'; -is $t[1], 'e'; -is $t[-2], 'e'; - -{ - $[ = -3; - is $t[-3], 'a'; -} - -is $r->[3], "a"; -is $r->[4], "b"; -is $r->[8], "f"; -is $r->[9], undef; -is_deeply [ scalar $r->[4] ], [ "b" ]; -is_deeply [ $r->[4] ], [ "b" ]; - -is $t[$i3], "a"; -is $t[$i4], "b"; -is $t[$i8], "f"; -is $t[$i9], undef; -is_deeply [ scalar $t[$i4] ], [ "b" ]; -is_deeply [ $t[$i4] ], [ "b" ]; -is_deeply [ scalar $t[@i4] ], [ "b" ]; -is_deeply [ $t[@i4] ], [ "b" ]; - -is $r->[$i3], "a"; -is $r->[$i4], "b"; -is $r->[$i8], "f"; -is $r->[$i9], undef; -is_deeply [ scalar $r->[$i4] ], [ "b" ]; -is_deeply [ $r->[$i4] ], [ "b" ]; -is_deeply [ scalar $r->[@i4] ], [ "b" ]; -is_deeply [ $r->[@i4] ], [ "b" ]; - - -1; diff --git a/ext/arybase/t/akeys.t b/ext/arybase/t/akeys.t deleted file mode 100644 index a76fade9db..0000000000 --- a/ext/arybase/t/akeys.t +++ /dev/null @@ -1,25 +0,0 @@ -use warnings; no warnings 'deprecated'; -use strict; - -BEGIN { - if("$]" < 5.011) { - require Test::More; - Test::More::plan(skip_all => "no array keys on this Perl"); - } -} - -use Test::More tests => 4; - -our @t; - -$[ = 3; - -@t = (); -is_deeply [ scalar keys @t ], [ 0 ]; -is_deeply [ keys @t ], []; - -@t = qw(a b c d e f); -is_deeply [ scalar keys @t ], [ 6 ]; -is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ]; - -1; diff --git a/ext/arybase/t/arybase.t b/ext/arybase/t/arybase.t deleted file mode 100644 index f3d32874e2..0000000000 --- a/ext/arybase/t/arybase.t +++ /dev/null @@ -1,37 +0,0 @@ -#!perl - -# Basic tests for $[ as a variable -# plus miscellaneous bug fix tests - -no warnings 'deprecated'; -use Test::More tests => 7; - -sub outside_base_scope { return "${'['}" } - -$[ = 3; -my $base = \$[; -is "$$base", 3, 'retval of $['; -is outside_base_scope, 0, 'retval of $[ outside its scope'; - -${'['} = 3; -pass('run-time $[ = 3 assignment (in $[ = 3 scope)'); -{ - $[ = 0; - ${'['} = 0; - pass('run-time $[ = 0 assignment (in $[ = 3 scope)'); -} - -eval { ${'['} = 1 }; my $f = __FILE__; my $l = __LINE__; -is $@, "That use of \$[ is unsupported at $f line $l.\n", - "error when setting $[ to integer other than current base at run-time"; - -$[ = 6.7; -is "$[", 6, '$[ is an integer'; - -eval { my $x = 45; $[ = \$x }; $l = __LINE__; -is $@, "That use of \$[ is unsupported at $f line $l.\n", - 'error when setting $[ to ref'; - -sub foo { my $x; $x = wait } # compilation of this routine used to crash - -1; diff --git a/ext/arybase/t/aslice.t b/ext/arybase/t/aslice.t deleted file mode 100644 index 20782e59a5..0000000000 --- a/ext/arybase/t/aslice.t ... 1285 lines suppressed ... -- Perl5 Master Repository
