X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=b9b2ca288ab704817f719e1653fe8f348d5e37fe;hb=5b6782b28b8a9d505447276bdd3de3a802f641dd;hp=a3e0f26b4b2558e1343ae65bfa1b5ac2839220fb;hpb=2b1b43eab3a253674c13d1ea253f3b0a85b45a0d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mg.c b/mg.c
index a3e0f26..b9b2ca2 100644
--- 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':		
@@ -863,7 +882,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 		 * XXX Does the new way break anything?
 		 */
 		paren = atoi(mg->mg_ptr); /* $& is in [0] */
-		reg_numbered_buff_get( paren, rx, sv, 0);
+		CALLREG_NUMBUF(rx,paren,sv);
 		break;
 	    }
 	    sv_setsv(sv,&PL_sv_undef);
@@ -872,7 +891,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '+':
 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 	    if (rx->lastparen) {
-	        reg_numbered_buff_get( rx->lastparen, rx, sv, 0);
+	        CALLREG_NUMBUF(rx,rx->lastparen,sv);
 	        break;
 	    }
 	}
@@ -881,7 +900,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '\016':		/* ^N */
 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 	    if (rx->lastcloseparen) {
-	        reg_numbered_buff_get( rx->lastcloseparen, rx, sv, 0);
+	        CALLREG_NUMBUF(rx,rx->lastcloseparen,sv);
 	        break;
 	    }
 
@@ -891,16 +910,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '`':
       do_prematch_fetch:
 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-	  reg_numbered_buff_get( -2, rx, sv, 0);
-	  break;
+	    CALLREG_NUMBUF(rx,-2,sv);
+	    break;
 	}
 	sv_setsv(sv,&PL_sv_undef);
 	break;
     case '\'':
       do_postmatch_fetch:
 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-	  reg_numbered_buff_get( -1, rx, sv, 0);
-	  break;
+	    CALLREG_NUMBUF(rx,-1,sv);
+	    break;
 	}
 	sv_setsv(sv,&PL_sv_undef);
 	break;
@@ -1186,7 +1205,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
 #endif
     	    /* cache state so we don't fetch it again */
     	    if(sigstate == (Sighandler_t) SIG_IGN)
-    	    	sv_setpv(sv,"IGNORE");
+    	    	sv_setpvs(sv,"IGNORE");
     	    else
     	    	sv_setsv(sv,&PL_sv_undef);
 	    PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
@@ -1259,6 +1278,19 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+/*
+ * The signal handling nomenclature has gotten a bit confusing since the advent of
+ * safe signals.  S_raise_signal only raises signals by analogy with what the 
+ * underlying system's signal mechanism does.  It might be more proper to say that
+ * it defers signals that have already been raised and caught.  
+ *
+ * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending 
+ * in the sense of being on the system's signal queue in between raising and delivery.  
+ * They are only pending on Perl's deferral list, i.e., they track deferred signals 
+ * awaiting delivery after the current Perl opcode completes and say nothing about
+ * signals raised but not yet caught in the underlying signal implementation.
+ */
+
 #ifndef SIG_PENDING_DIE_COUNT
 #  define SIG_PENDING_DIE_COUNT 120
 #endif
@@ -2241,11 +2273,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 = (const char*)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 */