[perl.git] branch blead, updated. v5.25.9-35-g32207c637b

[Aaron Crane]

In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/32207c637b216a1dfa7317d111af89f149743ff3?hp=769b28f489b6336875b378e2e47e731628f45af0>

- Log -----------------------------------------------------------------
commit 32207c637b216a1dfa7317d111af89f149743ff3
Author: Aaron Crane <a...@cpan.org>
Date:   Tue Jan 24 19:50:32 2017 +0000

    RT#130623: assertions when tying into non-packages
-----------------------------------------------------------------------

Summary of changes:
 pp_sys.c   | 25 +++++++++++++++++++------
 t/op/tie.t | 18 ++++++++++++++++++
 2 files changed, 37 insertions(+), 6 deletions(-)

diff --git a/pp_sys.c b/pp_sys.c
index d8e9c30467..7c125b5137 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -953,13 +953,26 @@ PP(pp_tie)
         */
        stash = gv_stashsv(*MARK, 0);
        if (!stash) {
-           SV *stashname = SvOK(*MARK) ? *MARK : &PL_sv_no;
-           if (!SvCUR(*MARK)) {
-               stashname = sv_2mortal(newSVpvs("main"));
+           if (SvROK(*MARK))
+               DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" 
SVf "\"",
+                   methname, SVfARG(*MARK));
+           else if (isGV(*MARK)) {
+               /* If the glob doesn't name an existing package, using
+                * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
+                * generate the name for the error message explicitly. */
+               SV *stashname = newSV(0);
+               gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
+               DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" 
SVf "\"",
+                   methname, SVfARG(stashname));
+           }
+           else {
+               SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
+                             : SvCUR(*MARK)  ? *MARK
+                             :                 sv_2mortal(newSVpvs("main"));
+               DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" 
SVf "\""
+                   " (perhaps you forgot to load \"%" SVf "\"?)",
+                   methname, SVfARG(stashname), SVfARG(stashname));
            }
-           DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf 
"\""
-               " (perhaps you forgot to load \"%" SVf "\"?)",
-               methname, SVfARG(stashname), SVfARG(stashname));
        }
        else if (!(gv = gv_fetchmethod(stash, methname))) {
            /* The effective name can only be NULL for stashes that have
diff --git a/t/op/tie.t b/t/op/tie.t
index e5e7d30cc6..12fc935b27 100644
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -942,6 +942,24 @@ tie $foo, undef;
 EXPECT
 Can't locate object method "TIESCALAR" via package "main" at - line 2.
 ########
+# tie into nonexistent glob [RT#130623 assertion failure]
+tie $foo, *FOO;
+EXPECT
+Can't locate object method "TIESCALAR" via package "FOO" at - line 2.
+########
+# tie into glob when package exists but not method: no "*", no "main::"
+{ package PackageWithoutTIESCALAR }
+tie $foo, *PackageWithoutTIESCALAR;
+EXPECT
+Can't locate object method "TIESCALAR" via package "PackageWithoutTIESCALAR" 
at - line 3.
+########
+# tie into reference [RT#130623 assertion failure]
+eval { tie $foo, \"nope" };
+my $exn = $@ // "";
+print $exn =~ s/0x\w+/0xNNN/rg;
+EXPECT
+Can't locate object method "TIESCALAR" via package "SCALAR(0xNNN)" at - line 2.
+########
 #
 # STORE freeing tie'd AV
 sub TIEARRAY  { bless [] }

--
Perl5 Master Repository