This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Split the storage of the layers specificied by open.pm into one hint
authorNicholas Clark <nick@ccl4.org>
Sat, 17 Feb 2007 12:39:17 +0000 (12:39 +0000)
committerNicholas Clark <nick@ccl4.org>
Sat, 17 Feb 2007 12:39:17 +0000 (12:39 +0000)
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

embed.fnc
embed.h
ext/B/B.xs
ext/B/B/Concise.pm
ext/B/t/OptreeCheck.pm
mg.c
perl.h
perlio.c
proto.h

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
 #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)
index 02b1efb..d12392f 100644 (file)
@@ -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);
     }
 }
index 8f99abc..46f2fb0 100644 (file)
@@ -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
index 68a6247..47d4a13 100644 (file)
@@ -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 */
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: