From: Gurusamy Sarathy <gsar@cpan.org>
Date: Tue, 11 Jul 2000 18:34:56 +0000 (+0000)
Subject: integrate cfgperl change#6250 into mainline
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=def3634bd95d269e50804282110ddcc3b0e6e39b;p=p5sagit%2Fp5-mst-13.2.git

integrate cfgperl change#6250 into mainline

p4raw-link: @6250 on //depot/cfgperl: ec6a9911b75518dd4c77eb4985d8bee0371df340

p4raw-id: //depot/perl@6360
p4raw-branched: from //depot/cfgperl@6250 'branch in' t/op/my_stash.t
p4raw-integrated: from //depot/cfgperl@6250 'copy in' MANIFEST
	(@6232..) 'merge in' toke.c (@6241..) embed.pl proto.h
	(@6243..)
---

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 9a45f0f..b88235b 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2485,6 +2485,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 31e2baf..28b4908 100644
--- a/proto.h
+++ b/proto.h
@@ -1234,6 +1234,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 fe14358..6b5fc49 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;