1 /* gv.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11 /*
12 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
13 * of your inquisitiveness, I shall spend all the rest of my days in answering
14 * you. What more do you want to know?'
15 * 'The names of all the stars, and of all living things, and the whole
16 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
17 * laughed Pippin.
18 *
19 * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
20 */
21
22 /*
23 =head1 GV Handling and Stashes
24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
26 corresponding to $foo, @foo, %foo.
27
28 GVs are usually found as values in stashes (symbol table hashes) where
29 Perl stores its global variables.
30
31 A B<stash> is a hash that contains all variables that are defined
32 within a package. See L<perlguts/Stashes and Globs>
33
34 =for apidoc Ayh||GV
35
36 =cut
37 */
38
39 #include "EXTERN.h"
40 #define PERL_IN_GV_C
41 #include "perl.h"
42 #include "overload.inc"
43 #include "keywords.h"
44 #include "feature.h"
45
46 static const char S_autoload[] = "AUTOLOAD";
47 #define S_autolen (sizeof("AUTOLOAD")-1)
48
49 /*
50 =for apidoc gv_add_by_type
51
52 Make sure there is a slot of type C<type> in the GV C<gv>.
53
54 =cut
55 */
56
57 GV *
Perl_gv_add_by_type(pTHX_ GV * gv,svtype type)58 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
59 {
60 SV **where;
61
62 if (
63 !gv
64 || (
65 SvTYPE((const SV *)gv) != SVt_PVGV
66 && SvTYPE((const SV *)gv) != SVt_PVLV
67 )
68 ) {
69 const char *what;
70 if (type == SVt_PVIO) {
71 /*
72 * if it walks like a dirhandle, then let's assume that
73 * this is a dirhandle.
74 */
75 what = OP_IS_DIRHOP(PL_op->op_type) ?
76 "dirhandle" : "filehandle";
77 } else if (type == SVt_PVHV) {
78 what = "hash";
79 } else {
80 what = type == SVt_PVAV ? "array" : "scalar";
81 }
82 Perl_croak(aTHX_ "Bad symbol for %s", what);
83 }
84
85 if (type == SVt_PVHV) {
86 where = (SV **)&GvHV(gv);
87 } else if (type == SVt_PVAV) {
88 where = (SV **)&GvAV(gv);
89 } else if (type == SVt_PVIO) {
90 where = (SV **)&GvIOp(gv);
91 } else {
92 where = &GvSV(gv);
93 }
94
95 if (!*where)
96 {
97 *where = newSV_type(type);
98 if ( type == SVt_PVAV
99 && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
100 {
101 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
102 }
103 }
104 return gv;
105 }
106
107 /*
108 =for apidoc gv_fetchfile
109 =for apidoc_item gv_fetchfile_flags
110
111 These return the debugger glob for the file (compiled by Perl) whose name is
112 given by the C<name> parameter.
113
114 There are currently exactly two differences between these functions.
115
116 The C<name> parameter to C<gv_fetchfile> is a C string, meaning it is
117 C<NUL>-terminated; whereas the C<name> parameter to C<gv_fetchfile_flags> is a
118 Perl string, whose length (in bytes) is passed in via the C<namelen> parameter
119 This means the name may contain embedded C<NUL> characters.
120 C<namelen> doesn't exist in plain C<gv_fetchfile>).
121
122 The other difference is that C<gv_fetchfile_flags> has an extra C<flags>
123 parameter, which is currently completely ignored, but allows for possible
124 future extensions.
125
126 =cut
127 */
128 GV *
Perl_gv_fetchfile(pTHX_ const char * name)129 Perl_gv_fetchfile(pTHX_ const char *name)
130 {
131 PERL_ARGS_ASSERT_GV_FETCHFILE;
132 return gv_fetchfile_flags(name, strlen(name), 0);
133 }
134
135 GV *
Perl_gv_fetchfile_flags(pTHX_ const char * const name,const STRLEN namelen,const U32 flags)136 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
137 const U32 flags)
138 {
139 char smallbuf[128];
140 char *tmpbuf;
141 const STRLEN tmplen = namelen + 2;
142 GV *gv;
143
144 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
145 PERL_UNUSED_ARG(flags);
146
147 if (!PL_defstash)
148 return NULL;
149
150 if (tmplen <= sizeof smallbuf)
151 tmpbuf = smallbuf;
152 else
153 Newx(tmpbuf, tmplen, char);
154 /* This is where the debugger's %{"::_<$filename"} hash is created */
155 tmpbuf[0] = '_';
156 tmpbuf[1] = '<';
157 memcpy(tmpbuf + 2, name, namelen);
158 GV **gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, (flags & GVF_NOADD) ? FALSE : TRUE);
159 if (gvp) {
160 gv = *gvp;
161 if (!isGV(gv)) {
162 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
163 #ifdef PERL_DONT_CREATE_GVSV
164 GvSV(gv) = newSVpvn(name, namelen);
165 #else
166 sv_setpvn(GvSV(gv), name, namelen);
167 #endif
168 }
169 if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
170 hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
171 }
172 else {
173 gv = NULL;
174 }
175 if (tmpbuf != smallbuf)
176 Safefree(tmpbuf);
177 return gv;
178 }
179
180 /*
181 =for apidoc gv_const_sv
182
183 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
184 inlining, or C<gv> is a placeholder reference that would be promoted to such
185 a typeglob, then returns the value returned by the sub. Otherwise, returns
186 C<NULL>.
187
188 =cut
189 */
190
191 SV *
Perl_gv_const_sv(pTHX_ GV * gv)192 Perl_gv_const_sv(pTHX_ GV *gv)
193 {
194 PERL_ARGS_ASSERT_GV_CONST_SV;
195 PERL_UNUSED_CONTEXT;
196
197 if (SvTYPE(gv) == SVt_PVGV)
198 return cv_const_sv(GvCVu(gv));
199 return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
200 }
201
202 GP *
Perl_newGP(pTHX_ GV * const gv)203 Perl_newGP(pTHX_ GV *const gv)
204 {
205 GP *gp;
206 U32 hash;
207 const char *file;
208 STRLEN len;
209
210 PERL_ARGS_ASSERT_NEWGP;
211 Newxz(gp, 1, GP);
212 gp->gp_egv = gv; /* allow compiler to reuse gv after this */
213 #ifndef PERL_DONT_CREATE_GVSV
214 gp->gp_sv = newSV_type(SVt_NULL);
215 #endif
216
217 /* PL_curcop may be null here. E.g.,
218 INIT { bless {} and exit }
219 frees INIT before looking up DESTROY (and creating *DESTROY)
220 */
221 if (PL_curcop) {
222 char *tmp= CopFILE(PL_curcop);
223 gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
224
225 if (tmp) {
226 file = tmp;
227 len = CopFILE_LEN(PL_curcop);
228 }
229 else goto no_file;
230 }
231 else {
232 no_file:
233 file = "";
234 len = 0;
235 }
236
237 PERL_HASH(hash, file, len);
238 gp->gp_file_hek = share_hek(file, len, hash);
239 gp->gp_refcnt = 1;
240
241 return gp;
242 }
243
244 /* Assign CvGV(cv) = gv, handling weak references.
245 * See also S_anonymise_cv_maybe */
246
247 void
Perl_cvgv_set(pTHX_ CV * cv,GV * gv)248 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
249 {
250 GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
251 HEK *hek;
252 PERL_ARGS_ASSERT_CVGV_SET;
253
254 if (oldgv == gv)
255 return;
256
257 if (oldgv) {
258 if (CvCVGV_RC(cv)) {
259 SvREFCNT_dec_NN(oldgv);
260 CvCVGV_RC_off(cv);
261 }
262 else {
263 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
264 }
265 }
266 else if ((hek = CvNAME_HEK(cv))) {
267 unshare_hek(hek);
268 CvLEXICAL_off(cv);
269 }
270
271 CvNAMED_off(cv);
272 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
273 assert(!CvCVGV_RC(cv));
274
275 if (!gv)
276 return;
277
278 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
279 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
280 else {
281 CvCVGV_RC_on(cv);
282 SvREFCNT_inc_simple_void_NN(gv);
283 }
284 }
285
286 /* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a
287 GV, but for efficiency that GV may not in fact exist. This function,
288 called by CvGV, reifies it. */
289
290 GV *
Perl_cvgv_from_hek(pTHX_ CV * cv)291 Perl_cvgv_from_hek(pTHX_ CV *cv)
292 {
293 GV *gv;
294 SV **svp;
295 PERL_ARGS_ASSERT_CVGV_FROM_HEK;
296 assert(SvTYPE(cv) == SVt_PVCV);
297 if (!CvSTASH(cv)) return NULL;
298 ASSUME(CvNAME_HEK(cv));
299 svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
300 gv = MUTABLE_GV(svp && *svp ? *svp : newSV_type(SVt_NULL));
301 if (!isGV(gv))
302 gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
303 HEK_LEN(CvNAME_HEK(cv)),
304 SVf_UTF8 * cBOOL(HEK_UTF8(CvNAME_HEK(cv))));
305 if (!CvNAMED(cv)) { /* gv_init took care of it */
306 assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
307 return gv;
308 }
309 unshare_hek(CvNAME_HEK(cv));
310 CvNAMED_off(cv);
311 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
312 if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
313 CvCVGV_RC_on(cv);
314 return gv;
315 }
316
317 /* Assign CvSTASH(cv) = st, handling weak references. */
318
319 void
Perl_cvstash_set(pTHX_ CV * cv,HV * st)320 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
321 {
322 HV *oldst = CvSTASH(cv);
323 PERL_ARGS_ASSERT_CVSTASH_SET;
324 if (oldst == st)
325 return;
326 if (oldst)
327 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
328 SvANY(cv)->xcv_stash = st;
329 if (st)
330 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
331 }
332
333 /*
334 =for apidoc gv_init_pvn
335
336 Converts a scalar into a typeglob. This is an incoercible typeglob;
337 assigning a reference to it will assign to one of its slots, instead of
338 overwriting it as happens with typeglobs created by C<SvSetSV>. Converting
339 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
340 for perl's internal use.
341
342 C<gv> is the scalar to be converted.
343
344 C<stash> is the parent stash/package, if any.
345
346 C<name> and C<len> give the name. The name must be unqualified;
347 that is, it must not include the package name. If C<gv> is a
348 stash element, it is the caller's responsibility to ensure that the name
349 passed to this function matches the name of the element. If it does not
350 match, perl's internal bookkeeping will get out of sync.
351
352 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
353 the return value of SvUTF8(sv). It can also take the
354 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
355 seen before (i.e., suppress "Used once" warnings).
356
357 =for apidoc Amnh||GV_ADDMULTI
358
359 =for apidoc gv_init
360
361 The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
362 has no flags parameter. If the C<multi> parameter is set, the
363 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
364
365 =for apidoc gv_init_pv
366
367 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
368 instead of separate char * and length parameters.
369
370 =for apidoc gv_init_sv
371
372 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
373 char * and length parameters. C<flags> is currently unused.
374
375 =cut
376 */
377
378 void
Perl_gv_init_sv(pTHX_ GV * gv,HV * stash,SV * namesv,U32 flags)379 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
380 {
381 char *namepv;
382 STRLEN namelen;
383 PERL_ARGS_ASSERT_GV_INIT_SV;
384 namepv = SvPV(namesv, namelen);
385 if (SvUTF8(namesv))
386 flags |= SVf_UTF8;
387 gv_init_pvn(gv, stash, namepv, namelen, flags);
388 }
389
390 void
Perl_gv_init_pv(pTHX_ GV * gv,HV * stash,const char * name,U32 flags)391 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
392 {
393 PERL_ARGS_ASSERT_GV_INIT_PV;
394 gv_init_pvn(gv, stash, name, strlen(name), flags);
395 }
396
397 /* Packages in the symbol table are "stashes" - hashes where the keys are symbol
398 names and the values are typeglobs. The value $foo::bar is actually found
399 by looking up the typeglob *foo::{bar} and then reading its SCALAR slot.
400
401 At least, that's what you see in Perl space if you use typeglob syntax.
402 Usually it's also what's actually stored in the stash, but for some cases
403 different values are stored (as a space optimisation) and converted to full
404 typeglobs "on demand" - if a typeglob syntax is used to read a value. It's
405 the job of this function, Perl_gv_init_pvn(), to undo any trickery and
406 replace the SV stored in the stash with the regular PVGV structure that it is
407 a shorthand for. This has to be done "in-place" by upgrading the actual SV
408 that is already stored in the stash to a PVGV.
409
410 As the public documentation above says:
411 Converting any scalar that is C<SvOK()> may produce unpredictable
412 results and is reserved for perl's internal use.
413
414 Values that can be stored:
415
416 * plain scalar - a subroutine declaration
417 The scalar's string value is the subroutine prototype; the integer -1 is
418 "no prototype". ie shorthand for sub foo ($$); or sub bar;
419 * reference to a scalar - a constant. ie shorthand for sub PI() { 4; }
420 * reference to a sub - a subroutine (avoids allocating a PVGV)
421
422 The earliest optimisation was subroutine declarations, implemented in 1998
423 by commit 8472ac73d6d80294:
424 "Sub declaration cost reduced from ~500 to ~100 bytes"
425
426 This space optimisation needs to be invisible to regular Perl code. For this
427 code:
428
429 sub foo ($$);
430 *foo = [];
431
432 When the first line is compiled, the optimisation is used, and $::{foo} is
433 assigned the scalar '$$'. No PVGV or PVCV is created.
434
435 When the second line encountered, the typeglob lookup on foo needs to
436 "upgrade" the symbol table entry to a PVGV, and then create a PVCV in the
437 {CODE} slot with the prototype $$ and no body. The typeglob is then available
438 so that [] can be assigned to the {ARRAY} slot. For the code above the
439 upgrade happens at compile time, the assignment at runtime.
440
441 Analogous code unwinds the other optimisations.
442 */
443 void
Perl_gv_init_pvn(pTHX_ GV * gv,HV * stash,const char * name,STRLEN len,U32 flags)444 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
445 {
446 const U32 old_type = SvTYPE(gv);
447 const bool doproto = old_type > SVt_NULL;
448 char * const proto = (doproto && SvPOK(gv))
449 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
450 : NULL;
451 const STRLEN protolen = proto ? SvCUR(gv) : 0;
452 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
453 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
454 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
455 const bool really_sub =
456 has_constant && SvTYPE(has_constant) == SVt_PVCV;
457 COP * const old = PL_curcop;
458
459 PERL_ARGS_ASSERT_GV_INIT_PVN;
460 assert (!(proto && has_constant));
461
462 if (has_constant) {
463 /* The constant has to be a scalar, array or subroutine. */
464 switch (SvTYPE(has_constant)) {
465 case SVt_PVHV:
466 case SVt_PVFM:
467 case SVt_PVIO:
468 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
469 sv_reftype(has_constant, 0));
470 NOT_REACHED; /* NOTREACHED */
471 break;
472
473 default: NOOP;
474 }
475 SvRV_set(gv, NULL);
476 SvROK_off(gv);
477 }
478
479
480 if (old_type < SVt_PVGV) {
481 if (old_type >= SVt_PV)
482 SvCUR_set(gv, 0);
483 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
484 }
485 if (SvLEN(gv)) {
486 if (proto) {
487 /* For this case, we are "stealing" the buffer from the SvPV and
488 re-attaching to an SV below with the call to sv_usepvn_flags().
489 Hence we don't free it. */
490 SvPV_set(gv, NULL);
491 }
492 else {
493 /* There is no valid prototype. (SvPOK() must be true for a valid
494 prototype.) Hence we free the memory. */
495 Safefree(SvPVX_mutable(gv));
496 }
497 SvLEN_set(gv, 0);
498 SvPOK_off(gv);
499 }
500 SvIOK_off(gv);
501 isGV_with_GP_on(gv);
502
503 if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
504 && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE
505 || CvSTART(has_constant)->op_type == OP_DBSTATE))
506 PL_curcop = (COP *)CvSTART(has_constant);
507 GvGP_set(gv, Perl_newGP(aTHX_ gv));
508 PL_curcop = old;
509 GvSTASH(gv) = stash;
510 if (stash)
511 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
512 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
513 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
514 GvMULTI_on(gv); /* _was_ mentioned */
515 if (really_sub) {
516 /* Not actually a constant. Just a regular sub. */
517 CV * const cv = (CV *)has_constant;
518 GvCV_set(gv,cv);
519 if (CvNAMED(cv) && CvSTASH(cv) == stash && (
520 CvNAME_HEK(cv) == GvNAME_HEK(gv)
521 || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
522 && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
523 && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
524 && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
525 )
526 ))
527 CvGV_set(cv,gv);
528 }
529 else if (doproto) {
530 CV *cv;
531 if (has_constant) {
532 /* newCONSTSUB takes ownership of the reference from us. */
533 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
534 /* In case op.c:S_process_special_blocks stole it: */
535 if (!GvCV(gv))
536 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
537 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
538 /* If this reference was a copy of another, then the subroutine
539 must have been "imported", by a Perl space assignment to a GV
540 from a reference to CV. */
541 if (exported_constant)
542 GvIMPORTED_CV_on(gv);
543 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
544 } else {
545 cv = newSTUB(gv,1);
546 }
547 if (proto) {
548 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
549 SV_HAS_TRAILING_NUL);
550 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
551 }
552 }
553 }
554
555 STATIC void
S_gv_init_svtype(pTHX_ GV * gv,const svtype sv_type)556 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
557 {
558 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
559
560 switch (sv_type) {
561 case SVt_PVIO:
562 (void)GvIOn(gv);
563 break;
564 case SVt_PVAV:
565 (void)GvAVn(gv);
566 break;
567 case SVt_PVHV:
568 (void)GvHVn(gv);
569 break;
570 #ifdef PERL_DONT_CREATE_GVSV
571 case SVt_NULL:
572 case SVt_PVCV:
573 case SVt_PVFM:
574 case SVt_PVGV:
575 break;
576 default:
577 if(GvSVn(gv)) {
578 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
579 If we just cast GvSVn(gv) to void, it ignores evaluating it for
580 its side effect */
581 }
582 #endif
583 }
584 }
585
586 static void core_xsub(pTHX_ CV* cv);
587
588 static GV *
S_maybe_add_coresub(pTHX_ HV * const stash,GV * gv,const char * const name,const STRLEN len)589 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
590 const char * const name, const STRLEN len)
591 {
592 const int code = keyword(name, len, 1);
593 static const char file[] = __FILE__;
594 CV *cv, *oldcompcv = NULL;
595 int opnum = 0;
596 bool ampable = TRUE; /* &{}-able */
597 COP *oldcurcop = NULL;
598 yy_parser *oldparser = NULL;
599 I32 oldsavestack_ix = 0;
600
601 assert(gv || stash);
602 assert(name);
603
604 if (!code) return NULL; /* Not a keyword */
605 switch (code < 0 ? -code : code) {
606 /* no support for \&CORE::infix;
607 no support for funcs that do not parse like funcs */
608 case KEY___DATA__: case KEY___END__ :
609 case KEY_ADJUST : case KEY_AUTOLOAD: case KEY_BEGIN : case KEY_CHECK :
610 case KEY_DESTROY : case KEY_END : case KEY_INIT : case KEY_UNITCHECK:
611 case KEY_and : case KEY_catch : case KEY_class :
612 case KEY_cmp : case KEY_default: case KEY_defer :
613 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
614 case KEY_eq : case KEY_eval : case KEY_field :
615 case KEY_finally:
616 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
617 case KEY_given : case KEY_goto : case KEY_grep : case KEY_gt :
618 case KEY_if : case KEY_isa :
619 case KEY_last :
620 case KEY_le : case KEY_local : case KEY_lt : case KEY_m :
621 case KEY_map : case KEY_method : case KEY_my :
622 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
623 case KEY_package: case KEY_print: case KEY_printf:
624 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
625 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
626 case KEY_s : case KEY_say : case KEY_sort :
627 case KEY_state: case KEY_sub :
628 case KEY_tr : case KEY_try :
629 case KEY_unless:
630 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
631 case KEY_x : case KEY_xor : case KEY_y :
632 return NULL;
633 case KEY_chdir:
634 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
635 case KEY_eof : case KEY_exec: case KEY_exists :
636 case KEY_lstat:
637 case KEY_split:
638 case KEY_stat:
639 case KEY_system:
640 case KEY_truncate: case KEY_unlink:
641 ampable = FALSE;
642 }
643 if (!gv) {
644 gv = (GV *)newSV_type(SVt_NULL);
645 gv_init(gv, stash, name, len, TRUE);
646 }
647 GvMULTI_on(gv);
648 if (ampable) {
649 ENTER;
650 oldcurcop = PL_curcop;
651 oldparser = PL_parser;
652 lex_start(NULL, NULL, 0);
653 oldcompcv = PL_compcv;
654 PL_compcv = NULL; /* Prevent start_subparse from setting
655 CvOUTSIDE. */
656 oldsavestack_ix = start_subparse(FALSE,0);
657 cv = PL_compcv;
658 }
659 else {
660 /* Avoid calling newXS, as it calls us, and things start to
661 get hairy. */
662 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
663 GvCV_set(gv,cv);
664 GvCVGEN(gv) = 0;
665 CvISXSUB_on(cv);
666 CvXSUB(cv) = core_xsub;
667 PoisonPADLIST(cv);
668 }
669 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
670 from PL_curcop. */
671 /* XSUBs can't be perl lang/perl5db.pl debugged
672 if (PERLDB_LINE_OR_SAVESRC)
673 (void)gv_fetchfile(file); */
674 CvFILE(cv) = (char *)file;
675 /* XXX This is inefficient, as doing things this order causes
676 a prototype check in newATTRSUB. But we have to do
677 it this order as we need an op number before calling
678 new ATTRSUB. */
679 (void)core_prototype((SV *)cv, name, code, &opnum);
680 if (stash)
681 (void)hv_store(stash,name,len,(SV *)gv,0);
682 if (ampable) {
683 #ifdef DEBUGGING
684 CV *orig_cv = cv;
685 #endif
686 CvLVALUE_on(cv);
687 /* newATTRSUB will free the CV and return NULL if we're still
688 compiling after a syntax error */
689 if ((cv = newATTRSUB_x(
690 oldsavestack_ix, (OP *)gv,
691 NULL,NULL,
692 coresub_op(
693 opnum
694 ? newSVuv((UV)opnum)
695 : newSVpvn(name,len),
696 code, opnum
697 ),
698 TRUE
699 )) != NULL) {
700 assert(GvCV(gv) == orig_cv);
701 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
702 && opnum != OP_UNDEF && opnum != OP_KEYS)
703 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
704 }
705 LEAVE;
706 PL_parser = oldparser;
707 PL_curcop = oldcurcop;
708 PL_compcv = oldcompcv;
709 }
710 if (cv) {
711 SV *opnumsv = newSViv(
712 (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
713 (OP_ENTEREVAL | (1<<16))
714 : opnum ? opnum : (((I32)name[2]) << 16));
715 cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
716 SvREFCNT_dec_NN(opnumsv);
717 }
718
719 return gv;
720 }
721
722 /*
723 =for apidoc gv_fetchmeth
724 =for apidoc_item gv_fetchmeth_pv
725 =for apidoc_item gv_fetchmeth_pvn
726 =for apidoc_item gv_fetchmeth_sv
727
728 These each look for a glob with name C<name>, containing a defined subroutine,
729 returning the GV of that glob if found, or C<NULL> if not.
730
731 C<stash> is always searched (first), unless it is C<NULL>.
732
733 If C<stash> is NULL, or was searched but nothing was found in it, and the
734 C<GV_SUPER> bit is set in C<flags>, stashes accessible via C<@ISA> are searched
735 next. Searching is conducted according to L<C<MRO> order|perlmroapi>.
736
737 Finally, if no matches were found so far, and the C<GV_NOUNIVERSAL> flag in
738 C<flags> is not set, C<UNIVERSAL::> is searched.
739
740 The argument C<level> should be either 0 or -1. If -1, the function will
741 return without any side effects or caching. If 0, the function makes sure
742 there is a glob named C<name> in C<stash>, creating one if necessary.
743 The subroutine slot in the glob will be set to any subroutine found in the
744 C<stash> and C<SUPER::> search, hence caching any C<SUPER::> result. Note that
745 subroutines found in C<UNIVERSAL::> are not cached.
746
747 The GV returned from these may be a method cache entry, which is not visible to
748 Perl code. So when calling C<call_sv>, you should not use the GV directly;
749 instead, you should use the method's CV, which can be obtained from the GV with
750 the C<GvCV> macro.
751
752 The only other significant value for C<flags> is C<SVf_UTF8>, indicating that
753 C<name> is to be treated as being encoded in UTF-8.
754
755 Plain C<gv_fetchmeth> lacks a C<flags> parameter, hence always searches in
756 C<stash>, then C<UNIVERSAL::>, and C<name> is never UTF-8. Otherwise it is
757 exactly like C<gv_fetchmeth_pvn>.
758
759 The other forms do have a C<flags> parameter, and differ only in how the glob
760 name is specified.
761
762 In C<gv_fetchmeth_pv>, C<name> is a C language NUL-terminated string.
763
764 In C<gv_fetchmeth_pvn>, C<name> points to the first byte of the name, and an
765 additional parameter, C<len>, specifies its length in bytes. Hence, the name
766 may contain embedded-NUL characters.
767
768 In C<gv_fetchmeth_sv>, C<*name> is an SV, and the name is the PV extracted from
769 that, using L</C<SvPV>>. If the SV is marked as being in UTF-8, the extracted
770 PV will also be.
771
772 =for apidoc Amnh||GV_SUPER
773
774 =cut
775 */
776
777 GV *
Perl_gv_fetchmeth_sv(pTHX_ HV * stash,SV * namesv,I32 level,U32 flags)778 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
779 {
780 char *namepv;
781 STRLEN namelen;
782 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
783 if (LIKELY(SvPOK_nog(namesv))) /* common case */
784 return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
785 flags | SvUTF8(namesv));
786 namepv = SvPV(namesv, namelen);
787 if (SvUTF8(namesv)) flags |= SVf_UTF8;
788 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
789 }
790
791
792 GV *
Perl_gv_fetchmeth_pv(pTHX_ HV * stash,const char * name,I32 level,U32 flags)793 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
794 {
795 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
796 return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
797 }
798
799 /* NOTE: No support for tied ISA */
800
801 PERL_STATIC_INLINE GV*
S_gv_fetchmeth_internal(pTHX_ HV * stash,SV * meth,const char * name,STRLEN len,I32 level,U32 flags)802 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
803 {
804 GV** gvp;
805 HE* he;
806 AV* linear_av;
807 SV** linear_svp;
808 SV* linear_sv;
809 HV* cstash, *cachestash;
810 GV* candidate = NULL;
811 CV* cand_cv = NULL;
812 GV* topgv = NULL;
813 const char *hvname;
814 STRLEN hvnamelen;
815 I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
816 I32 items;
817 U32 topgen_cmp;
818 U32 is_utf8 = flags & SVf_UTF8;
819
820 /* UNIVERSAL methods should be callable without a stash */
821 if (!stash) {
822 create = 0; /* probably appropriate */
823 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
824 return 0;
825 }
826
827 assert(stash);
828
829 hvname = HvNAME_get(stash);
830 hvnamelen = HvNAMELEN_get(stash);
831 if (!hvname)
832 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
833
834 assert(hvname);
835 assert(name || meth);
836
837 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
838 flags & GV_SUPER ? "SUPER " : "",
839 name ? name : SvPV_nolen(meth), hvname) );
840
841 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
842
843 if (flags & GV_SUPER) {
844 if (!HvAUX(stash)->xhv_mro_meta->super)
845 HvAUX(stash)->xhv_mro_meta->super = newHV();
846 cachestash = HvAUX(stash)->xhv_mro_meta->super;
847 }
848 else cachestash = stash;
849
850 /* check locally for a real method or a cache entry */
851 he = (HE*)hv_common(
852 cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
853 );
854 if (he) gvp = (GV**)&HeVAL(he);
855 else gvp = NULL;
856
857 if(gvp) {
858 topgv = *gvp;
859 have_gv:
860 assert(topgv);
861 if (SvTYPE(topgv) != SVt_PVGV)
862 {
863 if (!name)
864 name = SvPV_nomg(meth, len);
865 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
866 }
867 if ((cand_cv = GvCV(topgv))) {
868 /* If genuine method or valid cache entry, use it */
869 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
870 return topgv;
871 }
872 else {
873 /* stale cache entry, junk it and move on */
874 SvREFCNT_dec_NN(cand_cv);
875 GvCV_set(topgv, NULL);
876 cand_cv = NULL;
877 GvCVGEN(topgv) = 0;
878 }
879 }
880 else if (GvCVGEN(topgv) == topgen_cmp) {
881 /* cache indicates no such method definitively */
882 return 0;
883 }
884 else if (stash == cachestash
885 && len > 1 /* shortest is uc */
886 && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
887 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
888 goto have_gv;
889 }
890
891 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
892 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
893 items = AvFILLp(linear_av); /* no +1, to skip over self */
894 while (items--) {
895 linear_sv = *linear_svp++;
896 assert(linear_sv);
897 cstash = gv_stashsv(linear_sv, 0);
898
899 if (!cstash) {
900 if ( ckWARN(WARN_SYNTAX)) {
901 if( /* these are loaded from Perl_Gv_AMupdate() one way or another */
902 ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */
903 || ( memEQs( name, len, "DESTROY") )
904 ) {
905 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
906 "Can't locate package %" SVf " for @%" HEKf "::ISA",
907 SVfARG(linear_sv),
908 HEKfARG(HvNAME_HEK(stash)));
909
910 } else if( memEQs( name, len, "AUTOLOAD") ) {
911 /* gobble this warning */
912 } else {
913 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
914 "While trying to resolve method call %.*s->%.*s()"
915 " can not locate package %" SVf_QUOTEDPREFIX " yet it is mentioned in @%.*s::ISA"
916 " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)",
917 (int) hvnamelen, hvname,
918 (int) len, name,
919 SVfARG(linear_sv),
920 (int) hvnamelen, hvname,
921 SVfARG(linear_sv));
922 }
923 }
924 continue;
925 }
926
927 assert(cstash);
928
929 gvp = (GV**)hv_common(
930 cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
931 );
932 if (!gvp) {
933 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
934 const char *hvname = HvNAME(cstash); assert(hvname);
935 if (strBEGINs(hvname, "CORE")
936 && (candidate =
937 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
938 ))
939 goto have_candidate;
940 }
941 continue;
942 }
943 else candidate = *gvp;
944 have_candidate:
945 assert(candidate);
946 if (SvTYPE(candidate) != SVt_PVGV)
947 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
948 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
949 /*
950 * Found real method, cache method in topgv if:
951 * 1. topgv has no synonyms (else inheritance crosses wires)
952 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
953 */
954 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
955 CV *old_cv = GvCV(topgv);
956 SvREFCNT_dec(old_cv);
957 SvREFCNT_inc_simple_void_NN(cand_cv);
958 GvCV_set(topgv, cand_cv);
959 GvCVGEN(topgv) = topgen_cmp;
960 }
961 return candidate;
962 }
963 }
964
965 /* Check UNIVERSAL without caching */
966 if((level == 0 || level == -1) && !(flags & GV_NOUNIVERSAL)) {
967 candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
968 flags &~GV_SUPER);
969 if(candidate) {
970 cand_cv = GvCV(candidate);
971 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
972 CV *old_cv = GvCV(topgv);
973 SvREFCNT_dec(old_cv);
974 SvREFCNT_inc_simple_void_NN(cand_cv);
975 GvCV_set(topgv, cand_cv);
976 GvCVGEN(topgv) = topgen_cmp;
977 }
978 return candidate;
979 }
980 }
981
982 if (topgv && GvREFCNT(topgv) == 1 && !(flags & GV_NOUNIVERSAL)) {
983 /* cache the fact that the method is not defined */
984 GvCVGEN(topgv) = topgen_cmp;
985 }
986
987 return 0;
988 }
989
990 GV *
Perl_gv_fetchmeth_pvn(pTHX_ HV * stash,const char * name,STRLEN len,I32 level,U32 flags)991 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
992 {
993 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
994 return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
995 }
996
997 /*
998 =for apidoc gv_fetchmeth_autoload
999
1000 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
1001 parameter.
1002
1003 =for apidoc gv_fetchmeth_sv_autoload
1004
1005 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
1006 of an SV instead of a string/length pair.
1007
1008 =cut
1009 */
1010
1011 GV *
Perl_gv_fetchmeth_sv_autoload(pTHX_ HV * stash,SV * namesv,I32 level,U32 flags)1012 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
1013 {
1014 char *namepv;
1015 STRLEN namelen;
1016 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
1017 namepv = SvPV(namesv, namelen);
1018 if (SvUTF8(namesv))
1019 flags |= SVf_UTF8;
1020 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
1021 }
1022
1023 /*
1024 =for apidoc gv_fetchmeth_pv_autoload
1025
1026 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
1027 instead of a string/length pair.
1028
1029 =cut
1030 */
1031
1032 GV *
Perl_gv_fetchmeth_pv_autoload(pTHX_ HV * stash,const char * name,I32 level,U32 flags)1033 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
1034 {
1035 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
1036 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
1037 }
1038
1039 /*
1040 =for apidoc gv_fetchmeth_pvn_autoload
1041
1042 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
1043 Returns a glob for the subroutine.
1044
1045 For an autoloaded subroutine without a GV, will create a GV even
1046 if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
1047 of the result may be zero.
1048
1049 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
1050
1051 =cut
1052 */
1053
1054 GV *
Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV * stash,const char * name,STRLEN len,I32 level,U32 flags)1055 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
1056 {
1057 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
1058
1059 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
1060
1061 if (!gv) {
1062 CV *cv;
1063 GV **gvp;
1064
1065 if (!stash)
1066 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
1067 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1068 return NULL;
1069 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
1070 return NULL;
1071 cv = GvCV(gv);
1072 if (!(CvROOT(cv) || CvXSUB(cv)))
1073 return NULL;
1074 /* Have an autoload */
1075 if (level < 0) /* Cannot do without a stub */
1076 gv_fetchmeth_pvn(stash, name, len, 0, flags);
1077 gvp = (GV**)hv_fetch(stash, name,
1078 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
1079 if (!gvp)
1080 return NULL;
1081 return *gvp;
1082 }
1083 return gv;
1084 }
1085
1086 /*
1087 =for apidoc gv_fetchmethod_autoload
1088
1089 Returns the glob which contains the subroutine to call to invoke the method
1090 on the C<stash>. In fact in the presence of autoloading this may be the
1091 glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
1092 already setup.
1093
1094 The third parameter of C<gv_fetchmethod_autoload> determines whether
1095 AUTOLOAD lookup is performed if the given method is not present: non-zero
1096 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
1097 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
1098 with a non-zero C<autoload> parameter.
1099
1100 These functions grant C<"SUPER"> token
1101 as a prefix of the method name. Note
1102 that if you want to keep the returned glob for a long time, you need to
1103 check for it being "AUTOLOAD", since at the later time the call may load a
1104 different subroutine due to C<$AUTOLOAD> changing its value. Use the glob
1105 created as a side effect to do this.
1106
1107 These functions have the same side-effects as C<gv_fetchmeth> with
1108 C<level==0>. The warning against passing the GV returned by
1109 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
1110
1111 =cut
1112 */
1113
1114 GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV * stash,const char * name,I32 autoload)1115 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
1116 {
1117 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
1118
1119 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1120 }
1121
1122 GV *
Perl_gv_fetchmethod_sv_flags(pTHX_ HV * stash,SV * namesv,U32 flags)1123 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1124 {
1125 char *namepv;
1126 STRLEN namelen;
1127 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1128 namepv = SvPV(namesv, namelen);
1129 if (SvUTF8(namesv))
1130 flags |= SVf_UTF8;
1131 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1132 }
1133
1134 GV *
Perl_gv_fetchmethod_pv_flags(pTHX_ HV * stash,const char * name,U32 flags)1135 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1136 {
1137 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1138 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1139 }
1140
1141 GV *
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV * stash,const char * name,const STRLEN len,U32 flags)1142 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1143 {
1144 const char * const origname = name;
1145 const char * const name_end = name + len;
1146 const char *last_separator = NULL;
1147 GV* gv;
1148 HV* ostash = stash;
1149 SV *const error_report = MUTABLE_SV(stash);
1150 const U32 autoload = flags & GV_AUTOLOAD;
1151 const U32 do_croak = flags & GV_CROAK;
1152 const U32 is_utf8 = flags & SVf_UTF8;
1153
1154 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1155
1156 if (SvTYPE(stash) < SVt_PVHV)
1157 stash = NULL;
1158 else {
1159 /* The only way stash can become NULL later on is if last_separator is set,
1160 which in turn means that there is no need for a SVt_PVHV case
1161 the error reporting code. */
1162 }
1163
1164 {
1165 /* check if the method name is fully qualified or
1166 * not, and separate the package name from the actual
1167 * method name.
1168 *
1169 * leaves last_separator pointing to the beginning of the
1170 * last package separator (either ' or ::) or 0
1171 * if none was found.
1172 *
1173 * leaves name pointing at the beginning of the
1174 * method name.
1175 */
1176 const char *name_cursor = name;
1177 const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1178 for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1179 if (*name_cursor == '\'') {
1180 last_separator = name_cursor;
1181 name = name_cursor + 1;
1182 }
1183 else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1184 last_separator = name_cursor++;
1185 name = name_cursor + 1;
1186 }
1187 }
1188 }
1189
1190 /* did we find a separator? */
1191 if (last_separator) {
1192 STRLEN sep_len= last_separator - origname;
1193 if ( memEQs(origname, sep_len, "SUPER")) {
1194 /* ->SUPER::method should really be looked up in original stash */
1195 stash = CopSTASH(PL_curcop);
1196 flags |= GV_SUPER;
1197 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1198 origname, HvENAME_get(stash), name) );
1199 }
1200 else if ( sep_len >= 7 &&
1201 strBEGINs(last_separator - 7, "::SUPER")) {
1202 /* don't autovivify if ->NoSuchStash::SUPER::method */
1203 stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1204 if (stash) flags |= GV_SUPER;
1205 }
1206 else {
1207 /* don't autovivify if ->NoSuchStash::method */
1208 stash = gv_stashpvn(origname, sep_len, is_utf8);
1209 }
1210 ostash = stash;
1211 }
1212
1213 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1214 if (!gv) {
1215 /* This is the special case that exempts Foo->import and
1216 Foo->unimport from being an error even if there's no
1217 import/unimport subroutine */
1218 if (strEQ(name,"import") || strEQ(name,"unimport")) {
1219 gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1220 NULL, 0, 0, NULL));
1221 } else if (autoload)
1222 gv = gv_autoload_pvn(
1223 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1224 );
1225 if (!gv && do_croak) {
1226 /* Right now this is exclusively for the benefit of S_method_common
1227 in pp_hot.c */
1228 if (stash) {
1229 /* If we can't find an IO::File method, it might be a call on
1230 * a filehandle. If IO:File has not been loaded, try to
1231 * require it first instead of croaking */
1232 const char *stash_name = HvNAME_get(stash);
1233 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1234 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1235 STR_WITH_LEN("IO/File.pm"), 0,
1236 HV_FETCH_ISEXISTS, NULL, 0)
1237 ) {
1238 require_pv("IO/File.pm");
1239 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1240 if (gv)
1241 return gv;
1242 }
1243 Perl_croak(aTHX_
1244 "Can't locate object method %" UTF8f_QUOTEDPREFIX ""
1245 " via package %" HEKf_QUOTEDPREFIX,
1246 UTF8fARG(is_utf8, name_end - name, name),
1247 HEKfARG(HvNAME_HEK(stash)));
1248 }
1249 else {
1250 SV* packnamesv;
1251
1252 if (last_separator) {
1253 packnamesv = newSVpvn_flags(origname, last_separator - origname,
1254 SVs_TEMP | is_utf8);
1255 } else {
1256 packnamesv = error_report;
1257 }
1258
1259 Perl_croak(aTHX_
1260 "Can't locate object method %" UTF8f_QUOTEDPREFIX ""
1261 " via package %" SVf_QUOTEDPREFIX ""
1262 " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)",
1263 UTF8fARG(is_utf8, name_end - name, name),
1264 SVfARG(packnamesv), SVfARG(packnamesv));
1265 }
1266 }
1267 }
1268 else if (autoload) {
1269 CV* const cv = GvCV(gv);
1270 if (!CvROOT(cv) && !CvXSUB(cv)) {
1271 GV* stubgv;
1272 GV* autogv;
1273
1274 if (CvANON(cv) || CvLEXICAL(cv))
1275 stubgv = gv;
1276 else {
1277 stubgv = CvGV(cv);
1278 if (GvCV(stubgv) != cv) /* orphaned import */
1279 stubgv = gv;
1280 }
1281 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1282 GvNAME(stubgv), GvNAMELEN(stubgv),
1283 GV_AUTOLOAD_ISMETHOD
1284 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1285 if (autogv)
1286 gv = autogv;
1287 }
1288 }
1289
1290 return gv;
1291 }
1292
1293
1294 /*
1295 =for apidoc gv_autoload_pv
1296 =for apidoc_item gv_autoload_pvn
1297 =for apidoc_item gv_autoload_sv
1298
1299 These each search for an C<AUTOLOAD> method, returning NULL if not found, or
1300 else returning a pointer to its GV, while setting the package
1301 L<C<$AUTOLOAD>|perlobj/AUTOLOAD> variable to C<name> (fully qualified). Also,
1302 if found and the GV's CV is an XSUB, the CV's PV will be set to C<name>, and
1303 its stash will be set to the stash of the GV.
1304
1305 Searching is done in L<C<MRO> order|perlmroapi>, as specified in
1306 L</C<gv_fetchmeth>>, beginning with C<stash> if it isn't NULL.
1307
1308 The forms differ only in how C<name> is specified.
1309
1310 In C<gv_autoload_pv>, C<namepv> is a C language NUL-terminated string.
1311
1312 In C<gv_autoload_pvn>, C<name> points to the first byte of the name, and an
1313 additional parameter, C<len>, specifies its length in bytes. Hence, C<*name>
1314 may contain embedded-NUL characters.
1315
1316 In C<gv_autoload_sv>, C<*namesv> is an SV, and the name is the PV extracted
1317 from that using L</C<SvPV>>. If the SV is marked as being in UTF-8, the
1318 extracted PV will also be.
1319
1320 =cut
1321 */
1322
1323 GV*
Perl_gv_autoload_sv(pTHX_ HV * stash,SV * namesv,U32 flags)1324 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1325 {
1326 char *namepv;
1327 STRLEN namelen;
1328 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1329 namepv = SvPV(namesv, namelen);
1330 if (SvUTF8(namesv))
1331 flags |= SVf_UTF8;
1332 return gv_autoload_pvn(stash, namepv, namelen, flags);
1333 }
1334
1335 GV*
Perl_gv_autoload_pv(pTHX_ HV * stash,const char * namepv,U32 flags)1336 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1337 {
1338 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1339 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1340 }
1341
1342 GV*
Perl_gv_autoload_pvn(pTHX_ HV * stash,const char * name,STRLEN len,U32 flags)1343 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1344 {
1345 GV* gv;
1346 CV* cv;
1347 HV* varstash;
1348 GV* vargv;
1349 SV* varsv;
1350 SV *packname = NULL;
1351 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1352
1353 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1354
1355 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1356 return NULL;
1357 if (stash) {
1358 if (SvTYPE(stash) < SVt_PVHV) {
1359 STRLEN packname_len = 0;
1360 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1361 packname = newSVpvn_flags(packname_ptr, packname_len,
1362 SVs_TEMP | SvUTF8(stash));
1363 stash = NULL;
1364 }
1365 else
1366 packname = newSVhek_mortal(HvNAME_HEK(stash));
1367 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1368 }
1369 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1370 is_utf8 | (flags & GV_SUPER))))
1371 return NULL;
1372 cv = GvCV(gv);
1373
1374 if (!(CvROOT(cv) || CvXSUB(cv)))
1375 return NULL;
1376
1377 /*
1378 * Inheriting AUTOLOAD for non-methods no longer works
1379 */
1380 if (
1381 !(flags & GV_AUTOLOAD_ISMETHOD)
1382 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1383 )
1384 Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1385 "::%" UTF8f "() is no longer allowed",
1386 SVfARG(packname),
1387 UTF8fARG(is_utf8, len, name));
1388
1389 if (CvISXSUB(cv)) {
1390 /* Instead of forcing the XSUB to do another lookup for $AUTOLOAD
1391 * and split that value on the last '::', pass along the same data
1392 * via the SvPVX field in the CV, and the stash in CvSTASH.
1393 *
1394 * Due to an unfortunate accident of history, the SvPVX field
1395 * serves two purposes. It is also used for the subroutine's
1396 * prototype. Since SvPVX has been documented as returning the sub
1397 * name for a long time, but not as returning the prototype, we have to
1398 * preserve the SvPVX AUTOLOAD behaviour and put the prototype
1399 * elsewhere.
1400 *
1401 * We put the prototype in the same allocated buffer, but after
1402 * the sub name. The SvPOK flag indicates the presence of a proto-
1403 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1404 * If both flags are on, then SvLEN is used to indicate the end of
1405 * the prototype (artificially lower than what is actually allo-
1406 * cated), at the risk of having to reallocate a few bytes unneces-
1407 * sarily--but that should happen very rarely, if ever.
1408 *
1409 * We use SvUTF8 for both prototypes and sub names, so if one is
1410 * UTF8, the other must be upgraded.
1411 */
1412 CvSTASH_set(cv, stash);
1413 if (SvPOK(cv)) { /* Ouch! */
1414 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1415 STRLEN ulen;
1416 const char *proto = CvPROTO(cv);
1417 assert(proto);
1418 if (SvUTF8(cv))
1419 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1420 ulen = SvCUR(tmpsv);
1421 SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
1422 sv_catpvn_flags(
1423 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1424 );
1425 SvTEMP_on(tmpsv); /* Allow theft */
1426 sv_setsv_nomg((SV *)cv, tmpsv);
1427 SvTEMP_off(tmpsv);
1428 SvREFCNT_dec_NN(tmpsv);
1429 SvLEN_set(cv, SvCUR(cv) + 1);
1430 SvCUR_set(cv, ulen);
1431 }
1432 else {
1433 sv_setpvn((SV *)cv, name, len);
1434 SvPOK_off(cv);
1435 if (is_utf8)
1436 SvUTF8_on(cv);
1437 else SvUTF8_off(cv);
1438 }
1439 CvAUTOLOAD_on(cv);
1440 }
1441
1442 /*
1443 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1444 * The subroutine's original name may not be "AUTOLOAD", so we don't
1445 * use that, but for lack of anything better we will use the sub's
1446 * original package to look up $AUTOLOAD.
1447 */
1448 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1449 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1450 ENTER;
1451
1452 if (!isGV(vargv)) {
1453 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1454 #ifdef PERL_DONT_CREATE_GVSV
1455 GvSV(vargv) = newSV_type(SVt_NULL);
1456 #endif
1457 }
1458 LEAVE;
1459 varsv = GvSVn(vargv);
1460 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1461 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1462 sv_setsv(varsv, packname);
1463 sv_catpvs(varsv, "::");
1464 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1465 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1466 sv_catpvn_flags(
1467 varsv, name, len,
1468 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1469 );
1470 if (is_utf8)
1471 SvUTF8_on(varsv);
1472 return gv;
1473 }
1474
1475
1476 /* require_tie_mod() internal routine for requiring a module
1477 * that implements the logic of automatic ties like %! and %-
1478 * It loads the module and then calls the _tie_it subroutine
1479 * with the passed gv as an argument.
1480 *
1481 * The "gv" parameter should be the glob.
1482 * "varname" holds the 1-char name of the var, used for error messages.
1483 * "namesv" holds the module name. Its refcount will be decremented.
1484 * "flags": if flag & 1 then save the scalar before loading.
1485 * For the protection of $! to work (it is set by this routine)
1486 * the sv slot must already be magicalized.
1487 */
1488 STATIC void
S_require_tie_mod(pTHX_ GV * gv,const char varname,const char * name,STRLEN len,const U32 flags)1489 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1490 STRLEN len, const U32 flags)
1491 {
1492 const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1493
1494 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1495
1496 /* If it is not tied */
1497 if (!target || !SvRMAGICAL(target)
1498 || !mg_find(target,
1499 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1500 {
1501 HV *stash;
1502 GV **gvp;
1503 dSP;
1504
1505 PUSHSTACKi(PERLSI_MAGIC);
1506 ENTER;
1507
1508 #define GET_HV_FETCH_TIE_FUNC \
1509 ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \
1510 && *gvp \
1511 && ( (isGV(*gvp) && GvCV(*gvp)) \
1512 || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \
1513 )
1514
1515 /* Load the module if it is not loaded. */
1516 if (!(stash = gv_stashpvn(name, len, 0))
1517 || ! GET_HV_FETCH_TIE_FUNC)
1518 {
1519 SV * const module = newSVpvn(name, len);
1520 const char type = varname == '[' ? '$' : '%';
1521 if ( flags & 1 )
1522 save_scalar(gv);
1523 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1524 assert(sp == PL_stack_sp);
1525 stash = gv_stashpvn(name, len, 0);
1526 if (!stash)
1527 Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1528 type, varname, name);
1529 else if (! GET_HV_FETCH_TIE_FUNC)
1530 Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1531 type, varname, name);
1532 }
1533 /* Now call the tie function. It should be in *gvp. */
1534 assert(gvp); assert(*gvp);
1535 PUSHMARK(SP);
1536 XPUSHs((SV *)gv);
1537 PUTBACK;
1538 call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1539 LEAVE;
1540 POPSTACK;
1541 }
1542 }
1543
1544 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1545 * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1546 * a true string WITHOUT a len.
1547 */
1548 #define require_tie_mod_s(gv, varname, name, flags) \
1549 S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1550
1551 /*
1552 =for apidoc gv_stashpv
1553
1554 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1555 determine the length of C<name>, then calls C<gv_stashpvn()>.
1556
1557 =cut
1558 */
1559
1560 HV*
Perl_gv_stashpv(pTHX_ const char * name,I32 create)1561 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1562 {
1563 PERL_ARGS_ASSERT_GV_STASHPV;
1564 return gv_stashpvn(name, strlen(name), create);
1565 }
1566
1567 /*
1568 =for apidoc gv_stashpvn
1569
1570 Returns a pointer to the stash for a specified package. The C<namelen>
1571 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1572 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1573 created if it does not already exist. If the package does not exist and
1574 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1575 is returned.
1576
1577 Flags may be one of:
1578
1579 GV_ADD Create and initialize the package if doesn't
1580 already exist
1581 GV_NOADD_NOINIT Don't create the package,
1582 GV_ADDMG GV_ADD iff the GV is magical
1583 GV_NOINIT GV_ADD, but don't initialize
1584 GV_NOEXPAND Don't expand SvOK() entries to PVGV
1585 SVf_UTF8 The name is in UTF-8
1586
1587 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1588
1589 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1590 recommended for performance reasons.
1591
1592 =for apidoc Amnh||GV_ADD
1593 =for apidoc Amnh||GV_NOADD_NOINIT
1594 =for apidoc Amnh||GV_NOINIT
1595 =for apidoc Amnh||GV_NOEXPAND
1596 =for apidoc Amnh||GV_ADDMG
1597 =for apidoc Amnh||SVf_UTF8
1598
1599 =cut
1600 */
1601
1602 /*
1603 gv_stashpvn_internal
1604
1605 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1606 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1607
1608 */
1609
1610 PERL_STATIC_INLINE HV*
S_gv_stashpvn_internal(pTHX_ const char * name,U32 namelen,I32 flags)1611 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1612 {
1613 char smallbuf[128];
1614 char *tmpbuf;
1615 HV *stash;
1616 GV *tmpgv;
1617 U32 tmplen = namelen + 2;
1618
1619 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1620
1621 if (tmplen <= sizeof smallbuf)
1622 tmpbuf = smallbuf;
1623 else
1624 Newx(tmpbuf, tmplen, char);
1625 Copy(name, tmpbuf, namelen, char);
1626 tmpbuf[namelen] = ':';
1627 tmpbuf[namelen+1] = ':';
1628 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1629 if (tmpbuf != smallbuf)
1630 Safefree(tmpbuf);
1631 if (!tmpgv || !isGV_with_GP(tmpgv))
1632 return NULL;
1633 stash = GvHV(tmpgv);
1634 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1635 assert(stash);
1636 if (!HvHasNAME(stash)) {
1637 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1638
1639 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1640 /* If the containing stash has multiple effective
1641 names, see that this one gets them, too. */
1642 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1643 mro_package_moved(stash, NULL, tmpgv, 1);
1644 }
1645 return stash;
1646 }
1647
1648 /*
1649 =for apidoc gv_stashsvpvn_cached
1650
1651 Returns a pointer to the stash for a specified package, possibly
1652 cached. Implements both L<perlapi/C<gv_stashpvn>> and
1653 L<perlapi/C<gv_stashsv>>.
1654
1655 Requires one of either C<namesv> or C<namepv> to be non-null.
1656
1657 If the flag C<GV_CACHE_ONLY> is set, return the stash only if found in the
1658 cache; see L<perlapi/C<gv_stashpvn>> for details on the other C<flags>.
1659
1660 Note it is strongly preferred for C<namesv> to be non-null, for performance
1661 reasons.
1662
1663 =for apidoc Emnh||GV_CACHE_ONLY
1664
1665 =cut
1666 */
1667
1668 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1669 assert(namesv || name)
1670
1671 HV*
Perl_gv_stashsvpvn_cached(pTHX_ SV * namesv,const char * name,U32 namelen,I32 flags)1672 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1673 {
1674 HV* stash;
1675 HE* he;
1676
1677 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1678
1679 he = (HE *)hv_common(
1680 PL_stashcache, namesv, name, namelen,
1681 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1682 );
1683
1684 if (he) {
1685 SV *sv = HeVAL(he);
1686 HV *hv;
1687 assert(SvIOK(sv));
1688 hv = INT2PTR(HV*, SvIVX(sv));
1689 assert(SvTYPE(hv) == SVt_PVHV);
1690 return hv;
1691 }
1692 else if (flags & GV_CACHE_ONLY) return NULL;
1693
1694 if (namesv) {
1695 if (SvOK(namesv)) { /* prevent double uninit warning */
1696 STRLEN len;
1697 name = SvPV_const(namesv, len);
1698 namelen = len;
1699 flags |= SvUTF8(namesv);
1700 } else {
1701 name = ""; namelen = 0;
1702 }
1703 }
1704 stash = gv_stashpvn_internal(name, namelen, flags);
1705
1706 if (stash && namelen) {
1707 SV* const ref = newSViv(PTR2IV(stash));
1708 (void)hv_store(PL_stashcache, name,
1709 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1710 }
1711
1712 return stash;
1713 }
1714
1715 HV*
Perl_gv_stashpvn(pTHX_ const char * name,U32 namelen,I32 flags)1716 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1717 {
1718 PERL_ARGS_ASSERT_GV_STASHPVN;
1719 return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1720 }
1721
1722 /*
1723 =for apidoc gv_stashsv
1724
1725 Returns a pointer to the stash for a specified package. See
1726 C<L</gv_stashpvn>>.
1727
1728 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1729 reasons.
1730
1731 =cut
1732 */
1733
1734 HV*
Perl_gv_stashsv(pTHX_ SV * sv,I32 flags)1735 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1736 {
1737 PERL_ARGS_ASSERT_GV_STASHSV;
1738 return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1739 }
1740 GV *
Perl_gv_fetchpv(pTHX_ const char * nambeg,I32 flags,const svtype sv_type)1741 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) {
1742 PERL_ARGS_ASSERT_GV_FETCHPV;
1743 return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type);
1744 }
1745
1746 GV *
Perl_gv_fetchsv(pTHX_ SV * name,I32 flags,const svtype sv_type)1747 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1748 STRLEN len;
1749 const char * const nambeg =
1750 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1751 PERL_ARGS_ASSERT_GV_FETCHSV;
1752 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1753 }
1754
1755 PERL_STATIC_INLINE void
S_gv_magicalize_isa(pTHX_ GV * gv)1756 S_gv_magicalize_isa(pTHX_ GV *gv)
1757 {
1758 AV* av;
1759
1760 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1761
1762 av = GvAVn(gv);
1763 GvMULTI_on(gv);
1764 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1765 NULL, 0);
1766
1767 if(HvSTASH_IS_CLASS(GvSTASH(gv))) {
1768 /* Don't permit modification of @ISA outside of the class management
1769 * code. This is temporarily undone by class.c when fiddling with the
1770 * array, so it knows it can be done safely.
1771 */
1772 SvREADONLY_on((SV *)av);
1773 }
1774 }
1775
1776 /* This function grabs name and tries to split a stash and glob
1777 * from its contents. TODO better description, comments
1778 *
1779 * If the function returns TRUE and 'name == name_end', then
1780 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1781 */
1782 PERL_STATIC_INLINE bool
S_parse_gv_stash_name(pTHX_ HV ** stash,GV ** gv,const char ** name,STRLEN * len,const char * nambeg,STRLEN full_len,const U32 is_utf8,const I32 add)1783 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1784 STRLEN *len, const char *nambeg, STRLEN full_len,
1785 const U32 is_utf8, const I32 add)
1786 {
1787 char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1788 const char *name_cursor;
1789 const char *const name_end = nambeg + full_len;
1790 const char *const name_em1 = name_end - 1;
1791 char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1792
1793 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1794
1795 if ( full_len > 2
1796 && **name == '*'
1797 && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1798 {
1799 /* accidental stringify on a GV? */
1800 (*name)++;
1801 }
1802
1803 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1804 if (name_cursor < name_em1 &&
1805 ((*name_cursor == ':' && name_cursor[1] == ':')
1806 || *name_cursor == '\''))
1807 {
1808 if (!*stash)
1809 *stash = PL_defstash;
1810 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1811 goto notok;
1812
1813 *len = name_cursor - *name;
1814 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1815 const char *key;
1816 GV**gvp;
1817 if (*name_cursor == ':') {
1818 key = *name;
1819 *len += 2;
1820 }
1821 else { /* using ' for package separator */
1822 /* use our pre-allocated buffer when possible to save a malloc */
1823 char *tmpbuf;
1824 if ( *len+2 <= sizeof smallbuf)
1825 tmpbuf = smallbuf;
1826 else {
1827 /* only malloc once if needed */
1828 if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1829 Newx(tmpfullbuf, full_len+2, char);
1830 tmpbuf = tmpfullbuf;
1831 }
1832 Copy(*name, tmpbuf, *len, char);
1833 tmpbuf[(*len)++] = ':';
1834 tmpbuf[(*len)++] = ':';
1835 key = tmpbuf;
1836 }
1837 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1838 *gv = gvp ? *gvp : NULL;
1839 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1840 goto notok;
1841 }
1842 /* here we know that *gv && *gv != &PL_sv_undef */
1843 if (SvTYPE(*gv) != SVt_PVGV)
1844 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1845 else
1846 GvMULTI_on(*gv);
1847
1848 if (!(*stash = GvHV(*gv))) {
1849 *stash = GvHV(*gv) = newHV();
1850 if (!HvHasNAME(*stash)) {
1851 if (GvSTASH(*gv) == PL_defstash && *len == 6
1852 && strBEGINs(*name, "CORE"))
1853 hv_name_sets(*stash, "CORE", 0);
1854 else
1855 hv_name_set(
1856 *stash, nambeg, name_cursor-nambeg, is_utf8
1857 );
1858 /* If the containing stash has multiple effective
1859 names, see that this one gets them, too. */
1860 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1861 mro_package_moved(*stash, NULL, *gv, 1);
1862 }
1863 }
1864 else if (!HvHasNAME(*stash))
1865 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1866 }
1867
1868 if (*name_cursor == ':')
1869 name_cursor++;
1870 *name = name_cursor+1;
1871 if (*name == name_end) {
1872 if (!*gv) {
1873 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1874 if (SvTYPE(*gv) != SVt_PVGV) {
1875 gv_init_pvn(*gv, PL_defstash, "main::", 6,
1876 GV_ADDMULTI);
1877 GvHV(*gv) =
1878 MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1879 }
1880 }
1881 goto ok;
1882 }
1883 }
1884 }
1885 *len = name_cursor - *name;
1886 ok:
1887 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1888 return TRUE;
1889 notok:
1890 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1891 return FALSE;
1892 }
1893
1894
1895 /* Checks if an unqualified name is in the main stash */
1896 PERL_STATIC_INLINE bool
S_gv_is_in_main(pTHX_ const char * name,STRLEN len,const U32 is_utf8)1897 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1898 {
1899 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1900
1901 /* If it's an alphanumeric variable */
1902 if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1903 /* Some "normal" variables are always in main::,
1904 * like INC or STDOUT.
1905 */
1906 switch (len) {
1907 case 1:
1908 if (*name == '_')
1909 return TRUE;
1910 break;
1911 case 3:
1912 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1913 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1914 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1915 return TRUE;
1916 break;
1917 case 4:
1918 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1919 && name[3] == 'V')
1920 return TRUE;
1921 break;
1922 case 5:
1923 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1924 && name[3] == 'I' && name[4] == 'N')
1925 return TRUE;
1926 break;
1927 case 6:
1928 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1929 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1930 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1931 return TRUE;
1932 break;
1933 case 7:
1934 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1935 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1936 && name[6] == 'T')
1937 return TRUE;
1938 break;
1939 }
1940 }
1941 /* *{""}, or a special variable like $@ */
1942 else
1943 return TRUE;
1944
1945 return FALSE;
1946 }
1947
1948
1949 /* This function is called if parse_gv_stash_name() failed to
1950 * find a stash, or if GV_NOTQUAL or an empty name was passed
1951 * to gv_fetchpvn_flags.
1952 *
1953 * It returns FALSE if the default stash can't be found nor created,
1954 * which might happen during global destruction.
1955 */
1956 PERL_STATIC_INLINE bool
S_find_default_stash(pTHX_ HV ** stash,const char * name,STRLEN len,const U32 is_utf8,const I32 add,const svtype sv_type)1957 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1958 const U32 is_utf8, const I32 add,
1959 const svtype sv_type)
1960 {
1961 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1962
1963 /* No stash in name, so see how we can default */
1964
1965 if ( gv_is_in_main(name, len, is_utf8) ) {
1966 *stash = PL_defstash;
1967 }
1968 else {
1969 if (IN_PERL_COMPILETIME) {
1970 *stash = PL_curstash;
1971 if (add && (PL_hints & HINT_STRICT_VARS) &&
1972 sv_type != SVt_PVCV &&
1973 sv_type != SVt_PVGV &&
1974 sv_type != SVt_PVFM &&
1975 sv_type != SVt_PVIO &&
1976 !(len == 1 && sv_type == SVt_PV &&
1977 (*name == 'a' || *name == 'b')) )
1978 {
1979 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1980 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1981 SvTYPE(*gvp) != SVt_PVGV)
1982 {
1983 *stash = NULL;
1984 }
1985 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1986 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1987 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1988 {
1989 /* diag_listed_as: Variable "%s" is not imported%s */
1990 Perl_ck_warner_d(
1991 aTHX_ packWARN(WARN_MISC),
1992 "Variable \"%c%" UTF8f "\" is not imported",
1993 sv_type == SVt_PVAV ? '@' :
1994 sv_type == SVt_PVHV ? '%' : '$',
1995 UTF8fARG(is_utf8, len, name));
1996 if (GvCVu(*gvp))
1997 Perl_ck_warner_d(
1998 aTHX_ packWARN(WARN_MISC),
1999 "\t(Did you mean &%" UTF8f " instead?)\n",
2000 UTF8fARG(is_utf8, len, name)
2001 );
2002 *stash = NULL;
2003 }
2004 }
2005 }
2006 else {
2007 /* Use the current op's stash */
2008 *stash = CopSTASH(PL_curcop);
2009 }
2010 }
2011
2012 if (!*stash) {
2013 if (add && !PL_in_clean_all) {
2014 GV *gv;
2015 qerror(Perl_mess(aTHX_
2016 "Global symbol \"%s%" UTF8f
2017 "\" requires explicit package name (did you forget to "
2018 "declare \"my %s%" UTF8f "\"?)",
2019 (sv_type == SVt_PV ? "$"
2020 : sv_type == SVt_PVAV ? "@"
2021 : sv_type == SVt_PVHV ? "%"
2022 : ""), UTF8fARG(is_utf8, len, name),
2023 (sv_type == SVt_PV ? "$"
2024 : sv_type == SVt_PVAV ? "@"
2025 : sv_type == SVt_PVHV ? "%"
2026 : ""), UTF8fARG(is_utf8, len, name)));
2027 /* To maintain the output of errors after the strict exception
2028 * above, and to keep compat with older releases, rather than
2029 * placing the variables in the pad, we place
2030 * them in the <none>:: stash.
2031 */
2032 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
2033 if (!gv) {
2034 /* symbol table under destruction */
2035 return FALSE;
2036 }
2037 *stash = GvHV(gv);
2038 }
2039 else
2040 return FALSE;
2041 }
2042
2043 if (!SvREFCNT(*stash)) /* symbol table under destruction */
2044 return FALSE;
2045
2046 return TRUE;
2047 }
2048
2049 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
2050 redefine SvREADONLY_on for that purpose. We don’t use it later on in
2051 this file. */
2052 #undef SvREADONLY_on
2053 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
2054
2055 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
2056 * a new GV.
2057 * Note that it does not insert the GV into the stash prior to
2058 * magicalization, which some variables require need in order
2059 * to work (like %+, %-, %!), so callers must take care of
2060 * that.
2061 *
2062 * It returns true if the gv did turn out to be magical one; i.e.,
2063 * if gv_magicalize actually did something.
2064 */
2065 PERL_STATIC_INLINE bool
S_gv_magicalize(pTHX_ GV * gv,HV * stash,const char * name,STRLEN len,const svtype sv_type)2066 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
2067 const svtype sv_type)
2068 {
2069 SSize_t paren;
2070
2071 PERL_ARGS_ASSERT_GV_MAGICALIZE;
2072
2073 if (stash != PL_defstash) { /* not the main stash */
2074 /* We only have to check for a few names here: a, b, EXPORT, ISA
2075 and VERSION. All the others apply only to the main stash or to
2076 CORE (which is checked right after this). */
2077 if (len) {
2078 switch (*name) {
2079 case 'E':
2080 if (
2081 len >= 6 && name[1] == 'X' &&
2082 (memEQs(name, len, "EXPORT")
2083 ||memEQs(name, len, "EXPORT_OK")
2084 ||memEQs(name, len, "EXPORT_FAIL")
2085 ||memEQs(name, len, "EXPORT_TAGS"))
2086 )
2087 GvMULTI_on(gv);
2088 break;
2089 case 'I':
2090 if (memEQs(name, len, "ISA"))
2091 gv_magicalize_isa(gv);
2092 break;
2093 case 'V':
2094 if (memEQs(name, len, "VERSION"))
2095 GvMULTI_on(gv);
2096 break;
2097 case 'a':
2098 if (stash == PL_debstash && memEQs(name, len, "args")) {
2099 GvMULTI_on(gv_AVadd(gv));
2100 break;
2101 }
2102 /* FALLTHROUGH */
2103 case 'b':
2104 if (len == 1 && sv_type == SVt_PV)
2105 GvMULTI_on(gv);
2106 /* FALLTHROUGH */
2107 default:
2108 goto try_core;
2109 }
2110 goto ret;
2111 }
2112 try_core:
2113 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
2114 /* Avoid null warning: */
2115 const char * const stashname = HvNAME(stash); assert(stashname);
2116 if (strBEGINs(stashname, "CORE"))
2117 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
2118 }
2119 }
2120 else if (len > 1) {
2121 #ifndef EBCDIC
2122 if (*name > 'V' ) {
2123 NOOP;
2124 /* Nothing else to do.
2125 The compiler will probably turn the switch statement into a
2126 branch table. Make sure we avoid even that small overhead for
2127 the common case of lower case variable names. (On EBCDIC
2128 platforms, we can't just do:
2129 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
2130 because cases like '\027' in the switch statement below are
2131 C1 (non-ASCII) controls on those platforms, so the remapping
2132 would make them larger than 'V')
2133 */
2134 } else
2135 #endif
2136 {
2137 switch (*name) {
2138 case 'A':
2139 if (memEQs(name, len, "ARGV")) {
2140 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
2141 }
2142 else if (memEQs(name, len, "ARGVOUT")) {
2143 GvMULTI_on(gv);
2144 }
2145 break;
2146 case 'E':
2147 if (
2148 len >= 6 && name[1] == 'X' &&
2149 (memEQs(name, len, "EXPORT")
2150 ||memEQs(name, len, "EXPORT_OK")
2151 ||memEQs(name, len, "EXPORT_FAIL")
2152 ||memEQs(name, len, "EXPORT_TAGS"))
2153 )
2154 GvMULTI_on(gv);
2155 break;
2156 case 'I':
2157 if (memEQs(name, len, "ISA")) {
2158 gv_magicalize_isa(gv);
2159 }
2160 break;
2161 case 'S':
2162 if (memEQs(name, len, "SIG")) {
2163 HV *hv;
2164 I32 i;
2165 if (!PL_psig_name) {
2166 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
2167 Newxz(PL_psig_pend, SIG_SIZE, int);
2168 PL_psig_ptr = PL_psig_name + SIG_SIZE;
2169 } else {
2170 /* I think that the only way to get here is to re-use an
2171 embedded perl interpreter, where the previous
2172 use didn't clean up fully because
2173 PL_perl_destruct_level was 0. I'm not sure that we
2174 "support" that, in that I suspect in that scenario
2175 there are sufficient other garbage values left in the
2176 interpreter structure that something else will crash
2177 before we get here. I suspect that this is one of
2178 those "doctor, it hurts when I do this" bugs. */
2179 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
2180 Zero(PL_psig_pend, SIG_SIZE, int);
2181 }
2182 GvMULTI_on(gv);
2183 hv = GvHVn(gv);
2184 hv_magic(hv, NULL, PERL_MAGIC_sig);
2185 for (i = 1; i < SIG_SIZE; i++) {
2186 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
2187 if (init)
2188 sv_setsv(*init, &PL_sv_undef);
2189 }
2190 }
2191 break;
2192 case 'V':
2193 if (memEQs(name, len, "VERSION"))
2194 GvMULTI_on(gv);
2195 break;
2196 case '\003': /* $^CHILD_ERROR_NATIVE */
2197 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2198 goto magicalize;
2199 /* @{^CAPTURE} %{^CAPTURE} */
2200 if (memEQs(name, len, "\003APTURE")) {
2201 AV* const av = GvAVn(gv);
2202 const Size_t n = *name;
2203
2204 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2205 SvREADONLY_on(av);
2206
2207 require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2208
2209 } else /* %{^CAPTURE_ALL} */
2210 if (memEQs(name, len, "\003APTURE_ALL")) {
2211 require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2212 }
2213 break;
2214 case '\005': /* ${^ENCODING} */
2215 if (memEQs(name, len, "\005NCODING"))
2216 goto magicalize;
2217 break;
2218 case '\007': /* ${^GLOBAL_PHASE} */
2219 if (memEQs(name, len, "\007LOBAL_PHASE"))
2220 goto ro_magicalize;
2221 break;
2222 case '\010': /* %{^HOOK} */
2223 if (memEQs(name, len, "\010OOK")) {
2224 GvMULTI_on(gv);
2225 HV *hv = GvHVn(gv);
2226 hv_magic(hv, NULL, PERL_MAGIC_hook);
2227 }
2228 break;
2229 case '\014':
2230 if ( memEQs(name, len, "\014AST_FH") || /* ${^LAST_FH} */
2231 memEQs(name, len, "\014AST_SUCCESSFUL_PATTERN")) /* ${^LAST_SUCCESSFUL_PATTERN} */
2232 goto ro_magicalize;
2233 break;
2234 case '\015': /* ${^MATCH} */
2235 if (memEQs(name, len, "\015ATCH")) {
2236 paren = RX_BUFF_IDX_CARET_FULLMATCH;
2237 goto storeparen;
2238 }
2239 break;
2240 case '\017': /* ${^OPEN} */
2241 if (memEQs(name, len, "\017PEN"))
2242 goto magicalize;
2243 break;
2244 case '\020': /* ${^PREMATCH} ${^POSTMATCH} */
2245 if (memEQs(name, len, "\020REMATCH")) {
2246 paren = RX_BUFF_IDX_CARET_PREMATCH;
2247 goto storeparen;
2248 }
2249 if (memEQs(name, len, "\020OSTMATCH")) {
2250 paren = RX_BUFF_IDX_CARET_POSTMATCH;
2251 goto storeparen;
2252 }
2253 break;
2254 case '\023':
2255 if (memEQs(name, len, "\023AFE_LOCALES"))
2256 goto ro_magicalize;
2257 break;
2258 case '\024': /* ${^TAINT} */
2259 if (memEQs(name, len, "\024AINT"))
2260 goto ro_magicalize;
2261 break;
2262 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
2263 if (memEQs(name, len, "\025NICODE"))
2264 goto ro_magicalize;
2265 if (memEQs(name, len, "\025TF8LOCALE"))
2266 goto ro_magicalize;
2267 if (memEQs(name, len, "\025TF8CACHE"))
2268 goto magicalize;
2269 break;
2270 case '\027': /* $^WARNING_BITS */
2271 if (memEQs(name, len, "\027ARNING_BITS"))
2272 goto magicalize;
2273 #ifdef WIN32
2274 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2275 goto magicalize;
2276 #endif
2277 break;
2278 case '1':
2279 case '2':
2280 case '3':
2281 case '4':
2282 case '5':
2283 case '6':
2284 case '7':
2285 case '8':
2286 case '9':
2287 {
2288 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2289 this test */
2290 UV uv;
2291 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2292 goto ret;
2293 /* XXX why are we using a SSize_t? */
2294 paren = (SSize_t)(I32)uv;
2295 goto storeparen;
2296 }
2297 }
2298 }
2299 } else {
2300 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
2301 be case '\0' in this switch statement (ie a default case) */
2302 switch (*name) {
2303 case '&': /* $& */
2304 paren = RX_BUFF_IDX_FULLMATCH;
2305 goto sawampersand;
2306 case '`': /* $` */
2307 paren = RX_BUFF_IDX_PREMATCH;
2308 goto sawampersand;
2309 case '\'': /* $' */
2310 paren = RX_BUFF_IDX_POSTMATCH;
2311 sawampersand:
2312 #ifdef PERL_SAWAMPERSAND
2313 if (!(
2314 sv_type == SVt_PVAV ||
2315 sv_type == SVt_PVHV ||
2316 sv_type == SVt_PVCV ||
2317 sv_type == SVt_PVFM ||
2318 sv_type == SVt_PVIO
2319 )) { PL_sawampersand |=
2320 (*name == '`')
2321 ? SAWAMPERSAND_LEFT
2322 : (*name == '&')
2323 ? SAWAMPERSAND_MIDDLE
2324 : SAWAMPERSAND_RIGHT;
2325 }
2326 #endif
2327 goto storeparen;
2328 case '1': /* $1 */
2329 case '2': /* $2 */
2330 case '3': /* $3 */
2331 case '4': /* $4 */
2332 case '5': /* $5 */
2333 case '6': /* $6 */
2334 case '7': /* $7 */
2335 case '8': /* $8 */
2336 case '9': /* $9 */
2337 paren = *name - '0';
2338
2339 storeparen:
2340 /* Flag the capture variables with a NULL mg_ptr
2341 Use mg_len for the array index to lookup. */
2342 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2343 break;
2344
2345 case ':': /* $: */
2346 sv_setpv(GvSVn(gv),PL_chopset);
2347 goto magicalize;
2348
2349 case '?': /* $? */
2350 #ifdef COMPLEX_STATUS
2351 SvUPGRADE(GvSVn(gv), SVt_PVLV);
2352 #endif
2353 goto magicalize;
2354
2355 case '!': /* $! */
2356 GvMULTI_on(gv);
2357 /* If %! has been used, automatically load Errno.pm. */
2358
2359 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2360
2361 /* magicalization must be done before require_tie_mod_s is called */
2362 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2363 require_tie_mod_s(gv, '!', "Errno", 1);
2364
2365 break;
2366 case '-': /* $-, %-, @- */
2367 case '+': /* $+, %+, @+ */
2368 GvMULTI_on(gv); /* no used once warnings here */
2369 { /* $- $+ */
2370 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2371 if (*name == '+')
2372 SvREADONLY_on(GvSVn(gv));
2373 }
2374 { /* %- %+ */
2375 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2376 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2377 }
2378 { /* @- @+ */
2379 AV* const av = GvAVn(gv);
2380 const Size_t n = *name;
2381
2382 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2383 SvREADONLY_on(av);
2384 }
2385 break;
2386 case '*': /* $* */
2387 case '#': /* $# */
2388 if (sv_type == SVt_PV)
2389 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2390 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2391 break;
2392 case '\010': /* $^H */
2393 {
2394 HV *const hv = GvHVn(gv);
2395 hv_magic(hv, NULL, PERL_MAGIC_hints);
2396 }
2397 goto magicalize;
2398 case '\023': /* $^S */
2399 ro_magicalize:
2400 SvREADONLY_on(GvSVn(gv));
2401 /* FALLTHROUGH */
2402 case '0': /* $0 */
2403 case '^': /* $^ */
2404 case '~': /* $~ */
2405 case '=': /* $= */
2406 case '%': /* $% */
2407 case '.': /* $. */
2408 case '(': /* $( */
2409 case ')': /* $) */
2410 case '<': /* $< */
2411 case '>': /* $> */
2412 case '\\': /* $\ */
2413 case '/': /* $/ */
2414 case '|': /* $| */
2415 case '$': /* $$ */
2416 case '[': /* $[ */
2417 case '\001': /* $^A */
2418 case '\003': /* $^C */
2419 case '\004': /* $^D */
2420 case '\005': /* $^E */
2421 case '\006': /* $^F */
2422 case '\011': /* $^I, NOT \t in EBCDIC */
2423 case '\016': /* $^N */
2424 case '\017': /* $^O */
2425 case '\020': /* $^P */
2426 case '\024': /* $^T */
2427 case '\027': /* $^W */
2428 magicalize:
2429 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2430 break;
2431
2432 case '\014': /* $^L */
2433 sv_setpvs(GvSVn(gv),"\f");
2434 break;
2435 case ';': /* $; */
2436 sv_setpvs(GvSVn(gv),"\034");
2437 break;
2438 case ']': /* $] */
2439 {
2440 SV * const sv = GvSV(gv);
2441 if (!sv_derived_from(PL_patchlevel, "version"))
2442 upg_version(PL_patchlevel, TRUE);
2443 GvSV(gv) = vnumify(PL_patchlevel);
2444 SvREADONLY_on(GvSV(gv));
2445 SvREFCNT_dec(sv);
2446 }
2447 break;
2448 case '\026': /* $^V */
2449 {
2450 SV * const sv = GvSV(gv);
2451 GvSV(gv) = new_version(PL_patchlevel);
2452 SvREADONLY_on(GvSV(gv));
2453 SvREFCNT_dec(sv);
2454 }
2455 break;
2456 case 'a':
2457 case 'b':
2458 if (sv_type == SVt_PV)
2459 GvMULTI_on(gv);
2460 }
2461 }
2462
2463 ret:
2464 /* Return true if we actually did something. */
2465 return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2466 || ( GvSV(gv) && (
2467 SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2468 )
2469 );
2470 }
2471
2472 /* If we do ever start using this later on in the file, we need to make
2473 sure we don’t accidentally use the wrong definition. */
2474 #undef SvREADONLY_on
2475
2476 /* This function is called when the stash already holds the GV of the magic
2477 * variable we're looking for, but we need to check that it has the correct
2478 * kind of magic. For example, if someone first uses $! and then %!, the
2479 * latter would end up here, and we add the Errno tie to the HASH slot of
2480 * the *! glob.
2481 */
2482 PERL_STATIC_INLINE void
S_maybe_multimagic_gv(pTHX_ GV * gv,const char * name,const svtype sv_type)2483 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2484 {
2485 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2486
2487 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2488 if (*name == '!')
2489 require_tie_mod_s(gv, '!', "Errno", 1);
2490 else if (*name == '-' || *name == '+')
2491 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2492 } else if (sv_type == SVt_PV) {
2493 if (*name == '*' || *name == '#') {
2494 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2495 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2496 }
2497 }
2498 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2499 switch (*name) {
2500 #ifdef PERL_SAWAMPERSAND
2501 case '`':
2502 PL_sawampersand |= SAWAMPERSAND_LEFT;
2503 (void)GvSVn(gv);
2504 break;
2505 case '&':
2506 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2507 (void)GvSVn(gv);
2508 break;
2509 case '\'':
2510 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2511 (void)GvSVn(gv);
2512 break;
2513 #endif
2514 }
2515 }
2516 }
2517
2518 /*
2519 =for apidoc gv_fetchpv
2520 =for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type
2521 =for apidoc_item ||gv_fetchpvn_flags
2522 =for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type
2523 =for apidoc_item ||gv_fetchsv
2524 =for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type
2525
2526 These all return the GV of type C<sv_type> whose name is given by the inputs,
2527 or NULL if no GV of that name and type could be found. See L<perlguts/Stashes
2528 and Globs>.
2529
2530 The only differences are how the input name is specified, and if 'get' magic is
2531 normally used in getting that name.
2532
2533 Don't be fooled by the fact that only one form has C<flags> in its name. They
2534 all have a C<flags> parameter in fact, and all the flag bits have the same
2535 meanings for all
2536
2537 If any of the flags C<GV_ADD>, C<GV_ADDMG>, C<GV_ADDWARN>, C<GV_ADDMULTI>, or
2538 C<GV_NOINIT> is set, a GV is created if none already exists for the input name
2539 and type. However, C<GV_ADDMG> will only do the creation for magical GV's.
2540 For all of these flags except C<GV_NOINIT>, C<L</gv_init_pvn>> is called after
2541 the addition. C<GV_ADDWARN> is used when the caller expects that adding won't
2542 be necessary because the symbol should already exist; but if not, add it
2543 anyway, with a warning that it was unexpectedly absent. The C<GV_ADDMULTI>
2544 flag means to pretend that the GV has been seen before (I<i.e.>, suppress "Used
2545 once" warnings).
2546
2547 The flag C<GV_NOADD_NOINIT> causes C<L</gv_init_pvn>> not be to called if the
2548 GV existed but isn't PVGV.
2549
2550 If the C<SVf_UTF8> bit is set, the name is treated as being encoded in UTF-8;
2551 otherwise the name won't be considered to be UTF-8 in the C<pv>-named forms,
2552 and the UTF-8ness of the underlying SVs will be used in the C<sv> forms.
2553
2554 If the flag C<GV_NOTQUAL> is set, the caller warrants that the input name is a
2555 plain symbol name, not qualified with a package, otherwise the name is checked
2556 for being a qualified one.
2557
2558 In C<gv_fetchpv>, C<nambeg> is a C string, NUL-terminated with no intermediate
2559 NULs.
2560
2561 In C<gv_fetchpvs>, C<name> is a literal C string, hence is enclosed in
2562 double quotes.
2563
2564 C<gv_fetchpvn> and C<gv_fetchpvn_flags> are identical. In these, <nambeg> is
2565 a Perl string whose byte length is given by C<full_len>, and may contain
2566 embedded NULs.
2567
2568 In C<gv_fetchsv> and C<gv_fetchsv_nomg>, the name is extracted from the PV of
2569 the input C<name> SV. The only difference between these two forms is that
2570 'get' magic is normally done on C<name> in C<gv_fetchsv>, and always skipped
2571 with C<gv_fetchsv_nomg>. Including C<GV_NO_SVGMAGIC> in the C<flags> parameter
2572 to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>.
2573
2574 =for apidoc Amnh||GV_ADD
2575 =for apidoc Amnh||GV_ADDMG
2576 =for apidoc Amnh||GV_ADDMULTI
2577 =for apidoc Amnh||GV_ADDWARN
2578 =for apidoc Amnh||GV_NOINIT
2579 =for apidoc Amnh||GV_NOADD_NOINIT
2580 =for apidoc Amnh||GV_NOTQUAL
2581 =for apidoc Amnh||GV_NO_SVGMAGIC
2582 =for apidoc Amnh||SVf_UTF8
2583
2584 =cut
2585 */
2586
2587 GV *
Perl_gv_fetchpvn_flags(pTHX_ const char * nambeg,STRLEN full_len,I32 flags,const svtype sv_type)2588 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2589 const svtype sv_type)
2590 {
2591 const char *name = nambeg;
2592 GV *gv = NULL;
2593 GV**gvp;
2594 STRLEN len;
2595 HV *stash = NULL;
2596 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2597 const I32 no_expand = flags & GV_NOEXPAND;
2598 const I32 add = flags & ~GV_NOADD_MASK;
2599 const U32 is_utf8 = flags & SVf_UTF8;
2600 bool addmg = cBOOL(flags & GV_ADDMG);
2601 const char *const name_end = nambeg + full_len;
2602 U32 faking_it;
2603
2604 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2605
2606 /* If we have GV_NOTQUAL, the caller promised that
2607 * there is no stash, so we can skip the check.
2608 * Similarly if full_len is 0, since then we're
2609 * dealing with something like *{""} or ""->foo()
2610 */
2611 if ((flags & GV_NOTQUAL) || !full_len) {
2612 len = full_len;
2613 }
2614 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2615 if (name == name_end) return gv;
2616 }
2617 else {
2618 return NULL;
2619 }
2620
2621 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2622 return NULL;
2623 }
2624
2625 /* By this point we should have a stash and a name */
2626 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2627 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2628 if (addmg) gv = (GV *)newSV_type(SVt_NULL); /* tentatively */
2629 else return NULL;
2630 }
2631 else gv = *gvp, addmg = 0;
2632 /* From this point on, addmg means gv has not been inserted in the
2633 symtab yet. */
2634
2635 if (SvTYPE(gv) == SVt_PVGV) {
2636 /* The GV already exists, so return it, but check if we need to do
2637 * anything else with it before that.
2638 */
2639 if (add) {
2640 /* This is the heuristic that handles if a variable triggers the
2641 * 'used only once' warning. If there's already a GV in the stash
2642 * with this name, then we assume that the variable has been used
2643 * before and turn its MULTI flag on.
2644 * It's a heuristic because it can easily be "tricked", like with
2645 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2646 * not warning about $main::foo being used just once
2647 */
2648 GvMULTI_on(gv);
2649 gv_init_svtype(gv, sv_type);
2650 /* You reach this path once the typeglob has already been created,
2651 either by the same or a different sigil. If this path didn't
2652 exist, then (say) referencing $! first, and %! second would
2653 mean that %! was not handled correctly. */
2654 if (len == 1 && stash == PL_defstash) {
2655 maybe_multimagic_gv(gv, name, sv_type);
2656 }
2657 else if (sv_type == SVt_PVAV
2658 && memEQs(name, len, "ISA")
2659 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2660 gv_magicalize_isa(gv);
2661 }
2662 return gv;
2663 } else if (no_init) {
2664 assert(!addmg);
2665 return gv;
2666 }
2667 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2668 * don't expand it to a glob. This is an optimization so that things
2669 * copying constants over, like Exporter, don't have to be rewritten
2670 * to take into account that you can store more than just globs in
2671 * stashes.
2672 */
2673 else if (no_expand && SvROK(gv)) {
2674 assert(!addmg);
2675 return gv;
2676 }
2677
2678 /* Adding a new symbol.
2679 Unless of course there was already something non-GV here, in which case
2680 we want to behave as if there was always a GV here, containing some sort
2681 of subroutine.
2682 Otherwise we run the risk of creating things like GvIO, which can cause
2683 subtle bugs. eg the one that tripped up SQL::Translator */
2684
2685 faking_it = SvOK(gv);
2686
2687 if (add & GV_ADDWARN)
2688 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2689 "Had to create %" UTF8f " unexpectedly",
2690 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2691 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2692
2693 if ( full_len != 0
2694 && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2695 && !ckWARN(WARN_ONCE) )
2696 {
2697 GvMULTI_on(gv) ;
2698 }
2699
2700 /* set up magic where warranted */
2701 if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2702 /* See 23496c6 */
2703 if (addmg) {
2704 /* gv_magicalize magicalised this gv, so we want it
2705 * stored in the symtab.
2706 * Effectively the caller is asking, ‘Does this gv exist?’
2707 * And we respond, ‘Er, *now* it does!’
2708 */
2709 (void)hv_store(stash,name,len,(SV *)gv,0);
2710 }
2711 }
2712 else if (addmg) {
2713 /* The temporary GV created above */
2714 SvREFCNT_dec_NN(gv);
2715 gv = NULL;
2716 }
2717
2718 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2719 return gv;
2720 }
2721
2722 /*
2723 =for apidoc gv_efullname3
2724 =for apidoc_item gv_efullname4
2725 =for apidoc_item gv_fullname3
2726 =for apidoc_item gv_fullname4
2727
2728 Place the full package name of C<gv> into C<sv>. The C<gv_e*> forms return
2729 instead the effective package name (see L</HvENAME>).
2730
2731 If C<prefix> is non-NULL, it is considered to be a C language NUL-terminated
2732 string, and the stored name will be prefaced with it.
2733
2734 The other difference between the functions is that the C<*4> forms have an
2735 extra parameter, C<keepmain>. If C<true> an initial C<main::> in the name is
2736 kept; if C<false> it is stripped. With the C<*3> forms, it is always kept.
2737
2738 =cut
2739 */
2740
2741 void
Perl_gv_fullname4(pTHX_ SV * sv,const GV * gv,const char * prefix,bool keepmain)2742 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2743 {
2744 const char *name;
2745 const HV * const hv = GvSTASH(gv);
2746
2747 PERL_ARGS_ASSERT_GV_FULLNAME4;
2748
2749 sv_setpv(sv, prefix ? prefix : "");
2750
2751 if (hv && (name = HvNAME(hv))) {
2752 const STRLEN len = HvNAMELEN(hv);
2753 if (keepmain || ! memBEGINs(name, len, "main")) {
2754 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2755 sv_catpvs(sv,"::");
2756 }
2757 }
2758 else sv_catpvs(sv,"__ANON__::");
2759 sv_catsv(sv,newSVhek_mortal(GvNAME_HEK(gv)));
2760 }
2761
2762 void
Perl_gv_efullname4(pTHX_ SV * sv,const GV * gv,const char * prefix,bool keepmain)2763 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2764 {
2765 const GV * const egv = GvEGVx(gv);
2766
2767 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2768
2769 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2770 }
2771
2772
2773 /* recursively scan a stash and any nested stashes looking for entries
2774 * that need the "only used once" warning raised
2775 */
2776
2777 void
Perl_gv_check(pTHX_ HV * stash)2778 Perl_gv_check(pTHX_ HV *stash)
2779 {
2780 I32 i;
2781
2782 PERL_ARGS_ASSERT_GV_CHECK;
2783
2784 if (!HvHasAUX(stash))
2785 return;
2786
2787 assert(HvARRAY(stash));
2788
2789 /* mark stash is being scanned, to avoid recursing */
2790 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2791 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2792 const HE *entry;
2793 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2794 GV *gv;
2795 HV *hv;
2796 STRLEN keylen = HeKLEN(entry);
2797 const char * const key = HeKEY(entry);
2798
2799 if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' &&
2800 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2801 {
2802 if (hv != PL_defstash && hv != stash
2803 && !(HvHasAUX(hv)
2804 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2805 )
2806 gv_check(hv); /* nested package */
2807 }
2808 else if ( HeKLEN(entry) != 0
2809 && *HeKEY(entry) != '_'
2810 && isIDFIRST_lazy_if_safe(HeKEY(entry),
2811 HeKEY(entry) + HeKLEN(entry),
2812 HeUTF8(entry)) )
2813 {
2814 const char *file;
2815 gv = MUTABLE_GV(HeVAL(entry));
2816 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2817 continue;
2818 file = GvFILE(gv);
2819 assert(PL_curcop == &PL_compiling);
2820 CopLINE_set(PL_curcop, GvLINE(gv));
2821 #ifdef USE_ITHREADS
2822 SAVECOPFILE_FREE(PL_curcop);
2823 CopFILE_set(PL_curcop, (char *)file); /* set for warning */
2824 #else
2825 CopFILEGV(PL_curcop)
2826 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2827 #endif
2828 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2829 "Name \"%" HEKf "::%" HEKf
2830 "\" used only once: possible typo",
2831 HEKfARG(HvNAME_HEK(stash)),
2832 HEKfARG(GvNAME_HEK(gv)));
2833 }
2834 }
2835 }
2836 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2837 }
2838
2839 /*
2840 =for apidoc newGVgen
2841 =for apidoc_item newGVgen_flags
2842
2843 Create a new, guaranteed to be unique, GV in the package given by the
2844 NUL-terminated C language string C<pack>, and return a pointer to it.
2845
2846 For C<newGVgen> or if C<flags> in C<newGVgen_flags> is 0, C<pack> is to be
2847 considered to be encoded in Latin-1. The only other legal C<flags> value is
2848 C<SVf_UTF8>, which indicates C<pack> is to be considered to be encoded in
2849 UTF-8.
2850
2851 =cut
2852 */
2853
2854 GV *
Perl_newGVgen_flags(pTHX_ const char * pack,U32 flags)2855 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2856 {
2857 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2858 assert(!(flags & ~SVf_UTF8));
2859
2860 return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2861 UTF8fARG(flags, strlen(pack), pack),
2862 (long)PL_gensym++),
2863 GV_ADD, SVt_PVGV);
2864 }
2865
2866 /* hopefully this is only called on local symbol table entries */
2867
2868 GP*
Perl_gp_ref(pTHX_ GP * gp)2869 Perl_gp_ref(pTHX_ GP *gp)
2870 {
2871 if (!gp)
2872 return NULL;
2873 gp->gp_refcnt++;
2874 if (gp->gp_cv) {
2875 if (gp->gp_cvgen) {
2876 /* If the GP they asked for a reference to contains
2877 a method cache entry, clear it first, so that we
2878 don't infect them with our cached entry */
2879 SvREFCNT_dec_NN(gp->gp_cv);
2880 gp->gp_cv = NULL;
2881 gp->gp_cvgen = 0;
2882 }
2883 }
2884 return gp;
2885 }
2886
2887 void
Perl_gp_free(pTHX_ GV * gv)2888 Perl_gp_free(pTHX_ GV *gv)
2889 {
2890 GP* gp;
2891 int attempts = 100;
2892 bool in_global_destruction = PL_phase == PERL_PHASE_DESTRUCT;
2893
2894 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2895 return;
2896 if (gp->gp_refcnt == 0) {
2897 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2898 "Attempt to free unreferenced glob pointers"
2899 pTHX__FORMAT pTHX__VALUE);
2900 return;
2901 }
2902 if (gp->gp_refcnt > 1) {
2903 borrowed:
2904 if (gp->gp_egv == gv)
2905 gp->gp_egv = 0;
2906 gp->gp_refcnt--;
2907 GvGP_set(gv, NULL);
2908 return;
2909 }
2910
2911 while (1) {
2912 /* Copy and null out all the glob slots, so destructors do not see
2913 freed SVs. */
2914 HEK * const file_hek = gp->gp_file_hek;
2915 SV * sv = gp->gp_sv;
2916 AV * av = gp->gp_av;
2917 HV * hv = gp->gp_hv;
2918 IO * io = gp->gp_io;
2919 CV * cv = gp->gp_cv;
2920 CV * form = gp->gp_form;
2921
2922 int need = 0;
2923
2924 gp->gp_file_hek = NULL;
2925 gp->gp_sv = NULL;
2926 gp->gp_av = NULL;
2927 gp->gp_hv = NULL;
2928 gp->gp_io = NULL;
2929 gp->gp_cv = NULL;
2930 gp->gp_form = NULL;
2931
2932 if (file_hek)
2933 unshare_hek(file_hek);
2934
2935 /* Storing the SV on the temps stack (instead of freeing it immediately)
2936 is an admitted bodge that attempt to compensate for the lack of
2937 reference counting on the stack. The motivation is that typeglob syntax
2938 is extremely short hence programs such as '$a += (*a = 2)' are often
2939 found randomly by researchers running fuzzers. Previously these
2940 programs would trigger errors, that the researchers would
2941 (legitimately) report, and then we would spend time figuring out that
2942 the cause was "stack not reference counted" and so not a dangerous
2943 security hole. This consumed a lot of researcher time, our time, and
2944 prevents "interesting" security holes being uncovered.
2945
2946 Typeglob assignment is rarely used in performance critical production
2947 code, so we aren't causing much slowdown by doing extra work here.
2948
2949 In turn, the need to check for SvOBJECT (and references to objects) is
2950 because we have regression tests that rely on timely destruction that
2951 happens *within this while loop* to demonstrate behaviour, and
2952 potentially there is also *working* code in the wild that relies on
2953 such behaviour.
2954
2955 And we need to avoid doing this in global destruction else we can end
2956 up with "Attempt to free temp prematurely ... Unbalanced string table
2957 refcount".
2958
2959 Hence the whole thing is a heuristic intended to mitigate against
2960 simple problems likely found by fuzzers but never written by humans,
2961 whilst leaving working code unchanged. */
2962 if (sv) {
2963 SV *referent;
2964 if (SvREFCNT(sv) > 1 || SvOBJECT(sv) || UNLIKELY(in_global_destruction)) {
2965 SvREFCNT_dec_NN(sv);
2966 sv = NULL;
2967 } else if (SvROK(sv) && (referent = SvRV(sv))
2968 && (SvREFCNT(referent) > 1 || SvOBJECT(referent))) {
2969 SvREFCNT_dec_NN(sv);
2970 sv = NULL;
2971 } else {
2972 ++need;
2973 }
2974 }
2975 if (av) {
2976 if (SvREFCNT(av) > 1 || SvOBJECT(av) || UNLIKELY(in_global_destruction)) {
2977 SvREFCNT_dec_NN(av);
2978 av = NULL;
2979 } else {
2980 ++need;
2981 }
2982 }
2983 /* FIXME - another reference loop GV -> symtab -> GV ?
2984 Somehow gp->gp_hv can end up pointing at freed garbage. */
2985 if (hv && SvTYPE(hv) == SVt_PVHV) {
2986 const HEK *hvname_hek = HvNAME_HEK(hv);
2987 if (PL_stashcache && hvname_hek) {
2988 DEBUG_o(Perl_deb(aTHX_
2989 "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2990 HEKfARG(hvname_hek)));
2991 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2992 }
2993 if (SvREFCNT(hv) > 1 || SvOBJECT(hv) || UNLIKELY(in_global_destruction)) {
2994 SvREFCNT_dec_NN(hv);
2995 hv = NULL;
2996 } else {
2997 ++need;
2998 }
2999 }
3000 if (io && SvREFCNT(io) == 1 && IoIFP(io)
3001 && (IoTYPE(io) == IoTYPE_WRONLY ||
3002 IoTYPE(io) == IoTYPE_RDWR ||
3003 IoTYPE(io) == IoTYPE_APPEND)
3004 && ckWARN_d(WARN_IO)
3005 && IoIFP(io) != PerlIO_stdin()
3006 && IoIFP(io) != PerlIO_stdout()
3007 && IoIFP(io) != PerlIO_stderr()
3008 && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3009 io_close(io, gv, FALSE, TRUE);
3010 if (io) {
3011 if (SvREFCNT(io) > 1 || SvOBJECT(io) || UNLIKELY(in_global_destruction)) {
3012 SvREFCNT_dec_NN(io);
3013 io = NULL;
3014 } else {
3015 ++need;
3016 }
3017 }
3018 if (cv) {
3019 if (SvREFCNT(cv) > 1 || SvOBJECT(cv) || UNLIKELY(in_global_destruction)) {
3020 SvREFCNT_dec_NN(cv);
3021 cv = NULL;
3022 } else {
3023 ++need;
3024 }
3025 }
3026 if (form) {
3027 if (SvREFCNT(form) > 1 || SvOBJECT(form) || UNLIKELY(in_global_destruction)) {
3028 SvREFCNT_dec_NN(form);
3029 form = NULL;
3030 } else {
3031 ++need;
3032 }
3033 }
3034
3035 if (need) {
3036 /* We don't strictly need to defer all this to the end, but it's
3037 easiest to do so. The subtle problems we have are
3038 1) any of the actions triggered by the various SvREFCNT_dec()s in
3039 any of the intermediate blocks can cause more items to be added
3040 to the temps stack. So we can't "cache" its state locally
3041 2) We'd have to re-check the "extend by 1?" for each time.
3042 Whereas if we don't NULL out the values that we want to put onto
3043 the save stack until here, we can do it in one go, with one
3044 one size check. */
3045
3046 SSize_t max_ix = PL_tmps_ix + need;
3047
3048 if (max_ix >= PL_tmps_max) {
3049 tmps_grow_p(max_ix);
3050 }
3051
3052 if (sv) {
3053 PL_tmps_stack[++PL_tmps_ix] = sv;
3054 }
3055 if (av) {
3056 PL_tmps_stack[++PL_tmps_ix] = (SV *) av;
3057 }
3058 if (hv) {
3059 PL_tmps_stack[++PL_tmps_ix] = (SV *) hv;
3060 }
3061 if (io) {
3062 PL_tmps_stack[++PL_tmps_ix] = (SV *) io;
3063 }
3064 if (cv) {
3065 PL_tmps_stack[++PL_tmps_ix] = (SV *) cv;
3066 }
3067 if (form) {
3068 PL_tmps_stack[++PL_tmps_ix] = (SV *) form;
3069 }
3070 }
3071
3072 /* Possibly reallocated by a destructor */
3073 gp = GvGP(gv);
3074
3075 if (!gp->gp_file_hek
3076 && !gp->gp_sv
3077 && !gp->gp_av
3078 && !gp->gp_hv
3079 && !gp->gp_io
3080 && !gp->gp_cv
3081 && !gp->gp_form) break;
3082
3083 if (--attempts == 0) {
3084 Perl_die(aTHX_
3085 "panic: gp_free failed to free glob pointer - "
3086 "something is repeatedly re-creating entries"
3087 );
3088 }
3089 }
3090
3091 /* Possibly incremented by a destructor doing glob assignment */
3092 if (gp->gp_refcnt > 1) goto borrowed;
3093 Safefree(gp);
3094 GvGP_set(gv, NULL);
3095 }
3096
3097 int
Perl_magic_freeovrld(pTHX_ SV * sv,MAGIC * mg)3098 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
3099 {
3100 AMT * const amtp = (AMT*)mg->mg_ptr;
3101 PERL_UNUSED_ARG(sv);
3102
3103 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
3104
3105 if (amtp && AMT_AMAGIC(amtp)) {
3106 int i;
3107 for (i = 1; i < NofAMmeth; i++) {
3108 CV * const cv = amtp->table[i];
3109 if (cv) {
3110 SvREFCNT_dec_NN(MUTABLE_SV(cv));
3111 amtp->table[i] = NULL;
3112 }
3113 }
3114 }
3115 return 0;
3116 }
3117
3118 /*
3119 =for apidoc Gv_AMupdate
3120
3121 Recalculates overload magic in the package given by C<stash>.
3122
3123 Returns:
3124
3125 =over
3126
3127 =item 1 on success and there is some overload
3128
3129 =item 0 if there is no overload
3130
3131 =item -1 if some error occurred and it couldn't croak (because C<destructing>
3132 is true).
3133
3134 =back
3135
3136 =cut
3137 */
3138
3139 int
Perl_Gv_AMupdate(pTHX_ HV * stash,bool destructing)3140 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
3141 {
3142 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3143 AMT amt;
3144 const struct mro_meta* stash_meta = HvMROMETA(stash);
3145 U32 newgen;
3146
3147 PERL_ARGS_ASSERT_GV_AMUPDATE;
3148
3149 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
3150 if (mg) {
3151 const AMT * const amtp = (AMT*)mg->mg_ptr;
3152 if (amtp->was_ok_sub == newgen) {
3153 return AMT_AMAGIC(amtp) ? 1 : 0;
3154 }
3155 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
3156 }
3157
3158 DEBUG_o( Perl_deb(aTHX_ "Recalculating overload magic in package %s\n",HvNAME_get(stash)) );
3159
3160 Zero(&amt,1,AMT);
3161 amt.was_ok_sub = newgen;
3162 amt.fallback = AMGfallNO;
3163 amt.flags = 0;
3164
3165 {
3166 int filled = 0;
3167 int i;
3168 bool deref_seen = 0;
3169
3170
3171 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
3172
3173 /* Try to find via inheritance. */
3174 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
3175 SV * const sv = gv ? GvSV(gv) : NULL;
3176 CV* cv;
3177
3178 if (!gv)
3179 {
3180 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
3181 goto no_table;
3182 }
3183 #ifdef PERL_DONT_CREATE_GVSV
3184 else if (!sv) {
3185 NOOP; /* Equivalent to !SvTRUE and !SvOK */
3186 }
3187 #endif
3188 else if (SvTRUE(sv))
3189 /* don't need to set overloading here because fallback => 1
3190 * is the default setting for classes without overloading */
3191 amt.fallback=AMGfallYES;
3192 else if (SvOK(sv)) {
3193 amt.fallback=AMGfallNEVER;
3194 filled = 1;
3195 }
3196 else {
3197 filled = 1;
3198 }
3199
3200 assert(HvHasAUX(stash));
3201 /* initially assume the worst */
3202 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
3203
3204 for (i = 1; i < NofAMmeth; i++) {
3205 const char * const cooky = PL_AMG_names[i];
3206 /* Human-readable form, for debugging: */
3207 const char * const cp = AMG_id2name(i);
3208 const STRLEN l = PL_AMG_namelens[i];
3209
3210 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
3211 cp, HvNAME_get(stash)) );
3212 /* don't fill the cache while looking up!
3213 Creation of inheritance stubs in intermediate packages may
3214 conflict with the logic of runtime method substitution.
3215 Indeed, for inheritance A -> B -> C, if C overloads "+0",
3216 then we could have created stubs for "(+0" in A and C too.
3217 But if B overloads "bool", we may want to use it for
3218 numifying instead of C's "+0". */
3219 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
3220 cv = 0;
3221 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
3222 const HEK * const gvhek = CvGvNAME_HEK(cv);
3223 const HEK * const stashek =
3224 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
3225 if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
3226 && stashek
3227 && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
3228 /* This is a hack to support autoloading..., while
3229 knowing *which* methods were declared as overloaded. */
3230 /* GvSV contains the name of the method. */
3231 GV *ngv = NULL;
3232 SV *gvsv = GvSV(gv);
3233
3234 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
3235 "\" for overloaded \"%s\" in package \"%.256s\"\n",
3236 (void*)GvSV(gv), cp, HvNAME(stash)) );
3237 if (!gvsv || !SvPOK(gvsv)
3238 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
3239 {
3240 /* Can be an import stub (created by "can"). */
3241 if (destructing) {
3242 return -1;
3243 }
3244 else {
3245 const SV * const name = (gvsv && SvPOK(gvsv))
3246 ? gvsv
3247 : newSVpvs_flags("???", SVs_TEMP);
3248 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
3249 Perl_croak(aTHX_ "%s method \"%" SVf256
3250 "\" overloading \"%s\" "\
3251 "in package \"%" HEKf256 "\"",
3252 (GvCVGEN(gv) ? "Stub found while resolving"
3253 : "Can't resolve"),
3254 SVfARG(name), cp,
3255 HEKfARG(
3256 HvNAME_HEK(stash)
3257 ));
3258 }
3259 }
3260 cv = GvCV(gv = ngv);
3261 }
3262 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
3263 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
3264 GvNAME(CvGV(cv))) );
3265 filled = 1;
3266 } else if (gv) { /* Autoloaded... */
3267 cv = MUTABLE_CV(gv);
3268 filled = 1;
3269 }
3270 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
3271
3272 if (gv) {
3273 switch (i) {
3274 case to_sv_amg:
3275 case to_av_amg:
3276 case to_hv_amg:
3277 case to_gv_amg:
3278 case to_cv_amg:
3279 case nomethod_amg:
3280 deref_seen = 1;
3281 break;
3282 }
3283 }
3284 }
3285 if (!deref_seen)
3286 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
3287 * NB - aux var invalid here, HvARRAY() could have been
3288 * reallocated since it was assigned to */
3289 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
3290
3291 if (filled) {
3292 AMT_AMAGIC_on(&amt);
3293 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
3294 (char*)&amt, sizeof(AMT));
3295 return TRUE;
3296 }
3297 }
3298 /* Here we have no table: */
3299 no_table:
3300 AMT_AMAGIC_off(&amt);
3301 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
3302 (char*)&amt, sizeof(AMTS));
3303 return 0;
3304 }
3305
3306 /*
3307 =for apidoc gv_handler
3308
3309 Implements C<StashHANDLER>, which you should use instead
3310
3311 =cut
3312 */
3313
3314 CV*
Perl_gv_handler(pTHX_ HV * stash,I32 id)3315 Perl_gv_handler(pTHX_ HV *stash, I32 id)
3316 {
3317 MAGIC *mg;
3318 AMT *amtp;
3319 U32 newgen;
3320 struct mro_meta* stash_meta;
3321
3322 if (!stash || !HvHasNAME(stash))
3323 return NULL;
3324
3325 stash_meta = HvMROMETA(stash);
3326 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
3327
3328 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3329 if (!mg) {
3330 do_update:
3331 if (Gv_AMupdate(stash, 0) == -1)
3332 return NULL;
3333 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3334 }
3335 assert(mg);
3336 amtp = (AMT*)mg->mg_ptr;
3337 if ( amtp->was_ok_sub != newgen )
3338 goto do_update;
3339 if (AMT_AMAGIC(amtp)) {
3340 CV * const ret = amtp->table[id];
3341 if (ret && isGV(ret)) { /* Autoloading stab */
3342 /* Passing it through may have resulted in a warning
3343 "Inherited AUTOLOAD for a non-method deprecated", since
3344 our caller is going through a function call, not a method call.
3345 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
3346 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3347
3348 if (gv && GvCV(gv))
3349 return GvCV(gv);
3350 }
3351 return ret;
3352 }
3353
3354 return NULL;
3355 }
3356
3357
3358 /* Implement tryAMAGICun_MG macro.
3359 Do get magic, then see if the stack arg is overloaded and if so call it.
3360 Flags:
3361 AMGf_numeric apply sv_2num to the stack arg.
3362 */
3363
3364 bool
Perl_try_amagic_un(pTHX_ int method,int flags)3365 Perl_try_amagic_un(pTHX_ int method, int flags) {
3366 dSP;
3367 SV* tmpsv;
3368 SV* const arg = TOPs;
3369
3370 SvGETMAGIC(arg);
3371
3372 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
3373 AMGf_noright | AMGf_unary
3374 | (flags & AMGf_numarg))))
3375 {
3376 /* where the op is of the form:
3377 * $lex = $x op $y (where the assign is optimised away)
3378 * then assign the returned value to targ and return that;
3379 * otherwise return the value directly
3380 */
3381 if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3382 && (PL_op->op_private & OPpTARGET_MY))
3383 {
3384 dTARGET;
3385 sv_setsv(TARG, tmpsv);
3386 SETTARG;
3387 }
3388 else
3389 SETs(tmpsv);
3390
3391 PUTBACK;
3392 return TRUE;
3393 }
3394
3395 if ((flags & AMGf_numeric) && SvROK(arg))
3396 *sp = sv_2num(arg);
3397 return FALSE;
3398 }
3399
3400
3401 /*
3402 =for apidoc amagic_applies
3403
3404 Check C<sv> to see if the overloaded (active magic) operation C<method>
3405 applies to it. If the sv is not SvROK or it is not an object then returns
3406 false, otherwise checks if the object is blessed into a class supporting
3407 overloaded operations, and returns true if a call to amagic_call() with
3408 this SV and the given method would trigger an amagic operation, including
3409 via the overload fallback rules or via nomethod. Thus a call like:
3410
3411 amagic_applies(sv, string_amg, AMG_unary)
3412
3413 would return true for an object with overloading set up in any of the
3414 following ways:
3415
3416 use overload q("") => sub { ... };
3417 use overload q(0+) => sub { ... }, fallback => 1;
3418
3419 and could be used to tell if a given object would stringify to something
3420 other than the normal default ref stringification.
3421
3422 Note that the fact that this function returns TRUE does not mean you
3423 can succesfully perform the operation with amagic_call(), for instance
3424 any overloaded method might throw a fatal exception, however if this
3425 function returns FALSE you can be confident that it will NOT perform
3426 the given overload operation.
3427
3428 C<method> is an integer enum, one of the values found in F<overload.h>,
3429 for instance C<string_amg>.
3430
3431 C<flags> should be set to AMG_unary for unary operations.
3432
3433 =cut
3434 */
3435 bool
Perl_amagic_applies(pTHX_ SV * sv,int method,int flags)3436 Perl_amagic_applies(pTHX_ SV *sv, int method, int flags)
3437 {
3438 PERL_ARGS_ASSERT_AMAGIC_APPLIES;
3439 PERL_UNUSED_VAR(flags);
3440
3441 assert(method >= 0 && method < NofAMmeth);
3442
3443 if (!SvAMAGIC(sv))
3444 return FALSE;
3445
3446 HV *stash = SvSTASH(SvRV(sv));
3447 if (!Gv_AMG(stash))
3448 return FALSE;
3449
3450 MAGIC *mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3451 if (!mg)
3452 return FALSE;
3453
3454 CV **cvp = NULL;
3455 AMT *amtp = NULL;
3456 if (AMT_AMAGIC((AMT *)mg->mg_ptr)) {
3457 amtp = (AMT *)mg->mg_ptr;
3458 cvp = amtp->table;
3459 }
3460 if (!cvp)
3461 return FALSE;
3462
3463 if (cvp[method])
3464 return TRUE;
3465
3466 /* Note this logic should be kept in sync with amagic_call() */
3467 if (amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3468 CV *cv; /* This makes it easier to kee ... */
3469 int off,off1; /* ... in sync with amagic_call() */
3470
3471 /* look for substituted methods */
3472 /* In all the covered cases we should be called with assign==0. */
3473 switch (method) {
3474 case inc_amg:
3475 if ((cv = cvp[off=add_ass_amg]) || ((cv = cvp[off = add_amg])))
3476 return TRUE;
3477 break;
3478 case dec_amg:
3479 if((cv = cvp[off = subtr_ass_amg]) || ((cv = cvp[off = subtr_amg])))
3480 return TRUE;
3481 break;
3482 case bool__amg:
3483 if ((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]))
3484 return TRUE;
3485 break;
3486 case numer_amg:
3487 if((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]))
3488 return TRUE;
3489 break;
3490 case string_amg:
3491 if((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]))
3492 return TRUE;
3493 break;
3494 case not_amg:
3495 if((cv = cvp[off=bool__amg])
3496 || (cv = cvp[off=numer_amg])
3497 || (cv = cvp[off=string_amg]))
3498 return TRUE;
3499 break;
3500 case abs_amg:
3501 if((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3502 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg])))
3503 return TRUE;
3504 break;
3505 case neg_amg:
3506 if ((cv = cvp[off=subtr_amg]))
3507 return TRUE;
3508 break;
3509 }
3510 } else if (((cvp && amtp->fallback > AMGfallNEVER))
3511 && !(flags & AMGf_unary)) {
3512 /* We look for substitution for
3513 * comparison operations and
3514 * concatenation */
3515 if (method==concat_amg || method==concat_ass_amg
3516 || method==repeat_amg || method==repeat_ass_amg) {
3517 return FALSE; /* Delegate operation to string conversion */
3518 }
3519 switch (method) {
3520 case lt_amg:
3521 case le_amg:
3522 case gt_amg:
3523 case ge_amg:
3524 case eq_amg:
3525 case ne_amg:
3526 if (cvp[ncmp_amg])
3527 return TRUE;
3528 break;
3529 case slt_amg:
3530 case sle_amg:
3531 case sgt_amg:
3532 case sge_amg:
3533 case seq_amg:
3534 case sne_amg:
3535 if (cvp[scmp_amg])
3536 return TRUE;
3537 break;
3538 }
3539 }
3540
3541 if (cvp[nomethod_amg])
3542 return TRUE;
3543
3544 return FALSE;
3545 }
3546
3547
3548 /* Implement tryAMAGICbin_MG macro.
3549 Do get magic, then see if the two stack args are overloaded and if so
3550 call it.
3551 Flags:
3552 AMGf_assign op may be called as mutator (eg +=)
3553 AMGf_numeric apply sv_2num to the stack arg.
3554 */
3555
3556 bool
Perl_try_amagic_bin(pTHX_ int method,int flags)3557 Perl_try_amagic_bin(pTHX_ int method, int flags) {
3558 dSP;
3559 SV* const left = TOPm1s;
3560 SV* const right = TOPs;
3561
3562 SvGETMAGIC(left);
3563 if (left != right)
3564 SvGETMAGIC(right);
3565
3566 if (SvAMAGIC(left) || SvAMAGIC(right)) {
3567 SV * tmpsv;
3568 /* STACKED implies mutator variant, e.g. $x += 1 */
3569 bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
3570
3571 tmpsv = amagic_call(left, right, method,
3572 (mutator ? AMGf_assign: 0)
3573 | (flags & AMGf_numarg));
3574 if (tmpsv) {
3575 (void)POPs;
3576 /* where the op is one of the two forms:
3577 * $x op= $y
3578 * $lex = $x op $y (where the assign is optimised away)
3579 * then assign the returned value to targ and return that;
3580 * otherwise return the value directly
3581 */
3582 if ( mutator
3583 || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3584 && (PL_op->op_private & OPpTARGET_MY)))
3585 {
3586 dTARG;
3587 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
3588 sv_setsv(TARG, tmpsv);
3589 SETTARG;
3590 }
3591 else
3592 SETs(tmpsv);
3593
3594 PUTBACK;
3595 return TRUE;
3596 }
3597 }
3598
3599 if(left==right && SvGMAGICAL(left)) {
3600 SV * const left = sv_newmortal();
3601 *(sp-1) = left;
3602 /* Print the uninitialized warning now, so it includes the vari-
3603 able name. */
3604 if (!SvOK(right)) {
3605 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3606 sv_setbool(left, FALSE);
3607 }
3608 else sv_setsv_flags(left, right, 0);
3609 SvGETMAGIC(right);
3610 }
3611 if (flags & AMGf_numeric) {
3612 if (SvROK(TOPm1s))
3613 *(sp-1) = sv_2num(TOPm1s);
3614 if (SvROK(right))
3615 *sp = sv_2num(right);
3616 }
3617 return FALSE;
3618 }
3619
3620 /*
3621 =for apidoc amagic_deref_call
3622
3623 Perform C<method> overloading dereferencing on C<ref>, returning the
3624 dereferenced result. C<method> must be one of the dereference operations given
3625 in F<overload.h>.
3626
3627 If overloading is inactive on C<ref>, returns C<ref> itself.
3628
3629 =cut
3630 */
3631
3632 SV *
Perl_amagic_deref_call(pTHX_ SV * ref,int method)3633 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3634 SV *tmpsv = NULL;
3635 HV *stash;
3636
3637 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3638
3639 if (!SvAMAGIC(ref))
3640 return ref;
3641 /* return quickly if none of the deref ops are overloaded */
3642 stash = SvSTASH(SvRV(ref));
3643 assert(HvHasAUX(stash));
3644 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3645 return ref;
3646
3647 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3648 AMGf_noright | AMGf_unary))) {
3649 if (!SvROK(tmpsv))
3650 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3651 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3652 /* Bail out if it returns us the same reference. */
3653 return tmpsv;
3654 }
3655 ref = tmpsv;
3656 if (!SvAMAGIC(ref))
3657 break;
3658 }
3659 return tmpsv ? tmpsv : ref;
3660 }
3661
3662 bool
Perl_amagic_is_enabled(pTHX_ int method)3663 Perl_amagic_is_enabled(pTHX_ int method)
3664 {
3665 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3666
3667 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3668
3669 if ( !lex_mask || !SvOK(lex_mask) )
3670 /* overloading lexically disabled */
3671 return FALSE;
3672 else if ( lex_mask && SvPOK(lex_mask) ) {
3673 /* we have an entry in the hints hash, check if method has been
3674 * masked by overloading.pm */
3675 STRLEN len;
3676 const int offset = method / 8;
3677 const int bit = method % 8;
3678 char *pv = SvPV(lex_mask, len);
3679
3680 /* Bit set, so this overloading operator is disabled */
3681 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3682 return FALSE;
3683 }
3684 return TRUE;
3685 }
3686
3687 /*
3688 =for apidoc amagic_call
3689
3690 Perform the overloaded (active magic) operation given by C<method>.
3691 C<method> is one of the values found in F<overload.h>.
3692
3693 C<flags> affects how the operation is performed, as follows:
3694
3695 =over
3696
3697 =item C<AMGf_noleft>
3698
3699 C<left> is not to be used in this operation.
3700
3701 =item C<AMGf_noright>
3702
3703 C<right> is not to be used in this operation.
3704
3705 =item C<AMGf_unary>
3706
3707 The operation is done only on just one operand.
3708
3709 =item C<AMGf_assign>
3710
3711 The operation changes one of the operands, e.g., $x += 1
3712
3713 =back
3714
3715 =cut
3716 */
3717
3718 SV*
Perl_amagic_call(pTHX_ SV * left,SV * right,int method,int flags)3719 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3720 {
3721 MAGIC *mg;
3722 CV *cv=NULL;
3723 CV **cvp=NULL, **ocvp=NULL;
3724 AMT *amtp=NULL, *oamtp=NULL;
3725 int off = 0, off1, lr = 0, notfound = 0;
3726 int postpr = 0, force_cpy = 0;
3727 int assign = AMGf_assign & flags;
3728 const int assignshift = assign ? 1 : 0;
3729 int use_default_op = 0;
3730 int force_scalar = 0;
3731 #ifdef DEBUGGING
3732 int fl=0;
3733 #endif
3734 HV* stash=NULL;
3735
3736 PERL_ARGS_ASSERT_AMAGIC_CALL;
3737
3738 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3739 if (!amagic_is_enabled(method)) return NULL;
3740 }
3741
3742 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3743 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3744 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3745 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3746 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3747 : NULL))
3748 && ((cv = cvp[off=method+assignshift])
3749 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3750 * usual method */
3751 (
3752 #ifdef DEBUGGING
3753 fl = 1,
3754 #endif
3755 cv = cvp[off=method]))))
3756 {
3757 lr = -1; /* Call method for left argument */
3758 } else {
3759 /* Note this logic should be kept in sync with amagic_applies() */
3760 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3761 int logic;
3762
3763 /* look for substituted methods */
3764 /* In all the covered cases we should be called with assign==0. */
3765 switch (method) {
3766 case inc_amg:
3767 force_cpy = 1;
3768 if ((cv = cvp[off=add_ass_amg])
3769 || ((cv = cvp[off = add_amg])
3770 && (force_cpy = 0, (postpr = 1)))) {
3771 right = &PL_sv_yes; lr = -1; assign = 1;
3772 }
3773 break;
3774 case dec_amg:
3775 force_cpy = 1;
3776 if ((cv = cvp[off = subtr_ass_amg])
3777 || ((cv = cvp[off = subtr_amg])
3778 && (force_cpy = 0, (postpr=1)))) {
3779 right = &PL_sv_yes; lr = -1; assign = 1;
3780 }
3781 break;
3782 case bool__amg:
3783 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3784 break;
3785 case numer_amg:
3786 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3787 break;
3788 case string_amg:
3789 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3790 break;
3791 case not_amg:
3792 (void)((cv = cvp[off=bool__amg])
3793 || (cv = cvp[off=numer_amg])
3794 || (cv = cvp[off=string_amg]));
3795 if (cv)
3796 postpr = 1;
3797 break;
3798 case copy_amg:
3799 {
3800 /*
3801 * SV* ref causes confusion with the interpreter variable of
3802 * the same name
3803 */
3804 SV* const tmpRef=SvRV(left);
3805 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3806 /*
3807 * Just to be extra cautious. Maybe in some
3808 * additional cases sv_setsv is safe, too.
3809 */
3810 SV* const newref = newSVsv(tmpRef);
3811 SvOBJECT_on(newref);
3812 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3813 delegate to the stash. */
3814 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3815 return newref;
3816 }
3817 }
3818 break;
3819 case abs_amg:
3820 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3821 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3822 SV* const nullsv=&PL_sv_zero;
3823 if (off1==lt_amg) {
3824 SV* const lessp = amagic_call(left,nullsv,
3825 lt_amg,AMGf_noright);
3826 logic = SvTRUE_NN(lessp);
3827 } else {
3828 SV* const lessp = amagic_call(left,nullsv,
3829 ncmp_amg,AMGf_noright);
3830 logic = (SvNV(lessp) < 0);
3831 }
3832 if (logic) {
3833 if (off==subtr_amg) {
3834 right = left;
3835 left = nullsv;
3836 lr = 1;
3837 }
3838 } else {
3839 return left;
3840 }
3841 }
3842 break;
3843 case neg_amg:
3844 if ((cv = cvp[off=subtr_amg])) {
3845 right = left;
3846 left = &PL_sv_zero;
3847 lr = 1;
3848 }
3849 break;
3850 case int_amg:
3851 case iter_amg: /* XXXX Eventually should do to_gv. */
3852 case ftest_amg: /* XXXX Eventually should do to_gv. */
3853 case regexp_amg:
3854 /* FAIL safe */
3855 return NULL; /* Delegate operation to standard mechanisms. */
3856
3857 case to_sv_amg:
3858 case to_av_amg:
3859 case to_hv_amg:
3860 case to_gv_amg:
3861 case to_cv_amg:
3862 /* FAIL safe */
3863 return left; /* Delegate operation to standard mechanisms. */
3864
3865 default:
3866 goto not_found;
3867 }
3868 if (!cv) goto not_found;
3869 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3870 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3871 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3872 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3873 ? (amtp = (AMT*)mg->mg_ptr)->table
3874 : NULL))
3875 && (cv = cvp[off=method])) { /* Method for right
3876 * argument found */
3877 lr=1;
3878 } else if (((cvp && amtp->fallback > AMGfallNEVER)
3879 || (ocvp && oamtp->fallback > AMGfallNEVER))
3880 && !(flags & AMGf_unary)) {
3881 /* We look for substitution for
3882 * comparison operations and
3883 * concatenation */
3884 if (method==concat_amg || method==concat_ass_amg
3885 || method==repeat_amg || method==repeat_ass_amg) {
3886 return NULL; /* Delegate operation to string conversion */
3887 }
3888 off = -1;
3889 switch (method) {
3890 case lt_amg:
3891 case le_amg:
3892 case gt_amg:
3893 case ge_amg:
3894 case eq_amg:
3895 case ne_amg:
3896 off = ncmp_amg;
3897 break;
3898 case slt_amg:
3899 case sle_amg:
3900 case sgt_amg:
3901 case sge_amg:
3902 case seq_amg:
3903 case sne_amg:
3904 off = scmp_amg;
3905 break;
3906 }
3907 if (off != -1) {
3908 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3909 cv = ocvp[off];
3910 lr = -1;
3911 }
3912 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3913 cv = cvp[off];
3914 lr = 1;
3915 }
3916 }
3917 if (cv)
3918 postpr = 1;
3919 else
3920 goto not_found;
3921 } else {
3922 not_found: /* No method found, either report or croak */
3923 switch (method) {
3924 case to_sv_amg:
3925 case to_av_amg:
3926 case to_hv_amg:
3927 case to_gv_amg:
3928 case to_cv_amg:
3929 /* FAIL safe */
3930 return left; /* Delegate operation to standard mechanisms. */
3931 }
3932 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3933 notfound = 1; lr = -1;
3934 } else if (cvp && (cv=cvp[nomethod_amg])) {
3935 notfound = 1; lr = 1;
3936 } else if ((use_default_op =
3937 (!ocvp || oamtp->fallback >= AMGfallYES)
3938 && (!cvp || amtp->fallback >= AMGfallYES))
3939 && !DEBUG_o_TEST) {
3940 /* Skip generating the "no method found" message. */
3941 return NULL;
3942 } else {
3943 SV *msg;
3944 if (off==-1) off=method;
3945 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3946 "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3947 AMG_id2name(method + assignshift),
3948 (flags & AMGf_unary ? " " : "\n\tleft "),
3949 SvAMAGIC(left)?
3950 "in overloaded package ":
3951 "has no overloaded magic",
3952 SvAMAGIC(left)?
3953 SVfARG(newSVhek_mortal(HvNAME_HEK(SvSTASH(SvRV(left))))):
3954 SVfARG(&PL_sv_no),
3955 SvAMAGIC(right)?
3956 ",\n\tright argument in overloaded package ":
3957 (flags & AMGf_unary
3958 ? ""
3959 : ",\n\tright argument has no overloaded magic"),
3960 SvAMAGIC(right)?
3961 SVfARG(newSVhek_mortal(HvNAME_HEK(SvSTASH(SvRV(right))))):
3962 SVfARG(&PL_sv_no)));
3963 if (use_default_op) {
3964 DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3965 } else {
3966 Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3967 }
3968 return NULL;
3969 }
3970 force_cpy = force_cpy || assign;
3971 }
3972 }
3973
3974 switch (method) {
3975 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3976 * operation. we need this to return a value, so that it can be assigned
3977 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3978 * increment or decrement was itself called in void context */
3979 case inc_amg:
3980 if (off == add_amg)
3981 force_scalar = 1;
3982 break;
3983 case dec_amg:
3984 if (off == subtr_amg)
3985 force_scalar = 1;
3986 break;
3987 /* in these cases, we're calling an assignment variant of an operator
3988 * (+= rather than +, for instance). regardless of whether it's a
3989 * fallback or not, it always has to return a value, which will be
3990 * assigned to the proper variable later */
3991 case add_amg:
3992 case subtr_amg:
3993 case mult_amg:
3994 case div_amg:
3995 case modulo_amg:
3996 case pow_amg:
3997 case lshift_amg:
3998 case rshift_amg:
3999 case repeat_amg:
4000 case concat_amg:
4001 case band_amg:
4002 case bor_amg:
4003 case bxor_amg:
4004 case sband_amg:
4005 case sbor_amg:
4006 case sbxor_amg:
4007 if (assign)
4008 force_scalar = 1;
4009 break;
4010 /* the copy constructor always needs to return a value */
4011 case copy_amg:
4012 force_scalar = 1;
4013 break;
4014 /* because of the way these are implemented (they don't perform the
4015 * dereferencing themselves, they return a reference that perl then
4016 * dereferences later), they always have to be in scalar context */
4017 case to_sv_amg:
4018 case to_av_amg:
4019 case to_hv_amg:
4020 case to_gv_amg:
4021 case to_cv_amg:
4022 force_scalar = 1;
4023 break;
4024 /* these don't have an op of their own; they're triggered by their parent
4025 * op, so the context there isn't meaningful ('$a and foo()' in void
4026 * context still needs to pass scalar context on to $a's bool overload) */
4027 case bool__amg:
4028 case numer_amg:
4029 case string_amg:
4030 force_scalar = 1;
4031 break;
4032 }
4033
4034 #ifdef DEBUGGING
4035 if (!notfound) {
4036 DEBUG_o(Perl_deb(aTHX_
4037 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
4038 AMG_id2name(off),
4039 method+assignshift==off? "" :
4040 " (initially \"",
4041 method+assignshift==off? "" :
4042 AMG_id2name(method+assignshift),
4043 method+assignshift==off? "" : "\")",
4044 flags & AMGf_unary? "" :
4045 lr==1 ? " for right argument": " for left argument",
4046 flags & AMGf_unary? " for argument" : "",
4047 stash ? SVfARG(newSVhek_mortal(HvNAME_HEK(stash))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
4048 fl? ",\n\tassignment variant used": "") );
4049 }
4050 #endif
4051 /* Since we use shallow copy during assignment, we need
4052 * to duplicate the contents, probably calling user-supplied
4053 * version of copy operator
4054 */
4055 /* We need to copy in following cases:
4056 * a) Assignment form was called.
4057 * assignshift==1, assign==T, method + 1 == off
4058 * b) Increment or decrement, called directly.
4059 * assignshift==0, assign==0, method + 0 == off
4060 * c) Increment or decrement, translated to assignment add/subtr.
4061 * assignshift==0, assign==T,
4062 * force_cpy == T
4063 * d) Increment or decrement, translated to nomethod.
4064 * assignshift==0, assign==0,
4065 * force_cpy == T
4066 * e) Assignment form translated to nomethod.
4067 * assignshift==1, assign==T, method + 1 != off
4068 * force_cpy == T
4069 */
4070 /* off is method, method+assignshift, or a result of opcode substitution.
4071 * In the latter case assignshift==0, so only notfound case is important.
4072 */
4073 if ( (lr == -1) && ( ( (method + assignshift == off)
4074 && (assign || (method == inc_amg) || (method == dec_amg)))
4075 || force_cpy) )
4076 {
4077 /* newSVsv does not behave as advertised, so we copy missing
4078 * information by hand */
4079 SV *tmpRef = SvRV(left);
4080 SV *rv_copy;
4081 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
4082 SvRV_set(left, rv_copy);
4083 SvSETMAGIC(left);
4084 SvREFCNT_dec_NN(tmpRef);
4085 }
4086 }
4087
4088 {
4089 dSP;
4090 UNOP myop;
4091 SV* res;
4092 const bool oldcatch = CATCH_GET;
4093 I32 oldmark, nret;
4094 /* for multiconcat, we may call overload several times,
4095 * with the context of individual concats being scalar,
4096 * regardless of the overall context of the multiconcat op
4097 */
4098 U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
4099 ? G_SCALAR : GIMME_V;
4100
4101 CATCH_SET(TRUE);
4102 Zero(&myop, 1, UNOP);
4103 myop.op_flags = OPf_STACKED;
4104 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
4105 myop.op_type = OP_ENTERSUB;
4106
4107
4108 switch (gimme) {
4109 case G_VOID:
4110 myop.op_flags |= OPf_WANT_VOID;
4111 break;
4112 case G_LIST:
4113 if (flags & AMGf_want_list) {
4114 myop.op_flags |= OPf_WANT_LIST;
4115 break;
4116 }
4117 /* FALLTHROUGH */
4118 default:
4119 myop.op_flags |= OPf_WANT_SCALAR;
4120 break;
4121 }
4122
4123 PUSHSTACKi(PERLSI_OVERLOAD);
4124 ENTER;
4125 SAVEOP();
4126 PL_op = (OP *) &myop;
4127 if (PERLDB_SUB && PL_curstash != PL_debstash)
4128 PL_op->op_private |= OPpENTERSUB_DB;
4129 Perl_pp_pushmark(aTHX);
4130
4131 EXTEND(SP, notfound + 5);
4132 PUSHs(lr>0? right: left);
4133 PUSHs(lr>0? left: right);
4134 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
4135 if (notfound) {
4136 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
4137 AMG_id2namelen(method + assignshift), SVs_TEMP));
4138 }
4139 else if (flags & AMGf_numarg)
4140 PUSHs(&PL_sv_undef);
4141 if (flags & AMGf_numarg)
4142 PUSHs(&PL_sv_yes);
4143 PUSHs(MUTABLE_SV(cv));
4144 PUTBACK;
4145 oldmark = TOPMARK;
4146 CALLRUNOPS(aTHX);
4147 LEAVE;
4148 SPAGAIN;
4149 nret = SP - (PL_stack_base + oldmark);
4150
4151 switch (gimme) {
4152 case G_VOID:
4153 /* returning NULL has another meaning, and we check the context
4154 * at the call site too, so this can be differentiated from the
4155 * scalar case */
4156 res = &PL_sv_undef;
4157 SP = PL_stack_base + oldmark;
4158 break;
4159 case G_LIST:
4160 if (flags & AMGf_want_list) {
4161 res = newSV_type_mortal(SVt_PVAV);
4162 av_extend((AV *)res, nret);
4163 while (nret--)
4164 av_store((AV *)res, nret, POPs);
4165 break;
4166 }
4167 /* FALLTHROUGH */
4168 default:
4169 res = POPs;
4170 break;
4171 }
4172
4173 PUTBACK;
4174 POPSTACK;
4175 CATCH_SET(oldcatch);
4176
4177 if (postpr) {
4178 int ans;
4179 switch (method) {
4180 case le_amg:
4181 case sle_amg:
4182 ans=SvIV(res)<=0; break;
4183 case lt_amg:
4184 case slt_amg:
4185 ans=SvIV(res)<0; break;
4186 case ge_amg:
4187 case sge_amg:
4188 ans=SvIV(res)>=0; break;
4189 case gt_amg:
4190 case sgt_amg:
4191 ans=SvIV(res)>0; break;
4192 case eq_amg:
4193 case seq_amg:
4194 ans=SvIV(res)==0; break;
4195 case ne_amg:
4196 case sne_amg:
4197 ans=SvIV(res)!=0; break;
4198 case inc_amg:
4199 case dec_amg:
4200 SvSetSV(left,res); return left;
4201 case not_amg:
4202 ans=!SvTRUE_NN(res); break;
4203 default:
4204 ans=0; break;
4205 }
4206 return boolSV(ans);
4207 } else if (method==copy_amg) {
4208 if (!SvROK(res)) {
4209 Perl_croak(aTHX_ "Copy method did not return a reference");
4210 }
4211 return SvREFCNT_inc(SvRV(res));
4212 } else {
4213 return res;
4214 }
4215 }
4216 }
4217
4218 /*
4219 =for apidoc gv_name_set
4220
4221 Set the name for GV C<gv> to C<name> which is C<len> bytes long. Thus it may
4222 contain embedded NUL characters.
4223
4224 If C<flags> contains C<SVf_UTF8>, the name is treated as being encoded in
4225 UTF-8; otherwise not.
4226
4227 =cut
4228 */
4229
4230 void
Perl_gv_name_set(pTHX_ GV * gv,const char * name,U32 len,U32 flags)4231 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
4232 {
4233 U32 hash;
4234
4235 PERL_ARGS_ASSERT_GV_NAME_SET;
4236
4237 if (len > I32_MAX)
4238 Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
4239
4240 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
4241 unshare_hek(GvNAME_HEK(gv));
4242 }
4243
4244 PERL_HASH(hash, name, len);
4245 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
4246 }
4247
4248 /*
4249 =for apidoc gv_try_downgrade
4250
4251 If the typeglob C<gv> can be expressed more succinctly, by having
4252 something other than a real GV in its place in the stash, replace it
4253 with the optimised form. Basic requirements for this are that C<gv>
4254 is a real typeglob, is sufficiently ordinary, and is only referenced
4255 from its package. This function is meant to be used when a GV has been
4256 looked up in part to see what was there, causing upgrading, but based
4257 on what was found it turns out that the real GV isn't required after all.
4258
4259 If C<gv> is a completely empty typeglob, it is deleted from the stash.
4260
4261 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
4262 sub, the typeglob is replaced with a scalar-reference placeholder that
4263 more compactly represents the same thing.
4264
4265 =cut
4266 */
4267
4268 void
Perl_gv_try_downgrade(pTHX_ GV * gv)4269 Perl_gv_try_downgrade(pTHX_ GV *gv)
4270 {
4271 HV *stash;
4272 CV *cv;
4273 HEK *namehek;
4274 SV **gvp;
4275 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
4276
4277 /* XXX Why and where does this leave dangling pointers during global
4278 destruction? */
4279 if (PL_phase == PERL_PHASE_DESTRUCT) return;
4280
4281 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
4282 !SvOBJECT(gv) && !SvREADONLY(gv) &&
4283 isGV_with_GP(gv) && GvGP(gv) &&
4284 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
4285 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
4286 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
4287 return;
4288 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
4289 return;
4290 if (SvMAGICAL(gv)) {
4291 MAGIC *mg;
4292 /* only backref magic is allowed */
4293 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
4294 return;
4295 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
4296 if (mg->mg_type != PERL_MAGIC_backref)
4297 return;
4298 }
4299 }
4300 cv = GvCV(gv);
4301 if (!cv) {
4302 HEK *gvnhek = GvNAME_HEK(gv);
4303 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
4304 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
4305 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
4306 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
4307 CvCONST(cv) && !CvNOWARN_AMBIGUOUS(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
4308 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
4309 (namehek = GvNAME_HEK(gv)) &&
4310 (gvp = hv_fetchhek(stash, namehek, 0)) &&
4311 *gvp == (SV*)gv) {
4312 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
4313 const bool imported = cBOOL(GvIMPORTED_CV(gv));
4314 SvREFCNT(gv) = 0;
4315 sv_clear((SV*)gv);
4316 SvREFCNT(gv) = 1;
4317 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
4318
4319 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
4320 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
4321 STRUCT_OFFSET(XPVIV, xiv_iv));
4322 SvRV_set(gv, value);
4323 }
4324 }
4325
4326 GV *
Perl_gv_override(pTHX_ const char * const name,const STRLEN len)4327 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
4328 {
4329 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
4330 GV * const *gvp;
4331 PERL_ARGS_ASSERT_GV_OVERRIDE;
4332 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
4333 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
4334 gv = gvp ? *gvp : NULL;
4335 if (gv && !isGV(gv)) {
4336 if (!SvPCS_IMPORTED(gv)) return NULL;
4337 gv_init(gv, PL_globalstash, name, len, 0);
4338 return gv;
4339 }
4340 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
4341 }
4342
4343 #include "XSUB.h"
4344
4345 static void
core_xsub(pTHX_ CV * cv)4346 core_xsub(pTHX_ CV* cv)
4347 {
4348 Perl_croak(aTHX_
4349 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
4350 );
4351 }
4352
4353 /*
4354 * ex: set ts=8 sts=4 sw=4 et:
4355 */
4356