Split the storage of the layers specificied by open.pm into one hint

for input, and one for output, as this better reflects how they are
used. The original "concatenate with \0" plan was really only a
compramise to avoid needing to increase every COP by 2 pointers.

p4raw-id: //depot/perl@30334

diff --git a/embed.fnc b/embed.fnc
index b41e2ea..7520258 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1837,6 +1837,8 @@ Mp        |int    |madparse
 AMdnoP |int    |Perl_signbit   |NV f
 #endif
 
+XEMop  |void   |emulate_cop_io |NN const COP *const c|NN SV *const sv
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:

diff --git a/embed.h b/embed.h
index f2c2a9d..5318688 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -4078,6 +4078,8 @@
 #endif
 #if !defined(HAS_SIGNBIT)
 #endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#endif
 #define ck_anoncode(a)         Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)            Perl_ck_bitop(aTHX_ a)
 #define ck_chdir(a)            Perl_ck_chdir(aTHX_ a)

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 02b1efb..d12392f 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -302,18 +302,14 @@ make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
 static SV *
 make_cop_io_object(pTHX_ SV *arg, COP *cop)
 {
-    if (CopHINTS_get(cop) & HINT_LEXICAL_IO) {
-       /* I feel you should be able to simply SvREFCNT_inc the return value
-          from this, but if you do (and restore the line
-          my $ioix = $cop->io->ix;
-          in B::COP::bsave in Bytecode.pm, then you get errors about
-          "attempt to free temp prematurely ... during global destruction.
-          The SV's flags are consistent with the error, but quite how the
-          temp escaped from the save stack is not clear.  */
-       SV *value = Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash,
-                                            0, "open", 4, 0, 0);
+    SV *const value = newSV(0);
+
+    Perl_emulate_cop_io(cop, value);
+
+    if(SvOK(value)) {
        return make_temp_object(aTHX_ arg, newSVsv(value));
     } else {
+       SvREFCNT_dec(value);
        return make_sv_object(aTHX_ arg, NULL);
     }
 }

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 8f99abc..46f2fb0 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -628,8 +628,8 @@ our %hints; # used to display each COP's op_hints values
 @hints{2,512,1024} = ('$', '&', '*');
 # integers, locale, bytes, arybase
 @hints{1,4,8,16,32} = ('i', 'l', 'b', '[');
-# block scope, localise %^H, $^OPEN
-@hints{256,131072,262144} = ('{','%','<');
+# block scope, localise %^H, $^OPEN (in), $^OPEN (out)
+@hints{256,131072,262144,524288} = ('{','%','<','>');
 # overload new integer, float, binary, string, re
 @hints{4096,8192,16384,32768,65536} = ('I', 'F', 'B', 'S', 'R');
 # taint and eval

diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm
index 68a6247..47d4a13 100644 (file)
--- a/ext/B/t/OptreeCheck.pm
+++ b/ext/B/t/OptreeCheck.pm
@@ -15,7 +15,7 @@ our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
 # This is a bit of a kludge. Really we need to find a way to encode in the
 # golden results that the hints wll differ because ${^OPEN} is set.
 
-if (((caller 0)[10]||{})->{'open'}) {
+if (((caller 0)[10]||{})->{'open<'}) {
     @open_todo = (skip => "\${^OPEN} is set");
 }
 

diff --git a/mg.c b/mg.c
index 8dfbac3..9a18bcb 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -666,6 +666,32 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
     } \
 } STMT_END
 
+void
+Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
+{
+    if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
+       sv_setsv(sv, &PL_sv_undef);
+    else {
+       sv_setpvs(sv, "");
+       SvUTF8_off(sv);
+       if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
+           SV *const value = Perl_refcounted_he_fetch(aTHX_
+                                                      c->cop_hints_hash,
+                                                      0, "open<", 5, 0, 0);
+           assert(value);
+           sv_catsv(sv, value);
+       }
+       sv_catpvs(sv, "\0");
+       if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
+           SV *const value = Perl_refcounted_he_fetch(aTHX_
+                                                      c->cop_hints_hash,
+                                                      0, "open>", 5, 0, 0);
+           assert(value);
+           sv_catsv(sv, value);
+       }
+    }
+}
+
 int
 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -769,14 +795,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
            SvTAINTED_off(sv);
        }
        else if (strEQ(remaining, "PEN")) {
-           if (!(CopHINTS_get(&PL_compiling) & HINT_LEXICAL_IO))
-               sv_setsv(sv, &PL_sv_undef);
-            else {
-               sv_setsv(sv,
-                        Perl_refcounted_he_fetch(aTHX_
-                                                 PL_compiling.cop_hints_hash,
-                                                 0, "open", 4, 0, 0));
-           }
+           Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
        }
        break;
     case '\020':               
