X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=c7c6455dcd08c9ffb29f5fe7c5ab212433ad1177;hb=3937c24e3f4ed26beafd7a2fbe3a20466bfc2b2d;hp=1d852d3c086c4cad162c14c1c77d3f5d338ff1d9;hpb=b28d0864af067162e2d26cc66b6b8acb6d3cddc8;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/doio.c b/doio.c
index 1d852d3..c7c6455 100644
--- a/doio.c
+++ b/doio.c
@@ -125,22 +125,42 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
     }
 
     if (as_raw) {
-	result = rawmode & 3;
-	IoTYPE(io) = "<>++"[result];
+#if defined(O_LARGEFILE)
+	rawmode |= O_LARGEFILE;
+#endif
+
+#ifndef O_ACCMODE
+#define O_ACCMODE 3		/* Assume traditional implementation */
+#endif
+
+	switch (result = rawmode & O_ACCMODE) {
+	case O_RDONLY:
+	     IoTYPE(io) = '<';
+	     break;
+	case O_WRONLY:
+	     IoTYPE(io) = '>';
+	     break;
+	case O_RDWR:
+	default:
+	     IoTYPE(io) = '+';
+	     break;
+	}
+
 	writing = (result > 0);
 	fd = PerlLIO_open3(name, rawmode, rawperm);
+
 	if (fd == -1)
 	    fp = NULL;
 	else {
 	    char *fpmode;
-	    if (result == 0)
+	    if (result == O_RDONLY)
 		fpmode = "r";
 #ifdef O_APPEND
 	    else if (rawmode & O_APPEND)
-		fpmode = (result == 1) ? "a" : "a+";
+		fpmode = (result == O_WRONLY) ? "a" : "a+";
 #endif
 	    else
-		fpmode = (result == 1) ? "w" : "r+";
+		fpmode = (result == O_WRONLY) ? "w" : "r+";
 	    fp = PerlIO_fdopen(fd, fpmode);
 	    if (!fp)
 		PerlLIO_close(fd);
@@ -172,9 +192,10 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
 		TAINT_ENV();
 	    TAINT_PROPER("piped open");
 	    if (name[strlen(name)-1] == '|') {
+		dTHR;
 		name[strlen(name)-1] = '\0' ;
-		if (PL_dowarn)
-		    warn("Can't do bidirectional pipe");
+		if (ckWARN(WARN_PIPE))
+		    warner(WARN_PIPE, "Can't do bidirectional pipe");
 	    }
 	    fp = PerlProc_popen(name,"w");
 	    writing = 1;
@@ -283,8 +304,9 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
 	}
     }
     if (!fp) {
-	if (PL_dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
-	    warn(warn_nl, "open");
+	dTHR;
+	if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n'))
+	    warner(WARN_NEWLINE, PL_warn_nl, "open");
 	goto say_false;
     }
     if (IoTYPE(io) &&
@@ -344,8 +366,12 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
 	PerlIO_clearerr(fp);
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fd = PerlIO_fileno(fp);
-    fcntl(fd,F_SETFD,fd > PL_maxsysfd);
+    {
+	int save_errno = errno;
+	fd = PerlIO_fileno(fp);
+	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+	errno = save_errno;
+    }
 #endif
     IoIFP(io) = fp;
     if (writing) {
@@ -400,7 +426,7 @@ nextargv(register GV *gv)
 	sv_setsv(GvSV(gv),sv);
 	SvSETMAGIC(GvSV(gv));
 	PL_oldname = SvPVx(GvSV(gv), oldlen);
-	if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,0,0,Nullfp)) {
+	if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
 	    if (PL_inplace) {
 		TAINT_PROPER("inplace open");
 		if (oldlen == 1 && *PL_oldname == '-') {
@@ -462,7 +488,7 @@ nextargv(register GV *gv)
 		    do_close(gv,FALSE);
 		    (void)PerlLIO_unlink(SvPVX(sv));
 		    (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
-		    do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,0,0,Nullfp);
+		    do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
 #endif /* DOSISH */
 #else
 		    (void)UNLINK(SvPVX(sv));
@@ -493,8 +519,13 @@ nextargv(register GV *gv)
 		sv_setpvn(sv,">",!PL_inplace);
 		sv_catpvn(sv,PL_oldname,oldlen);
 		SETERRNO(0,0);		/* in case sprintf set errno */
+#ifdef VMS
+		if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
+                 O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) { 
+#else
 		if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
 			     O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
+#endif
 		    warn("Can't do inplace edit on %s: %s",
 		      PL_oldname, Strerror(errno) );
 		    do_close(gv,FALSE);
@@ -525,7 +556,7 @@ nextargv(register GV *gv)
 	}
 	else
 	    PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
-	      SvPV(sv, PL_na), Strerror(errno));
+	      SvPV(sv, oldlen), Strerror(errno));
     }
     if (PL_inplace) {
 	(void)do_close(PL_argvoutgv,FALSE);
@@ -596,8 +627,10 @@ do_close(GV *gv, bool not_implicit)
     io = GvIO(gv);
     if (!io) {		/* never opened */
 	if (not_implicit) {
-	    if (PL_dowarn)
-		warn("Close on unopened file <%s>",GvENAME(gv));
+	    dTHR;
+	    if (ckWARN(WARN_UNOPENED))
+		warner(WARN_UNOPENED, 
+		       "Close on unopened file <%s>",GvENAME(gv));
 	    SETERRNO(EBADF,SS$_IVCHAN);
 	}
 	return FALSE;
@@ -681,7 +714,7 @@ do_eof(GV *gv)
     return TRUE;
 }
 
-long
+Off_t
 do_tell(GV *gv)
 {
     register IO *io;
@@ -694,14 +727,17 @@ do_tell(GV *gv)
 #endif
 	return PerlIO_tell(fp);
     }
-    if (PL_dowarn)
-	warn("tell() on unopened file");
+    {
+	dTHR;
+	if (ckWARN(WARN_UNOPENED))
+	    warner(WARN_UNOPENED, "tell() on unopened file");
+    }
     SETERRNO(EBADF,RMS$_IFI);
-    return -1L;
+    return (Off_t)-1;
 }
 
 bool
