X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/eb06eac93f0120092363c6c7ba87bb7054e76844..85091ccc46b54ca843402c676923435ca5b88474:/doio.c

diff --git a/doio.c b/doio.c
index 2f660cc..022b499 100644
--- a/doio.c
+++ b/doio.c
@@ -861,10 +861,7 @@ Perl_nextargv(pTHX_ register GV *gv)
 #ifdef HAS_FCHMOD
 		(void)fchmod(PL_lastfd,PL_filemode);
 #else
-#  if !(defined(WIN32) && defined(__BORLANDC__))
-		/* Borland runtime creates a readonly file! */
 		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
-#  endif
 #endif
 		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
 #ifdef HAS_FCHOWN
@@ -929,8 +926,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
     io = GvIO(gv);
     if (!io) {		/* never opened */
 	if (not_implicit) {
-	    if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
-		report_evil_fh(gv, io, PL_op->op_type);
+	    report_evil_fh(gv);
 	    SETERRNO(EBADF,SS_IVCHAN);
 	}
 	return FALSE;
@@ -996,8 +992,8 @@ Perl_do_eof(pTHX_ GV *gv)
 
     if (!io)
 	return TRUE;
-    else if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
-	report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
+    else if (IoTYPE(io) == IoTYPE_WRONLY)
+	report_wrongway_fh(gv, '>');
 
     while (IoIFP(io)) {
         if (PerlIO_has_cntptr(IoIFP(io))) {	/* (the code works without this) */
@@ -1035,20 +1031,19 @@ Off_t
 Perl_do_tell(pTHX_ GV *gv)
 {
     dVAR;
-    register IO *io = NULL;
+    IO *const io = GvIO(gv);
     register PerlIO *fp;
 
     PERL_ARGS_ASSERT_DO_TELL;
 
-    if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
+    if (io && (fp = IoIFP(io))) {
 #ifdef ULTRIX_STDIO_BOTCH
 	if (PerlIO_eof(fp))
 	    (void)PerlIO_seek(fp, 0L, 2);	/* ultrix 1.2 workaround */
 #endif
 	return PerlIO_tell(fp);
     }
-    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
-	report_evil_fh(gv, io, PL_op->op_type);
+    report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
 }
@@ -1057,18 +1052,17 @@ bool
 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
 {
     dVAR;
-    register IO *io = NULL;
+    IO *const io = GvIO(gv);
     register PerlIO *fp;
 
-    if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
+    if (io && (fp = IoIFP(io))) {
 #ifdef ULTRIX_STDIO_BOTCH
 	if (PerlIO_eof(fp))
 	    (void)PerlIO_seek(fp, 0L, 2);	/* ultrix 1.2 workaround */
 #endif
 	return PerlIO_seek(fp, pos, whence) >= 0;
     }
-    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
-	report_evil_fh(gv, io, PL_op->op_type);
+    report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return FALSE;
 }
@@ -1077,15 +1071,14 @@ Off_t
 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 {
     dVAR;
-    register IO *io = NULL;
+    IO *const io = GvIO(gv);
     register PerlIO *fp;
 
     PERL_ARGS_ASSERT_DO_SYSSEEK;
 
-    if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
+    if (io && (fp = IoIFP(io)))
 	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
-    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
-	report_evil_fh(gv, io, PL_op->op_type);
+    report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
 }
@@ -1228,6 +1221,9 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 		tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
 		tmps = (char *) tmpbuf;
 	    }
+	    else if (ckWARN_d(WARN_UTF8)) {
+		(void) check_utf8_print((const U8*) tmps, len);
+	    }
 	}
 	else if (DO_UTF8(sv)) {
 	    STRLEN tmplen = len;
@@ -1241,7 +1237,12 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 	    else {
 		assert((char *)result == tmps);
 		Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
-				 "Wide character in %s", OP_DESC(PL_op));
+				 "Wide character in %s",
+				   PL_op ? OP_DESC(PL_op) : "print"
+				);
+		    /* Could also check that isn't one of the things to avoid
+		     * in utf8 by using check_utf8_print(), but not doing so,
+		     * since the stream isn't a UTF8 stream */
 	    }
 	}
 	/* To detect whether the process is about to overstep its
@@ -1282,13 +1283,11 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
             } else {
-                if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
-                    report_evil_fh(gv, io, PL_op->op_type);
+		report_evil_fh(gv);
                 return (PL_laststatval = -1);
             }
 	} else {
-            if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
-                report_evil_fh(gv, io, PL_op->op_type);
+	    report_evil_fh(gv);
             return (PL_laststatval = -1);
         }
     }
@@ -1300,12 +1299,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
 	const char *s;
 	STRLEN len;
 	PUTBACK;
-	if (isGV_with_GP(sv)) {
-	    gv = MUTABLE_GV(sv);
-	    goto do_fstat;
-	}
-	else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
-	    gv = MUTABLE_GV(SvRV(sv));
+	if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
 	    goto do_fstat;
 	}
         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
@@ -1345,22 +1339,19 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
 	if (ckWARN(WARN_IO)) {
 	    Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
 		    GvENAME(cGVOP_gv));
-	    return (PL_laststatval = -1);
 	}
+	return (PL_laststatval = -1);
     }
-    else if (PL_laststype != OP_LSTAT
-	    && (PL_op->op_private & OPpFT_STACKED) && ckWARN(WARN_IO))
+    else if (PL_op->op_private & 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);
     sv_setpv(PL_statname,file);
     PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
@@ -1617,9 +1608,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
 	    tot = sp - mark;
 	    while (++mark <= sp) {
                 GV* gv;
-                if (isGV_with_GP(*mark)) {
-                    gv = MUTABLE_GV(*mark);
-		do_fchmod:
+                if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHMOD
 			APPLY_TAINT_PROPER();
@@ -1633,12 +1622,8 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
 			tot--;
 		    }
 		}
-		else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
-		    gv = MUTABLE_GV(SvRV(*mark));
-		    goto do_fchmod;
-		}
 		else {
-		    const char *name = SvPV_nolen_const(*mark);
+		    const char *name = SvPV_nomg_const_nolen(*mark);
 		    APPLY_TAINT_PROPER();
 		    if (PerlLIO_chmod(name, val))
 			tot--;
@@ -1657,9 +1642,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
 	    tot = sp - mark;
 	    while (++mark <= sp) {
                 GV* gv;
-                if (isGV_with_GP(*mark)) {
-                    gv = MUTABLE_GV(*mark);
-		do_fchown:
+		if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHOWN
 			APPLY_TAINT_PROPER();
@@ -1673,12 +1656,8 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
 			tot--;
 		    }
 		}
-		else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
-		    gv = MUTABLE_GV(SvRV(*mark));
-		    goto do_fchown;
-		}
 		else {
-		    const char *name = SvPV_nolen_const(*mark);
+		    const char *name = SvPV_nomg_const_nolen(*mark);
 		    APPLY_TAINT_PROPER();
 		    if (PerlLIO_chown(name, val, val2))
 			tot--;
@@ -1843,9 +1822,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();
@@ -1860,12 +1837,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))
@@ -1903,7 +1876,7 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp)
     /* [Comments and code from Len Reed]
      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
      * to write-protected files.  The execute permission bit is set
-     * by the Miscrosoft C library stat() function for the following:
+     * by the Microsoft C library stat() function for the following:
      *		.exe files
      *		.com files
      *		.bat files
@@ -2302,7 +2275,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);
@@ -2398,6 +2372,7 @@ Perl_vms_start_glob
 #endif
 #endif /* !CSH */
 #endif /* !DOSISH */
+    save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
     (void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd),
 		  FALSE, O_RDONLY, 0, NULL);
     fp = IoIFP(io);