Re: [PATCH] support 'my __PACKAGE__ $obj = ...'

Message-ID: <Pine.LNX.4.10.10006271412340.7587-100000@mojo.covalent.net>

p4raw-id: //depot/cfgperl@6250

diff --git a/MANIFEST b/MANIFEST
index b21da7d..25765e6 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1438,6 +1438,7 @@ t/op/method.t             See if method calls work
 t/op/misc.t            See if miscellaneous bugs have been fixed
 t/op/mkdir.t           See if mkdir works
 t/op/my.t              See if lexical scoping works
+t/op/my_stash.t                See if my Package works
 t/op/nothr5005.t       local @_ test which does not work under use5005threads
 t/op/numconvert.t      See if accessing fields does not change numeric values
 t/op/oct.t             See if oct and hex work

diff --git a/embed.pl b/embed.pl
index 96603be..c4cb705 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2484,6 +2484,7 @@ s |I32    |sublex_done
 s      |I32    |sublex_push
 s      |I32    |sublex_start
 s      |char * |filter_gets    |SV *sv|PerlIO *fp|STRLEN append
+s      |HV *   |find_in_my_stash|char *pkgname|I32 len
 s      |SV*    |new_constant   |char *s|STRLEN len|const char *key|SV *sv \
                                |SV *pv|const char *type
 s      |int    |ao             |int toketype

diff --git a/proto.h b/proto.h
index fc34840..d46179a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1233,6 +1233,7 @@ STATIC I32        S_sublex_done(pTHX);
 STATIC I32     S_sublex_push(pTHX);
 STATIC I32     S_sublex_start(pTHX);
 STATIC char *  S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append);
+STATIC HV *    S_find_in_my_stash(pTHX_ char *pkgname, I32 len);
 STATIC SV*     S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type);
 STATIC int     S_ao(pTHX_ int toketype);
 STATIC void    S_depcom(pTHX);

diff --git a/t/op/my_stash.t b/t/op/my_stash.t
new file mode 100644 (file)
index 0000000..ba266bf
--- /dev/null
+++ b/t/op/my_stash.t
@@ -0,0 +1,27 @@
+#!./perl
+
+package Foo;
+
+use Test;
+
+plan tests => 7;
+
+use constant MyClass => 'Foo::Bar::Biz::Baz';
+
+{
+    package Foo::Bar::Biz::Baz;
+}
+
+for (qw(Foo Foo:: MyClass __PACKAGE__)) {
+    eval "sub { my $_ \$obj = shift; }";
+    ok ! $@;
+#    print $@ if $@;
+}
+
+use constant NoClass => 'Nope::Foo::Bar::Biz::Baz';
+
+for (qw(Nope Nope:: NoClass)) {
+    eval "sub { my $_ \$obj = shift; }";
+    ok $@;
+#    print $@ if $@;
+}

diff --git a/toke.c b/toke.c
index 4c97aea..4a54f72 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2006,6 +2006,29 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
         return (sv_gets(sv, fp, append));
 }
 
+STATIC HV *S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
+{
+    GV *gv;
+
+    if (*pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
+        return PL_curstash;
+
+    if (len > 2 &&
+        (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
+        (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) {
+        return GvHV(gv); /* Foo:: */
+    }
+
+    /* use constant CLASS => 'MyClass' */
+    if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
+        SV *sv;
+        if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
+            pkgname = SvPV_nolen(sv);
+        }
+    }
+
+    return gv_stashpv(pkgname, FALSE);
+}
 
 #ifdef DEBUGGING
     static char* exp_name[] =
@@ -4410,7 +4433,7 @@ Perl_yylex(pTHX)
                s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
                if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
                    goto really_sub;
-               PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
+               PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
                if (!PL_in_my_stash) {
                    char tmpbuf[1024];
                    PL_bufptr = s;