-do_seek(GV *gv, long int pos, int whence)
+do_seek(GV *gv, Off_t pos, int whence)
 {
     register IO *io;
     register PerlIO *fp;
@@ -713,22 +749,28 @@ do_seek(GV *gv, long int pos, int whence)
 #endif
 	return PerlIO_seek(fp, pos, whence) >= 0;
     }
-    if (PL_dowarn)
-	warn("seek() on unopened file");
+    {
+	dTHR;
+	if (ckWARN(WARN_UNOPENED))
+	    warner(WARN_UNOPENED, "seek() on unopened file");
+    }
     SETERRNO(EBADF,RMS$_IFI);
     return FALSE;
 }
 
-long
-do_sysseek(GV *gv, long int pos, int whence)
+Off_t
+do_sysseek(GV *gv, Off_t pos, int whence)
 {
     register IO *io;
     register PerlIO *fp;
 
     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
 	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
-    if (PL_dowarn)
-	warn("sysseek() on unopened file");
+    {
+	dTHR;
+	if (ckWARN(WARN_UNOPENED))
+	    warner(WARN_UNOPENED, "sysseek() on unopened file");
+    }
     SETERRNO(EBADF,RMS$_IFI);
     return -1L;
 }
@@ -848,8 +890,11 @@ do_print(register SV *sv, PerlIO *fp)
     }
     switch (SvTYPE(sv)) {
     case SVt_NULL:
-	if (PL_dowarn)
-	    warn(warn_uninit);
+	{
+	    dTHR;
+	    if (ckWARN(WARN_UNINITIALIZED))
+		warner(WARN_UNINITIALIZED, PL_warn_uninit);
+	}
 	return TRUE;
     case SVt_IV:
 	if (SvIOK(sv)) {
@@ -889,8 +934,8 @@ my_stat(ARGSproto)
 	else {
 	    if (tmpgv == PL_defgv)
 		return PL_laststatval;
-	    if (PL_dowarn)
-		warn("Stat on unopened file <%s>",
+	    if (ckWARN(WARN_UNOPENED))
+		warner(WARN_UNOPENED, "Stat on unopened file <%s>",
 		  GvENAME(tmpgv));
 	    PL_statgv = Nullgv;
 	    sv_setpv(PL_statname,"");
@@ -900,6 +945,7 @@ my_stat(ARGSproto)
     else {
 	SV* sv = POPs;
 	char *s;
+	STRLEN n_a;
 	PUTBACK;
 	if (SvTYPE(sv) == SVt_PVGV) {
 	    tmpgv = (GV*)sv;
@@ -910,13 +956,13 @@ my_stat(ARGSproto)
 	    goto do_fstat;
 	}
 
-	s = SvPV(sv, PL_na);
+	s = SvPV(sv, n_a);
 	PL_statgv = Nullgv;
 	sv_setpv(PL_statname, s);
 	PL_laststype = OP_STAT;
 	PL_laststatval = PerlLIO_stat(s, &PL_statcache);
-	if (PL_laststatval < 0 && PL_dowarn && strchr(s, '\n'))
-	    warn(warn_nl, "stat");
+	if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
+	    warner(WARN_NEWLINE, PL_warn_nl, "stat");
 	return PL_laststatval;
     }
 }
@@ -926,6 +972,7 @@ my_lstat(ARGSproto)
 {
     djSP;
     SV *sv;
+    STRLEN n_a;
     if (PL_op->op_flags & OPf_REF) {
 	EXTEND(SP,1);
 	if (cGVOP->op_gv == PL_defgv) {
@@ -940,14 +987,14 @@ my_lstat(ARGSproto)
     PL_statgv = Nullgv;
     sv = POPs;
     PUTBACK;
-    sv_setpv(PL_statname,SvPV(sv, PL_na));
+    sv_setpv(PL_statname,SvPV(sv, n_a));
 #ifdef HAS_LSTAT
-    PL_laststatval = PerlLIO_lstat(SvPV(sv, PL_na),&PL_statcache);
+    PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
 #else
-    PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache);
+    PL_laststatval = PerlLIO_stat(SvPV(sv, n_a),&PL_statcache);
 #endif
-    if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
-	warn(warn_nl, "lstat");
+    if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
+	warner(WARN_NEWLINE, PL_warn_nl, "lstat");
     return PL_laststatval;
 }
 
@@ -956,6 +1003,7 @@ do_aexec(SV *really, register SV **mark, register SV **sp)
 {
     register char **a;
     char *tmps;
+    STRLEN n_a;
 
     if (sp > mark) {
 	dTHR;
@@ -963,19 +1011,20 @@ do_aexec(SV *really, register SV **mark, register SV **sp)
 	a = PL_Argv;
 	while (++mark <= sp) {
 	    if (*mark)
-		*a++ = SvPVx(*mark, PL_na);
+		*a++ = SvPVx(*mark, n_a);
 	    else
 		*a++ = "";
 	}
 	*a = Nullch;
 	if (*PL_Argv[0] != '/')	/* will execvp use PATH? */
 	    TAINT_ENV();		/* testing IFS here is overkill, probably */
-	if (really && *(tmps = SvPV(really, PL_na)))
+	if (really && *(tmps = SvPV(really, n_a)))
 	    PerlProc_execvp(tmps,PL_Argv);
 	else
 	    PerlProc_execvp(PL_Argv[0],PL_Argv);
-	if (PL_dowarn)
-	    warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
+	if (ckWARN(WARN_EXEC))
+	    warner(WARN_EXEC, "Can't exec \"%s\": %s", 
+		PL_Argv[0], Strerror(errno));
     }
     do_execfree();
     return FALSE;
@@ -1077,8 +1126,12 @@ do_exec(char *cmd)
 	    do_execfree();
 	    goto doshell;
 	}
-	if (PL_dowarn)
-	    warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
+	{
+	    dTHR;
+	    if (ckWARN(WARN_EXEC))
+		warner(WARN_EXEC, "Can't exec \"%s\": %s", 
+		    PL_Argv[0], Strerror(errno));
+	}
     }
     do_execfree();
     return FALSE;
@@ -1096,6 +1149,7 @@ apply(I32 type, register SV **mark, register SV **sp)
     char *what;
     char *s;
     SV **oldmark = mark;
+    STRLEN n_a;
 
 #define APPLY_TAINT_PROPER() \
     STMT_START {							\
@@ -1121,7 +1175,7 @@ apply(I32 type, register SV **mark, register SV **sp)
 	    APPLY_TAINT_PROPER();
 	    tot = sp - mark;
 	    while (++mark <= sp) {
-		char *name = SvPVx(*mark, PL_na);
+		char *name = SvPVx(*mark, n_a);
 		APPLY_TAINT_PROPER();
 		if (PerlLIO_chmod(name, val))
 		    tot--;
@@ -1138,7 +1192,7 @@ apply(I32 type, register SV **mark, register SV **sp)
 	    APPLY_TAINT_PROPER();
 	    tot = sp - mark;
 	    while (++mark <= sp) {
-		char *name = SvPVx(*mark, PL_na);
+		char *name = SvPVx(*mark, n_a);
 		APPLY_TAINT_PROPER();
 		if (PerlLIO_chown(name, val, val2))
 		    tot--;
@@ -1158,7 +1212,7 @@ nothing in the core.
 	APPLY_TAINT_PROPER();
 	if (mark == sp)
 	    break;
-	s = SvPVx(*++mark, PL_na);
+	s = SvPVx(*++mark, n_a);
 	if (isUPPER(*s)) {
 	    if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
 		s += 3;
@@ -1228,7 +1282,7 @@ nothing in the core.
 	APPLY_TAINT_PROPER();
 	tot = sp - mark;
 	while (++mark <= sp) {
-	    s = SvPVx(*mark, PL_na);
+	    s = SvPVx(*mark, n_a);
 	    APPLY_TAINT_PROPER();
 	    if (PL_euid || PL_unsafe) {
 		if (UNLINK(s))
@@ -1273,7 +1327,7 @@ nothing in the core.
 	    APPLY_TAINT_PROPER();
 	    tot = sp - mark;
 	    while (++mark <= sp) {
-		char *name = SvPVx(*mark, PL_na);
+		char *name = SvPVx(*mark, n_a);
 		APPLY_TAINT_PROPER();
 		if (PerlLIO_utime(name, &utbuf))
 		    tot--;
@@ -1398,7 +1452,7 @@ do_ipcget(I32 optype, SV **mark, SV **sp)
 #endif
 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
     default:
-	croak("%s not implemented", op_desc[optype]);
+	croak("%s not implemented", PL_op_desc[optype]);
 #endif
     }
     return -1;			/* should never happen */
@@ -1455,7 +1509,7 @@ do_ipcctl(I32 optype, SV **mark, SV **sp)
 #endif
 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
     default:
-	croak("%s not implemented", op_desc[optype]);
+	croak("%s not implemented", PL_op_desc[optype]);
 #endif
     }
 
@@ -1472,7 +1526,9 @@ do_ipcctl(I32 optype, SV **mark, SV **sp)
 	    a = SvPV(astr, len);
 	    if (len != infosize)
 		croak("Bad arg length for %s, is %lu, should be %ld",
-			op_desc[optype], (unsigned long)len, (long)infosize);
+		      PL_op_desc[optype],
+		      (unsigned long)len,
+		      (long)infosize);
 	}
     }
     else