@@ -2241,11 +2260,33 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            }
        }
        else if (strEQ(mg->mg_ptr, "\017PEN")) {
-           PL_compiling.cop_hints |= HINT_LEXICAL_IO;
-           PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
+           STRLEN len;
+           const char *const start = SvPV(sv, len);
+           const char *out = memchr(start, '\0', len);
+           SV *tmp;
+           struct refcounted_he *tmp_he;
+
+
+           PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
+           PL_hints
+               |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
+
+           /* Opening for input is more common than opening for output, so
+              ensure that hints for input are sooner on linked list.  */
+           tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
+                            : newSVpvs(""));
+           SvFLAGS(tmp) |= SvUTF8(sv);
+
+           tmp_he
+               = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, 
+                                        sv_2mortal(newSVpvs("open>")), tmp);
+
+           /* The UTF-8 setting is carried over  */
+           sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
+
            PL_compiling.cop_hints_hash
-               = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
-                                        sv_2mortal(newSVpvs("open")), sv);
+               = Perl_refcounted_he_new(aTHX_ tmp_he,
+                                        sv_2mortal(newSVpvs("open<")), tmp);
        }
        break;
     case '\020':       /* ^P */

diff --git a/perl.h b/perl.h
index 6104c63..61856e1 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4369,7 +4369,8 @@ enum {            /* pass one of these to get_vtbl */
 #define HINT_NEW_STRING                0x00008000
 #define HINT_NEW_RE            0x00010000
 #define HINT_LOCALIZE_HH       0x00020000 /* %^H needs to be copied */
-#define HINT_LEXICAL_IO                0x00040000 /* ${^OPEN} is set */
+#define HINT_LEXICAL_IO_IN     0x00040000 /* ${^OPEN} is set for input */
+#define HINT_LEXICAL_IO_OUT    0x00080000 /* ${^OPEN} is set for output */
 
 #define HINT_RE_TAINT          0x00100000 /* re pragma */
 #define HINT_RE_EVAL           0x00200000 /* re pragma */

diff --git a/perlio.c b/perlio.c
index 9586750..30f54ec 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -5114,30 +5114,30 @@ const char *
 Perl_PerlIO_context_layers(pTHX_ const char *mode)
 {
     dVAR;
-    const char *type = NULL;
+    const char *direction = NULL;
+    SV *layers;
     /*
      * Need to supply default layer info from open.pm
      */
-    if (PL_curcop && PL_curcop->cop_hints & HINT_LEXICAL_IO) {
-       SV * const layers
-           = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
-                                      "open", 4, 0, 0);
-       assert(layers);
-       if (SvOK(layers)) {
-           STRLEN len;
-           type = SvPV_const(layers, len);
-           if (type && mode && mode[0] != 'r') {
-               /*
-                * Skip to write part, which is separated by a '\0'
-                */
-               STRLEN read_len = strlen(type);
-               if (read_len < len) {
-                   type += read_len + 1;
-               }
-           }
-       }
+
+    if (!PL_curcop)
+       return NULL;
+
+    if (mode && mode[0] != 'r') {
+       if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
+           direction = "open>";
+    } else {
+       if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
+           direction = "open<";
     }
-    return type;
+    if (!direction)
+       return NULL;
+
+    layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+                                     0, direction, 5, 0, 0);
+
+    assert(layers);
+    return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
 }
 
 

diff --git a/proto.h b/proto.h
index ae03e11..cd7bfe3 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4602,6 +4602,11 @@ PERL_CALLCONV int        Perl_signbit(NV f)
 
 #endif
 
+PERL_CALLCONV void     Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet: