summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--embedvar.h1
-rw-r--r--ext/File-Glob/Glob.xs4
-rw-r--r--intrpvar.h3
-rw-r--r--op.c19
-rw-r--r--op.h5
-rw-r--r--perl.h2
-rw-r--r--pp_sys.c5
-rw-r--r--sv.c2
-rw-r--r--t/op/glob.t22
-rw-r--r--toke.c8
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);
View Lorry Controller Status