X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=413e342dbc95ada24a757c6467429e2f4da1c37b;hb=fc0dc3b334ed07492841d4d27f3f4100c92588d2;hp=b0c7a9e98cca56acda78d481e9c02f814a65b535;hpb=d5a9bfb0fc8643b1208bad4f15e3c88ef46b4160;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/doio.c b/doio.c
index b0c7a9e..413e342 100644
--- a/doio.c
+++ b/doio.c
@@ -87,7 +87,17 @@
 #endif
 
 bool
-Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp)
+Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
+	     int rawmode, int rawperm, PerlIO *supplied_fp)
+{
+    return do_open9(gv, name, len, as_raw, rawmode, rawperm,
+		    supplied_fp, Nullsv, 0);
+}
+
+bool
+Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
+	      int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
+	      I32 num_svs)
 {
     register IO *io = GvIOn(gv);
     PerlIO *saveifp = Nullfp;
@@ -116,7 +126,7 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
 	else if (IoIFP(io) != IoOFP(io)) {
 	    if (IoOFP(io)) {
 		result = PerlIO_close(IoOFP(io));
-		PerlIO_close(IoIFP(io));	/* clear stdio, fd already closed */
+		PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
 	    }
 	    else
 		result = PerlIO_close(IoIFP(io));
@@ -124,13 +134,14 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
 	else
 	    result = PerlIO_close(IoIFP(io));
 	if (result == EOF && fd > PL_maxsysfd)
-	    PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
-	      GvENAME(gv));
+	    PerlIO_printf(PerlIO_stderr(),
+			  "Warning: unable to close filehandle %s properly.\n",
+			  GvENAME(gv));
 	IoOFP(io) = IoIFP(io) = Nullfp;
     }
 
     if (as_raw) {
-#if defined(O_LARGEFILE)
+#if defined(USE_64_BIT_OFFSETS) && defined(O_LARGEFILE)
 	rawmode |= O_LARGEFILE;
 #endif
 
@@ -173,26 +184,44 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
     }
     else {
 	char *myname;
+	char *type = name;
+	char *otype = name;
+	STRLEN tlen;
+	STRLEN otlen = len;
 	char mode[3];		/* stdio file mode ("r\0" or "r+\0") */
 	int dodup;
 
+	if (num_svs) {
+	    type = name;
+	    name = SvPV(svs, tlen) ;
+	    len = (I32)tlen;
+	}
+
+	tlen = otlen;
 	myname = savepvn(name, len);
 	SAVEFREEPV(myname);
 	name = myname;
-	while (len && isSPACE(name[len-1]))
-	    name[--len] = '\0';
+	if (!num_svs)
+	    while (tlen && isSPACE(type[tlen-1]))
+		type[--tlen] = '\0';
 
 	mode[0] = mode[1] = mode[2] = '\0';
-	IoTYPE(io) = *name;
-	if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
-	    mode[1] = *name++;
-	    --len;
+	IoTYPE(io) = *type;
+	if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */
+	    mode[1] = *type++;
+	    --tlen;
 	    writing = 1;
 	}
 
