X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=aa36bef9aae5e46f0ef98ba720914f1acdfd4309;hb=7253302f2d3ad6cffc89ef8a0aa41e45bb4dc935;hp=4246e3cbd712386c1ba3ef9e5a4fc29f22080e36;hpb=e294cc5d7355a434d6b698c777674e1b7d4d4583;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_sys.c b/pp_sys.c
index 4246e3c..aa36bef 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1,7 +1,7 @@
 /*    pp_sys.c
  *
- *    Copyright (C) 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ *    2004, 2005, 2006, 2007 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -437,6 +437,7 @@ PP(pp_warn)
     else if (SP == MARK) {
 	tmpsv = &PL_sv_no;
 	EXTEND(SP, 1);
+	SP = MARK + 1;
     }
     else {
 	tmpsv = TOPs;
@@ -453,7 +454,7 @@ PP(pp_warn)
     if (!tmps || !len)
 	tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
 
-    Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
+    Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
     RETSETYES;
 }
 
@@ -517,7 +518,7 @@ PP(pp_die)
     if (!tmps || !len)
 	tmpsv = sv_2mortal(newSVpvs("Died"));
 
-    DIE(aTHX_ "%"SVf, (void*)tmpsv);
+    DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
 }
 
 /* I/O. */
@@ -537,10 +538,15 @@ PP(pp_open)
 
     if (!isGV(gv))
 	DIE(aTHX_ PL_no_usym, "filehandle");
+
     if ((io = GvIOp(gv))) {
 	MAGIC *mg;
 	IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 
+	if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
+	    Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
+		    "Opening dirhandle %s also as a file", GvENAME(gv));
+
 	mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
 	if (mg) {
 	    /* Method's args are same as ours ... */
@@ -707,8 +713,12 @@ PP(pp_umask)
     Mode_t anum;
 
     if (MAXARG < 1) {
-	anum = PerlLIO_umask(0);
-	(void)PerlLIO_umask(anum);
+	anum = PerlLIO_umask(022);
+	/* setting it to 022 between the two calls to umask avoids
+	 * to have a window where the umask is set to 0 -- meaning
+	 * that another thread could create world-writeable files. */
+	if (anum != 022)
+	    (void)PerlLIO_umask(anum);
     }
     else
 	anum = PerlLIO_umask(POPi);
@@ -766,22 +776,23 @@ PP(pp_binmode)
     }
 
     PUTBACK;
-    if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
-                       (discp) ? SvPV_nolen_const(discp) : NULL)) {
-	if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
-	     if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
-			mode_from_discipline(discp),
-                       (discp) ? SvPV_nolen_const(discp) : NULL)) {
-		SPAGAIN;
-		RETPUSHUNDEF;
-	     }
+    {
+	const int mode = mode_from_discipline(discp);
+	const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
+	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)) {
+		    SPAGAIN;
+		    RETPUSHUNDEF;
+		}
+	    }
+	    SPAGAIN;
+	    RETPUSHYES;
+	}
+	else {
+	    SPAGAIN;
+	    RETPUSHUNDEF;
 	}
-	SPAGAIN;
-	RETPUSHYES;
-    }
-    else {
-	SPAGAIN;
-	RETPUSHUNDEF;
     }
 }
 
@@ -839,10 +850,10 @@ PP(pp_tie)
 	/* Not clear why we don't call call_method here too.
 	 * perhaps to get different error message ?
 	 */
-	stash = gv_stashsv(*MARK, FALSE);
+	stash = gv_stashsv(*MARK, 0);
 	if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 	    DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
-		 methname, (void*)*MARK);
+		 methname, SVfARG(*MARK));
 	}
 	ENTER;
 	PUSHSTACKi(PERLSI_MAGIC);
@@ -941,7 +952,7 @@ PP(pp_dbmopen)
 
     HV * const hv = (HV*)POPs;
     SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
-    stash = gv_stashsv(sv, FALSE);
+    stash = gv_stashsv(sv, 0);
     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
 	PUTBACK;
 	require_pv("AnyDBM_File.pm");
@@ -1265,6 +1276,7 @@ PP(pp_enterwrite)
     register IO *io;
     GV *fgv;
     CV *cv;
+    SV * tmpsv = NULL;
 
     if (MAXARG == 0)
 	gv = PL_defoutgv;
@@ -1288,8 +1300,8 @@ PP(pp_enterwrite)
 
     cv = GvFORM(fgv);
     if (!cv) {
-	SV * const tmpsv = sv_newmortal();
 	const char *name;
+	tmpsv = sv_newmortal();
 	gv_efullname4(tmpsv, fgv, NULL, FALSE);
 	name = SvPV_nolen_const(tmpsv);
 	if (name && *name)
@@ -1483,6 +1495,8 @@ PP(pp_prtf)
 	goto just_say_no;
     }
     else {
+	if (SvTAINTED(MARK[1]))
+	    TAINT_PROPER("printf");
 	do_sprintf(sv, SP - MARK, MARK + 1);
 	if (!do_print(sv, fp))
 	    goto just_say_no;
@@ -1617,7 +1631,7 @@ PP(pp_sysread)
 	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
 	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
-			  (struct sockaddr *)namebuf, &bufsize);
+				  (struct sockaddr *)namebuf, &bufsize);
 	if (count < 0)
 	    RETPUSHUNDEF;
 #ifdef EPOC
