diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | mg.c | 12 | ||||
| -rw-r--r-- | op.c | 2 | ||||
| -rw-r--r-- | pad.c | 10 | ||||
| -rw-r--r-- | perl.c | 5 | ||||
| -rw-r--r-- | pp_hot.c | 2 | ||||
| -rw-r--r-- | pp_sys.c | 3 | ||||
| -rw-r--r-- | regcomp.c | 15 | ||||
| -rw-r--r-- | sv.c | 3 | ||||
| -rwxr-xr-x | t/op/closure.t | 17 | ||||
| -rwxr-xr-x | t/op/gv.t | 77 | ||||
| -rw-r--r-- | t/op/length.t | 15 | ||||
| -rw-r--r-- | t/uni/tie.t | 49 |
13 files changed, 185 insertions, 26 deletions
@@ -3940,6 +3940,7 @@ t/uni/upper.t See if Unicode casing works t/uni/write.t See if Unicode formats work t/win32/system.t See if system works in Win* t/win32/system_tests Test runner for system.t +t/uni/tie.t See if Unicode tie works t/x2p/s2p.t See if s2p/psed work uconfig.h Configuration header for microperl uconfig.sh Configuration script for microperl @@ -308,12 +308,15 @@ Perl_mg_length(pTHX_ SV *sv) } } - if (DO_UTF8(sv)) { + { + /* You can't know whether it's UTF-8 until you get the string again... + */ const U8 *s = (U8*)SvPV_const(sv, len); - len = utf8_length(s, s + len); + + if (DO_UTF8(sv)) { + len = utf8_length(s, s + len); + } } - else - (void)SvPV_const(sv, len); return len; } @@ -497,6 +500,7 @@ Perl_mg_free(pTHX_ SV *sv) if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); + SvMAGIC_set(sv, moremagic); } SvMAGIC_set(sv, NULL); return 0; @@ -8463,7 +8463,7 @@ Perl_peep(pTHX_ register OP *o) UNOP *refgen, *rv2cv; LISTOP *exlist; - if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID) + if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID) break; if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) @@ -1494,17 +1494,17 @@ Perl_cv_clone(pTHX_ CV *proto) if (SvFAKE(namesv)) { /* lexical from outside? */ sv = outpad[PARENT_PAD_INDEX(namesv)]; assert(sv); - /* formats may have an inactive parent */ - if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) { + /* formats may have an inactive parent, + while my $x if $false can leave an active var marked as + stale */ + if (SvPADSTALE(sv)) { if (ckWARN(WARN_CLOSURE)) Perl_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%s\" is not available", SvPVX_const(namesv)); sv = NULL; } - /* 'my $x if $y' can leave $x stale even in an active sub */ - else if (!SvPADSTALE(sv)) { + else SvREFCNT_inc_simple_void_NN(sv); - } } if (!sv) { const char sigil = SvPVX_const(namesv)[0]; @@ -1223,7 +1223,8 @@ perl_destruct(pTHXx) " flags=0x%"UVxf " refcnt=%"UVuf pTHX__FORMAT "\n" "\tallocated at %s:%d %s %s%s\n", - (void*)sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE, + (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt + pTHX__VALUE, sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", sv->sv_debug_line, sv->sv_debug_inpad ? "for" : "by", @@ -2620,7 +2621,9 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) Zero(&method_op, 1, UNOP); method_op.op_next = PL_op; method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; + method_op.op_type = OP_METHOD; myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + myop.op_type = OP_ENTERSUB; PL_op = (OP*)&method_op; } @@ -2025,7 +2025,7 @@ PP(pp_subst) I32 maxiters; register I32 i; bool once; - bool rxtainted; + U8 rxtainted; char *orig; I32 r_flags; register REGEXP *rx = PM_GETRE(pm); @@ -2999,10 +2999,9 @@ PP(pp_ftrread) effective = TRUE; break; - case OP_FTEEXEC: #ifdef PERL_EFF_ACCESS - access_mode = W_OK; + access_mode = X_OK; #else use_access = 0; #endif @@ -9372,6 +9372,7 @@ Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) dVAR; regexp *ret; I32 npar; + U32 precomp_offset; if (!r) return (REGEXP *)NULL; @@ -9394,7 +9395,9 @@ Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) /* Do it this way to avoid reading from *r after the StructCopy(). That way, if any of the sv_dup_inc()s dislodge *r from the L1 cache, it doesn't matter. */ - const bool anchored = r->check_substr == r->anchored_substr; + const bool anchored = r->check_substr + ? r->check_substr == r->anchored_substr + : r->check_utf8 == r->anchored_utf8; Newx(ret->substrs, 1, struct reg_substr_data); StructCopy(r->substrs, ret->substrs, struct reg_substr_data); @@ -9417,11 +9420,19 @@ Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) ret->check_substr = ret->float_substr; ret->check_utf8 = ret->float_utf8; } + } else if (ret->check_utf8) { + if (anchored) { + ret->check_utf8 = ret->anchored_utf8; + } else { + ret->check_utf8 = ret->float_utf8; + } } } + precomp_offset = RX_PRECOMP(ret) - ret->wrapped; + RXp_WRAPPED(ret) = SAVEPVN(RXp_WRAPPED(ret), RXp_WRAPLEN(ret)+1); - RX_PRECOMP(ret) = ret->wrapped + (RX_PRECOMP(ret) - ret->wrapped); + RX_PRECOMP(ret) = ret->wrapped + precomp_offset; ret->paren_names = hv_dup_inc(ret->paren_names, param); if (ret->pprivate) @@ -7635,7 +7635,8 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) else Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); } - if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) + if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) + || isGV_with_GP(sv)) Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_NAME(PL_op)); s = sv_2pv_flags(sv, &len, flags); diff --git a/t/op/closure.t b/t/op/closure.t index 7d8df6a2cc..d1cab953a5 100755 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -14,7 +14,7 @@ BEGIN { use Config; require './test.pl'; # for runperl() -print "1..187\n"; +print "1..188\n"; my $test = 1; sub test (&) { @@ -688,7 +688,22 @@ __EOF__ test { $flag == 1 }; } +# don't copy a stale lexical; crate a fresh undef one instead +sub f { + my $x if $_[0]; + sub { \$x } +} + +{ + f(1); + my $c1= f(0); + my $c2= f(0); + + my $r1 = $c1->(); + my $r2 = $c2->(); + test { $r1 != $r2 }; +} @@ -12,7 +12,7 @@ BEGIN { use warnings; require './test.pl'; -plan( tests => 161 ); +plan( tests => 178 ); # type coersion on assignment $foo = 'foo'; @@ -377,18 +377,15 @@ is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'spritsits', "Value", "Constant has correct value"); is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob"); -my $result; # Check that assignment to an existing typeglob works { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; - $result = *{"plunk"} = \&{"oonk"}; + *{"plunk"} = []; + *{"plunk"} = \&{"oonk"}; is($w, '', "Should be no warning"); } -is (ref \$result, 'GLOB', - "Non void assignment should still return a typeglob"); - is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'plunk', "Value", "Constant has correct value"); is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); @@ -398,7 +395,7 @@ my $gr = eval '\*plunk' or die; { my $w = ''; local $SIG{__WARN__} = sub { $w = $_[0] }; - $result = *{$gr} = \&{"oonk"}; + *{$gr} = \&{"oonk"}; is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)"); } @@ -406,6 +403,48 @@ is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); is (eval 'plunk', "Value", "Constant has correct value"); is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); +# Non-void context should defeat the optimisation, and will cause the original +# to be promoted (what change 26482 intended) +my $result; +{ + my $w = ''; + local $SIG{__WARN__} = sub { $w = $_[0] }; + $result = *{"awkkkkkk"} = \&{"oonk"}; + is($w, '', "Should be no warning"); +} + +is (ref \$result, 'GLOB', + "Non void assignment should still return a typeglob"); + +is (ref \$::{oonk}, 'GLOB', "This export does affect original"); +is (eval 'plunk', "Value", "Constant has correct value"); +is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); + +delete $::{oonk}; +$::{oonk} = \"Value"; + +sub non_dangling { + my $w = ''; + local $SIG{__WARN__} = sub { $w = $_[0] }; + *{"zap"} = \&{"oonk"}; + is($w, '', "Should be no warning"); +} + +non_dangling(); +is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); +is (eval 'zap', "Value", "Constant has correct value"); +is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS"); + +sub dangling { + local $SIG{__WARN__} = sub { die $_[0] }; + *{"biff"} = \&{"oonk"}; +} + +dangling(); +is (ref \$::{oonk}, 'GLOB', "This export does affect original"); +is (eval 'biff', "Value", "Constant has correct value"); +is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob"); + { use vars qw($glook $smek $foof); # Check reference assignment isn't affected by the SV type (bug #38439) @@ -494,6 +533,30 @@ foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { "Assigment works when glob created midway (bug 45607)"); 1' or die $@; } + +# For now these tests are here, but they would probably be better in a file for +# tests for croaks. (And in turn, that probably deserves to be in a different +# directory. Gerard Goossen has a point about the layout being unclear + +sub coerce_integer { + no warnings 'numeric'; + $_[0] |= 0; +} +sub coerce_number { + no warnings 'numeric'; + $_[0] += 0; +} +sub coerce_string { + $_[0] .= ''; +} + +foreach my $type (qw(integer number string)) { + my $prog = "coerce_$type(*STDERR)"; + is (scalar eval "$prog; 1", undef, "$prog failed..."); + like ($@, qr/Can't coerce GLOB to $type in/, + "with the correct error message"); +} + __END__ Perl Rules diff --git a/t/op/length.t b/t/op/length.t index 0c444840e5..41d34aee8e 100644 --- a/t/op/length.t +++ b/t/op/length.t @@ -2,10 +2,11 @@ BEGIN { chdir 't' if -d 't'; + require './test.pl'; @INC = '../lib'; } -print "1..20\n"; +plan (tests => 22); print "not " unless length("") == 0; print "ok 1\n"; @@ -148,3 +149,15 @@ print "ok 3\n"; substr($a, 0, 1) = ''; print length $a == 998 ? "ok 20\n" : "not ok 20\n"; } + +curr_test(21); + +require Tie::Scalar; + +$u = "ASCII"; + +tie $u, 'Tie::StdScalar', chr 256; + +is(length $u, 1, "Length of a UTF-8 scalar returned from tie"); +is(length $u, 1, "Again! Again!"); + diff --git a/t/uni/tie.t b/t/uni/tie.t new file mode 100644 index 0000000000..fa9f268bbf --- /dev/null +++ b/t/uni/tie.t @@ -0,0 +1,49 @@ +#!perl -w + +BEGIN { + if ($ENV{'PERL_CORE'}){ + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 9; +use strict; + +{ + package UTF8Toggle; + + sub TIESCALAR { + my $class = shift; + my $value = shift; + my $state = shift||0; + return bless [$value, $state], $class; + } + + sub FETCH { + my $self = shift; + $self->[1] = ! $self->[1]; + if ($self->[1]) { + utf8::downgrade($self->[0]); + } else { + utf8::upgrade($self->[0]); + } + $self->[0]; + } +} + +foreach my $t ("ASCII", "B\366se") { + my $length = length $t; + + my $u; + tie $u, 'UTF8Toggle', $t; + is (length $u, $length, "length of '$t'"); + is (length $u, $length, "length of '$t'"); + is (length $u, $length, "length of '$t'"); + is (length $u, $length, "length of '$t'"); +} + +{ + local $TODO = "Need more tests!"; + fail(); +} |