summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ext/B/B/Deparse.pm6
-rw-r--r--ext/B/t/deparse.t9
-rw-r--r--gv.c21
-rw-r--r--mg.c6
-rw-r--r--op.c11
-rw-r--r--perl.c2
-rw-r--r--perlio.c3
-rw-r--r--regcomp.c2
-rw-r--r--regen.pl18
-rw-r--r--regen_lib.pl16
-rw-r--r--t/mro/pkg_gen.t6
-rwxr-xr-xt/op/method.t30
-rw-r--r--t/op/re_tests1
-rwxr-xr-xt/op/universal.t8
14 files changed, 89 insertions, 50 deletions
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 64c6dc9891..c7ed82d638 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -2589,6 +2589,12 @@ sub pp_cond_expr {
my $newcond = $newop->first;
my $newtrue = $newcond->sibling;
$false = $newtrue->sibling; # last in chain is OP_AND => no else
+ if ($newcond->name eq "lineseq")
+ {
+ # lineseq to ensure correct line numbers in elsif()
+ # Bug #37302 fixed by change #33710.
+ $newcond = $newcond->first->sibling;
+ }
$newcond = $self->deparse($newcond, 1);
$newtrue = $self->deparse($newtrue, 0);
push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t
index 5553df8c89..dce503403e 100644
--- a/ext/B/t/deparse.t
+++ b/ext/B/t/deparse.t
@@ -27,7 +27,7 @@ BEGIN {
require feature;
feature->import(':5.10');
}
-use Test::More tests => 59;
+use Test::More tests => 60;
use B::Deparse;
my $deparse = B::Deparse->new();
@@ -409,3 +409,10 @@ given ('foo') {
when ($_ ~~ 'quux') { continue; }
default { 0; }
}
+####
+# 53 conditions in elsifs (regression in change #33710 which fixed bug #37302)
+if ($a) { x(); }
+elsif ($b) { x(); }
+elsif ($a and $b) { x(); }
+elsif ($a or $b) { x(); }
+else { x(); }
diff --git a/gv.c b/gv.c
index 5be19f2d94..d24b8ece7d 100644
--- a/gv.c
+++ b/gv.c
@@ -498,7 +498,7 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le
if (!stash)
return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
- if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
+ if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
return NULL;
if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
return NULL;
@@ -594,22 +594,23 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
const char *nsplit = NULL;
GV* gv;
HV* ostash = stash;
+ const char * const origname = name;
if (stash && SvTYPE(stash) < SVt_PVHV)
stash = NULL;
for (nend = name; *nend; nend++) {
- if (*nend == '\'')
+ if (*nend == '\'') {
nsplit = nend;
- else if (*nend == ':' && *(nend + 1) == ':')
- nsplit = ++nend;
+ name = nend + 1;
+ }
+ else if (*nend == ':' && *(nend + 1) == ':') {
+ nsplit = nend++;
+ name = nend + 1;
+ }
}
if (nsplit) {
- const char * const origname = name;
- name = nsplit + 1;
- if (*nsplit == ':')
- --nsplit;
- if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
+ if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
@@ -674,7 +675,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
const char *packname = "";
STRLEN packname_len = 0;
- if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
+ if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
return NULL;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
diff --git a/mg.c b/mg.c
index fd89832f85..b5e366db33 100644
--- a/mg.c
+++ b/mg.c
@@ -1537,7 +1537,8 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
: (GV*)SvMAGIC(mg->mg_obj)->mg_obj
);
- mro_isa_changed_in(stash);
+ if (stash)
+ mro_isa_changed_in(stash);
return 0;
}
@@ -1560,7 +1561,8 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
: (GV*)SvMAGIC(mg->mg_obj)->mg_obj
);
- mro_isa_changed_in(stash);
+ if (stash)
+ mro_isa_changed_in(stash);
return 0;
}
diff --git a/op.c b/op.c
index d331815578..3a5d8201ff 100644
--- a/op.c
+++ b/op.c
@@ -473,8 +473,6 @@ Perl_op_free(pTHX_ OP *o)
op_free(kid);
}
}
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
#ifdef PERL_DEBUG_READONLY_OPS
Slab_to_rw(o);
@@ -482,10 +480,17 @@ Perl_op_free(pTHX_ OP *o)
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
+ if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE
+ || (type == OP_NULL /* the COP might have been null'ed */
+ && ((OPCODE)o->op_targ == OP_NEXTSTATE
+ || (OPCODE)o->op_targ == OP_SETSTATE
+ || (OPCODE)o->op_targ == OP_DBSTATE))) {
cop_free((COP*)o);
}
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
+
op_clear(o);
if (o->op_latefree) {
o->op_latefreed = 1;
diff --git a/perl.c b/perl.c
index f9e15f1095..b1e21b3590 100644
--- a/perl.c
+++ b/perl.c
@@ -4272,6 +4272,8 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
{
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
# ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+ dVAR;
+
PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
||
diff --git a/perlio.c b/perlio.c
index 5de1260089..4e2d01b4b9 100644
--- a/perlio.c
+++ b/perlio.c
@@ -3120,6 +3120,9 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
IV result = 0;
int saveerr = 0;
int dupfd = -1;
+#ifdef USE_ITHREADS
+ dVAR;
+#endif
#ifdef SOCKS5_VERSION_NAME
/* Socks lib overrides close() but stdio isn't linked to
that library (though we are) - so we must call close()
diff --git a/regcomp.c b/regcomp.c
index 7aca0270e3..770e32881d 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -5608,6 +5608,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
RExC_seen |= REG_SEEN_LOOKBEHIND;
RExC_parse++;
case '=': /* (?=...) */
+ RExC_seen_zerolen++;
+ break;
case '!': /* (?!...) */
RExC_seen_zerolen++;
if (*RExC_parse == ')') {
diff --git a/regen.pl b/regen.pl
index 1a479cbed6..6670e17ad3 100644
--- a/regen.pl
+++ b/regen.pl
@@ -15,6 +15,9 @@ my $perl = $^X;
# changes. Um, what ?
# safer_unlink ("warnings.h", "lib/warnings.pm");
+# We no longer need the values on this mapping, as the "changed" message is
+# now generated by regen_lib.pl, so should we just drop them?
+
my %gen = (
'autodoc.pl' => [qw[pod/perlapi.pod pod/perlintern.pod]],
'embed.pl' => [qw[proto.h embed.h embedvar.h global.sym
@@ -43,20 +46,9 @@ sub do_cksum {
return %cksum;
}
-foreach my $pl (keys %gen) {
+# this puts autodoc.pl last, which can be useful as it reads reentr.c
+foreach my $pl (reverse sort keys %gen) {
my @command = ($^X, $pl, @ARGV);
print "@command\n";
- my %cksum0;
- %cksum0 = do_cksum($pl) unless $pl eq 'warnings.pl'; # the files were removed
system @command;
- next if $pl eq 'warnings.pl'; # the files were removed
- my %cksum1 = do_cksum($pl);
- my @chg;
- for my $f (@{ $gen{$pl} }) {
- push(@chg, $f)
- if !defined($cksum0{$f}) ||
- !defined($cksum1{$f}) ||
- $cksum0{$f} ne $cksum1{$f};
- }
- print "Changed: @chg\n" if @chg;
}
diff --git a/regen_lib.pl b/regen_lib.pl
index 89ac3f9009..6735bb9294 100644
--- a/regen_lib.pl
+++ b/regen_lib.pl
@@ -1,6 +1,7 @@
#!/usr/bin/perl -w
use strict;
-use vars qw($Is_W32 $Is_OS2 $Is_Cygwin $Is_NetWare $Needs_Write $Verbose);
+use vars qw($Is_W32 $Is_OS2 $Is_Cygwin $Is_NetWare $Needs_Write $Verbose
+ @Changed);
use Config; # Remember, this is running using an existing perl
use File::Compare;
use Symbol;
@@ -17,7 +18,13 @@ if ($Is_NetWare) {
$Needs_Write = $Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare;
-@ARGV = grep { not($_ eq '-v' and $Verbose = 1) } @ARGV;
+$Verbose = 0;
+@ARGV = grep { not($_ eq '-q' and $Verbose = -1) }
+ grep { not($_ eq '-v' and $Verbose = 1) } @ARGV;
+
+END {
+ print STDOUT "Changed: @Changed\n" if @Changed;
+}
sub safer_unlink {
my @names = @_;
@@ -46,11 +53,12 @@ sub rename_if_different {
my ($from, $to) = @_;
if (compare($from, $to) == 0) {
- warn "no changes between '$from' & '$to'\n" if $Verbose;
+ warn "no changes between '$from' & '$to'\n" if $Verbose > 0;
safer_unlink($from);
return;
}
- warn "changed '$from' to '$to'\n";
+ warn "changed '$from' to '$to'\n" if $Verbose > 0;
+ push @Changed, $to unless $Verbose < 0;
safer_rename_silent($from, $to) or die "renaming $from to $to: $!";
}
diff --git a/t/mro/pkg_gen.t b/t/mro/pkg_gen.t
index 6a507ac24d..e1f5eb0e8a 100644
--- a/t/mro/pkg_gen.t
+++ b/t/mro/pkg_gen.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
chdir 't' if -d 't';
-require q(./test.pl); plan(tests => 6);
+require q(./test.pl); plan(tests => 7);
{
package Foo;
@@ -34,3 +34,7 @@ is(mro::get_pkg_gen('Foo'), 1, "pkg_gen 1 for undef %Pkg::");
delete $::{"Foo::"};
is(mro::get_pkg_gen('Foo'), 0, 'pkg_gen 0 for delete $::{Pkg::}');
+
+delete $::{"Quux::"};
+push @Quux::ISA, "Woot"; # should not segfault
+ok(1, "No segfault on modification of ISA in a deleted stash");
diff --git a/t/op/method.t b/t/op/method.t
index aaf29be8df..46c46426eb 100755
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -183,23 +183,23 @@ is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
# test error messages if method loading fails
-is(do { eval '$e = bless {}, "E::A"; E::A->foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E::A" at/ ? 1 : $@}, 1);
-is(do { eval '$e = bless {}, "E::B"; $e->foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1);
-is(do { eval 'E::C->foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1);
-
-is(do { eval 'UNIVERSAL->E::D::foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1);
-is(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E::E" (perhaps / ? 1 : $@}, 1);
+eval '$e = bless {}, "E::A"; E::A->foo()';
+like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/);
+eval '$e = bless {}, "E::B"; $e->foo()';
+like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/);
+eval 'E::C->foo()';
+like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /);
+
+eval 'UNIVERSAL->E::D::foo()';
+like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /);
+eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
+like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /);
$e = bless {}, "E::F"; # force package to exist
-is(do { eval 'UNIVERSAL->E::F::foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
-is(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
+eval 'UNIVERSAL->E::F::foo()';
+like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/);
+eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
+like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/);
# TODO: we need some tests for the SUPER:: pseudoclass
diff --git a/t/op/re_tests b/t/op/re_tests
index 23cc041587..3d1183820d 100644
--- a/t/op/re_tests
+++ b/t/op/re_tests
@@ -414,6 +414,7 @@ a[-]?c ac y $& ac
'(abc)\1'i ABCABC y $1 ABC
'([a-c]*)\1'i ABCABC y $1 ABC
a(?!b). abad y $& ad
+(?=)a a y $& a
a(?=d). abad y $& ad
a(?=c|d). abad y $& ad
a(?:b|c|d)(.) ace y $1 e
diff --git a/t/op/universal.t b/t/op/universal.t
index 9817d3fe68..83916ee5f5 100755
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -10,7 +10,7 @@ BEGIN {
require "./test.pl";
}
-plan tests => 111;
+plan tests => 112;
$a = {};
bless $a, "Bob";
@@ -228,3 +228,9 @@ package main;
eval { UNIVERSAL::DOES([], "foo") };
like( $@, qr/Can't call method "DOES" on unblessed reference/,
'DOES call error message says DOES, not isa' );
+
+# Tests for can seem to be split between here and method.t
+# Add the verbatim perl code mentioned in the comments of
+# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html
+# but never actually tested.
+is(UNIVERSAL->can("NoSuchPackage::foo"), undef);
View Lorry Controller Status