diff options
-rw-r--r-- | MANIFEST | 1 | ||||
-rw-r--r-- | doio.c | 20 | ||||
-rwxr-xr-x | ext/IO/t/io_taint.t | 13 | ||||
-rw-r--r-- | mg.c | 2 | ||||
-rw-r--r-- | pp.c | 21 | ||||
-rw-r--r-- | pp_ctl.c | 4 | ||||
-rw-r--r-- | pp_hot.c | 14 | ||||
-rw-r--r-- | pp_sys.c | 43 | ||||
-rw-r--r-- | sv.c | 37 | ||||
-rw-r--r-- | t/io/pvbm.t | 81 | ||||
-rw-r--r-- | t/op/attrs.t | 9 | ||||
-rwxr-xr-x | t/op/inc.t | 13 | ||||
-rw-r--r-- | t/op/inccode.t | 25 | ||||
-rwxr-xr-x | t/op/magic.t | 20 | ||||
-rwxr-xr-x | t/op/ref.t | 66 | ||||
-rwxr-xr-x | t/op/undef.t | 12 | ||||
-rw-r--r-- | xsutils.c | 6 |
17 files changed, 308 insertions, 79 deletions
@@ -3556,6 +3556,7 @@ t/io/openpid.t See if open works for subprocesses t/io/open.t See if open works t/io/pipe.t See if secure pipes work t/io/print.t See if print commands work +t/io/pvbm.t See if PVBMs break IO commands t/io/read.t See if read works t/io/say.t See if say works t/io/tell.t See if file seeking works @@ -926,7 +926,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) if (!gv) gv = PL_argvgv; - if (!gv || SvTYPE(gv) != SVt_PVGV) { + if (!gv || !isGV_with_GP(gv)) { if (not_implicit) SETERRNO(EBADF,SS_IVCHAN); return FALSE; @@ -1307,11 +1307,11 @@ Perl_my_stat(pTHX) const char *s; STRLEN len; PUTBACK; - if (SvTYPE(sv) == SVt_PVGV) { + if (isGV_with_GP(sv)) { gv = (GV*)sv; goto do_fstat; } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { gv = (GV*)SvRV(sv); goto do_fstat; } @@ -1363,7 +1363,7 @@ Perl_my_lstat(pTHX) PL_statgv = NULL; sv = POPs; PUTBACK; - if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV && ckWARN(WARN_IO)) { + if (SvROK(sv) && isGV_with_GP(SvRV(sv)) && ckWARN(WARN_IO)) { Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s", GvENAME((GV*) SvRV(sv))); return (PL_laststatval = -1); @@ -1624,7 +1624,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) tot = sp - mark; while (++mark <= sp) { GV* gv; - if (SvTYPE(*mark) == SVt_PVGV) { + if (isGV_with_GP(*mark)) { gv = (GV*)*mark; do_fchmod: if (GvIO(gv) && IoIFP(GvIOp(gv))) { @@ -1640,7 +1640,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) tot--; } } - else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) { + else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) { gv = (GV*)SvRV(*mark); goto do_fchmod; } @@ -1664,7 +1664,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) tot = sp - mark; while (++mark <= sp) { GV* gv; - if (SvTYPE(*mark) == SVt_PVGV) { + if (isGV_with_GP(*mark)) { gv = (GV*)*mark; do_fchown: if (GvIO(gv) && IoIFP(GvIOp(gv))) { @@ -1680,7 +1680,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) tot--; } } - else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) { + else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) { gv = (GV*)SvRV(*mark); goto do_fchown; } @@ -1836,7 +1836,7 @@ nothing in the core. tot = sp - mark; while (++mark <= sp) { GV* gv; - if (SvTYPE(*mark) == SVt_PVGV) { + if (isGV_with_GP(*mark)) { gv = (GV*)*mark; do_futimes: if (GvIO(gv) && IoIFP(GvIOp(gv))) { @@ -1853,7 +1853,7 @@ nothing in the core. tot--; } } - else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) { + else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) { gv = (GV*)SvRV(*mark); goto do_futimes; } diff --git a/ext/IO/t/io_taint.t b/ext/IO/t/io_taint.t index 4a9b76e84b..1cec9d7baf 100755 --- a/ext/IO/t/io_taint.t +++ b/ext/IO/t/io_taint.t @@ -18,7 +18,7 @@ BEGIN { END { unlink "./__taint__$$" } -print "1..3\n"; +print "1..5\n"; use IO::File; $x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n"); print $x "$$\n"; @@ -43,4 +43,15 @@ print "not " if ($@ =~ /^Insecure/o); print "ok 3\n"; # No Insecure message from using the data $x->close; +# this will segfault if it fails + +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +eval { IO::Handle::untaint(PVBM) }; +print "ok 4\n"; + +eval { IO::Handle::untaint(\PVBM) }; +print "ok 5\n"; + exit 0; @@ -1497,7 +1497,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) PL_psig_name[i] = newSVpvn(s, len); SvREADONLY_on(PL_psig_name[i]); } - if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { + if (isGV_with_GP(sv) || SvROK(sv)) { if (i) { (void)rsignal(i, PL_csighandlerp); #ifdef HAS_SIGPROCMASK @@ -143,11 +143,11 @@ PP(pp_rv2gv) SvREFCNT_inc_void_NN(sv); sv = (SV*) gv; } - else if (SvTYPE(sv) != SVt_PVGV) + else if (!isGV_with_GP(sv)) DIE(aTHX_ "Not a GLOB reference"); } else { - if (SvTYPE(sv) != SVt_PVGV) { + if (!isGV_with_GP(sv)) { if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -285,7 +285,7 @@ PP(pp_rv2sv) else { gv = (GV*)sv; - if (SvTYPE(gv) != SVt_PVGV) { + if (!isGV_with_GP(gv)) { if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -822,9 +822,11 @@ PP(pp_undef) } break; case SVt_PVGV: - if (SvFAKE(sv)) + if (SvFAKE(sv)) { SvSetMagicSV(sv, &PL_sv_undef); - else { + break; + } + else if (isGV_with_GP(sv)) { GP *gp; HV *stash; @@ -842,8 +844,9 @@ PP(pp_undef) GvLINE(sv) = CopLINE(PL_curcop); GvEGV(sv) = (GV*)sv; GvMULTI_on(sv); + break; } - break; + /* FALL THROUGH */ default: if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) { SvPV_free(sv); @@ -860,7 +863,7 @@ PP(pp_undef) PP(pp_predec) { dVAR; dSP; - if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) DIE(aTHX_ PL_no_modify); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -877,7 +880,7 @@ PP(pp_predec) PP(pp_postinc) { dVAR; dSP; dTARGET; - if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) @@ -899,7 +902,7 @@ PP(pp_postinc) PP(pp_postdec) { dVAR; dSP; dTARGET; - if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) @@ -3353,11 +3353,11 @@ PP(pp_require) } } - if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { + if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { arg = SvRV(arg); } - if (SvTYPE(arg) == SVt_PVGV) { + if (isGV_with_GP(arg)) { IO * const io = GvIO((GV *)arg); ++filter_has_file; @@ -307,8 +307,8 @@ PP(pp_readline) dVAR; tryAMAGICunTARGET(iter, 0); PL_last_in_gv = (GV*)(*PL_stack_sp--); - if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { - if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) + if (!isGV_with_GP(PL_last_in_gv)) { + if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); else { dSP; @@ -397,7 +397,7 @@ PP(pp_eq) PP(pp_preinc) { dVAR; dSP; - if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) DIE(aTHX_ PL_no_modify); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -843,7 +843,7 @@ PP(pp_rv2av) else { GV *gv; - if (SvTYPE(sv) != SVt_PVGV) { + if (!isGV_with_GP(sv)) { if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -2665,6 +2665,8 @@ PP(pp_entersub) switch (SvTYPE(sv)) { /* This is overwhelming the most common case: */ case SVt_PVGV: + if (!isGV_with_GP(sv)) + DIE(aTHX_ "Not a CODE reference"); if (!(cv = GvCVu((GV*)sv))) { HV *stash; cv = sv_2cv(sv, &stash, &gv, 0); @@ -3074,7 +3076,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) /* if we got here, ob should be a reference or a glob */ if (!ob || !(SvOBJECT(ob) - || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) + || (SvTYPE(ob) == SVt_PVGV + && isGV_with_GP(ob) + && (ob = (SV*)GvIO((GV*)ob)) && SvOBJECT(ob)))) { Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", @@ -607,7 +607,7 @@ PP(pp_pipe_op) if (!rgv || !wgv) goto badexit; - if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV) + if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv)) DIE(aTHX_ PL_no_usym, "filehandle"); rstio = GvIOn(rgv); wstio = GvIOn(wgv); @@ -806,19 +806,22 @@ PP(pp_tie) methname = "TIEARRAY"; break; case SVt_PVGV: + if (isGV_with_GP(varsv)) { #ifdef GV_UNIQUE_CHECK - if (GvUNIQUE((GV*)varsv)) { - Perl_croak(aTHX_ "Attempt to tie unique GV"); - } + if (GvUNIQUE((GV*)varsv)) { + Perl_croak(aTHX_ "Attempt to tie unique GV"); + } #endif - methname = "TIEHANDLE"; - how = PERL_MAGIC_tiedscalar; - /* For tied filehandles, we apply tiedscalar magic to the IO - slot of the GP rather than the GV itself. AMS 20010812 */ - if (!GvIOp(varsv)) - GvIOp(varsv) = newIO(); - varsv = (SV *)GvIOp(varsv); - break; + methname = "TIEHANDLE"; + how = PERL_MAGIC_tiedscalar; + /* For tied filehandles, we apply tiedscalar magic to the IO + slot of the GP rather than the GV itself. AMS 20010812 */ + if (!GvIOp(varsv)) + GvIOp(varsv) = newIO(); + varsv = (SV *)GvIOp(varsv); + break; + } + /* FALL THROUGH */ default: methname = "TIESCALAR"; how = PERL_MAGIC_tiedscalar; @@ -883,7 +886,7 @@ PP(pp_untie) const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; - if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) + if (isGV_with_GP(sv) && !(sv = (SV *)GvIOp(sv))) RETPUSHYES; if ((mg = SvTIED_mg(sv, how))) { @@ -921,7 +924,7 @@ PP(pp_tied) const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; - if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) + if (isGV_with_GP(sv) && !(sv = (SV *)GvIOp(sv))) RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { @@ -2195,11 +2198,11 @@ PP(pp_truncate) SV * const sv = POPs; const char *name; - if (SvTYPE(sv) == SVt_PVGV) { + if (isGV_with_GP(sv)) { tmpgv = (GV*)sv; /* *main::FRED for example */ goto do_ftruncate_gv; } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */ goto do_ftruncate_gv; } @@ -2842,10 +2845,10 @@ PP(pp_stat) } else { SV* const sv = POPs; - if (SvTYPE(sv) == SVt_PVGV) { + if (isGV_with_GP(sv)) { gv = (GV*)sv; goto do_fstat; - } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) { gv = (GV*)SvRV(sv); if (PL_op->op_type == OP_LSTAT) goto do_fstat_warning_check; @@ -3401,10 +3404,10 @@ PP(pp_chdir) if (PL_op->op_flags & OPf_SPECIAL) { gv = gv_fetchsv(sv, 0, SVt_PVIO); } - else if (SvTYPE(sv) == SVt_PVGV) { + else if (isGV_with_GP(sv)) { gv = (GV*)sv; } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { gv = (GV*)SvRV(sv); } else { @@ -1543,6 +1543,8 @@ Perl_sv_setiv(pTHX_ register SV *const sv, const IV i) break; case SVt_PVGV: + if (!isGV_with_GP(sv)) + break; case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1650,6 +1652,8 @@ Perl_sv_setnv(pTHX_ register SV *const sv, const NV num) break; case SVt_PVGV: + if (!isGV_with_GP(sv)) + break; case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -7818,11 +7822,14 @@ Perl_sv_2io(pTHX_ SV *const sv) io = (IO*)sv; break; case SVt_PVGV: - gv = (GV*)sv; - io = GvIO(gv); - if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); - break; + if (isGV_with_GP(sv)) { + gv = (GV*)sv; + io = GvIO(gv); + if (!io) + Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); + break; + } + /* FALL THROUGH */ default: if (!SvOK(sv)) Perl_croak(aTHX_ PL_no_usym, "filehandle"); @@ -7875,10 +7882,13 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) *gvp = NULL; return NULL; case SVt_PVGV: - gv = (GV*)sv; - *gvp = gv; - *st = GvESTASH(gv); - goto fix_gv; + if (isGV_with_GP(sv)) { + gv = (GV*)sv; + *gvp = gv; + *st = GvESTASH(gv); + goto fix_gv; + } + /* FALL THROUGH */ default: if (SvROK(sv)) { @@ -7893,12 +7903,12 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) *st = CvSTASH(cv); return cv; } - else if(isGV(sv)) + else if(isGV_with_GP(sv)) gv = (GV*)sv; else Perl_croak(aTHX_ "Not a subroutine reference"); } - else if (isGV(sv)) { + else if (isGV_with_GP(sv)) { SvGETMAGIC(sv); gv = (GV*)sv; } @@ -7910,7 +7920,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) return NULL; } /* Some flags to gv_fetchsv mean don't really create the GV */ - if (SvTYPE(gv) != SVt_PVGV) { + if (!isGV_with_GP(gv)) { *st = NULL; return NULL; } @@ -8125,7 +8135,8 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; - case SVt_PVGV: return "GLOB"; + case SVt_PVGV: return (char *) (isGV_with_GP(sv) + ? "GLOB" : "SCALAR"); case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; case SVt_BIND: return "BIND"; diff --git a/t/io/pvbm.t b/t/io/pvbm.t new file mode 100644 index 0000000000..6c97edf4e3 --- /dev/null +++ b/t/io/pvbm.t @@ -0,0 +1,81 @@ +#!./perl + +# Test that various IO functions don't try to treat PVBMs as +# filehandles. Most of these will segfault perl if they fail. + +BEGIN { + chdir 't' if -d 't'; + @INC = qw(. ../lib); + require "./test.pl"; +} + +BEGIN { $| = 1 } + +plan(28); + +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +{ + my $which; + { + package Tie; + + sub TIEHANDLE { $which = 'TIEHANDLE' } + sub TIESCALAR { $which = 'TIESCALAR' } + } + my $pvbm = PVBM; + + tie $pvbm, 'Tie'; + is ($which, 'TIESCALAR', 'PVBM gets TIESCALAR'); +} + +{ + my $pvbm = PVBM; + ok (scalar eval { untie $pvbm; 1 }, 'untie(PVBM) doesn\'t segfault'); + ok (scalar eval { tied $pvbm; 1 }, 'tied(PVBM) doesn\'t segfault'); +} + +{ + my $pvbm = PVBM; + + ok (scalar eval { pipe $pvbm, PIPE; }, 'pipe(PVBM, ) succeeds'); + close foo; + close PIPE; + ok (scalar eval { pipe PIPE, $pvbm; }, 'pipe(, PVBM) succeeds'); + close foo; + close PIPE; + ok (!eval { pipe \$pvbm, PIPE; }, 'pipe(PVBM ref, ) fails'); + ok (!eval { pipe PIPE, \$pvbm; }, 'pipe(, PVBM ref) fails'); + + ok (!eval { truncate $pvbm, 0 }, 'truncate(PVBM) fails'); + ok (!eval { truncate \$pvbm, 0}, 'truncate(PVBM ref) fails'); + + ok (!eval { stat $pvbm }, 'stat(PVBM) fails'); + ok (!eval { stat \$pvbm }, 'stat(PVBM ref) fails'); + + ok (!eval { lstat $pvbm }, 'lstat(PVBM) fails'); + ok (!eval { lstat \$pvbm }, 'lstat(PVBM ref) fails'); + + ok (!eval { chdir $pvbm }, 'chdir(PVBM) fails'); + ok (!eval { chdir \$pvbm }, 'chdir(pvbm ref) fails'); + + ok (!eval { close $pvbm }, 'close(PVBM) fails'); + ok (!eval { close $pvbm }, 'close(PVBM ref) fails'); + + ok (!eval { chmod 0600, $pvbm }, 'chmod(PVBM) fails'); + ok (!eval { chmod 0600, \$pvbm }, 'chmod(PVBM ref) fails'); + + ok (!eval { chown 0, 0, $pvbm }, 'chown(PVBM) fails'); + ok (!eval { chown 0, 0, \$pvbm }, 'chown(PVBM ref) fails'); + + ok (!eval { utime 0, 0, $pvbm }, 'utime(PVBM) fails'); + ok (!eval { utime 0, 0, \$pvbm }, 'utime(PVBM ref) fails'); + + ok (!eval { <$pvbm> }, '<PVBM> fails'); + ok (!eval { readline $pvbm }, 'readline(PVBM) fails'); + ok (!eval { readline \$pvbm }, 'readline(PVBM ref) fails'); + + ok (!eval { open $pvbm, '<', 'none.such' }, 'open(PVBM) fails'); + ok (!eval { open \$pvbm, '<', 'none.such', }, 'open(PVBM ref) fails'); +} diff --git a/t/op/attrs.t b/t/op/attrs.t index 04e4517520..a27b61e580 100644 --- a/t/op/attrs.t +++ b/t/op/attrs.t @@ -10,7 +10,7 @@ BEGIN { require './test.pl'; } -plan 'no_plan'; +plan 90; $SIG{__WARN__} = sub { die @_ }; @@ -185,3 +185,10 @@ foreach my $value (\&foo, \$scalar, \@array, \%hash) { } } } + +# this will segfault if it fails +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +ok !defined(attributes::get(\PVBM)), + 'PVBMs don\'t segfault attributes::get'; diff --git a/t/op/inc.t b/t/op/inc.t index f722336d5b..99123c79d6 100755 --- a/t/op/inc.t +++ b/t/op/inc.t @@ -2,7 +2,7 @@ # use strict; -print "1..50\n"; +print "1..54\n"; my $test = 1; @@ -270,3 +270,14 @@ for my $n (47..113) { last; } die "Could not find a value which overflows the mantissa" unless $found; + +# these will segfault if they fail + +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +ok (scalar eval { my $pvbm = PVBM; $pvbm++ }); +ok (scalar eval { my $pvbm = PVBM; $pvbm-- }); +ok (scalar eval { my $pvbm = PVBM; ++$pvbm }); +ok (scalar eval { my $pvbm = PVBM; --$pvbm }); + diff --git a/t/op/inccode.t b/t/op/inccode.t index 9457226b59..45022fff6d 100644 --- a/t/op/inccode.t +++ b/t/op/inccode.t @@ -23,7 +23,7 @@ use strict; use File::Spec; require "test.pl"; -plan(tests => 45 + !$minitest * (3 + 14 * $can_fork)); +plan(tests => 49 + !$minitest * (3 + 14 * $can_fork)); my @tempfiles = (); @@ -211,6 +211,29 @@ is( $ret, 'abc', 'do "abc.pl" sees return value' ); @INC = @old_INC; } +# this will segfault if it fails + +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +# I don't know whether these requires should succeed or fail. 5.8 failed +# all of them; 5.10 with an ordinary constant in place of PVBM lets the +# latter two succeed. For now I don't care, as long as they don't +# segfault :). + +unshift @INC, sub { PVBM }; +eval 'require foo'; +ok( 1, 'returning PVBM doesn\'t segfault require' ); +eval 'use foo'; +ok( 1, 'returning PVBM doesn\'t segfault use' ); +shift @INC; +unshift @INC, sub { \PVBM }; +eval 'require foo'; +ok( 1, 'returning PVBM ref doesn\'t segfault require' ); +eval 'use foo'; +ok( 1, 'returning PVBM ref doesn\'t segfault use' ); +shift @INC; + exit if $minitest; SKIP: { diff --git a/t/op/magic.t b/t/op/magic.t index 799c7178ac..d852e834f0 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -36,7 +36,7 @@ sub skip { return 1; } -print "1..58\n"; +print "1..59\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; @@ -131,7 +131,23 @@ END my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : ''); print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n"; - $test += 4; + open(CMDPIPE, "| $PERL"); + print CMDPIPE <<'END'; + + sub PVBM () { 'foo' } + index 'foo', PVBM; + my $pvbm = PVBM; + + sub foo { exit 0 } + + $SIG{"INT"} = $pvbm; + kill "INT", $$; sleep 1; +END + close CMDPIPE; + $? >>= 8 if $^O eq 'VMS'; + print $? ? "not ok 7\n" : "ok 7\n"; + + $test += 5; } # can we slice ENV? diff --git a/t/op/ref.t b/t/op/ref.t index 3fdc833388..e3d66dc1c2 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -8,7 +8,7 @@ BEGIN { require 'test.pl'; use strict qw(refs subs); -plan(138); +plan(182); # Test glob operations. @@ -54,11 +54,6 @@ $BAR = \$BAZ; $BAZ = "hit"; is ($$$FOO, 'hit'); -# test that ref(vstring) makes sense -my $vstref = \v1; -is (ref($vstref), "VSTRING", "ref(vstr) eq VSTRING"); -like ( $vstref, qr/VSTRING\(0x[0-9a-f]+\)/, '\vstr is also VSTRING'); - # Test references to real arrays. my $test = curr_test(); @@ -131,9 +126,49 @@ sub mysub2 { lc shift } # Test the ref operator. -is (ref $subref, 'CODE'); -is (ref $ref, 'ARRAY'); -is (ref $refref, 'HASH'); +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +my $pviv = 1; "$pviv"; +my $pvnv = 1.0; "$pvnv"; +my $x; + +# we don't test +# tied lvalue => SCALAR, as we haven't tested tie yet +# BIND, 'cos we can't create them yet +# REGEXP, 'cos that requires overload or Scalar::Util +# LVALUE ref, 'cos I can't work out how to create one :) + +for ( + [ 'undef', SCALAR => \undef ], + [ 'constant IV', SCALAR => \1 ], + [ 'constant NV', SCALAR => \1.0 ], + [ 'constant PV', SCALAR => \'f' ], + [ 'scalar', SCALAR => \$x ], + [ 'PVIV', SCALAR => \$pviv ], + [ 'PVNV', SCALAR => \$pvnv ], + [ 'PVMG', SCALAR => \$0 ], + [ 'PVBM', SCALAR => \PVBM ], + [ 'vstring', VSTRING => \v1 ], + [ 'ref', REF => \\1 ], + [ 'lvalue', LVALUE => \substr($x, 0, 0) ], + [ 'named array', ARRAY => \@ary ], + [ 'anon array', ARRAY => [ 1 ] ], + [ 'named hash', HASH => \%whatever ], + [ 'anon hash', HASH => { a => 1 } ], + [ 'named sub', CODE => \&mysub, ], + [ 'anon sub', CODE => sub { 1; } ], + [ 'glob', GLOB => \*foo ], + [ 'format', FORMAT => *STDERR{FORMAT} ], +) { + my ($desc, $type, $ref) = @$_; + is (ref $ref, $type, "ref() for ref to $desc"); + like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc"); +} + +is (ref *STDOUT{IO}, 'IO::Handle', 'IO refs are blessed into IO::Handle'); +like (*STDOUT{IO}, qr/^IO::Handle=IO\(0x[0-9a-f]+\)$/, + 'stringify for IO refs'); # Test anonymous hash syntax. @@ -536,6 +571,19 @@ is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly"); } +# these will segfault if they fail + +my $pvbm = PVBM; +my $rpvbm = \$pvbm; + +ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref'); +ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref'); +ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref'); +ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref'); +ok (!eval { %$pvbm }, 'PVBM is not a HASH ref'); +ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref'); +ok (!eval { $rpvbm->foo }, 'PVBM is not an object'); + # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. $test = curr_test(); curr_test($test + 3); diff --git a/t/op/undef.t b/t/op/undef.t index 04cac52fd6..2262e755ce 100755 --- a/t/op/undef.t +++ b/t/op/undef.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..36\n"; +print "1..37\n"; print defined($a) ? "not ok 1\n" : "ok 1\n"; @@ -102,3 +102,13 @@ sub X::DESTROY { print "not " if each %hash; print "ok $test\n"; $test++; print "not " if defined delete $hash{'key2'}; print "ok $test\n"; $test++; } + +# this will segfault if it fails + +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +my $pvbm = PVBM; +undef $pvbm; +print 'not ' if defined $pvbm; +print "ok $test\n"; $test++; @@ -120,7 +120,7 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) break; case 'e': if (memEQ(name, "uniqu", 5)) { - if (SvTYPE(sv) == SVt_PVGV) { + if (isGV_with_GP(sv)) { if (negated) { GvUNIQUE_off(sv); } else { @@ -216,7 +216,7 @@ usage: XPUSHs(newSVpvs_flags("unique", SVs_TEMP)); break; case SVt_PVGV: - if (GvUNIQUE(sv)) + if (isGV_with_GP(sv) && GvUNIQUE(sv)) XPUSHs(newSVpvs_flags("unique", SVs_TEMP)); break; default: @@ -260,7 +260,7 @@ usage: stash = CvSTASH(sv); break; case SVt_PVGV: - if (GvGP(sv) && GvESTASH((GV*)sv)) + if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH((GV*)sv)) stash = GvESTASH((GV*)sv); break; default: |