New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
$, untieable? #143
Comments
From @Abigail#!/opt/perl/bin/perl -w use strict; print "0: "; print qq {[$"] [$,]}; print "\n"; tie $", 'A'; sub A::TIESCALAR {bless \my $x, 'A'} my @a = ("") x 5; __END__ 0: [ ] [,] Why can I tie (Perl 5.005_57 gives the same output) Abigail Perl Info
|
From @floatingatoll[abigail@delanet.com - Thu Jul 1 12:09:24 1999]:
This has been fixed as of bleadperl, @18374. Thanks for the report! |
@floatingatoll - Status changed from 'open' to 'resolved' |
From @Abigail[coral - Sun Jul 6 15:54:50 2003]:
Actually, it's only partially fixed. You can tie $, now, but it only Again my original program: #!/opt/perl/5.9.0/bin/perl -w use strict; print "0: "; print qq {[$"] [$,]}; print "\n"; tie $", 'A'; sub A::TIESCALAR {bless \my $x, 'A'} my @a = ("") x 5; Running this gives: 0: [ ] [,] We see here from the last line that if we access That was my original bugreport, and I don't think patch 18374 fixed it. Abigail |
From @Abigail[coral - Sun Jul 6 15:54:50 2003]:
Actually, it's only partially fixed. You can tie $, now, but it only Again my original program: #!/opt/perl/5.9.0/bin/perl -w use strict; print "0: "; print qq {[$"] [$,]}; print "\n"; tie $", 'A'; sub A::TIESCALAR {bless \my $x, 'A'} my @a = ("") x 5; 0: [ ] [,] We see here from the last line that if we access That was my original bugreport, and I don't think patch 18374 fixed it. Abigail |
From @Abigail[I tried sending this earlier today with the bugs.perl.com website, but [coral - Sun Jul 6 15:54:50 2003]:
Actually, it's only partially fixed. You can tie $, now, but it only Again my original program: #!/opt/perl/5.9.0/bin/perl -w use strict; print "0: "; print qq {[$"] [$,]}; print "\n"; tie $", 'A'; sub A::TIESCALAR {bless \my $x, 'A'} my @a = ("") x 5; 0: [ ] [,] We see here from the last line that if we access That was my original bugreport, and I don't think patch 18374 fixed it. I don't think bug #948 has been resolved, and I think it should be Abigail |
From @nwc10On Mon, Oct 20, 2003 at 11:42:55PM +0200, Abigail wrote:
It's now open again. I believe you caused this by sending a message As to the bug itself, at this time I have no ideas. Nicholas Clark |
From @richardcOn Mon, Oct 20, 2003 at 11:42:55PM +0200, Abigail wrote:
Robert points out that this falls under my domain. WebRT will only I'll add it to the FAQ at some point RSN, I promise. Further I pulled on my hat further and tried to cook this down into a Thanks
As Nicholas has pointed out already, the simple act of attaching -- |
From @richardcInline Patchdiff -urb bleadperl/t/op/tie.t bleadperl_hck/t/op/tie.t
--- bleadperl/t/op/tie.t 2003-09-05 06:31:40.000000000 +0100
+++ bleadperl_hck/t/op/tie.t 2003-10-20 23:47:31.000000000 +0100
@@ -446,3 +446,34 @@
}
EXPECT
ok
+########
+
+# TODO [perl #948] cannot meaningfully tie $,
+package TieDollarComma;
+
+sub TIESCALAR {
+ my $pkg = shift;
+ return bless \my $x, $pkg;
+}
+
+sub STORE {
+ my $self = shift;
+ $$self = shift;
+ print "STORE set '$$self'\n";
+}
+
+sub FETCH {
+ my $self = shift;
+ print "FETCH\n";
+ return $$self;
+}
+package main;
+
+tie $,, 'TieDollarComma';
+$, = 'BOBBINS';
+print "join", "things", "up\n";
+EXPECT
+STORE set 'BOBBINS'
+FETCH
+FETCH
+joinBOBBINSthingsBOBBINSup |
From @rgsRichard Clamp wrote:
Thanks, applied as #21532, along with a small fix to t/TEST so it |
From avorobey@pobox.comI attach a one-line patch that seems OK to me, but should really be When we update Note that this doesn't pass the test, but arguably the test is wrong: it |
From avorobey@pobox.comInline Patch--- perl-5.9.4-orig/mg.c 2006-08-15 15:37:41.000000000 +0300
+++ perl-5.9.4/mg.c 2006-10-09 14:24:13.000000000 +0200
@@ -2377,7 +2377,7 @@
if (PL_ofs_sv)
SvREFCNT_dec(PL_ofs_sv);
if (SvOK(sv) || SvGMAGICAL(sv)) {
- PL_ofs_sv = newSVsv(sv);
+ PL_ofs_sv = SvREFCNT_inc(sv);
}
else {
PL_ofs_sv = NULL; |
From @chipdude(Yes, bug #948. Kickin' it old school today.) Abigail long ago observed that Advanced students of the Perl guts will recognize that this change will have This patch has two additional points of interest. First, while an undef normal value for $, is allowed without warning, if a Second, a tied $, is fetched once per use, rather than once per print. This Share & Enjoy! Inline Patch
Chip Salzenberg <chip@pobox.com> |
From @TuxOn Thu, 13 Nov 2008 16:38:29 -0800, Chip Salzenberg <chip@pobox.com>
It is really wonderful to see you dig in like this! :) Do you still have your commits? I don't think the community would
-- |
From @chipdudeOn Fri, Nov 14, 2008 at 08:43:00AM +0100, H.Merijn Brand wrote:
One never forgets, apparently; rather like a bicycle, or a conditioned
There is a test in RT. I'll add it to the next version of the patch.
Due to bit rot of various kinds, I haven't had perforce commit access for a |
From @chipdudeOn Fri, Nov 14, 2008 at 12:12:59AM -0800, Chip Salzenberg wrote:
Actually it turns out the test had already been applied in t/op/tie.t, but Here's the new patch. I think this is ready to go. Inline Patchdiff --git a/embedvar.h b/embedvar.h
index 877dd28..6ea599f 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 63b9746..a6896bb 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 69d80d7..8226386 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 5bf82f2..f278e37 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 0a8d105..e5c9e3b 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 a9cffbf..6f4cc58 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 2489917..3876a78 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 4578824..b913b53 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 9615c46..5530c17 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 e9a384b..6083651 100644
--- a/sv.c
+++ b/sv.c
@@ -11737,6 +11737,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);
@@ -12083,7 +12084,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
--- 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
-- Chip Salzenberg <chip@pobox.com> |
From @AbigailOn Fri, Nov 14, 2008 at 12:44:36AM -0800, Chip Salzenberg wrote:
Congrats! I think this was the oldest open perl5 bug in the RT system, I can now pass the 'honour' of having reported the oldest open perl5 Too bad I can't remember what JAPH I wanted to write when I stumbled Abigail |
From @chipdudeOn Fri, Nov 14, 2008 at 10:55:02AM +0100, Abigail wrote:
At this rate, I should have the queue cleared out in a year or so.
And on that bug, I've asked for clarification on whether that fix absolutely
Well, nothing's stopping you from making a new one... :-) |
From @TuxOn Fri, 14 Nov 2008 00:44:36 -0800, Chip Salzenberg <chip@pobox.com>
Thanks, applied as change #34831
-- |
From @mhxOn 2008-11-14, at 13:37:52 +0100, H.Merijn Brand wrote:
Please, don't patch Devel::PPPort until it's really broken. This file is regenerated only from time to time, usually (No need to revert that part, it'll be fixed with the next Thanks, PS: Once more, very nice fix! :) [1] Even though the note is slightly wrong: it points -- |
@smpeters - Status changed from 'open' to 'resolved' |
From @chipdudeOn Fri, Nov 14, 2008 at 02:52:41PM +0100, Marcus Holland-Moritz wrote:
D'oh. Shall (not) do.
If I had access, though, I would revert it. No point in confusing the |
Migrated from rt.perl.org#948 (status was 'resolved')
Searchable as RT948$
The text was updated successfully, but these errors were encountered: