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

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

p4raw-id: //depot/perl@34831

diff --git a/embedvar.h b/embedvar.h
index 877dd28..6ea599f 100644 (file)
--- 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 63b9746..a6896bb 100644 (file)
--- 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 69d80d7..8226386 100644 (file)
--- 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 5bf82f2..f278e37 100644 (file)
--- 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 0a8d105..e5c9e3b 100644 (file)
--- 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 a9cffbf..6f4cc58 100644 (file)
--- 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 2489917..3876a78 100644 (file)
--- 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 4578824..b913b53 100644 (file)
--- 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 e22502f..a60a176 100644 (file)
--- 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 bae7604..efa347b 100644 (file)
--- 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 5ea2cda..51c8484 100755 (executable)
--- 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