From: Nick Ing-Simmons <nik@tiuk.ti.com>
Date: Fri, 7 May 1999 21:24:50 +0000 (+0000)
Subject: Implement open( my $fh, ...) and similar.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=853846ea710f8feaed8c98b358bdc8967dd522d2;p=p5sagit%2Fp5-mst-13.2.git

Implement open( my $fh, ...) and similar.
  Set flag in op.c for "constructor ops"
  In pp_rv2gv, if flag is set and arg is PADSV and uninit
  vivify as reference to a detached GV.
  (Name of GV is the pad name.)
This scheme should "just work" for pipe/socket etc. too.

#if 0 out the open(FH,undef) for now.
Change t/io/open.t to test open(my $fh,...)

p4raw-id: //depot/perl@3326
---

diff --git a/op.c b/op.c
index 2b6107e..5e2d593 100644
--- a/op.c
+++ b/op.c
@@ -4780,11 +4780,20 @@ ck_fun(OP *o)
 		    }
 		    else {
 			I32 flags = OPf_SPECIAL;
+			I32 private = 0;
 			/* is this op a FH constructor? */
-			if (is_handle_constructor(o,numargs))
-			    flags = 0;
+			if (is_handle_constructor(o,numargs)) {
+			    /* Set a flag to tell rv2gv to vivify 
+			     * need to "prove" flag does not mean something
+			     * else already - NI-S 1999/05/07
+			     */ 
+			    flags   = 0;                         
+			    private = OPpDEREF;
+			}
 			kid->op_sibling = 0;
 			kid = newUNOP(OP_RV2GV, flags, scalar(kid));
+			if (private)
+			    kid->op_private |= private;
 		    }
 		    kid->op_sibling = sibl;
 		    *tokid = kid;
diff --git a/pp.c b/pp.c
index 8c0fba7..5a15355 100644
--- a/pp.c
+++ b/pp.c
@@ -214,7 +214,7 @@ PP(pp_padany)
 
 PP(pp_rv2gv)
 {
-    djSP; dTOPss;
+    djSP; dTOPss;  
 
     if (SvROK(sv)) {
       wasref:
@@ -242,6 +242,21 @@ PP(pp_rv2gv)
 		    goto wasref;
 	    }
 	    if (!SvOK(sv)) {
+		/* If this is a 'my' scalar and flag is set then vivify 
+		 * NI-S 1999/05/07
+		 */ 
+		if ( (PL_op->op_private & OPpDEREF) && 
+		      cUNOP->op_first->op_type == OP_PADSV ) {
+		    STRLEN len;
+		    SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
+		    char *name = SvPV(padname,len); 
+		    GV *gv = (GV *) newSV(0);
+		    gv_init(gv, PL_curcop->cop_stash, name, len, 0);
+		    sv_upgrade(sv, SVt_RV);
+		    SvRV(sv) = (SV *) gv;
+		    SvROK_on(sv);
+		    goto wasref;
+		}  
 		if (PL_op->op_flags & OPf_REF ||
 		    PL_op->op_private & HINT_STRICT_REFS)
 		    DIE(PL_no_usym, "a symbol");
@@ -1016,8 +1031,13 @@ PP(pp_modulo)
 #endif
 
 	    /* Backward-compatibility clause: */
+#if 0
 	    dright = trunc(dright + 0.5);
 	    dleft  = trunc(dleft + 0.5);
+#else
+	    dright = floor(dright + 0.5);
+	    dleft  = floor(dleft + 0.5);
+#endif
 
 	    if (!dright)
 		DIE("Illegal modulus zero");
diff --git a/pp_sys.c b/pp_sys.c
index 3f4a112..e52a864 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -506,6 +506,8 @@ PP(pp_open)
 	DIE(PL_no_usym, "filehandle");
     if (GvIOp(gv))
 	IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
+
+#if 0 /* no undef means tmpfile() yet */
     if (sv == &PL_sv_undef) {
 #ifdef PerlIO
 	PerlIO *fp = PerlIO_tmpfile();
@@ -518,6 +520,8 @@ PP(pp_open)
 	    RETPUSHUNDEF;
 	RETURN;
     }   
+#endif /* no undef means tmpfile() yet */
+
     tmps = SvPV(sv, len);
     if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
 	PUSHi( (I32)PL_forkprocess );
diff --git a/t/io/open.t b/t/io/open.t
index 819393f..0203f34 100755
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -1,22 +1,34 @@
 #!./perl
 
 # $RCSfile$    
-$| = 1;
+$|  = 1;
+$^W = 1;
 
-print "1..6\n";
+print "1..8\n";   
 
-print "$!\nnot " unless open(A,undef);
+# my $file tests
+
+unlink("afile.new") if -f "afile";     
+print "$!\nnot " unless open(my $f,"+>afile");
 print "ok 1\n";
-print "not " unless print A "SomeData\n";
+print "not " unless -f "afile";     
 print "ok 2\n";
-print "not " unless tell(A) == 9;
+print "not " unless print $f "SomeData\n";
 print "ok 3\n";
-print "not " unless seek(A,0,0);
+print "not " unless tell($f) == 9;
 print "ok 4\n";
-$b = <A>;
-print "not " unless $b eq "SomeData\n";
+print "not " unless seek($f,0,0);
 print "ok 5\n";
-print "not " unless close(A);
+$b = <$f>;
+print "not " unless $b eq "SomeData\n";
 print "ok 6\n";
-     
+print "not " unless -f $f;     
+print "ok 7\n";
+eval  { die "Message" };   
+# warn $@;
+print "not " unless $@ =~ /<\$f> line 1/;
+print "ok 8\n";
+print "not " unless close($f);
+print "ok 9\n";
+unlink("afile");