Re: [ID 20000807.008] Double reads considered evil? (deja vu)

Message-Id: <E13MAj1-00038W-00@libra.cus.cam.ac.uk>

p4raw-id: //depot/perl@6552

diff --git a/doop.c b/doop.c
index 39d050b..074be99 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -487,7 +487,7 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s
     (void)SvUPGRADE(sv, SVt_PV);
     if (SvLEN(sv) < len + items) {     /* current length is way too short */
        while (items-- > 0) {
-           if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) {
+           if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
                SvPV(*mark, tmplen);
                len += tmplen;
            }

diff --git a/sv.h b/sv.h
index d242bf5..5500d2b 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -612,6 +612,8 @@ Set the length of the string which is in the SV.  See C<SvCUR>.
 #define SvAMAGIC_on(sv)                (SvFLAGS(sv) |= SVf_AMAGIC)
 #define SvAMAGIC_off(sv)       (SvFLAGS(sv) &= ~SVf_AMAGIC)
 
+#define SvGAMAGIC(sv)           (SvFLAGS(sv) & (SVs_GMG|SVf_AMAGIC)) 
+
 /*
 #define Gv_AMG(stash) \
         (HV_AMAGICmb(stash) && \

diff --git a/t/op/join.t b/t/op/join.t
index def5a9e..b50878e 100755 (executable)
--- a/t/op/join.t
+++ b/t/op/join.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..6\n";
+print "1..10\n";
 
 @x = (1, 2, 3);
 if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
@@ -20,3 +20,27 @@ if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";}
 $f = 'a';
 $f = join $f, 'b', 'e', 'k';
 if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";}
+
+# 7,8 check for multiple read of tied objects
+{ package X;
+  sub TIESCALAR { my $x = 7; bless \$x };
+  sub FETCH { my $y = shift; $$y += 5 };
+  tie my $t, 'X';
+  my $r = join ':', $t, 99, $t, 99;
+  print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99';
+  print "ok 7\n";
+  $r = join '', $t, 99, $t, 99;
+  print "# expected '22992799' got '$r'\nnot " if $r ne '22992799';
+  print "ok 8\n";
+};
+
+# 9,10 and for multiple read of undef
+{ my $s = 5;
+  local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } );
+  my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c';
+  print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c';
+  print "ok 9\n";
+  my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c';
+  print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c';
+  print "ok 10\n";
+};

diff --git a/t/pragma/overload.t b/t/pragma/overload.t
index 78ca147..a5949b6 100755 (executable)
--- a/t/pragma/overload.t
+++ b/t/pragma/overload.t
@@ -919,14 +919,21 @@ test $bar->[3], 13;               # 206
 my $aaa;
 { my $bbbb = 0; $aaa = bless \$bbbb, B }
 
-test !$aaa, 1;
+test !$aaa, 1;                 # 207
 
 unless ($aaa) {
-  test 'ok', 'ok';
+  test 'ok', 'ok';             # 208
 } else {
-  test 'is not', 'ok';
+  test 'is not', 'ok';         # 208
 }
 
+# check that overload isn't done twice by join
+{ my $c = 0;
+  package Join;
+  use overload '""' => sub { $c++ };
+  my $x = join '', bless([]), 'pq', bless([]);
+  main::test $x, '0pq1';               # 209
+};
 
 # Last test is:
-sub last {208}
+sub last {209}