-	if (*name == '|') {
+	if (*type == '|') {
+	    if (num_svs && (tlen != 2 || type[1] != '-')) {
+	      unknown_desr:
+		Perl_croak(aTHX_ "Unknown open() mode '%.*s'", otlen, otype);
+	    }
 	    /*SUPPRESS 530*/
-	    for (name++; isSPACE(*name); name++) ;
+	    for (type++; isSPACE(*type); type++) ;
+	    if (!num_svs)
+		name = type;
 	    if (*name == '\0') { /* command is missing 19990114 */
 		dTHR;
 		if (ckWARN(WARN_PIPE))
@@ -200,7 +229,7 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
 		errno = EPIPE;
 		goto say_false;
 	    }
-	    if (strNE(name,"-"))
+	    if (strNE(name,"-") || num_svs)
 		TAINT_ENV();
 	    TAINT_PROPER("piped open");
 	    if (name[strlen(name)-1] == '|') {
@@ -212,18 +241,22 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
 	    fp = PerlProc_popen(name,"w");
 	    writing = 1;
 	}
-	else if (*name == '>') {
+	else if (*type == '>') {
 	    TAINT_PROPER("open");
-	    name++;
-	    if (*name == '>') {
+	    type++;
+	    if (*type == '>') {
 		mode[0] = IoTYPE(io) = 'a';
-		name++;
+		type++;
+		tlen--;
 	    }
 	    else
 		mode[0] = 'w';
 	    writing = 1;
 
-	    if (*name == '&') {
+	    if (num_svs && tlen != 1)
+	        goto unknown_desr;
+	    if (*type == '&') {
+		name = type;
 	      duplicity:
 		dodup = 1;
 		name++;
@@ -249,7 +282,19 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
 			    goto say_false;
 			}
 			if (IoIFP(thatio)) {
-			    fd = PerlIO_fileno(IoIFP(thatio));
+			    PerlIO *fp = IoIFP(thatio);
+			    /* Flush stdio buffer before dup. --mjd
+			     * Unfortunately SEEK_CURing 0 seems to
+			     * be optimized away on most platforms;
+			     * only Solaris and Linux seem to flush
+			     * on that. --jhi */
+			    PerlIO_seek(fp, 0, SEEK_CUR);
+			    /* On the other hand, do all platforms
+			     * take gracefully to flushing a read-only
+			     * filehandle?  Perhaps we should do
+			     * fsetpos(src)+fgetpos(dst)?  --nik */
+			    PerlIO_flush(fp);
+			    fd = PerlIO_fileno(fp);
 			    if (IoTYPE(thatio) == 's')
 				IoTYPE(io) = 's';
 			}
@@ -268,35 +313,46 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
 	    }
 	    else {
 		/*SUPPRESS 530*/
-		for (; isSPACE(*name); name++) ;
-		if (strEQ(name,"-")) {
+		for (; isSPACE(*type); type++) ;
+		if (strEQ(type,"-")) {
 		    fp = PerlIO_stdout();
 		    IoTYPE(io) = '-';
 		}
 		else  {
-		    fp = PerlIO_open(name,mode);
+		    fp = PerlIO_open((num_svs ? name : type), mode);
 		}
 	    }
 	}
-	else if (*name == '<') {
+	else if (*type == '<') {
+	    if (num_svs && tlen != 1)
+	        goto unknown_desr;
 	    /*SUPPRESS 530*/
-	    for (name++; isSPACE(*name); name++) ;
+	    for (type++; isSPACE(*type); type++) ;
 	    mode[0] = 'r';
-	    if (*name == '&')
+	    if (*type == '&') {
+		name = type;
 		goto duplicity;
-	    if (strEQ(name,"-")) {
+	    }
+	    if (strEQ(type,"-")) {
 		fp = PerlIO_stdin();
 		IoTYPE(io) = '-';
 	    }
 	    else
-		fp = PerlIO_open(name,mode);
+		fp = PerlIO_open((num_svs ? name : type), mode);
 	}
-	else if (len > 1 && name[len-1] == '|') {
-	    name[--len] = '\0';
-	    while (len && isSPACE(name[len-1]))
-		name[--len] = '\0';
-	    /*SUPPRESS 530*/
-	    for (; isSPACE(*name); name++) ;
+	else if (tlen > 1 && type[tlen-1] == '|') {
+	    if (num_svs) {
+		if (tlen != 2 || type[0] != '-')
+		    goto unknown_desr;
+	    }
+	    else {
+		type[--tlen] = '\0';
+		while (tlen && isSPACE(type[tlen-1]))
+		    type[--tlen] = '\0';
+		/*SUPPRESS 530*/
+		for (; isSPACE(*type); type++) ;
+		name = type;
+	    }
 	    if (*name == '\0') { /* command is missing 19990114 */
 		dTHR;
 		if (ckWARN(WARN_PIPE))
@@ -304,13 +360,16 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
 		errno = EPIPE;
 		goto say_false;
 	    }
-	    if (strNE(name,"-"))
+	    if (strNE(name,"-") || num_svs)
 		TAINT_ENV();
 	    TAINT_PROPER("piped open");
 	    fp = PerlProc_popen(name,"r");
 	    IoTYPE(io) = '|';
 	}
 	else {
+	    if (num_svs)
+		goto unknown_desr;
+	    name = type;
 	    IoTYPE(io) = '<';
 	    /*SUPPRESS 530*/
 	    for (; isSPACE(*name); name++) ;
@@ -366,7 +425,7 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
 	    }
 	}
 	if (fd != PerlIO_fileno(fp)) {
-	    int pid;
+	    Pid_t pid;
 	    SV *sv;
 
 	    PerlLIO_dup2(PerlIO_fileno(fp), fd);
@@ -501,7 +560,7 @@ Perl_nextargv(pTHX_ register GV *gv)
 		    }
 #endif
 #ifdef HAS_RENAME
-#ifndef DOSISH
+#if !defined(DOSISH) && !defined(CYGWIN)
 		    if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
 		        if (ckWARN_d(WARN_INPLACE))	
 			    Perl_warner(aTHX_ WARN_INPLACE, 
@@ -675,7 +734,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
 	}
 	return FALSE;
     }
-    retval = io_close(io);
+    retval = io_close(io, not_implicit);
     if (not_implicit) {
 	IoLINES(io) = 0;
 	IoPAGE(io) = 0;
@@ -686,7 +745,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
 }
 
 bool
-Perl_io_close(pTHX_ IO *io)
+Perl_io_close(pTHX_ IO *io, bool not_implicit)
 {
     bool retval = FALSE;
     int status;
@@ -694,8 +753,13 @@ Perl_io_close(pTHX_ IO *io)
     if (IoIFP(io)) {
 	if (IoTYPE(io) == '|') {
 	    status = PerlProc_pclose(IoIFP(io));
-	    STATUS_NATIVE_SET(status);
-	    retval = (STATUS_POSIX == 0);
+	    if (not_implicit) {
+		STATUS_NATIVE_SET(status);
+		retval = (STATUS_POSIX == 0);
+	    }
+	    else {
+		retval = (status != -1);
+	    }
 	}
 	else if (IoTYPE(io) == '-')
 	    retval = TRUE;
@@ -709,7 +773,7 @@ Perl_io_close(pTHX_ IO *io)
 	}
 	IoOFP(io) = IoIFP(io) = Nullfp;
     }
-    else {
+    else if (not_implicit) {
 	SETERRNO(EBADF,SS$_IVCHAN);
     }
 
@@ -821,7 +885,7 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 	    Perl_warner(aTHX_ WARN_UNOPENED, "sysseek() on unopened file");
     }
     SETERRNO(EBADF,RMS$_IFI);
-    return -1L;
+    return (Off_t)-1;
 }
 
 int
@@ -949,10 +1013,17 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 	if (SvIOK(sv)) {
 	    if (SvGMAGICAL(sv))
 		mg_get(sv);
-	    if (SvIsUV(sv))		/* XXXX 64-bit? */
+#ifdef IV_IS_QUAD
+	    if (SvIsUV(sv))
+		PerlIO_printf(fp, "%" PERL_PRIu64, (UV)SvUVX(sv));
+	    else
+		PerlIO_printf(fp, "%" PERL_PRId64, (IV)SvIVX(sv));
+#else
+	    if (SvIsUV(sv))
 		PerlIO_printf(fp, "%lu", (unsigned long)SvUVX(sv));
 	    else
 		PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
+#endif
 	    return !PerlIO_error(fp);
 	}
 	/* FALL THROUGH */
@@ -960,6 +1031,12 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 	tmps = SvPV(sv, len);
 	break;
     }
+    /* To detect whether the process is about to overstep its
+     * filesize limit we would need getrlimit().  We could then
+     * also transparently raise the limit with setrlimit() --
+     * but only until the system hard limit/the filesystem limit,
+     * at which we would get EPERM.  Note that when using buffered
+     * io the write failure can be delayed until the flush/close. --jhi */
     if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
 	return FALSE;
     return !PerlIO_error(fp);
@@ -1053,7 +1130,8 @@ Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
 }
 
 bool
-do_aexec5(SV *really, register SV **mark, register SV **sp, int fd, int do_report)
+Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
+	       int fd, int do_report)
 {
     register char **a;
     char *tmps;
@@ -1427,8 +1505,10 @@ nothing in the core.
 
 /* Do the permissions allow some operation?  Assumes statcache already set. */
 #ifndef VMS /* VMS' cando is in vms.c */
-I32
-Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp)
+bool
+Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
+/* Note: we use `effective' both for uids and gids.
+ * Here we are betting on Uid_t being equal or wider than Gid_t.  */
 {
 #ifdef DOSISH
     /* [Comments and code from Len Reed]
@@ -1452,11 +1532,11 @@ Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp)
      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
       * too so it will actually look into the files for magic numbers
       */
-     return (bit & statbufp->st_mode) ? TRUE : FALSE;
+     return (mode & statbufp->st_mode) ? TRUE : FALSE;
 
 #else /* ! DOSISH */
     if ((effective ? PL_euid : PL_uid) == 0) {	/* root is special */
-	if (bit == S_IXUSR) {
+	if (mode == S_IXUSR) {
 	    if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
 		return TRUE;
 	}
@@ -1465,22 +1545,22 @@ Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp)
 	return FALSE;
     }
     if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
-	if (statbufp->st_mode & bit)
+	if (statbufp->st_mode & mode)
 	    return TRUE;	/* ok as "user" */
     }
-    else if (ingroup((I32)statbufp->st_gid,effective)) {
-	if (statbufp->st_mode & bit >> 3)
+    else if (ingroup(statbufp->st_gid,effective)) {
+	if (statbufp->st_mode & mode >> 3)
 	    return TRUE;	/* ok as "group" */
     }
-    else if (statbufp->st_mode & bit >> 6)
+    else if (statbufp->st_mode & mode >> 6)
 	return TRUE;	/* ok as "other" */
     return FALSE;
 #endif /* ! DOSISH */
 }
 #endif /* ! VMS */
 
-I32
-Perl_ingroup(pTHX_ I32 testgid, I32 effective)
+bool
+Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
 {
     if (testgid == (effective ? PL_egid : PL_gid))
 	return TRUE;