@@ -1825,10 +1839,14 @@ PP(pp_send)
 
     SETERRNO(0,0);
     io = GvIO(gv);
-    if (!io || !IoIFP(io)) {
+    if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
 	retval = -1;
-	if (ckWARN(WARN_CLOSED))
-	    report_evil_fh(gv, io, PL_op->op_type);
+	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
+	    if (io && IoIFP(io))
+		report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
+	    else
+		report_evil_fh(gv, io, PL_op->op_type);
+	}
 	SETERRNO(EBADF,RMS_IFI);
 	goto say_undef;
     }
@@ -2780,7 +2798,8 @@ PP(pp_stat)
 {
     dVAR;
     dSP;
-    GV *gv;
+    GV *gv = NULL;
+    IO *io;
     I32 gimme;
     I32 max = 13;
 
@@ -2791,7 +2810,7 @@ PP(pp_stat)
 	    do_fstat_warning_check:
 		if (ckWARN(WARN_IO))
 		    Perl_warner(aTHX_ packWARN(WARN_IO),
-			"lstat() on filehandle %s", GvENAME(gv));
+			"lstat() on filehandle %s", gv ? GvENAME(gv) : "");
 	    } else if (PL_laststype != OP_LSTAT)
 		Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
 	}
@@ -2802,7 +2821,8 @@ PP(pp_stat)
 	    PL_statgv = gv;
 	    sv_setpvn(PL_statname, "", 0);
             if(gv) {
-                IO* const io = GvIO(gv);
+                io = GvIO(gv);
+                do_fstat_have_io:
                 if (io) {
                     if (IoIFP(io)) {
                         PL_laststatval = 
@@ -2832,13 +2852,18 @@ PP(pp_stat)
 	if (SvTYPE(sv) == SVt_PVGV) {
 	    gv = (GV*)sv;
 	    goto do_fstat;
-	}
-	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
-	    gv = (GV*)SvRV(sv);
-	    if (PL_op->op_type == OP_LSTAT)
-		goto do_fstat_warning_check;
-	    goto do_fstat;
-	}
+	} else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+            gv = (GV*)SvRV(sv);
+            if (PL_op->op_type == OP_LSTAT)
+                goto do_fstat_warning_check;
+            goto do_fstat;
+        } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 
+            io = (IO*)SvRV(sv);
+            if (PL_op->op_type == OP_LSTAT)
+                goto do_fstat_warning_check;
+            goto do_fstat_have_io; 
+        }
+        
 	sv_setpv(PL_statname, SvPV_nolen_const(sv));
 	PL_statgv = NULL;
 	PL_laststype = PL_op->op_type;
@@ -2899,9 +2924,9 @@ PP(pp_stat)
 	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
 	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
 #else
-	PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
-	PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
-	PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
+	PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
+	PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
+	PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
 #endif
 #ifdef USE_STAT_BLOCKS
 	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
@@ -3002,7 +3027,7 @@ PP(pp_ftrread)
 
     if (use_access) {
 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
-	const char *const name = POPpx;
+	const char *name = POPpx;
 	if (effective) {
 #  ifdef PERL_EFF_ACCESS
 	    result = PERL_EFF_ACCESS(name, access_mode);
@@ -3322,7 +3347,7 @@ PP(pp_fttext)
 
 #if defined(DOSISH) || defined(USEMYBINMODE)
     /* ignore trailing ^Z on short files */
-    if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
+    if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
 	--len;
 #endif
 
@@ -3422,15 +3447,14 @@ PP(pp_chdir)
 #ifdef HAS_FCHDIR
 	IO* const io = GvIO(gv);
 	if (io) {
-	    if (IoIFP(io)) {
-		PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
-	    }
-	    else if (IoDIRP(io)) {
+	    if (IoDIRP(io)) {
 #ifdef HAS_DIRFD
 		PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
 #else
 		DIE(aTHX_ PL_no_func, "dirfd");
 #endif
+	    } else if (IoIFP(io)) {
+                PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
 	    }
 	    else {
 		if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
@@ -3750,6 +3774,9 @@ PP(pp_open_dir)
     if (!io)
 	goto nope;
 
+    if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
+	Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
+		"Opening filehandle %s also as a directory", GvENAME(gv));
     if (IoDIRP(io))
 	PerlDir_close(IoDIRP(io));
     if (!(IoDIRP(io) = PerlDir_open(dirname)))
@@ -4638,7 +4665,7 @@ PP(pp_ghostent)
 	STRLEN addrlen;
 	Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
 
-	hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
+	hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
 #else
 	DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
 #endif