In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/21c01741f7906ac8801dc4d13087c6243af2de47?hp=1578dcc9a6e07f8598ff065b64e15481aa6152d0>
- Log ----------------------------------------------------------------- commit 21c01741f7906ac8801dc4d13087c6243af2de47 Author: Father Chrysostomos <[email protected]> Date: Mon Jul 15 19:00:21 2013 -0700 perldelta for #77814 M pod/perldelta.pod commit 96c2a8ff507ccc5e4a6d00051b23e7a73d844322 Author: Father Chrysostomos <[email protected]> Date: Mon Jul 15 18:57:01 2013 -0700 [perl #77814] Make defelems propagate pos When elements of @_ refer to nonexistent hash or array elements, then the magic scalar in $_[0] delegates all set/get actions to the element in represents, vivifying it if needed. pos($_[0]), however, was not delegating the value to the element, but storing it on the magical âdeferred elementâ scalar. M embed.fnc M embed.h M mg.c M pp.c M pp_ctl.c M pp_hot.c M proto.h M regexec.c M sv.c M t/op/pos.t commit d30fb84472a75fa446629f16d12e1ced09787ce4 Author: Father Chrysostomos <[email protected]> Date: Mon Jul 15 00:21:55 2013 -0700 perldelta for vstrings and set-magic M pod/perldelta.pod commit ff44333e5a9d9dca5272bb166df463607ebd3020 Author: Father Chrysostomos <[email protected]> Date: Mon Jul 15 00:05:57 2013 -0700 Make set-magic handle vstrings properly Assigning a vstring to a tied variable would result in a plain string in $_[1] in STORE. Assigning a vstring to a magic deferred element would result in a plain string in the aggregateâs actual element. When magic is invoked, the magic flags are temporarily turned off on the sv so that recursive calls to magic donât happen. This makes it easier to implement functions like Perl_magic_set to read the value of the sv without triggering get-magic. Since vstrings are only considered vstrings when they are SvRMAGICAL, this meant that set-magic would turn vstrings temporarily into plain strings. Subsequent copying (e.g., in STORE) would then fail to copy the vstring magic. This commit changes mg_set to leave the rmagical flag on, since it does not affect the functionaiity of set-magic. M embed.fnc M embed.h M mg.c M proto.h M t/op/tie.t M t/op/ver.t commit f4245ada08d64d9ac0a9bc6c6c17e4d10ddcffc2 Author: Father Chrysostomos <[email protected]> Date: Sat Jul 13 17:57:46 2013 -0700 t/op/array.t: remove âno warnings "deprecated"â The tests using the deprecated feature were removed in e1dccc0d34. M t/op/array.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 6 +++++- embed.h | 4 +++- mg.c | 43 +++++++++++++++++++++++++------------------ pod/perldelta.pod | 11 +++++++++++ pp.c | 6 ++---- pp_ctl.c | 10 ++-------- pp_hot.c | 34 +++++++--------------------------- proto.h | 15 +++++++++++++-- regexec.c | 14 +++----------- sv.c | 18 ++++++++++++++++++ t/op/array.t | 5 ----- t/op/pos.t | 28 +++++++++++++++++++++++++++- t/op/tie.t | 8 ++++++++ t/op/ver.t | 6 +++++- 14 files changed, 129 insertions(+), 79 deletions(-) diff --git a/embed.fnc b/embed.fnc index df387d1..5cbcc08 100644 --- a/embed.fnc +++ b/embed.fnc @@ -842,6 +842,8 @@ Apd |int |mg_copy |NN SV *sv|NN SV *nsv|NULLOK const char *key \ pd |void |mg_localize |NN SV* sv|NN SV* nsv|bool setmagic ApdR |MAGIC* |mg_find |NULLOK const SV* sv|int type ApdR |MAGIC* |mg_findext |NULLOK const SV* sv|int type|NULLOK const MGVTBL *vtbl +: exported for re.pm +EpR |MAGIC* |mg_find_mglob |NN SV* sv Apd |int |mg_free |NN SV* sv Apd |void |mg_free_type |NN SV* sv|int how Apd |int |mg_get |NN SV* sv @@ -1360,6 +1362,8 @@ Apd |void |sv_magic |NN SV *const sv|NULLOK SV *const obj|const int how \ Apd |MAGIC *|sv_magicext |NN SV *const sv|NULLOK SV *const obj|const int how \ |NULLOK const MGVTBL *const vtbl|NULLOK const char *const name \ |const I32 namlen +: exported for re.pm +Ep |MAGIC *|sv_magicext_mglob|NN SV *sv ApdbamR |SV* |sv_mortalcopy |NULLOK SV *const oldsv XpaR |SV* |sv_mortalcopy_flags|NULLOK SV *const oldsv|U32 flags ApdR |SV* |sv_newmortal @@ -1785,7 +1789,7 @@ sM |void |clear_placeholders |NN HV *hv|U32 items #endif #if defined(PERL_IN_MG_C) -s |void |save_magic |I32 mgs_ix|NN SV *sv +s |void |save_magic_flags|I32 mgs_ix|NN SV *sv|U32 flags -s |int |magic_methpack |NN SV *sv|NN const MAGIC *mg|NN SV *meth s |SV* |magic_methcall1|NN SV *sv|NN const MAGIC *mg \ |NN SV *meth|U32 flags \ diff --git a/embed.h b/embed.h index 2fc8466..1550817 100644 --- a/embed.h +++ b/embed.h @@ -857,6 +857,7 @@ #if defined(PERL_CORE) || defined(PERL_EXT) #define av_reify(a) Perl_av_reify(aTHX_ a) #define current_re_engine() Perl_current_re_engine(aTHX) +#define mg_find_mglob(a) Perl_mg_find_mglob(aTHX_ a) #define op_clear(a) Perl_op_clear(aTHX_ a) #define qerror(a) Perl_qerror(aTHX_ a) #define reg_named_buff(a,b,c,d) Perl_reg_named_buff(aTHX_ a,b,c,d) @@ -868,6 +869,7 @@ #define reg_temp_copy(a,b) Perl_reg_temp_copy(aTHX_ a,b) #define regprop(a,b,c) Perl_regprop(aTHX_ a,b,c) #define report_uninit(a) Perl_report_uninit(aTHX_ a) +#define sv_magicext_mglob(a) Perl_sv_magicext_mglob(aTHX_ a) #define validate_proto(a,b,c) Perl_validate_proto(aTHX_ a,b,c) #define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a) #define yylex() Perl_yylex(aTHX) @@ -1395,7 +1397,7 @@ #define magic_methcall1(a,b,c,d,e,f) S_magic_methcall1(aTHX_ a,b,c,d,e,f) #define magic_methpack(a,b,c) S_magic_methpack(aTHX_ a,b,c) #define restore_magic(a) S_restore_magic(aTHX_ a) -#define save_magic(a,b) S_save_magic(aTHX_ a,b) +#define save_magic_flags(a,b,c) S_save_magic_flags(aTHX_ a,b,c) #define unwind_handler_stack(a) S_unwind_handler_stack(aTHX_ a) # endif # if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C) diff --git a/mg.c b/mg.c index 518d108..99169cc 100644 --- a/mg.c +++ b/mg.c @@ -90,13 +90,13 @@ struct magic_state { /* MGS is typedef'ed to struct magic_state in perl.h */ STATIC void -S_save_magic(pTHX_ I32 mgs_ix, SV *sv) +S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) { dVAR; MGS* mgs; bool bumped = FALSE; - PERL_ARGS_ASSERT_SAVE_MAGIC; + PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS; assert(SvMAGICAL(sv)); @@ -120,12 +120,14 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ mgs->mgs_bumped = bumped; - SvMAGICAL_off(sv); + SvFLAGS(sv) &= ~flags; /* Turning READONLY off for a copy-on-write scalar (including shared hash keys) is a bad idea. */ if (!SvIsCOW(sv)) SvREADONLY_off(sv); } +#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG) + /* =for apidoc mg_magical @@ -263,7 +265,7 @@ Perl_mg_set(pTHX_ SV *sv) if (PL_localizing == 2 && sv == DEFSV) return 0; - save_magic(mgs_ix, sv); + save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */ for (mg = SvMAGIC(sv); mg; mg = nextmg) { const MGVTBL* vtbl = mg->mg_virtual; @@ -434,6 +436,21 @@ Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl) return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1); } +MAGIC * +Perl_mg_find_mglob(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_MG_FIND_MGLOB; + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { + /* This sv is only a delegate. //g magic must be attached to + its target. */ + vivify_defelem(sv); + sv = LvTARG(sv); + } + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) + return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0); + return NULL; +} + /* =for apidoc mg_copy @@ -2074,19 +2091,17 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) { dVAR; SV* const lsv = LvTARG(sv); + MAGIC * const found = mg_find_mglob(lsv); PERL_ARGS_ASSERT_MAGIC_GETPOS; PERL_UNUSED_ARG(mg); - if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { - MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global); - if (found && found->mg_len >= 0) { + if (found && found->mg_len >= 0) { I32 i = found->mg_len; if (DO_UTF8(lsv)) sv_pos_b2u(lsv, &i); sv_setiv(sv, i); return 0; - } } SvOK_off(sv); return 0; @@ -2106,19 +2121,11 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETPOS; PERL_UNUSED_ARG(mg); - if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) - found = mg_find(lsv, PERL_MAGIC_regex_global); - else - found = NULL; + found = mg_find_mglob(lsv); if (!found) { if (!SvOK(sv)) return 0; -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(lsv)) - sv_force_normal_flags(lsv, 0); -#endif - found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, - NULL, 0); + found = sv_magicext_mglob(lsv); } else if (!SvOK(sv)) { found->mg_len = -1; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index e33c001..ef8d64a 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -618,6 +618,17 @@ Under copy-on-write builds (the default as of 5.19.1) C<${'_<-e'}[0]> no longer gets mangled. This is the first line of input saved for the debugger's use for one-liners [perl #118627]. +=item * + +Assigning a vstring to a tied variable or to a subroutine argument aliased +to a nonexistent hash or array element now works, without flattening the +vstring into a regular string. + +=item * + +C<pos> did not work properly on subroutine arguments aliased to nonexistent +hash and array elements [perl #77814]. + =back =head1 Known Problems diff --git a/pp.c b/pp.c index e7e06ff..1aaeefc 100644 --- a/pp.c +++ b/pp.c @@ -438,8 +438,7 @@ PP(pp_pos) RETURN; } else { - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global); + const MAGIC * const mg = mg_find_mglob(sv); if (mg && mg->mg_len >= 0) { dTARGET; I32 i = mg->mg_len; @@ -448,8 +447,7 @@ PP(pp_pos) PUSHi(i); RETURN; } - } - RETPUSHUNDEF; + RETPUSHUNDEF; } } diff --git a/pp_ctl.c b/pp_ctl.c index d8f63b7..d611c4c 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -325,14 +325,8 @@ PP(pp_substcont) SV * const sv = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ; MAGIC *mg; - SvUPGRADE(sv, SVt_PVMG); - if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); -#endif - mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, - NULL, 0); + if (!(mg = mg_find_mglob(sv))) { + mg = sv_magicext_mglob(sv); } mg->mg_len = m - orig; } diff --git a/pp_hot.c b/pp_hot.c index 084f4a2..914a9d7 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1390,10 +1390,9 @@ PP(pp_match) /* XXXX What part of this is needed with true \G-support? */ if (global) { + MAGIC * const mg = mg_find_mglob(TARG); RX_OFFS(rx)[0].start = -1; - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global); - if (mg && mg->mg_len >= 0) { + if (mg && mg->mg_len >= 0) { if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN)) RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len; else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) { @@ -1405,7 +1404,6 @@ PP(pp_match) RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len; minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0; update_minmatch = 0; - } } } #ifdef PERL_SAWAMPERSAND @@ -1491,16 +1489,9 @@ PP(pp_match) } if (global) { if (dynpm->op_pmflags & PMf_CONTINUE) { - MAGIC* mg = NULL; - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) - mg = mg_find(TARG, PERL_MAGIC_regex_global); + MAGIC *mg = mg_find_mglob(TARG); if (!mg) { -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(TARG)) - sv_force_normal_flags(TARG, 0); -#endif - mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, - &PL_vtbl_mglob, NULL, 0); + mg = sv_magicext_mglob(TARG); } if (RX_OFFS(rx)[0].start != -1) { mg->mg_len = RX_OFFS(rx)[0].end; @@ -1524,18 +1515,9 @@ PP(pp_match) } else { if (global) { - MAGIC* mg; - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) - mg = mg_find(TARG, PERL_MAGIC_regex_global); - else - mg = NULL; + MAGIC *mg = mg_find_mglob(TARG); if (!mg) { -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(TARG)) - sv_force_normal_flags(TARG, 0); -#endif - mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, - &PL_vtbl_mglob, NULL, 0); + mg = sv_magicext_mglob(TARG); } if (RX_OFFS(rx)[0].start != -1) { mg->mg_len = RX_OFFS(rx)[0].end; @@ -1631,11 +1613,9 @@ yup: /* Confirmed by INTUIT */ nope: ret_no: if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global); + MAGIC* const mg = mg_find_mglob(TARG); if (mg) mg->mg_len = -1; - } } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) diff --git a/proto.h b/proto.h index 242e35b..cbb8664 100644 --- a/proto.h +++ b/proto.h @@ -2468,6 +2468,12 @@ PERL_CALLCONV int Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) PERL_CALLCONV MAGIC* Perl_mg_find(pTHX_ const SV* sv, int type) __attribute__warn_unused_result__; +PERL_CALLCONV MAGIC* Perl_mg_find_mglob(pTHX_ SV* sv) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_MG_FIND_MGLOB \ + assert(sv) + PERL_CALLCONV MAGIC* Perl_mg_findext(pTHX_ const SV* sv, int type, const MGVTBL *vtbl) __attribute__warn_unused_result__; @@ -4115,6 +4121,11 @@ PERL_CALLCONV MAGIC * Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const #define PERL_ARGS_ASSERT_SV_MAGICEXT \ assert(sv) +PERL_CALLCONV MAGIC * Perl_sv_magicext_mglob(pTHX_ SV *sv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB \ + assert(sv) + /* PERL_CALLCONV SV* Perl_sv_mortalcopy(pTHX_ SV *const oldsv) __attribute__malloc__ __attribute__warn_unused_result__; */ @@ -5792,9 +5803,9 @@ STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) assert(sv); assert(mg); assert(meth) STATIC void S_restore_magic(pTHX_ const void *p); -STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv) +STATIC void S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_SAVE_MAGIC \ +#define PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS \ assert(sv) STATIC void S_unwind_handler_stack(pTHX_ const void *p); diff --git a/regexec.c b/regexec.c index 6367e2e..3869d04 100644 --- a/regexec.c +++ b/regexec.c @@ -2194,9 +2194,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, reginfo->ganch = startpos + prog->gofs; DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, "GPOS IGNOREPOS: reginfo->ganch = startpos + %"UVxf"\n",(UV)prog->gofs)); - } else if (sv && SvTYPE(sv) >= SVt_PVMG - && SvMAGIC(sv) - && (mg = mg_find(sv, PERL_MAGIC_regex_global)) + } else if (sv && (mg = mg_find_mglob(sv)) && mg->mg_len >= 0) { reginfo->ganch = strbeg + mg->mg_len; /* Defined pos() */ DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, @@ -7533,15 +7531,9 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo) DEFSV_set(reginfo->sv); } - if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv) - && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) { + if (!(mg = mg_find_mglob(reginfo->sv))) { /* prepare for quick setting of pos */ -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(reginfo->sv)) - sv_force_normal_flags(reginfo->sv, 0); -#endif - mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global, - &PL_vtbl_mglob, NULL, 0); + mg = sv_magicext_mglob(reginfo->sv); mg->mg_len = -1; } eval_state->pos_magic = mg; diff --git a/sv.c b/sv.c index 183b60b..e5f60a2 100644 --- a/sv.c +++ b/sv.c @@ -5410,6 +5410,24 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, return mg; } +MAGIC * +Perl_sv_magicext_mglob(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB; + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { + /* This sv is only a delegate. //g magic must be attached to + its target. */ + vivify_defelem(sv); + sv = LvTARG(sv); + } +#ifdef PERL_OLD_COPY_ON_WRITE + if (SvIsCOW(sv)) + sv_force_normal_flags(sv, 0); +#endif + return sv_magicext(sv, NULL, PERL_MAGIC_regex_global, + &PL_vtbl_mglob, 0, 0); +} + /* =for apidoc sv_magic diff --git a/t/op/array.t b/t/op/array.t index 90dd046..86740a1 100644 --- a/t/op/array.t +++ b/t/op/array.t @@ -20,9 +20,6 @@ is($tmp, 5); is($#ary, 3); is(join('',@ary), '1234'); -{ - no warnings 'deprecated'; - @foo = (); $r = join(',', $#foo, @foo); is($r, "-1"); @@ -55,8 +52,6 @@ $bar[2] = '2'; $r = join(',', $#bar, @bar); is($r, "2,0,,2"); -} - $foo = 'now is the time'; ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); is($F1, 'now'); diff --git a/t/op/pos.t b/t/op/pos.t index 4c50aa9..4eca3a6 100644 --- a/t/op/pos.t +++ b/t/op/pos.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 12; +plan tests => 21; $x='banana'; $x=~/.a/g; @@ -63,3 +63,29 @@ is eval 'pos *a', 1, 'pos *glob works'; pos($1) = 2; # set pos; was ignoring UTF8-ness "$1"; # turn on UTF8 flag is pos($1), 2, 'pos is not confused about changing UTF8-ness'; + +sub { + $_[0] = "hello"; + pos $_[0] = 3; + is pos $h{k}, 3, 'defelems can propagate pos assignment'; + $_[0] =~ /./g; + is pos $h{k}, 4, 'defelems can propagate implicit pos (via //g)'; + $_[0] =~ /oentuhoetn/g; + is pos $h{k}, undef, 'failed //g sets pos through defelem'; + $_[1] = "hello"; + pos $h{l} = 3; + is pos $_[1], 3, 'reading pos through a defelem'; + pos $h{l} = 4; + $_[1] =~ /(.)/g; + is "$1", 'o', '//g can read pos through a defelem'; + $_[2] = "hello"; + () = $_[2] =~ /l/gc; + is pos $h{m}, 4, '//gc in list cx can set pos through a defelem'; + $_[3] = "hello"; + $_[3] =~ + s<e><is pos($h{n}), 1, 's///g setting pos through a defelem'>egg; + $h{n} = 'hello'; + $_[3] =~ /e(?{ is pos $h{n},2, 're-evals set pos through defelems' })/; + pos $h{n} = 1; + ok $_[3] =~ /\Ge/, '\G works with defelem scalars'; +}->($h{k}, $h{l}, $h{m}, $h{n}); diff --git a/t/op/tie.t b/t/op/tie.t index ad58af7..6ff5870 100644 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -1332,3 +1332,11 @@ Can't call method "FETCHSIZE" on an undefined value at - line 5. Can't call method "FETCHSIZE" on an undefined value at - line 6. Can't call method "FETCHSIZE" on an undefined value at - line 7. Can't call method "FETCHSIZE" on an undefined value at - line 8. +######## + +# Assigning vstrings to tied scalars +sub TIESCALAR{bless[]}; +sub STORE { print ref \$_[1], "\n" } +tie $x, ""; $x = v3; +EXPECT +VSTRING diff --git a/t/op/ver.t b/t/op/ver.t index 5fca626..3969d11 100644 --- a/t/op/ver.t +++ b/t/op/ver.t @@ -11,7 +11,7 @@ $DOWARN = 1; # enable run-time warnings now use Config; -plan( tests => 57 ); +plan( tests => 58 ); eval 'use v5.5.640'; is( $@, '', "use v5.5.640; $@"); @@ -276,6 +276,10 @@ is ref \$a, 'SCALAR', $a = v102; $a =~ y/f/g/; is ref \$a, 'SCALAR', 'y/// flattens vstrings'; +sub { $_[0] = v3; + is ref \$h{nonexistent}, 'VSTRING', 'defelems can pass vstrings' } +->($h{nonexistent}); + # The following tests whether v-strings are correctly # interpreted by the tokeniser when it's in a XTERMORDORDOR # state (fittingly, the only tokeniser state to contain the -- Perl5 Master Repository
