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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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");