X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/094a3eec8ad4cfb12d72a98f11e9186594579b57..b019ef6e0373869c85928ce041f76e06febe16cd:/doio.c

diff --git a/doio.c b/doio.c
index 6b5300c..fed1a49 100644
--- a/doio.c
+++ b/doio.c
@@ -126,8 +126,9 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
 	if (result == EOF && fd > PL_maxsysfd) {
 	    /* Why is this not Perl_warn*() call ? */
 	    PerlIO_printf(Perl_error_log,
-			  "Warning: unable to close filehandle %s properly.\n",
-			  GvENAME(gv));
+		"Warning: unable to close filehandle %"HEKf" properly.\n",
+		 HEKfARG(GvENAME_HEK(gv))
+	    );
 	}
 	IoOFP(io) = IoIFP(io) = NULL;
     }
@@ -148,7 +149,8 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
 	int ismodifying;
 
 	if (num_svs != 0) {
-	     Perl_croak(aTHX_ "panic: sysopen with multiple args");
+	    Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld",
+		       (long) num_svs);
 	}
 	/* It's not always
 
@@ -318,7 +320,10 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
 		    }
 		    while (isSPACE(*type))
 			type++;
-		    if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
+		    if (num_svs && (
+			     SvIOK(*svp)
+			  || (SvPOKp(*svp) && looks_like_number(*svp))
+		       )) {
 			fd = SvUV(*svp);
 			num_svs = 0;
 		    }
@@ -541,14 +546,16 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
 	if ((IoTYPE(io) == IoTYPE_RDONLY) &&
 	    (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
 		Perl_warner(aTHX_ packWARN(WARN_IO),
-			    "Filehandle STD%s reopened as %s only for input",
+			    "Filehandle STD%s reopened as %"HEKf
+			    " only for input",
 			    ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
-			    GvENAME(gv));
+			    HEKfARG(GvENAME_HEK(gv)));
 	}
 	else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
 		Perl_warner(aTHX_ packWARN(WARN_IO),
-			    "Filehandle STDIN reopened as %s only for output",
-			    GvENAME(gv));
+		    "Filehandle STDIN reopened as %"HEKf" only for output",
+		     HEKfARG(GvENAME_HEK(gv))
+		);
 	}
     }
 
@@ -1215,26 +1222,31 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 	U8 *tmpbuf = NULL;
 	bool happy = TRUE;
 
-	if (PerlIO_isutf8(fp)) {
-	    if (!SvUTF8(sv)) {
+	if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
+	    if (!SvUTF8(sv)) {	/* Convert to utf8 if necessary */
 		/* We don't modify the original scalar.  */
 		tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
 		tmps = (char *) tmpbuf;
 	    }
-	    else if (ckWARN_d(WARN_UTF8)) {
+	    else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
 		(void) check_utf8_print((const U8*) tmps, len);
 	    }
-	}
-	else if (DO_UTF8(sv)) {
+	} /* else stream isn't utf8 */
+	else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
+				   convert to bytes */
 	    STRLEN tmplen = len;
 	    bool utf8 = TRUE;
 	    U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
 	    if (!utf8) {
+
+		/* Here, succeeded in downgrading from utf8.  Set up to below
+		 * output the converted value */
 		tmpbuf = result;
 		tmps = (char *) tmpbuf;
 		len = tmplen;
 	    }
-	    else {
+	    else {  /* Non-utf8 output stream, but string only representable in
+		       utf8 */
 		assert((char *)result == tmps);
 		Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 				 "Wide character in %s",
@@ -1267,7 +1279,6 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
     GV* gv;
 
     if (PL_op->op_flags & OPf_REF) {
-	EXTEND(SP,1);
 	gv = cGVOP_gv;
       do_fstat:
         if (gv == PL_defgv)
@@ -1275,30 +1286,26 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
 	io = GvIO(gv);
         do_fstat_have_io:
         PL_laststype = OP_STAT;
-        PL_statgv = gv;
+        PL_statgv = gv ? gv : (GV *)io;
         sv_setpvs(PL_statname, "");
         if(io) {
 	    if (IoIFP(io)) {
 	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
-            } else {
-		report_evil_fh(gv);
-                return (PL_laststatval = -1);
             }
-	} else {
-	    report_evil_fh(gv);
-            return (PL_laststatval = -1);
         }
+	PL_laststatval = -1;
+	report_evil_fh(gv);
+	return -1;
     }
-    else if (PL_op->op_private & OPpFT_STACKED) {
+    else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
+	     == OPpFT_STACKED)
 	return PL_laststatval;
-    }
     else {
-	SV* const sv = POPs;
+	SV* const sv = TOPs;
 	const char *s;
 	STRLEN len;
-	PUTBACK;
 	if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
 	    goto do_fstat;
 	}
@@ -1327,35 +1334,31 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
     dVAR;
     static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat";
     dSP;
-    SV *sv;
     const char *file;
     if (PL_op->op_flags & OPf_REF) {
-	EXTEND(SP,1);
 	if (cGVOP_gv == PL_defgv) {
 	    if (PL_laststype != OP_LSTAT)
 		Perl_croak(aTHX_ no_prev_lstat);
 	    return PL_laststatval;
 	}
+	PL_laststatval = -1;
 	if (ckWARN(WARN_IO)) {
-	    Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
-		    GvENAME(cGVOP_gv));
+	    Perl_warner(aTHX_ packWARN(WARN_IO),
+		 	     "Use of -l on filehandle %"HEKf,
+			      HEKfARG(GvENAME_HEK(cGVOP_gv)));
 	}
-	return (PL_laststatval = -1);
+	return -1;
     }
