[perl #948] [PATCH] Allow tied $,

Message-ID: <20081114084436.GJ5779@tytlal.topaz.cx>

p4raw-id: //depot/perl@34831

11 files changed, 21 insertions, 33 deletions

diff --git a/embedvar.h b/embedvar.h
index 877dd289aa..6ea599f972 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -211,7 +211,7 @@
 #define PL_numeric_name		(vTHX->Inumeric_name)
 #define PL_numeric_radix_sv	(vTHX->Inumeric_radix_sv)
 #define PL_numeric_standard	(vTHX->Inumeric_standard)
-#define PL_ofs_sv		(vTHX->Iofs_sv)
+#define PL_ofsgv		(vTHX->Iofsgv)
 #define PL_oldname		(vTHX->Ioldname)
 #define PL_op			(vTHX->Iop)
 #define PL_op_mask		(vTHX->Iop_mask)
@@ -523,7 +523,7 @@
 #define PL_Inumeric_name	PL_numeric_name
 #define PL_Inumeric_radix_sv	PL_numeric_radix_sv
 #define PL_Inumeric_standard	PL_numeric_standard
-#define PL_Iofs_sv		PL_ofs_sv
+#define PL_Iofsgv		PL_ofsgv
 #define PL_Ioldname		PL_oldname
 #define PL_Iop			PL_op
 #define PL_Iop_mask		PL_op_mask
diff --git a/ext/Devel/PPPort/parts/apidoc.fnc b/ext/Devel/PPPort/parts/apidoc.fnc
index 63b97468b8..a6896bbb61 100644
--- a/ext/Devel/PPPort/parts/apidoc.fnc
+++ b/ext/Devel/PPPort/parts/apidoc.fnc
@@ -302,7 +302,7 @@ mn|GV *|PL_DBsub
 mn|GV*|PL_last_in_gv
 mn|SV *|PL_DBsingle
 mn|SV *|PL_DBtrace
-mn|SV*|PL_ofs_sv
+mn|GV*|PL_ofsgv
 mn|SV*|PL_rs
 ms||djSP
 m|STRLEN|PAD_COMPNAME_GEN|PADOFFSET po
diff --git a/ext/XS/APItest/t/svpeek.t b/ext/XS/APItest/t/svpeek.t
index 69d80d7583..822638648e 100644
--- a/ext/XS/APItest/t/svpeek.t
+++ b/ext/XS/APItest/t/svpeek.t
@@ -21,7 +21,7 @@ $| = 1;
   is (DPeek ($/),    'PVMG("\n"\0)',		'$/');
   is (DPeek ($\),    'PVMG()',			'$\\');
   is (DPeek ($.),    'PVMG()',			'$.');
-  is (DPeek ($,),    'PVMG()',			'$,');
+  is (DPeek ($,),    'UNDEF',			'$,');
   is (DPeek ($;),    'PV("\34"\0)',		'$;');
   is (DPeek ($"),    'PV(" "\0)',		'$"');
   is (DPeek ($:),    'PVMG(" \n-"\0)',		'$:');
diff --git a/gv.c b/gv.c
index 5bf82f2255..f278e37ce5 100644
--- a/gv.c
+++ b/gv.c
@@ -1409,7 +1409,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	case ')':
 	case '<':
 	case '>':
-	case ',':
 	case '\\':
 	case '/':
 	case '\001':	/* $^A */
@@ -2328,7 +2327,6 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
 	case ')':
 	case '<':
 	case '>':
-	case ',':
 	case '\\':
 	case '/':
 	case '|':
diff --git a/intrpvar.h b/intrpvar.h
index 0a8d10552f..e5c9e3bed1 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -102,16 +102,16 @@ The input record separator - C<$/> in Perl space.
 
 The GV which was last used for a filehandle input operation. (C<< <FH> >>)
 
-=for apidoc mn|SV*|PL_ofs_sv
+=for apidoc mn|GV*|PL_ofsgv
 
-The output field separator - C<$,> in Perl space.
+The glob containing the output field separator - C<*,> in Perl space.
 
 =cut
 */
 
 PERLVAR(Irs,		SV *)		/* input record separator $/ */
 PERLVAR(Ilast_in_gv,	GV *)		/* GV used in last <FH> */
-PERLVAR(Iofs_sv,	SV *)		/* output field separator $, */
+PERLVAR(Iofsgv,		GV *)		/* GV of output field separator *, */
 PERLVAR(Idefoutgv,	GV *)		/* default FH for output */
 PERLVARI(Ichopset,	const char *, " \n-")	/* $: */
 PERLVAR(Iformtarget,	SV *)
diff --git a/mg.c b/mg.c
index a9cffbf426..6f4cc5805b 100644
--- a/mg.c
+++ b/mg.c
@@ -1026,8 +1026,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	if (GvIOp(PL_defoutgv))
 	    sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 	break;
-    case ',':
-	break;
     case '\\':
 	if (PL_ors_sv)
 	    sv_copypv(sv, PL_ors_sv);
@@ -2604,16 +2602,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    PL_ors_sv = NULL;
 	}
 	break;
-    case ',':
-	if (PL_ofs_sv)
-	    SvREFCNT_dec(PL_ofs_sv);
-	if (SvOK(sv) || SvGMAGICAL(sv)) {
-	    PL_ofs_sv = newSVsv(sv);
-	}
-	else {
-	    PL_ofs_sv = NULL;
-	}
-	break;
     case '[':
 	CopARYBASE_set(&PL_compiling, SvIV(sv));
 	break;
diff --git a/perl.c b/perl.c
index 24899175b8..3876a7833b 100644
--- a/perl.c
+++ b/perl.c
@@ -946,8 +946,8 @@ perl_destruct(pTHXx)
 
     /* magical thingies */
 
-    SvREFCNT_dec(PL_ofs_sv);	/* $, */
-    PL_ofs_sv = NULL;
+    SvREFCNT_dec(PL_ofsgv);	/* *, */
+    PL_ofsgv = NULL;
 
     SvREFCNT_dec(PL_ors_sv);	/* $\ */
     PL_ors_sv = NULL;
@@ -4551,6 +4551,8 @@ S_init_predump_symbols(pTHX)
     IO *io;
 
     sv_setpvs(get_sv("\"", TRUE), " ");
+    PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
+
     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
     GvMULTI_on(PL_stdingv);
     io = GvIOp(PL_stdingv);
diff --git a/perlapi.h b/perlapi.h
index 4578824afc..b913b532bd 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -458,8 +458,8 @@ END_EXTERN_C
 #define PL_numeric_radix_sv	(*Perl_Inumeric_radix_sv_ptr(aTHX))
 #undef  PL_numeric_standard
 #define PL_numeric_standard	(*Perl_Inumeric_standard_ptr(aTHX))
-#undef  PL_ofs_sv
-#define PL_ofs_sv		(*Perl_Iofs_sv_ptr(aTHX))
+#undef  PL_ofsgv
+#define PL_ofsgv		(*Perl_Iofsgv_ptr(aTHX))
 #undef  PL_oldname
 #define PL_oldname		(*Perl_Ioldname_ptr(aTHX))
 #undef  PL_op
diff --git a/pp_hot.c b/pp_hot.c
index e22502f6ff..a60a176750 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -753,14 +753,16 @@ PP(pp_print)
 	goto just_say_no;
     }
     else {
+	SV * const ofs = GvSV(PL_ofsgv); /* $, */
 	MARK++;
-	if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
+	if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
 	    while (MARK <= SP) {
 		if (!do_print(*MARK, fp))
 		    break;
 		MARK++;
 		if (MARK <= SP) {
-		    if (!do_print(PL_ofs_sv, fp)) { /* $, */
+		    /* don't use 'ofs' here - it may be invalidated by magic callbacks */
+		    if (!do_print(GvSV(PL_ofsgv), fp)) {
 			MARK--;
 			break;
 		    }
diff --git a/sv.c b/sv.c
index bae7604f66..efa347b9c6 100644
--- a/sv.c
+++ b/sv.c
@@ -11761,6 +11761,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_regex_pad = AvARRAY(PL_regex_padav);
 
     /* shortcuts to various I/O objects */
+    PL_ofsgv            = gv_dup(proto_perl->Iofsgv, param);
     PL_stdingv		= gv_dup(proto_perl->Istdingv, param);
     PL_stderrgv		= gv_dup(proto_perl->Istderrgv, param);
     PL_defgv		= gv_dup(proto_perl->Idefgv, param);
@@ -12107,7 +12108,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_curpm		= proto_perl->Icurpm;	/* XXX No PMOP ref count */
     PL_rs		= sv_dup_inc(proto_perl->Irs, param);
     PL_last_in_gv	= gv_dup(proto_perl->Ilast_in_gv, param);
-    PL_ofs_sv		= sv_dup_inc(proto_perl->Iofs_sv, param);
     PL_defoutgv		= gv_dup_inc(proto_perl->Idefoutgv, param);
     PL_chopset		= proto_perl->Ichopset;	/* XXX never deallocated */
     PL_toptarget	= sv_dup_inc(proto_perl->Itoptarget, param);
diff --git a/t/op/tie.t b/t/op/tie.t
index 5ea2cda7a1..51c84845bf 100755
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -447,7 +447,7 @@ EXPECT
 ok
 ########
 
-# TODO [perl #948] cannot meaningfully tie $,
+# [perl #948] cannot meaningfully tie $,
 package TieDollarComma;
 
 sub TIESCALAR {
@@ -463,7 +463,7 @@ sub STORE {
 
 sub FETCH {
     my $self = shift;
-    print "FETCH\n";
+    print "<FETCH>";
     return $$self;
 }
 package main;
@@ -473,9 +473,7 @@ $, = 'BOBBINS';
 print "join", "things", "up\n";
 EXPECT
 STORE set 'BOBBINS'
-FETCH
-FETCH
-joinBOBBINSthingsBOBBINSup
+join<FETCH>BOBBINSthings<FETCH>BOBBINSup
 ########
 
 # test SCALAR method