X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=481864b2c257e57a4d4f9f3ce8545fdd64086b5a;hb=b09a11114be6edce50b92b1c65da7aba898fd577;hp=66ca0fb50d23ce077172e11e05dbb12d9461605b;hpb=22f1178fc6ea7d78b2fce6108796ec629a70476b;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_sys.c b/pp_sys.c
index 66ca0fb..481864b 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -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);
@@ -762,8 +762,12 @@ PP(pp_binmode)
 
     PUTBACK;
     {
-	const int mode = mode_from_discipline(discp);
-	const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
+	STRLEN len = 0;
+	const char *d = NULL;
+	int mode;
+	if (discp)
+	    d = SvPV_const(discp, len);
+	mode = mode_from_discipline(d, len);
 	if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
 	    if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
 		if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
@@ -802,26 +806,29 @@ 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;
 	    break;
     }
     items = SP - MARK++;
-    if (sv_isobject(*MARK)) {
+    if (sv_isobject(*MARK)) { /* Calls GET magic. */
 	ENTER;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
@@ -835,10 +842,12 @@ PP(pp_tie)
 	/* Not clear why we don't call call_method here too.
 	 * perhaps to get different error message ?
 	 */
-	stash = gv_stashsv(*MARK, 0);
+	STRLEN len;
+	const char *name = SvPV_nomg_const(*MARK, len);
+	stash = gv_stashpvn(name, len, 0);
 	if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 	    DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
-		 methname, SVfARG(*MARK));
+		 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
 	}
 	ENTER;
 	PUSHSTACKi(PERLSI_MAGIC);
@@ -877,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))) {
@@ -915,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))) {
@@ -942,7 +951,7 @@ PP(pp_dbmopen)
 	PUTBACK;
 	require_pv("AnyDBM_File.pm");
 	SPAGAIN;
-	if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
+	if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
 	    DIE(aTHX_ "No dbm on this machine");
     }
 
@@ -1240,12 +1249,13 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
     register PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
 
+    PERL_ARGS_ASSERT_DOFORM;
+
     ENTER;
     SAVETMPS;
 
     PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
-    PUSHFORMAT(cx);
-    cx->blk_sub.retop = retop;
+    PUSHFORMAT(cx, retop);
     SAVECOMPPAD();
     PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
 
@@ -1305,7 +1315,7 @@ PP(pp_enterwrite)
 PP(pp_leavewrite)
 {
     dVAR; dSP;
-    GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
+    GV * const gv = cxstack[cxstack_ix].blk_format.gv;
     register IO * const io = GvIOp(gv);
     PerlIO *ofp;
     PerlIO *fp;
@@ -2188,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;
 	    }
@@ -2835,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;
@@ -2999,10 +3009,9 @@ PP(pp_ftrread)
 	effective = TRUE;
 	break;
 
-
     case OP_FTEEXEC:
 #ifdef PERL_EFF_ACCESS
-	access_mode = W_OK;
+	access_mode = X_OK;
 #else
 	use_access = 0;
 #endif
@@ -3395,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 {
@@ -3599,6 +3608,8 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename)
     int anum = 1;
     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
 
+    PERL_ARGS_ASSERT_DOONELINER;
+
     Newx(cmdline, size, char);
     my_strlcpy(cmdline, cmd, size);
     my_strlcat(cmdline, " ", size);
@@ -4163,14 +4174,14 @@ PP(pp_system)
     result = 0;
     if (PL_op->op_flags & OPf_STACKED) {
 	SV * const really = *++MARK;
-#  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
+#  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
 	value = (I32)do_aspawn(really, MARK, SP);
 #  else
 	value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
 #  endif
     }
     else if (SP - MARK != 1) {
-#  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
+#  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
 	value = (I32)do_aspawn(NULL, MARK, SP);
 #  else
 	value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
@@ -4606,6 +4617,8 @@ S_space_join_names_mortal(pTHX_ char *const *array)
 {
     SV *target;
 
+    PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
+
     if (array && *array) {
 	target = newSVpvs_flags("", SVs_TEMP);
 	while (1) {
@@ -4935,7 +4948,7 @@ PP(pp_snetent)
 {
 #ifdef HAS_SETNETENT
     dVAR; dSP;
-    PerlSock_setnetent(TOPi);
+    (void)PerlSock_setnetent(TOPi);
     RETSETYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "setnetent");
@@ -4946,7 +4959,7 @@ PP(pp_sprotoent)
 {
 #ifdef HAS_SETPROTOENT
     dVAR; dSP;
-    PerlSock_setprotoent(TOPi);
+    (void)PerlSock_setprotoent(TOPi);
     RETSETYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "setprotoent");
@@ -4957,7 +4970,7 @@ PP(pp_sservent)
 {
 #ifdef HAS_SETSERVENT
     dVAR; dSP;
-    PerlSock_setservent(TOPi);
+    (void)PerlSock_setservent(TOPi);
     RETSETYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "setservent");