-    else if (PL_laststype != OP_LSTAT
-	    && (PL_op->op_private & OPpFT_STACKED) && ckWARN(WARN_IO))
+    if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
+	     == OPpFT_STACKED) {
+      if (PL_laststype != OP_LSTAT)
 	Perl_croak(aTHX_ no_prev_lstat);
+      return PL_laststatval;
+    } 
 
     PL_laststype = OP_LSTAT;
     PL_statgv = NULL;
-    sv = POPs;
-    PUTBACK;
-    if (SvROK(sv) && isGV_with_GP(SvRV(sv)) && ckWARN(WARN_IO)) {
-	Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
-		GvENAME((const GV *)SvRV(sv)));
-	return (PL_laststatval = -1);
-    }
-    file = SvPV_flags_const_nolen(sv, flags);
+    file = SvPV_flags_const_nolen(TOPs, flags);
     sv_setpv(PL_statname,file);
     PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n'))
@@ -1562,6 +1565,10 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 
 #endif /* OS2 || WIN32 */
 
+#ifdef VMS
+#include <starlet.h> /* for sys$delprc */
+#endif
+
 I32
 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
 {
@@ -1570,6 +1577,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
     register I32 tot = 0;
     const char *const what = PL_op_name[type];
     const char *s;
+    STRLEN len;
     SV ** const oldmark = mark;
 
     PERL_ARGS_ASSERT_APPLY;
@@ -1680,12 +1688,14 @@ nothing in the core.
 	APPLY_TAINT_PROPER();
 	if (mark == sp)
 	    break;
-	s = SvPVx_nolen_const(*++mark);
+	s = SvPVx_const(*++mark, len);
 	if (isALPHA(*s)) {
-	    if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
+	    if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
 		s += 3;
-	    if ((val = whichsig(s)) < 0)
-		Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
+                len -= 3;
+            }
+           if ((val = whichsig_pvn(s, len)) < 0)
+               Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
 	}
 	else
 	    val = SvIV(*mark);
@@ -1695,7 +1705,6 @@ nothing in the core.
 	/* kill() doesn't do process groups (job trees?) under VMS */
 	if (val < 0) val = -val;
 	if (val == SIGKILL) {
-#	    include <starlet.h>
 	    /* Use native sys$delprc() to insure that target process is
 	     * deleted; supervisor-mode images don't pay attention to
 	     * CRTL's emulation of Unix-style signals and kill()
@@ -1765,7 +1774,7 @@ nothing in the core.
 	while (++mark <= sp) {
 	    s = SvPV_nolen_const(*mark);
 	    APPLY_TAINT_PROPER();
-	    if (PL_euid || PL_unsafe) {
+	    if (PerlProc_geteuid() || PL_unsafe) {
 		if (UNLINK(s))
 		    tot--;
 	    }
@@ -1825,9 +1834,7 @@ nothing in the core.
 	    tot = sp - mark;
 	    while (++mark <= sp) {
                 GV* gv;
-                if (isGV_with_GP(*mark)) {
-                    gv = MUTABLE_GV(*mark);
-		do_futimes:
+                if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FUTIMES
 			APPLY_TAINT_PROPER();
@@ -1842,12 +1849,8 @@ nothing in the core.
 			tot--;
 		    }
 		}
-		else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
-		    gv = MUTABLE_GV(SvRV(*mark));
-		    goto do_futimes;
-		}
 		else {
-		    const char * const name = SvPV_nolen_const(*mark);
+		    const char * const name = SvPV_nomg_const_nolen(*mark);
 		    APPLY_TAINT_PROPER();
 #ifdef HAS_FUTIMES
 		    if (utimes(name, (struct timeval *)utbufp))
@@ -1909,7 +1912,7 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp)
 # ifdef __CYGWIN__
     if (ingroup(544,effective)) {     /* member of Administrators */
 # else
-    if ((effective ? PL_euid : PL_uid) == 0) {	/* root is special */
+    if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) {	/* root is special */
 # endif
 	if (mode == S_IXUSR) {
 	    if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
@@ -1919,7 +1922,7 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp)
 	    return TRUE;		/* root reads and writes anything */
 	return FALSE;
     }
-    if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
+    if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
 	if (statbufp->st_mode & mode)
 	    return TRUE;	/* ok as "user" */
     }
@@ -1938,7 +1941,7 @@ static bool
 S_ingroup(pTHX_ Gid_t testgid, bool effective)
 {
     dVAR;
-    if (testgid == (effective ? PL_egid : PL_gid))
+    if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
 	return TRUE;
 #ifdef HAS_GETGROUPS
     {
@@ -2284,7 +2287,8 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
 	/* suppress warning when reading into undef var (tchrist 3/Mar/00) */
 	if (! SvOK(mstr))
 	    sv_setpvs(mstr, "");
-	SvPV_force_nolen(mstr);
+	SvUPGRADE(mstr, SVt_PV);
+	SvPOK_only(mstr);
 	mbuf = SvGROW(mstr, (STRLEN)msize+1);
 
 	Copy(shm + mpos, mbuf, msize, char);
@@ -2380,6 +2384,13 @@ Perl_vms_start_glob
 #endif
 #endif /* !CSH */
 #endif /* !DOSISH */
+    {
+	GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
+	SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
+	if (home && *home) SvGETMAGIC(*home);
+	save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
+	if (home && *home) SvSETMAGIC(*home);
+    }
     (void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd),
 		  FALSE, O_RDONLY, 0, NULL);
     fp = IoIFP(io);
@@ -2392,8 +2403,8 @@ Perl_vms_start_glob
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */