Fix CORE::glob

This commit makes CORE::glob bypassing glob overrides.

A side effect of the fix is that, with the default glob implementa-
tion, undefining *CORE::GLOBAL::glob no longer results in an ‘unde-
fined subroutine’ error.

Another side effect is that compilation of a glob op no longer assumes
that the loading of File::Glob will create the *CORE::GLOB::glob type-
glob.  ‘++$INC{"File/Glob.pm"}; sub File::Glob::csh_glob; eval '<*>';’
used to crash.

This is accomplished using a mechanism similar to lock() and
threads::shared.  There is a new PL_globhook interpreter varia-
ble that pp_glob calls when there is no override present.  Thus,
File::Glob (which is supposed to be transparent, as it *is* the
built-in implementation) no longer interferes with the user mechanism
for overriding glob.

This removes one tier from the five or so hacks that constitute glob’s
implementation, and which work together to make it one of the buggiest
and most inconsistent areas of Perl.

10 files changed, 57 insertions, 14 deletions

diff --git a/embedvar.h b/embedvar.h
index 3542482c52..f618aefd85 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -150,6 +150,7 @@
 #define PL_gid			(vTHX->Igid)
 #define PL_glob_index		(vTHX->Iglob_index)
 #define PL_globalstash		(vTHX->Iglobalstash)
+#define PL_globhook		(vTHX->Iglobhook)
 #define PL_hash_seed		(vTHX->Ihash_seed)
 #define PL_hintgv		(vTHX->Ihintgv)
 #define PL_hints		(vTHX->Ihints)
diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
index 2a9fbb027f..a5f531d68f 100644
--- a/ext/File-Glob/Glob.xs
+++ b/ext/File-Glob/Glob.xs
@@ -321,6 +321,10 @@ BOOT:
 {
     CV *cv = newXS("File::Glob::bsd_glob", XS_File__Glob_doglob, __FILE__);
     XSANY.any_i32 = 1;
+#ifndef PERL_EXTERNAL_GLOB
+    /* Don’t do this at home! The globhook interface is highly volatile. */
+    PL_globhook = csh_glob;
+#endif
 }
 
 BOOT:
diff --git a/intrpvar.h b/intrpvar.h
index 97e473846e..66daab2916 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -724,6 +724,9 @@ PERLVARI(I, utf8_foldable, SV *, NULL)
 
 PERLVAR(I, custom_ops,	HV *)		/* custom op registrations */
 
+/* Hook for File::Glob */
+PERLVARI(I, globhook,	globhook_t, NULL)
+
 PERLVAR(I, reentrant_retint, int)	/* Integer return value from reentrant functions */
 
 /* The last unconditional member of the interpreter structure when 5.10.0 was
diff --git a/op.c b/op.c
index 7690e4c59b..c34dec5f1c 100644
--- a/op.c
+++ b/op.c
@@ -3091,6 +3091,7 @@ OP *
 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
 {
     dVAR;
+    if (type < 0) type = -type, flags |= OPf_SPECIAL;
     if (!o || o->op_type != OP_LIST)
 	o = newLISTOP(OP_LIST, 0, o, NULL);
     else
@@ -7988,6 +7989,7 @@ Perl_ck_glob(pTHX_ OP *o)
 {
     dVAR;
     GV *gv;
+    const bool core = o->op_flags & OPf_SPECIAL;
 
     PERL_ARGS_ASSERT_CK_GLOB;
 
@@ -7995,7 +7997,8 @@ Perl_ck_glob(pTHX_ OP *o)
     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
 	op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
 
-    if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
+    if (core) gv = NULL;
+    else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
 	  && GvCVu(gv) && GvIMPORTED_CV(gv)))
     {
 	gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
@@ -8003,21 +8006,13 @@ Perl_ck_glob(pTHX_ OP *o)
 
 #if !defined(PERL_EXTERNAL_GLOB)
     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
-	GV *glob_gv;
 	ENTER;
 	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 		newSVpvs("File::Glob"), NULL, NULL, NULL);
-	if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
-	    gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
-	    GvCV_set(gv, GvCV(glob_gv));
-	    SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
-	    GvIMPORTED_CV_on(gv);
-	}
 	LEAVE;
     }
-#endif /* PERL_EXTERNAL_GLOB */
+#endif /* !PERL_EXTERNAL_GLOB */
 
-    assert(!(o->op_flags & OPf_SPECIAL));
     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
 	/* convert
 	 *     glob
@@ -8044,8 +8039,12 @@ Perl_ck_glob(pTHX_ OP *o)
 	o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
 	return o;
     }
+    else o->op_flags &= ~OPf_SPECIAL;
     gv = newGVgen("main");
     gv_IOadd(gv);
+#ifndef PERL_EXTERNAL_GLOB
+    sv_setiv(GvSVn(gv),PL_glob_index++);
+#endif
     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
     scalarkids(o);
     return o;
diff --git a/op.h b/op.h
index d09ccf1f60..76b17bb721 100644
--- a/op.h
+++ b/op.h
@@ -143,7 +143,10 @@ Deprecated.  Use C<GIMME_V> instead.
 				    that was optimised away, so it should
 				    not be bound via =~ */
 				/*  On OP_CONST, from a constant CV */
-				/*  On OP_GLOB, use Perl glob function */
+				/*  On OP_GLOB, two meanings:
+				    - Before ck_glob, called as CORE::glob
+				    - After ck_glob, use Perl glob function
+			         */
 
 /* old names; don't use in new code, but don't break them, either */
 #define OPf_LIST	OPf_WANT_LIST
diff --git a/perl.h b/perl.h
index 8048b5633c..30b8eb2b27 100644
--- a/perl.h
+++ b/perl.h
@@ -4918,6 +4918,8 @@ typedef void(*Perl_ophook_t)(pTHX_ OP*);
 typedef int (*Perl_keyword_plugin_t)(pTHX_ char*, STRLEN, OP**);
 typedef void(*Perl_cpeep_t)(pTHX_ OP *, OP *);
 
+typedef void(*globhook_t)(pTHX);
+
 #define KEYWORD_PLUGIN_DECLINE 0
 #define KEYWORD_PLUGIN_STMT    1
 #define KEYWORD_PLUGIN_EXPR    2
diff --git a/pp_sys.c b/pp_sys.c
index 19ba0cb026..3458177bb7 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -370,6 +370,11 @@ PP(pp_glob)
     }
     /* stack args are: wildcard, gv(_GEN_n) */
 
+    if (PL_globhook) {
+	SETs(GvSV(TOPs));
+	PL_globhook(aTHX);
+	return NORMAL;
+    }
 
     /* Note that we only ever get here if File::Glob fails to load
      * without at the same time croaking, for some reason, or if
diff --git a/sv.c b/sv.c
index 2e0553ac73..21b5c2ab74 100644
--- a/sv.c
+++ b/sv.c
@@ -13012,6 +13012,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_destroyhook	= proto_perl->Idestroyhook;
     PL_signalhook	= proto_perl->Isignalhook;
 
+    PL_globhook		= proto_perl->Iglobhook;
+
 #ifdef THREADS_HAVE_PIDS
     PL_ppid		= proto_perl->Ippid;
 #endif
diff --git a/t/op/glob.t b/t/op/glob.t
index f26d7b3ade..3c64353736 100644
--- a/t/op/glob.t
+++ b/t/op/glob.t
@@ -6,7 +6,7 @@ BEGIN {
     require 'test.pl';
 }
 
-plan( tests => 14 );
+plan( tests => 17 );
 
 @oops = @ops = <op/*>;
 
@@ -60,6 +60,19 @@ cmp_ok($i,'==',2,'remove File::Glob stash');
     eval "<.>";
     ok(!length($@),"remove File::Glob stash *and* CORE::GLOBAL::glob");
 }
+# Also try undeffing the typeglob itself, instead of hiding it
+{
+    local *CORE::GLOBAL::glob;
+    ok eval  { glob("0"); 1 },
+	'undefined *CORE::GLOBAL::glob{CODE} at run time';
+}
+# And hide the typeglob without hiding File::Glob (crashes from 5.8
+# to 5.15.4)
+{
+    local %CORE::GLOBAL::;
+    ok eval q{ glob("0"); 1 },
+	'undefined *CORE::GLOBAL::glob{CODE} at compile time';
+}
 
 # ... while ($var = glob(...)) should test definedness not truth
 
@@ -87,3 +100,10 @@ cmp_ok(scalar(@oops),'>',0,'glob globbed something');
 # On Windows, external glob uses File::DosGlob which returns "~", so this
 # should pass anyway.
 ok <~>, '~ works';
+
+{
+    my $called;
+    local *CORE::GLOBAL::glob = sub { ++$called };
+    eval 'CORE::glob("0")';
+    ok !$called, 'CORE::glob bypasses overrides';
+}
diff --git a/toke.c b/toke.c
index 47ad80490b..aaeff85a27 100644
--- a/toke.c
+++ b/toke.c
@@ -7071,7 +7071,8 @@ Perl_yylex(pTHX)
 		    Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
 		if (tmp < 0)
 		    tmp = -tmp;
-		else if (tmp == KEY_require || tmp == KEY_do)
+		else if (tmp == KEY_require || tmp == KEY_do
+		      || tmp == KEY_glob)
 		    /* that's a way to remember we saw "CORE::" */
 		    orig_keyword = tmp;
 		goto reserved_word;
@@ -7423,7 +7424,10 @@ Perl_yylex(pTHX)
 	    OPERATOR(GIVEN);
 
 	case KEY_glob:
-	    LOP(OP_GLOB,XTERM);
+	    LOP(
+	     orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
+	     XTERM
+	    );
 
 	case KEY_hex:
 	    UNI(OP_HEX);