X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f36eea1037c5e636f0a49c0b179f8f7dce70d331..2ad994b6e36daff31f875d44d1ce2915fef0e125:/pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index bf2b352..7ce9dae 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1,6 +1,6 @@
 /*    pp_sys.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (c) 1991-2002, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -838,24 +838,26 @@ PP(pp_untie)
 	SV *obj = SvRV(mg->mg_obj);
 	GV *gv;
 	CV *cv = NULL;
-	if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
-            isGV(gv) && (cv = GvCV(gv))) {
-	    PUSHMARK(SP);
-	    XPUSHs(SvTIED_obj((SV*)gv, mg));
-	    XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
-	    PUTBACK;
-	    ENTER;
-	    call_sv((SV *)cv, G_VOID);
-	    LEAVE;
-	    SPAGAIN;
-        }
-        else if (ckWARN(WARN_UNTIE)) {
-	    if (mg && SvREFCNT(obj) > 1)
-		Perl_warner(aTHX_ WARN_UNTIE,
-		    "untie attempted while %"UVuf" inner references still exist",
-		    (UV)SvREFCNT(obj) - 1 ) ;
+        if (obj) {
+	    if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
+               isGV(gv) && (cv = GvCV(gv))) {
+	       PUSHMARK(SP);
+	       XPUSHs(SvTIED_obj((SV*)gv, mg));
+	       XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
+	       PUTBACK;
+	       ENTER;
+	       call_sv((SV *)cv, G_VOID);
+	       LEAVE;
+	       SPAGAIN;
+            }
+           else if (ckWARN(WARN_UNTIE)) {
+	       if (mg && SvREFCNT(obj) > 1)
+		  Perl_warner(aTHX_ WARN_UNTIE,
+		      "untie attempted while %"UVuf" inner references still exist",
+		       (UV)SvREFCNT(obj) - 1 ) ;
+           }
         }
-	sv_unmagic(sv, how);
+	sv_unmagic(sv, how) ;
     }
     RETPUSHYES;
 }
@@ -1132,7 +1134,7 @@ PP(pp_getc)
 {
     dSP; dTARGET;
     GV *gv;
-    IO *io;
+    IO *io = NULL;
     MAGIC *mg;
 
     if (MAXARG == 0)
@@ -1155,8 +1157,11 @@ PP(pp_getc)
 	    SvSetMagicSV_nosteal(TARG, TOPs);
 	RETURN;
     }
-    if (!gv || do_eof(gv)) /* make sure we have fp with something */
+    if (!gv || do_eof(gv)) { /* make sure we have fp with something */
+	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED) && IoTYPE(io) != IoTYPE_WRONLY)
+	    report_evil_fh(gv, io, PL_op->op_type);
 	RETPUSHUNDEF;
+    }
     TAINT;
     sv_setpv(TARG, " ");
     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
@@ -1892,7 +1897,7 @@ PP(pp_eof)
     if (MAXARG == 0) {
 	if (PL_op->op_flags & OPf_SPECIAL) {	/* eof() */
 	    IO *io;
-	    gv = PL_last_in_gv = PL_argvgv;
+	    gv = PL_last_in_gv = GvEGV(PL_argvgv);
 	    io = GvIO(gv);
 	    if (io && !IoIFP(io)) {
 		if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
@@ -2066,7 +2071,7 @@ PP(pp_truncate)
 	else {
 	    SV *sv = POPs;
 	    char *name;
-	  
+	
 	    if (SvTYPE(sv) == SVt_PVGV) {
 	        tmpgv = (GV*)sv;		/* *main::FRED for example */
 		goto do_ftruncate;
@@ -2280,7 +2285,7 @@ PP(pp_socket)
 
 PP(pp_sockpair)
 {
-#ifdef HAS_SOCKETPAIR
+#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM))
     dSP;
     GV *gv1;
     GV *gv2;
@@ -2469,6 +2474,7 @@ PP(pp_accept)
     struct sockaddr saddr;	/* use a struct to avoid alignment problems */
     Sock_size_t len = sizeof saddr;
     int fd;
+    int fd2;
 
     ggv = (GV*)POPs;
     ngv = (GV*)POPs;
@@ -2489,7 +2495,11 @@ PP(pp_accept)
     if (IoIFP(nstio))
 	do_close(ngv, FALSE);
     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
-    IoOFP(nstio) = PerlIO_fdopen(fd, "w");
+    /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit
+       fclose of IoOFP's FILE * - and hence leak memory.
+       Special treatment of _this_ case of IoIFP != IoOFP seems wrong.
+     */
+    IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w");
     IoTYPE(nstio) = IoTYPE_SOCKET;
     if (!IoIFP(nstio) || !IoOFP(nstio)) {
 	if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
@@ -2499,6 +2509,7 @@ PP(pp_accept)
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd);	/* ensure close-on-exec */
 #endif
 
 #ifdef EPOC
@@ -2718,12 +2729,12 @@ PP(pp_stat)
     if (PL_op->op_flags & OPf_REF) {
 	gv = cGVOP_gv;
 	if (PL_op->op_type == OP_LSTAT) {
-	    if (PL_laststype != OP_LSTAT)
-		Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
-	    if (ckWARN(WARN_IO) && gv != PL_defgv)
-		Perl_warner(aTHX_ WARN_IO,
+	    if (gv != PL_defgv) {
+		if (ckWARN(WARN_IO))
+		    Perl_warner(aTHX_ WARN_IO,
 			"lstat() on filehandle %s", GvENAME(gv));
-		/* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
+	    } else if (PL_laststype != OP_LSTAT)
+		Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
 	}
 
       do_fstat:
@@ -2748,6 +2759,9 @@ PP(pp_stat)
 	}
 	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
 	    gv = (GV*)SvRV(sv);
+	    if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
+		Perl_warner(aTHX_ WARN_IO,
+			"lstat() on filehandle %s", GvENAME(gv));
 	    goto do_fstat;
 	}
 	sv_setpv(PL_statname, SvPV(sv,n_a));
@@ -3303,6 +3317,7 @@ PP(pp_fttext)
       really_filename:
 	PL_statgv = Nullgv;
 	PL_laststatval = -1;
+	PL_laststype = OP_STAT;
 	sv_setpv(PL_statname, SvPV(sv, n_a));
 	if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
 	    if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
@@ -3410,8 +3425,9 @@ PP(pp_chdir)
                 deprecate("chdir('') or chdir(undef) as chdir()");
             tmps = SvPV(*svp, n_a);
         }
-        else {            
+        else {
             PUSHi(0);
+            TAINT_PROPER("chdir");
             RETURN;
         }
     }
@@ -3513,9 +3529,8 @@ PP(pp_rename)
 
 PP(pp_link)
 {
-    dSP;
 #ifdef HAS_LINK
-    dTARGET;
+    dSP; dTARGET;
     STRLEN n_a;
     char *tmps2 = POPpx;
     char *tmps = SvPV(TOPs, n_a);
@@ -3923,8 +3938,11 @@ PP(pp_fork)
 	RETSETUNDEF;
     if (!childpid) {
 	/*SUPPRESS 560*/
-	if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
+	if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
+            SvREADONLY_off(GvSV(tmpgv));
 	    sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
+            SvREADONLY_on(GvSV(tmpgv));
+        }
 	hv_clear(PL_pidstatus);	/* no kids, so don't wait for 'em */
     }
     PUSHi(childpid);
@@ -4026,7 +4044,17 @@ PP(pp_system)
 	 Pid_t childpid;
 	 int status;
 	 Sigsave_t ihand,qhand;     /* place to save signals during system() */
-	 
+	
+	 if (PL_tainting) {
+	     SV *cmd = NULL;
+	     if (PL_op->op_flags & OPf_STACKED)
+		cmd = *(MARK + 1);
+	     else if (SP - MARK != 1)
+		cmd = *SP;
+	     if (cmd && *(SvPV_nolen(cmd)) != '/')
+		TAINT_ENV();
+	 }
+
 	 if (PerlProc_pipe(pp) >= 0)
 	      did_pipes = 1;
 	 while ((childpid = PerlProc_fork()) == -1) {
@@ -4062,7 +4090,7 @@ PP(pp_system)
 	      if (did_pipes) {
 		   int errkid;
 		   int n = 0, n1;
-		   
+		
 		   while (n < sizeof(int)) {
 			n1 = PerlLIO_read(pp[0],
 					  (void*)(((char*)&errkid)+n),
@@ -4299,6 +4327,10 @@ PP(pp_time)
    it's supported.    --AD  9/96.
 */
 
+#ifdef __BEOS__
+#  define HZ 1000000
+#endif
+
 #ifndef HZ
 #  ifdef CLK_TCK
 #    define HZ CLK_TCK