From ec6a9911b75518dd4c77eb4985d8bee0371df340 Mon Sep 17 00:00:00 2001
From: Doug MacEachern <dougm@covalent.net>
Date: Tue, 27 Jun 2000 07:17:28 -0700
Subject: [PATCH] Re: [PATCH] support 'my __PACKAGE__ $obj = ...' Message-ID:
 <Pine.LNX.4.10.10006271412340.7587-100000@mojo.covalent.net>

p4raw-id: //depot/cfgperl@6250
---
 MANIFEST        |  1 +
 embed.pl        |  1 +
 proto.h         |  1 +
 t/op/my_stash.t | 27 +++++++++++++++++++++++++++
 toke.c          | 25 ++++++++++++++++++++++++-
 5 files changed, 54 insertions(+), 1 deletion(-)
 create mode 100644 t/op/my_stash.t

diff --git a/MANIFEST b/MANIFEST
index b21da7d..25765e6 100644
--- 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
--- 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
--- 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
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
--- 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;
-- 
2.7.4