This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Lookup overloaded assignment operators when trying to swap the arguments
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
1129b882 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
67fbe0e1 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
79072805
LW
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 *
a0d0e21e
LW
9 */
10
11/*
12 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
4ac71550 13 * of your inquisitiveness, I shall spend all the rest of my days in answering
a0d0e21e
LW
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.
4ac71550 18 *
cdad3b53 19 * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
79072805
LW
20 */
21
ccfc67b7
JH
22/*
23=head1 GV Functions
166f8a29
DM
24
25A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
26It is a structure that holds a pointer to a scalar, an array, a hash etc,
27corresponding to $foo, @foo, %foo.
28
29GVs are usually found as values in stashes (symbol table hashes) where
30Perl stores its global variables.
31
32=cut
ccfc67b7
JH
33*/
34
79072805 35#include "EXTERN.h"
864dbfa3 36#define PERL_IN_GV_C
79072805 37#include "perl.h"
8261f8eb 38#include "overload.c"
4aaa4757 39#include "keywords.h"
2846acbf 40#include "feature.h"
79072805 41
f54cb97a
AL
42static const char S_autoload[] = "AUTOLOAD";
43static const STRLEN S_autolen = sizeof(S_autoload)-1;
5c7983e5 44
c69033f2 45GV *
d5713896 46Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
c69033f2 47{
d5713896 48 SV **where;
7918f24d 49
13be902c
FC
50 if (
51 !gv
52 || (
53 SvTYPE((const SV *)gv) != SVt_PVGV
54 && SvTYPE((const SV *)gv) != SVt_PVLV
55 )
56 ) {
bb85b28a
NC
57 const char *what;
58 if (type == SVt_PVIO) {
59 /*
60 * if it walks like a dirhandle, then let's assume that
61 * this is a dirhandle.
62 */
332c2eac 63 what = OP_IS_DIRHOP(PL_op->op_type) ?
bb85b28a 64 "dirhandle" : "filehandle";
bb85b28a
NC
65 } else if (type == SVt_PVHV) {
66 what = "hash";
67 } else {
68 what = type == SVt_PVAV ? "array" : "scalar";
69 }
de6f7947 70 /* diag_listed_as: Bad symbol for filehandle */
bb85b28a
NC
71 Perl_croak(aTHX_ "Bad symbol for %s", what);
72 }
d5713896
NC
73
74 if (type == SVt_PVHV) {
75 where = (SV **)&GvHV(gv);
76 } else if (type == SVt_PVAV) {
77 where = (SV **)&GvAV(gv);
bb85b28a
NC
78 } else if (type == SVt_PVIO) {
79 where = (SV **)&GvIOp(gv);
d5713896
NC
80 } else {
81 where = &GvSV(gv);
82 }
7918f24d 83
d5713896
NC
84 if (!*where)
85 *where = newSV_type(type);
79072805
LW
86 return gv;
87}
88
89GV *
864dbfa3 90Perl_gv_fetchfile(pTHX_ const char *name)
79072805 91{
7918f24d 92 PERL_ARGS_ASSERT_GV_FETCHFILE;
d9095cec
NC
93 return gv_fetchfile_flags(name, strlen(name), 0);
94}
95
96GV *
97Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
98 const U32 flags)
99{
97aff369 100 dVAR;
4116122e 101 char smallbuf[128];
53d95988 102 char *tmpbuf;
d9095cec 103 const STRLEN tmplen = namelen + 2;
79072805
LW
104 GV *gv;
105
7918f24d 106 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
d9095cec
NC
107 PERL_UNUSED_ARG(flags);
108
1d7c1841 109 if (!PL_defstash)
a0714e2c 110 return NULL;
1d7c1841 111
d9095cec 112 if (tmplen <= sizeof smallbuf)
53d95988
CS
113 tmpbuf = smallbuf;
114 else
798b63bc 115 Newx(tmpbuf, tmplen, char);
0ac0412a 116 /* This is where the debugger's %{"::_<$filename"} hash is created */
53d95988
CS
117 tmpbuf[0] = '_';
118 tmpbuf[1] = '<';
d9095cec
NC
119 memcpy(tmpbuf + 2, name, namelen);
120 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
1d7c1841 121 if (!isGV(gv)) {
d9095cec 122 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
c69033f2 123#ifdef PERL_DONT_CREATE_GVSV
d9095cec 124 GvSV(gv) = newSVpvn(name, namelen);
c69033f2 125#else
d9095cec 126 sv_setpvn(GvSV(gv), name, namelen);
c69033f2 127#endif
1d7c1841 128 }
5a9a79a4
FC
129 if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
130 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
53d95988
CS
131 if (tmpbuf != smallbuf)
132 Safefree(tmpbuf);
79072805
LW
133 return gv;
134}
135
62d55b22
NC
136/*
137=for apidoc gv_const_sv
138
139If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
140inlining, or C<gv> is a placeholder reference that would be promoted to such
141a typeglob, then returns the value returned by the sub. Otherwise, returns
142NULL.
143
144=cut
145*/
146
147SV *
148Perl_gv_const_sv(pTHX_ GV *gv)
149{
7918f24d
NC
150 PERL_ARGS_ASSERT_GV_CONST_SV;
151
62d55b22
NC
152 if (SvTYPE(gv) == SVt_PVGV)
153 return cv_const_sv(GvCVu(gv));
154 return SvROK(gv) ? SvRV(gv) : NULL;
155}
156
12816592
NC
157GP *
158Perl_newGP(pTHX_ GV *const gv)
159{
160 GP *gp;
19bad673
NC
161 U32 hash;
162#ifdef USE_ITHREADS
1df5f7c1
NC
163 const char *const file
164 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
19bad673
NC
165 const STRLEN len = strlen(file);
166#else
167 SV *const temp_sv = CopFILESV(PL_curcop);
168 const char *file;
169 STRLEN len;
170
7918f24d
NC
171 PERL_ARGS_ASSERT_NEWGP;
172
19bad673
NC
173 if (temp_sv) {
174 file = SvPVX(temp_sv);
175 len = SvCUR(temp_sv);
176 } else {
177 file = "";
178 len = 0;
179 }
180#endif
f4890806
NC
181
182 PERL_HASH(hash, file, len);
183
12816592
NC
184 Newxz(gp, 1, GP);
185
186#ifndef PERL_DONT_CREATE_GVSV
b5c2dcb8 187 gp->gp_sv = newSV(0);
12816592
NC
188#endif
189
1df5f7c1 190 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
12816592
NC
191 /* XXX Ideally this cast would be replaced with a change to const char*
192 in the struct. */
f4890806 193 gp->gp_file_hek = share_hek(file, len, hash);
12816592
NC
194 gp->gp_egv = gv;
195 gp->gp_refcnt = 1;
196
197 return gp;
198}
199
803f2748
DM
200/* Assign CvGV(cv) = gv, handling weak references.
201 * See also S_anonymise_cv_maybe */
202
203void
204Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
205{
206 GV * const oldgv = CvGV(cv);
207 PERL_ARGS_ASSERT_CVGV_SET;
208
209 if (oldgv == gv)
210 return;
211
212 if (oldgv) {
cfc1e951 213 if (CvCVGV_RC(cv)) {
803f2748 214 SvREFCNT_dec(oldgv);
cfc1e951
DM
215 CvCVGV_RC_off(cv);
216 }
803f2748 217 else {
803f2748
DM
218 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
219 }
220 }
221
b3f91e91 222 SvANY(cv)->xcv_gv = gv;
c794ca97 223 assert(!CvCVGV_RC(cv));
803f2748
DM
224
225 if (!gv)
226 return;
227
c794ca97
DM
228 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
229 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
230 else {
cfc1e951 231 CvCVGV_RC_on(cv);
803f2748
DM
232 SvREFCNT_inc_simple_void_NN(gv);
233 }
803f2748
DM
234}
235
c68d9564
Z
236/* Assign CvSTASH(cv) = st, handling weak references. */
237
238void
239Perl_cvstash_set(pTHX_ CV *cv, HV *st)
240{
241 HV *oldst = CvSTASH(cv);
242 PERL_ARGS_ASSERT_CVSTASH_SET;
243 if (oldst == st)
244 return;
245 if (oldst)
246 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
247 SvANY(cv)->xcv_stash = st;
248 if (st)
249 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
250}
803f2748 251
e1104062
FC
252/*
253=for apidoc gv_init_pvn
254
255Converts a scalar into a typeglob. This is an incoercible typeglob;
256assigning a reference to it will assign to one of its slots, instead of
257overwriting it as happens with typeglobs created by SvSetSV. Converting
258any scalar that is SvOK() may produce unpredictable results and is reserved
259for perl's internal use.
260
261C<gv> is the scalar to be converted.
262
263C<stash> is the parent stash/package, if any.
264
04ec7e59
FC
265C<name> and C<len> give the name. The name must be unqualified;
266that is, it must not include the package name. If C<gv> is a
e1104062
FC
267stash element, it is the caller's responsibility to ensure that the name
268passed to this function matches the name of the element. If it does not
269match, perl's internal bookkeeping will get out of sync.
270
04ec7e59
FC
271C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
272the return value of SvUTF8(sv). It can also take the
273GV_ADDMULTI flag, which means to pretend that the GV has been
e1104062
FC
274seen before (i.e., suppress "Used once" warnings).
275
276=for apidoc gv_init
277
278The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
04ec7e59
FC
279has no flags parameter. If the C<multi> parameter is set, the
280GV_ADDMULTI flag will be passed to gv_init_pvn().
e1104062
FC
281
282=for apidoc gv_init_pv
283
284Same as gv_init_pvn(), but takes a nul-terminated string for the name
285instead of separate char * and length parameters.
286
287=for apidoc gv_init_sv
288
289Same as gv_init_pvn(), but takes an SV * for the name instead of separate
290char * and length parameters. C<flags> is currently unused.
291
292=cut
293*/
294
463ee0b2 295void
04ec7e59 296Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
e6066781
BF
297{
298 char *namepv;
299 STRLEN namelen;
300 PERL_ARGS_ASSERT_GV_INIT_SV;
301 namepv = SvPV(namesv, namelen);
302 if (SvUTF8(namesv))
303 flags |= SVf_UTF8;
04ec7e59 304 gv_init_pvn(gv, stash, namepv, namelen, flags);
e6066781
BF
305}
306
307void
04ec7e59 308Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
e6066781
BF
309{
310 PERL_ARGS_ASSERT_GV_INIT_PV;
04ec7e59 311 gv_init_pvn(gv, stash, name, strlen(name), flags);
e6066781
BF
312}
313
314void
04ec7e59 315Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
463ee0b2 316{
27da23d5 317 dVAR;
3b6733bf
NC
318 const U32 old_type = SvTYPE(gv);
319 const bool doproto = old_type > SVt_NULL;
f9509170 320 char * const proto = (doproto && SvPOK(gv))
dad95a0a 321 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
f9509170 322 : NULL;
49a54bbe 323 const STRLEN protolen = proto ? SvCUR(gv) : 0;
e0260a5b 324 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
756cb477 325 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
1ccdb730 326 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
756cb477 327
e6066781 328 PERL_ARGS_ASSERT_GV_INIT_PVN;
756cb477
NC
329 assert (!(proto && has_constant));
330
331 if (has_constant) {
5c1f4d79
NC
332 /* The constant has to be a simple scalar type. */
333 switch (SvTYPE(has_constant)) {
334 case SVt_PVAV:
335 case SVt_PVHV:
336 case SVt_PVCV:
337 case SVt_PVFM:
338 case SVt_PVIO:
339 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
340 sv_reftype(has_constant, 0));
42d0e0b7 341 default: NOOP;
5c1f4d79 342 }
756cb477
NC
343 SvRV_set(gv, NULL);
344 SvROK_off(gv);
345 }
463ee0b2 346
3b6733bf
NC
347
348 if (old_type < SVt_PVGV) {
349 if (old_type >= SVt_PV)
350 SvCUR_set(gv, 0);
ad64d0ec 351 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
3b6733bf 352 }
55d729e4
GS
353 if (SvLEN(gv)) {
354 if (proto) {
f880fe2f 355 SvPV_set(gv, NULL);
b162af07 356 SvLEN_set(gv, 0);
55d729e4
GS
357 SvPOK_off(gv);
358 } else
94010e71 359 Safefree(SvPVX_mutable(gv));
55d729e4 360 }
2e5b91de
NC
361 SvIOK_off(gv);
362 isGV_with_GP_on(gv);
12816592 363
c43ae56f 364 GvGP_set(gv, Perl_newGP(aTHX_ gv));
e15faf7d
NC
365 GvSTASH(gv) = stash;
366 if (stash)
ad64d0ec 367 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
04f3bf56 368 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
04ec7e59
FC
369 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
370 GvMULTI_on(gv); /* _was_ mentioned */
55d729e4 371 if (doproto) { /* Replicate part of newSUB here. */
e3d2b9e7 372 CV *cv;
55d729e4 373 ENTER;
756cb477
NC
374 if (has_constant) {
375 /* newCONSTSUB takes ownership of the reference from us. */
e38acfd7 376 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
75bd28cf
FC
377 /* In case op.c:S_process_special_blocks stole it: */
378 if (!GvCV(gv))
c43ae56f 379 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
439cdf38 380 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
1ccdb730
NC
381 /* If this reference was a copy of another, then the subroutine
382 must have been "imported", by a Perl space assignment to a GV
383 from a reference to CV. */
384 if (exported_constant)
385 GvIMPORTED_CV_on(gv);
756cb477 386 } else {
756cb477 387 (void) start_subparse(0,0); /* Create empty CV in compcv. */
e3d2b9e7 388 cv = PL_compcv;
c43ae56f 389 GvCV_set(gv,cv);
756cb477 390 }
55d729e4
GS
391 LEAVE;
392
e1a479c5 393 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
b3f91e91 394 CvGV_set(cv, gv);
e3d2b9e7 395 CvFILE_set_from_cop(cv, PL_curcop);
c68d9564 396 CvSTASH_set(cv, PL_curstash);
55d729e4 397 if (proto) {
e3d2b9e7 398 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
49a54bbe 399 SV_HAS_TRAILING_NUL);
e0260a5b 400 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
55d729e4
GS
401 }
402 }
463ee0b2
LW
403}
404
76e3520e 405STATIC void
e6066781 406S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
a0d0e21e 407{
e6066781 408 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
7918f24d 409
a0d0e21e
LW
410 switch (sv_type) {
411 case SVt_PVIO:
412 (void)GvIOn(gv);
413 break;
414 case SVt_PVAV:
415 (void)GvAVn(gv);
416 break;
417 case SVt_PVHV:
418 (void)GvHVn(gv);
419 break;
c69033f2
NC
420#ifdef PERL_DONT_CREATE_GVSV
421 case SVt_NULL:
422 case SVt_PVCV:
423 case SVt_PVFM:
e654831b 424 case SVt_PVGV:
c69033f2
NC
425 break;
426 default:
dbdce04c
NC
427 if(GvSVn(gv)) {
428 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
429 If we just cast GvSVn(gv) to void, it ignores evaluating it for
430 its side effect */
431 }
c69033f2 432#endif
a0d0e21e
LW
433 }
434}
435
0f8d4b5e
FC
436static void core_xsub(pTHX_ CV* cv);
437
438static GV *
439S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
87566176 440 const char * const name, const STRLEN len)
0f8d4b5e
FC
441{
442 const int code = keyword(name, len, 1);
443 static const char file[] = __FILE__;
97021f77 444 CV *cv, *oldcompcv = NULL;
0f8d4b5e
FC
445 int opnum = 0;
446 SV *opnumsv;
447 bool ampable = TRUE; /* &{}-able */
97021f77
FC
448 COP *oldcurcop = NULL;
449 yy_parser *oldparser = NULL;
450 I32 oldsavestack_ix = 0;
0f8d4b5e
FC
451
452 assert(gv || stash);
453 assert(name);
0f8d4b5e 454
0f8d4b5e
FC
455 if (code >= 0) return NULL; /* not overridable */
456 switch (-code) {
457 /* no support for \&CORE::infix;
458 no support for funcs that take labels, as their parsing is
459 weird */
460 case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
461 case KEY_eq: case KEY_ge:
462 case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
463 case KEY_or: case KEY_x: case KEY_xor:
464 return NULL;
465 case KEY_chdir:
466 case KEY_chomp: case KEY_chop:
467 case KEY_each: case KEY_eof: case KEY_exec:
468 case KEY_keys:
469 case KEY_lstat:
470 case KEY_pop:
471 case KEY_push:
472 case KEY_shift:
473 case KEY_splice:
474 case KEY_stat:
475 case KEY_system:
476 case KEY_truncate: case KEY_unlink:
477 case KEY_unshift:
478 case KEY_values:
479 ampable = FALSE;
480 }
481 if (!gv) {
482 gv = (GV *)newSV(0);
483 gv_init(gv, stash, name, len, TRUE);
484 }
7e68c38b 485 GvMULTI_on(gv);
0f8d4b5e
FC
486 if (ampable) {
487 ENTER;
488 oldcurcop = PL_curcop;
489 oldparser = PL_parser;
490 lex_start(NULL, NULL, 0);
491 oldcompcv = PL_compcv;
492 PL_compcv = NULL; /* Prevent start_subparse from setting
493 CvOUTSIDE. */
494 oldsavestack_ix = start_subparse(FALSE,0);
495 cv = PL_compcv;
496 }
497 else {
498 /* Avoid calling newXS, as it calls us, and things start to
499 get hairy. */
500 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
501 GvCV_set(gv,cv);
502 GvCVGEN(gv) = 0;
503 mro_method_changed_in(GvSTASH(gv));
504 CvISXSUB_on(cv);
505 CvXSUB(cv) = core_xsub;
506 }
507 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
508 from PL_curcop. */
509 (void)gv_fetchfile(file);
510 CvFILE(cv) = (char *)file;
511 /* XXX This is inefficient, as doing things this order causes
512 a prototype check in newATTRSUB. But we have to do
513 it this order as we need an op number before calling
514 new ATTRSUB. */
515 (void)core_prototype((SV *)cv, name, code, &opnum);
87566176 516 if (stash)
73c02f15 517 (void)hv_store(stash,name,len,(SV *)gv,0);
0f8d4b5e 518 if (ampable) {
0f8d4b5e 519 CvLVALUE_on(cv);
7e68c38b
FC
520 newATTRSUB_flags(
521 oldsavestack_ix, (OP *)gv,
0f8d4b5e
FC
522 NULL,NULL,
523 coresub_op(
524 opnum
525 ? newSVuv((UV)opnum)
526 : newSVpvn(name,len),
527 code, opnum
7e68c38b
FC
528 ),
529 1
0f8d4b5e
FC
530 );
531 assert(GvCV(gv) == cv);
532 if (opnum != OP_VEC && opnum != OP_SUBSTR)
533 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
534 LEAVE;
535 PL_parser = oldparser;
536 PL_curcop = oldcurcop;
537 PL_compcv = oldcompcv;
538 }
539 opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
540 cv_set_call_checker(
541 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
542 );
543 SvREFCNT_dec(opnumsv);
544 return gv;
545}
546
954c1994 547/*
6c53d59b
FC
548=for apidoc gv_fetchmeth
549
550Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
551
e6919483
BF
552=for apidoc gv_fetchmeth_sv
553
554Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
555of an SV instead of a string/length pair.
556
557=cut
558*/
559
560GV *
561Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
562{
563 char *namepv;
564 STRLEN namelen;
565 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
566 namepv = SvPV(namesv, namelen);
567 if (SvUTF8(namesv))
568 flags |= SVf_UTF8;
569 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
570}
571
572/*
573=for apidoc gv_fetchmeth_pv
574
575Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
576instead of a string/length pair.
577
578=cut
579*/
580
581GV *
582Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
583{
584 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
585 return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
586}
587
588/*
589=for apidoc gv_fetchmeth_pvn
954c1994
GS
590
591Returns the glob with the given C<name> and a defined subroutine or
592C<NULL>. The glob lives in the given C<stash>, or in the stashes
07766739 593accessible via @ISA and UNIVERSAL::.
954c1994
GS
594
595The argument C<level> should be either 0 or -1. If C<level==0>, as a
596side-effect creates a glob with the given C<name> in the given C<stash>
597which in the case of success contains an alias for the subroutine, and sets
e1a479c5 598up caching info for this glob.
954c1994 599
e6919483
BF
600Currently, the only significant value for C<flags> is SVf_UTF8.
601
954c1994
GS
602This function grants C<"SUPER"> token as a postfix of the stash name. The
603GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
4929bf7b 604visible to Perl code. So when calling C<call_sv>, you should not use
954c1994 605the GV directly; instead, you should use the method's CV, which can be
b267980d 606obtained from the GV with the C<GvCV> macro.
954c1994
GS
607
608=cut
609*/
610
e1a479c5
BB
611/* NOTE: No support for tied ISA */
612
79072805 613GV *
e6919483 614Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
79072805 615{
97aff369 616 dVAR;
463ee0b2 617 GV** gvp;
e1a479c5
BB
618 AV* linear_av;
619 SV** linear_svp;
620 SV* linear_sv;
621 HV* cstash;
622 GV* candidate = NULL;
623 CV* cand_cv = NULL;
e1a479c5 624 GV* topgv = NULL;
bfcb3514 625 const char *hvname;
e1a479c5
BB
626 I32 create = (level >= 0) ? 1 : 0;
627 I32 items;
628 STRLEN packlen;
629 U32 topgen_cmp;
04f3bf56 630 U32 is_utf8 = flags & SVf_UTF8;
a0d0e21e 631
e6919483 632 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
7918f24d 633
af09ea45
IK
634 /* UNIVERSAL methods should be callable without a stash */
635 if (!stash) {
e1a479c5 636 create = 0; /* probably appropriate */
da51bb9b 637 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
af09ea45
IK
638 return 0;
639 }
640
e1a479c5
BB
641 assert(stash);
642
bfcb3514
NC
643 hvname = HvNAME_get(stash);
644 if (!hvname)
e1a479c5 645 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
e27ad1f2 646
e1a479c5
BB
647 assert(hvname);
648 assert(name);
463ee0b2 649
bfcb3514 650 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
44a8e56a 651
dd69841b 652 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
e1a479c5
BB
653
654 /* check locally for a real method or a cache entry */
c60dbbc3 655 gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create);
e1a479c5
BB
656 if(gvp) {
657 topgv = *gvp;
0f8d4b5e 658 have_gv:
e1a479c5
BB
659 assert(topgv);
660 if (SvTYPE(topgv) != SVt_PVGV)
04ec7e59 661 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
e1a479c5
BB
662 if ((cand_cv = GvCV(topgv))) {
663 /* If genuine method or valid cache entry, use it */
664 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
665 return topgv;
666 }
667 else {
668 /* stale cache entry, junk it and move on */
669 SvREFCNT_dec(cand_cv);
c43ae56f
DM
670 GvCV_set(topgv, NULL);
671 cand_cv = NULL;
e1a479c5
BB
672 GvCVGEN(topgv) = 0;
673 }
674 }
675 else if (GvCVGEN(topgv) == topgen_cmp) {
676 /* cache indicates no such method definitively */
677 return 0;
678 }
0f8d4b5e
FC
679 else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
680 && strnEQ(hvname, "CORE", 4)
87566176 681 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
0f8d4b5e 682 goto have_gv;
463ee0b2 683 }
79072805 684
e1a479c5
BB
685 packlen = HvNAMELEN_get(stash);
686 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
687 HV* basestash;
688 packlen -= 7;
772d5078
BF
689 basestash = gv_stashpvn(hvname, packlen,
690 GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
e1a479c5 691 linear_av = mro_get_linear_isa(basestash);
9607fc9c 692 }
e1a479c5
BB
693 else {
694 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
79072805 695 }
a0d0e21e 696
e1a479c5
BB
697 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
698 items = AvFILLp(linear_av); /* no +1, to skip over self */
699 while (items--) {
700 linear_sv = *linear_svp++;
701 assert(linear_sv);
702 cstash = gv_stashsv(linear_sv, 0);
703
dd69841b 704 if (!cstash) {
ecad31f0 705 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
d0c0e7dd 706 "Can't locate package %"SVf" for @%"HEKf"::ISA",
ecad31f0 707 SVfARG(linear_sv),
d0c0e7dd 708 HEKfARG(HvNAME_HEK(stash)));
e1a479c5
BB
709 continue;
710 }
9607fc9c 711
e1a479c5
BB
712 assert(cstash);
713
c60dbbc3 714 gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
0f8d4b5e
FC
715 if (!gvp) {
716 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
717 const char *hvname = HvNAME(cstash); assert(hvname);
718 if (strnEQ(hvname, "CORE", 4)
719 && (candidate =
87566176 720 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
0f8d4b5e
FC
721 ))
722 goto have_candidate;
723 }
724 continue;
725 }
726 else candidate = *gvp;
727 have_candidate:
e1a479c5 728 assert(candidate);
04f3bf56 729 if (SvTYPE(candidate) != SVt_PVGV)
04ec7e59 730 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
e1a479c5
BB
731 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
732 /*
733 * Found real method, cache method in topgv if:
734 * 1. topgv has no synonyms (else inheritance crosses wires)
735 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
736 */
737 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
9bfbb681
VP
738 CV *old_cv = GvCV(topgv);
739 SvREFCNT_dec(old_cv);
e1a479c5 740 SvREFCNT_inc_simple_void_NN(cand_cv);
c43ae56f 741 GvCV_set(topgv, cand_cv);
e1a479c5
BB
742 GvCVGEN(topgv) = topgen_cmp;
743 }
744 return candidate;
745 }
746 }
9607fc9c 747
e1a479c5
BB
748 /* Check UNIVERSAL without caching */
749 if(level == 0 || level == -1) {
e6919483 750 candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags);
e1a479c5
BB
751 if(candidate) {
752 cand_cv = GvCV(candidate);
753 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
9bfbb681
VP
754 CV *old_cv = GvCV(topgv);
755 SvREFCNT_dec(old_cv);
e1a479c5 756 SvREFCNT_inc_simple_void_NN(cand_cv);
c43ae56f 757 GvCV_set(topgv, cand_cv);
e1a479c5
BB
758 GvCVGEN(topgv) = topgen_cmp;
759 }
760 return candidate;
761 }
762 }
763
764 if (topgv && GvREFCNT(topgv) == 1) {
765 /* cache the fact that the method is not defined */
766 GvCVGEN(topgv) = topgen_cmp;
a0d0e21e
LW
767 }
768
79072805
LW
769 return 0;
770}
771
954c1994 772/*
460e5730
FC
773=for apidoc gv_fetchmeth_autoload
774
775This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
776parameter.
777
d21989ed 778=for apidoc gv_fetchmeth_sv_autoload
611c1e95 779
d21989ed
BF
780Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
781of an SV instead of a string/length pair.
782
783=cut
784*/
785
786GV *
787Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
788{
789 char *namepv;
790 STRLEN namelen;
791 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
792 namepv = SvPV(namesv, namelen);
793 if (SvUTF8(namesv))
794 flags |= SVf_UTF8;
795 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
796}
797
798/*
799=for apidoc gv_fetchmeth_pv_autoload
800
801Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
802instead of a string/length pair.
803
804=cut
805*/
806
807GV *
808Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
809{
810 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
811 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
812}
813
814/*
815=for apidoc gv_fetchmeth_pvn_autoload
816
817Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
611c1e95
IZ
818Returns a glob for the subroutine.
819
820For an autoloaded subroutine without a GV, will create a GV even
821if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
822of the result may be zero.
823
d21989ed
BF
824Currently, the only significant value for C<flags> is SVf_UTF8.
825
611c1e95
IZ
826=cut
827*/
828
829GV *
d21989ed 830Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
611c1e95 831{
499321d3 832 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
611c1e95 833
d21989ed 834 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
7918f24d 835
611c1e95 836 if (!gv) {
611c1e95
IZ
837 CV *cv;
838 GV **gvp;
839
840 if (!stash)
6136c704 841 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
7edbdc6b 842 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
6136c704 843 return NULL;
d21989ed 844 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
6136c704 845 return NULL;
611c1e95
IZ
846 cv = GvCV(gv);
847 if (!(CvROOT(cv) || CvXSUB(cv)))
6136c704 848 return NULL;
611c1e95
IZ
849 /* Have an autoload */
850 if (level < 0) /* Cannot do without a stub */
d21989ed 851 gv_fetchmeth_pvn(stash, name, len, 0, flags);
c60dbbc3
BF
852 gvp = (GV**)hv_fetch(stash, name,
853 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
611c1e95 854 if (!gvp)
6136c704 855 return NULL;
611c1e95
IZ
856 return *gvp;
857 }
858 return gv;
859}
860
861/*
954c1994
GS
862=for apidoc gv_fetchmethod_autoload
863
864Returns the glob which contains the subroutine to call to invoke the method
865on the C<stash>. In fact in the presence of autoloading this may be the
866glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
b267980d 867already setup.
954c1994
GS
868
869The third parameter of C<gv_fetchmethod_autoload> determines whether
870AUTOLOAD lookup is performed if the given method is not present: non-zero
b267980d 871means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
954c1994 872Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
b267980d 873with a non-zero C<autoload> parameter.
954c1994
GS
874
875These functions grant C<"SUPER"> token as a prefix of the method name. Note
876that if you want to keep the returned glob for a long time, you need to
877check for it being "AUTOLOAD", since at the later time the call may load a
878different subroutine due to $AUTOLOAD changing its value. Use the glob
b267980d 879created via a side effect to do this.
954c1994
GS
880
881These functions have the same side-effects and as C<gv_fetchmeth> with
882C<level==0>. C<name> should be writable if contains C<':'> or C<'
883''>. The warning against passing the GV returned by C<gv_fetchmeth> to
b267980d 884C<call_sv> apply equally to these functions.
954c1994
GS
885
886=cut
887*/
888
7d3b1f61 889STATIC HV*
9cc50d5b 890S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
7d3b1f61
BB
891{
892 AV* superisa;
893 GV** gvp;
894 GV* gv;
895 HV* stash;
896
7918f24d
NC
897 PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
898
f8e7a8bc 899 stash = gv_stashpvn(name, namelen, flags);
7d3b1f61
BB
900 if(stash) return stash;
901
902 /* If we must create it, give it an @ISA array containing
903 the real package this SUPER is for, so that it's tied
904 into the cache invalidation code correctly */
f8e7a8bc 905 stash = gv_stashpvn(name, namelen, GV_ADD | flags);
7d3b1f61
BB
906 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
907 gv = *gvp;
f8e7a8bc 908 gv_init(gv, stash, "ISA", 3, TRUE);
7d3b1f61
BB
909 superisa = GvAVn(gv);
910 GvMULTI_on(gv);
ad64d0ec 911 sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
8e3a4a30 912#ifdef USE_ITHREADS
f8e7a8bc 913 av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
6379d4a9
FC
914 CopSTASH_len(PL_curcop) < 0
915 ? -CopSTASH_len(PL_curcop)
916 : CopSTASH_len(PL_curcop),
917 SVf_UTF8*(CopSTASH_len(PL_curcop) < 0)
f8e7a8bc 918 ));
8e3a4a30
NC
919#else
920 av_push(superisa, newSVhek(CopSTASH(PL_curcop)
921 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
922#endif
7d3b1f61
BB
923
924 return stash;
925}
926
dc848c6f 927GV *
864dbfa3 928Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
dc848c6f 929{
547bb267
NC
930 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
931
256d1bb2
NC
932 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
933}
934
44130a26
BF
935GV *
936Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
937{
938 char *namepv;
939 STRLEN namelen;
940 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
941 namepv = SvPV(namesv, namelen);
942 if (SvUTF8(namesv))
943 flags |= SVf_UTF8;
944 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
945}
946
947GV *
948Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
949{
950 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
951 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
952}
953
256d1bb2
NC
954/* Don't merge this yet, as it's likely to get a len parameter, and possibly
955 even a U32 hash */
956GV *
44130a26 957Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
256d1bb2 958{
97aff369 959 dVAR;
08105a92 960 register const char *nend;
c445ea15 961 const char *nsplit = NULL;
a0d0e21e 962 GV* gv;
0dae17bd 963 HV* ostash = stash;
c94593d0 964 const char * const origname = name;
ad64d0ec 965 SV *const error_report = MUTABLE_SV(stash);
256d1bb2
NC
966 const U32 autoload = flags & GV_AUTOLOAD;
967 const U32 do_croak = flags & GV_CROAK;
14d1dfbd 968 const U32 is_utf8 = flags & SVf_UTF8;
0dae17bd 969
44130a26 970 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
7918f24d 971
eff494dd 972 if (SvTYPE(stash) < SVt_PVHV)
5c284bb0 973 stash = NULL;
c9bf4021
NC
974 else {
975 /* The only way stash can become NULL later on is if nsplit is set,
976 which in turn means that there is no need for a SVt_PVHV case
977 the error reporting code. */
978 }
b267980d 979
44130a26 980 for (nend = name; *nend || nend != (origname + len); nend++) {
c94593d0 981 if (*nend == '\'') {
a0d0e21e 982 nsplit = nend;
c94593d0
NC
983 name = nend + 1;
984 }
985 else if (*nend == ':' && *(nend + 1) == ':') {
986 nsplit = nend++;
987 name = nend + 1;
988 }
a0d0e21e
LW
989 }
990 if (nsplit) {
7edbdc6b 991 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
9607fc9c 992 /* ->SUPER::method should really be looked up in original stash */
d0c0e7dd
FC
993 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_
994 "%"HEKf"::SUPER",
995 HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))
996 ));
af09ea45 997 /* __PACKAGE__::SUPER stash should be autovivified */
9cc50d5b 998 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
cea2e8a9 999 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
bfcb3514 1000 origname, HvNAME_get(stash), name) );
4633a7c4 1001 }
e189a56d 1002 else {
af09ea45 1003 /* don't autovifify if ->NoSuchStash::method */
14d1dfbd 1004 stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
e189a56d
IK
1005
1006 /* however, explicit calls to Pkg::SUPER::method may
1007 happen, and may require autovivification to work */
1008 if (!stash && (nsplit - origname) >= 7 &&
1009 strnEQ(nsplit - 7, "::SUPER", 7) &&
14d1dfbd 1010 gv_stashpvn(origname, nsplit - origname - 7, is_utf8))
9cc50d5b 1011 stash = gv_get_super_pkg(origname, nsplit - origname, flags);
e189a56d 1012 }
0dae17bd 1013 ostash = stash;
4633a7c4
LW
1014 }
1015
14d1dfbd 1016 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
a0d0e21e 1017 if (!gv) {
2f6e0fe7 1018 if (strEQ(name,"import") || strEQ(name,"unimport"))
159b6efe 1019 gv = MUTABLE_GV(&PL_sv_yes);
dc848c6f 1020 else if (autoload)
c8416c26
BF
1021 gv = gv_autoload_pvn(
1022 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1023 );
256d1bb2
NC
1024 if (!gv && do_croak) {
1025 /* Right now this is exclusively for the benefit of S_method_common
1026 in pp_hot.c */
1027 if (stash) {
15e6cdd9
DG
1028 /* If we can't find an IO::File method, it might be a call on
1029 * a filehandle. If IO:File has not been loaded, try to
1030 * require it first instead of croaking */
1031 const char *stash_name = HvNAME_get(stash);
31b05a0f
FR
1032 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1033 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1034 STR_WITH_LEN("IO/File.pm"), 0,
1035 HV_FETCH_ISEXISTS, NULL, 0)
15e6cdd9 1036 ) {
31b05a0f 1037 require_pv("IO/File.pm");
14d1dfbd 1038 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
15e6cdd9
DG
1039 if (gv)
1040 return gv;
1041 }
256d1bb2 1042 Perl_croak(aTHX_
d0c0e7dd
FC
1043 "Can't locate object method \"%"SVf
1044 "\" via package \"%"HEKf"\"",
f937af42
BF
1045 SVfARG(newSVpvn_flags(name, nend - name,
1046 SVs_TEMP | is_utf8)),
d0c0e7dd 1047 HEKfARG(HvNAME_HEK(stash)));
256d1bb2
NC
1048 }
1049 else {
ecad31f0 1050 SV* packnamesv;
256d1bb2 1051
256d1bb2 1052 if (nsplit) {
ecad31f0
BF
1053 packnamesv = newSVpvn_flags(origname, nsplit - origname,
1054 SVs_TEMP | is_utf8);
256d1bb2 1055 } else {
ecad31f0 1056 packnamesv = sv_2mortal(newSVsv(error_report));
256d1bb2
NC
1057 }
1058
1059 Perl_croak(aTHX_
ecad31f0
BF
1060 "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
1061 " (perhaps you forgot to load \"%"SVf"\"?)",
1062 SVfARG(newSVpvn_flags(name, nend - name,
1063 SVs_TEMP | is_utf8)),
1064 SVfARG(packnamesv), SVfARG(packnamesv));
256d1bb2
NC
1065 }
1066 }
463ee0b2 1067 }
dc848c6f 1068 else if (autoload) {
9d4ba2ae 1069 CV* const cv = GvCV(gv);
09280a33
CS
1070 if (!CvROOT(cv) && !CvXSUB(cv)) {
1071 GV* stubgv;
1072 GV* autogv;
1073
1074 if (CvANON(cv))
1075 stubgv = gv;
1076 else {
1077 stubgv = CvGV(cv);
1078 if (GvCV(stubgv) != cv) /* orphaned import */
1079 stubgv = gv;
1080 }
c8416c26
BF
1081 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1082 GvNAME(stubgv), GvNAMELEN(stubgv),
1083 GV_AUTOLOAD_ISMETHOD
1084 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
dc848c6f
PP
1085 if (autogv)
1086 gv = autogv;
1087 }
1088 }
44a8e56a
PP
1089
1090 return gv;
1091}
1092
1093GV*
0eeb01b9 1094Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
5fba3c91
BF
1095{
1096 char *namepv;
1097 STRLEN namelen;
0fe84f7c 1098 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
5fba3c91
BF
1099 namepv = SvPV(namesv, namelen);
1100 if (SvUTF8(namesv))
1101 flags |= SVf_UTF8;
0eeb01b9 1102 return gv_autoload_pvn(stash, namepv, namelen, flags);
5fba3c91
BF
1103}
1104
1105GV*
0eeb01b9 1106Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
5fba3c91 1107{
0fe84f7c 1108 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
0eeb01b9 1109 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
5fba3c91
BF
1110}
1111
1112GV*
0eeb01b9 1113Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
44a8e56a 1114{
27da23d5 1115 dVAR;
44a8e56a
PP
1116 GV* gv;
1117 CV* cv;
1118 HV* varstash;
1119 GV* vargv;
1120 SV* varsv;
c8416c26
BF
1121 SV *packname = NULL;
1122 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
44a8e56a 1123
0fe84f7c 1124 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
7918f24d 1125
7edbdc6b 1126 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
a0714e2c 1127 return NULL;
0dae17bd
GS
1128 if (stash) {
1129 if (SvTYPE(stash) < SVt_PVHV) {
c8416c26
BF
1130 STRLEN packname_len = 0;
1131 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1132 packname = newSVpvn_flags(packname_ptr, packname_len,
1133 SVs_TEMP | SvUTF8(stash));
5c284bb0 1134 stash = NULL;
0dae17bd 1135 }
c8416c26
BF
1136 else
1137 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
0dae17bd 1138 }
c8416c26 1139 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
a0714e2c 1140 return NULL;
dc848c6f
PP
1141 cv = GvCV(gv);
1142
adb5a9ae 1143 if (!(CvROOT(cv) || CvXSUB(cv)))
a0714e2c 1144 return NULL;
ed850460 1145
dc848c6f
PP
1146 /*
1147 * Inheriting AUTOLOAD for non-methods works ... for now.
1148 */
0eeb01b9
FC
1149 if (
1150 !(flags & GV_AUTOLOAD_ISMETHOD)
1151 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
041457d9 1152 )
d1d15184 1153 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
ecad31f0
BF
1154 "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
1155 SVfARG(packname),
1156 SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
44a8e56a 1157
aed2304a 1158 if (CvISXSUB(cv)) {
bb619f37
FC
1159 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1160 * and split that value on the last '::', pass along the same data
1161 * via the SvPVX field in the CV, and the stash in CvSTASH.
8fa6a409
FC
1162 *
1163 * Due to an unfortunate accident of history, the SvPVX field
e1fa07e3 1164 * serves two purposes. It is also used for the subroutine's pro-
8fa6a409
FC
1165 * type. Since SvPVX has been documented as returning the sub name
1166 * for a long time, but not as returning the prototype, we have
1167 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1168 * elsewhere.
1169 *
1170 * We put the prototype in the same allocated buffer, but after
1171 * the sub name. The SvPOK flag indicates the presence of a proto-
1172 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1173 * If both flags are on, then SvLEN is used to indicate the end of
1174 * the prototype (artificially lower than what is actually allo-
1175 * cated), at the risk of having to reallocate a few bytes unneces-
1176 * sarily--but that should happen very rarely, if ever.
1177 *
1178 * We use SvUTF8 for both prototypes and sub names, so if one is
1179 * UTF8, the other must be upgraded.
adb5a9ae 1180 */
c68d9564 1181 CvSTASH_set(cv, stash);
8fa6a409
FC
1182 if (SvPOK(cv)) { /* Ouch! */
1183 SV *tmpsv = newSVpvn_flags(name, len, is_utf8);
1184 STRLEN ulen;
1185 const char *proto = CvPROTO(cv);
1186 assert(proto);
1187 if (SvUTF8(cv))
1188 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1189 ulen = SvCUR(tmpsv);
1190 SvCUR(tmpsv)++; /* include null in string */
1191 sv_catpvn_flags(
1192 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1193 );
1194 SvTEMP_on(tmpsv); /* Allow theft */
1195 sv_setsv_nomg((SV *)cv, tmpsv);
05b525f4 1196 SvTEMP_off(tmpsv);
8fa6a409
FC
1197 SvREFCNT_dec(tmpsv);
1198 SvLEN(cv) = SvCUR(cv) + 1;
1199 SvCUR(cv) = ulen;
1200 }
1201 else {
1202 sv_setpvn((SV *)cv, name, len);
1203 SvPOK_off(cv);
1204 if (is_utf8)
c8416c26 1205 SvUTF8_on(cv);
8fa6a409
FC
1206 else SvUTF8_off(cv);
1207 }
1208 CvAUTOLOAD_on(cv);
adb5a9ae 1209 }
adb5a9ae 1210
44a8e56a
PP
1211 /*
1212 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1213 * The subroutine's original name may not be "AUTOLOAD", so we don't
1214 * use that, but for lack of anything better we will use the sub's
1215 * original package to look up $AUTOLOAD.
1216 */
1217 varstash = GvSTASH(CvGV(cv));
5c7983e5 1218 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
3d35f11b
GS
1219 ENTER;
1220
c69033f2 1221 if (!isGV(vargv)) {
04ec7e59 1222 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
c69033f2 1223#ifdef PERL_DONT_CREATE_GVSV
561b68a9 1224 GvSV(vargv) = newSV(0);
c69033f2
NC
1225#endif
1226 }
3d35f11b 1227 LEAVE;
e203899d 1228 varsv = GvSVn(vargv);
c8416c26 1229 sv_setsv(varsv, packname);
396482e1 1230 sv_catpvs(varsv, "::");
d40bf27b
NC
1231 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1232 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
61a9130e
FC
1233 sv_catpvn_flags(
1234 varsv, name, len,
5bcd1ef4 1235 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
61a9130e 1236 );
c8416c26
BF
1237 if (is_utf8)
1238 SvUTF8_on(varsv);
a0d0e21e
LW
1239 return gv;
1240}
1241
44a2ac75
YO
1242
1243/* require_tie_mod() internal routine for requiring a module
486ec47a 1244 * that implements the logic of automatic ties like %! and %-
44a2ac75
YO
1245 *
1246 * The "gv" parameter should be the glob.
45cbc99a
RGS
1247 * "varpv" holds the name of the var, used for error messages.
1248 * "namesv" holds the module name. Its refcount will be decremented.
44a2ac75 1249 * "methpv" holds the method name to test for to check that things
45cbc99a
RGS
1250 * are working reasonably close to as expected.
1251 * "flags": if flag & 1 then save the scalar before loading.
44a2ac75
YO
1252 * For the protection of $! to work (it is set by this routine)
1253 * the sv slot must already be magicalized.
d2c93421 1254 */
44a2ac75
YO
1255STATIC HV*
1256S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
d2c93421 1257{
27da23d5 1258 dVAR;
da51bb9b 1259 HV* stash = gv_stashsv(namesv, 0);
45cbc99a 1260
7918f24d
NC
1261 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1262
0ea03996 1263 if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
45cbc99a
RGS
1264 SV *module = newSVsv(namesv);
1265 char varname = *varpv; /* varpv might be clobbered by load_module,
1266 so save it. For the moment it's always
1267 a single char. */
b82b06b8 1268 const char type = varname == '[' ? '$' : '%';
d2c93421 1269 dSP;
d2c93421 1270 ENTER;
44a2ac75 1271 if ( flags & 1 )
45cbc99a 1272 save_scalar(gv);
cac54379 1273 PUSHSTACKi(PERLSI_MAGIC);
45cbc99a 1274 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
cac54379 1275 POPSTACK;
d2c93421
RH
1276 LEAVE;
1277 SPAGAIN;
da51bb9b 1278 stash = gv_stashsv(namesv, 0);
44a2ac75 1279 if (!stash)
b82b06b8
FC
1280 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1281 type, varname, SVfARG(namesv));
45cbc99a 1282 else if (!gv_fetchmethod(stash, methpv))
b82b06b8
FC
1283 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1284 type, varname, SVfARG(namesv), methpv);
d2c93421 1285 }
45cbc99a 1286 SvREFCNT_dec(namesv);
44a2ac75 1287 return stash;
d2c93421
RH
1288}
1289
954c1994
GS
1290/*
1291=for apidoc gv_stashpv
1292
da51bb9b 1293Returns a pointer to the stash for a specified package. Uses C<strlen> to
75c442e4 1294determine the length of C<name>, then calls C<gv_stashpvn()>.
954c1994
GS
1295
1296=cut
1297*/
1298
a0d0e21e 1299HV*
864dbfa3 1300Perl_gv_stashpv(pTHX_ const char *name, I32 create)
a0d0e21e 1301{
7918f24d 1302 PERL_ARGS_ASSERT_GV_STASHPV;
dc437b57
PP
1303 return gv_stashpvn(name, strlen(name), create);
1304}
1305
bc96cb06
SH
1306/*
1307=for apidoc gv_stashpvn
1308
da51bb9b
NC
1309Returns a pointer to the stash for a specified package. The C<namelen>
1310parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1311to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1312created if it does not already exist. If the package does not exist and
1313C<flags> is 0 (or any other setting that does not create packages) then NULL
1314is returned.
1315
bc96cb06
SH
1316
1317=cut
1318*/
1319
dc437b57 1320HV*
da51bb9b 1321Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
dc437b57 1322{
0cea0058 1323 char smallbuf[128];
46fc3d4c 1324 char *tmpbuf;
a0d0e21e
LW
1325 HV *stash;
1326 GV *tmpgv;
add0ecde 1327 U32 tmplen = namelen + 2;
dc437b57 1328
7918f24d
NC
1329 PERL_ARGS_ASSERT_GV_STASHPVN;
1330
add0ecde 1331 if (tmplen <= sizeof smallbuf)
46fc3d4c
PP
1332 tmpbuf = smallbuf;
1333 else
add0ecde
VP
1334 Newx(tmpbuf, tmplen, char);
1335 Copy(name, tmpbuf, namelen, char);
1336 tmpbuf[namelen] = ':';
1337 tmpbuf[namelen+1] = ':';
1338 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
46fc3d4c
PP
1339 if (tmpbuf != smallbuf)
1340 Safefree(tmpbuf);
a0d0e21e 1341 if (!tmpgv)
da51bb9b 1342 return NULL;
a0d0e21e 1343 stash = GvHV(tmpgv);
1f656fcf 1344 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
9efb5c72 1345 assert(stash);
1f656fcf 1346 if (!HvNAME_get(stash)) {
0be4d16f 1347 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1f656fcf
FC
1348
1349 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1350 /* If the containing stash has multiple effective
1351 names, see that this one gets them, too. */
1352 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1353 mro_package_moved(stash, NULL, tmpgv, 1);
1354 }
a0d0e21e 1355 return stash;
463ee0b2
LW
1356}
1357
954c1994
GS
1358/*
1359=for apidoc gv_stashsv
1360
da51bb9b 1361Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
954c1994
GS
1362
1363=cut
1364*/
1365
a0d0e21e 1366HV*
da51bb9b 1367Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
a0d0e21e 1368{
dc437b57 1369 STRLEN len;
9d4ba2ae 1370 const char * const ptr = SvPV_const(sv,len);
7918f24d
NC
1371
1372 PERL_ARGS_ASSERT_GV_STASHSV;
1373
0be4d16f 1374 return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
a0d0e21e
LW
1375}
1376
1377
463ee0b2 1378GV *
fe9845cc 1379Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
7918f24d 1380 PERL_ARGS_ASSERT_GV_FETCHPV;
b7787f18 1381 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
7a5fd60d
NC
1382}
1383
1384GV *
fe9845cc 1385Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
7a5fd60d 1386 STRLEN len;
77cb3b01
FC
1387 const char * const nambeg =
1388 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
7918f24d 1389 PERL_ARGS_ASSERT_GV_FETCHSV;
7a5fd60d
NC
1390 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1391}
1392
ad7cce9f 1393STATIC void
290a1700 1394S_gv_magicalize_isa(pTHX_ GV *gv)
ad7cce9f
FR
1395{
1396 AV* av;
1397
1398 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1399
1400 av = GvAVn(gv);
1401 GvMULTI_on(gv);
1402 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1403 NULL, 0);
ad7cce9f
FR
1404}
1405
7a5fd60d
NC
1406GV *
1407Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
fe9845cc 1408 const svtype sv_type)
79072805 1409{
97aff369 1410 dVAR;
08105a92 1411 register const char *name = nambeg;
c445ea15 1412 register GV *gv = NULL;
79072805 1413 GV**gvp;
79072805 1414 I32 len;
b3d904f3 1415 register const char *name_cursor;
c445ea15 1416 HV *stash = NULL;
add2581e 1417 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
e26df76a 1418 const I32 no_expand = flags & GV_NOEXPAND;
780a5241 1419 const I32 add = flags & ~GV_NOADD_MASK;
04f3bf56 1420 const U32 is_utf8 = flags & SVf_UTF8;
9da346da 1421 bool addmg = !!(flags & GV_ADDMG);
b3d904f3
NC
1422 const char *const name_end = nambeg + full_len;
1423 const char *const name_em1 = name_end - 1;
5e0caaeb 1424 U32 faking_it;
79072805 1425
7918f24d
NC
1426 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1427
fafc274c
NC
1428 if (flags & GV_NOTQUAL) {
1429 /* Caller promised that there is no stash, so we can skip the check. */
1430 len = full_len;
1431 goto no_stash;
1432 }
1433
ecad31f0 1434 if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
b208e10c 1435 /* accidental stringify on a GV? */
c07a80fd 1436 name++;
b208e10c 1437 }
c07a80fd 1438
b3d904f3 1439 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
46c0ec20
FC
1440 if (name_cursor < name_em1 &&
1441 ((*name_cursor == ':'
b3d904f3 1442 && name_cursor[1] == ':')
46c0ec20 1443 || *name_cursor == '\''))
463ee0b2 1444 {
463ee0b2 1445 if (!stash)
3280af22 1446 stash = PL_defstash;
dc437b57 1447 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
a0714e2c 1448 return NULL;
463ee0b2 1449
b3d904f3 1450 len = name_cursor - name;
088225fd 1451 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
3a5b580c
NC
1452 const char *key;
1453 if (*name_cursor == ':') {
1454 key = name;
e771aaa9
NC
1455 len += 2;
1456 } else {
3a5b580c 1457 char *tmpbuf;
2ae0db35 1458 Newx(tmpbuf, len+2, char);
e771aaa9
NC
1459 Copy(name, tmpbuf, len, char);
1460 tmpbuf[len++] = ':';
1461 tmpbuf[len++] = ':';
3a5b580c 1462 key = tmpbuf;
e771aaa9 1463 }
0be4d16f 1464 gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
a0714e2c 1465 gv = gvp ? *gvp : NULL;
159b6efe 1466 if (gv && gv != (const GV *)&PL_sv_undef) {
6fa846a0 1467 if (SvTYPE(gv) != SVt_PVGV)
04ec7e59 1468 gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
6fa846a0
GS
1469 else
1470 GvMULTI_on(gv);
1471 }
3a5b580c 1472 if (key != name)
b9d2ea5b 1473 Safefree(key);
159b6efe 1474 if (!gv || gv == (const GV *)&PL_sv_undef)
a0714e2c 1475 return NULL;
85e6fe83 1476
463ee0b2 1477 if (!(stash = GvHV(gv)))
298d6511 1478 {
99ee9762
FC
1479 stash = GvHV(gv) = newHV();
1480 if (!HvNAME_get(stash)) {
e058c50a
FC
1481 if (GvSTASH(gv) == PL_defstash && len == 6
1482 && strnEQ(name, "CORE", 4))
1483 hv_name_set(stash, "CORE", 4, 0);
1484 else
1485 hv_name_set(
0be4d16f 1486 stash, nambeg, name_cursor-nambeg, is_utf8
e058c50a 1487 );
99ee9762
FC
1488 /* If the containing stash has multiple effective
1489 names, see that this one gets them, too. */
1490 if (HvAUX(GvSTASH(gv))->xhv_name_count)
1491 mro_package_moved(stash, NULL, gv, 1);
1492 }
298d6511 1493 }
99ee9762 1494 else if (!HvNAME_get(stash))
0be4d16f 1495 hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
463ee0b2
LW
1496 }
1497
b3d904f3
NC
1498 if (*name_cursor == ':')
1499 name_cursor++;
088225fd 1500 name = name_cursor+1;
ad6bfa9d 1501 if (name == name_end)
159b6efe
NC
1502 return gv
1503 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
79072805 1504 }
79072805 1505 }
b3d904f3 1506 len = name_cursor - name;
463ee0b2
LW
1507
1508 /* No stash in name, so see how we can default */
1509
1510 if (!stash) {
fafc274c 1511 no_stash:
8ccce9ae 1512 if (len && isIDFIRST_lazy(name)) {
9607fc9c
PP
1513 bool global = FALSE;
1514
8ccce9ae
NC
1515 switch (len) {
1516 case 1:
18ea00d7 1517 if (*name == '_')
9d116dd7 1518 global = TRUE;
18ea00d7 1519 break;
8ccce9ae
NC
1520 case 3:
1521 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1522 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1523 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
9d116dd7 1524 global = TRUE;
18ea00d7 1525 break;
8ccce9ae
NC
1526 case 4:
1527 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1528 && name[3] == 'V')
9d116dd7 1529 global = TRUE;
18ea00d7 1530 break;
8ccce9ae
NC
1531 case 5:
1532 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1533 && name[3] == 'I' && name[4] == 'N')
463ee0b2 1534 global = TRUE;
18ea00d7 1535 break;
8ccce9ae
NC
1536 case 6:
1537 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1538 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1539 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1540 global = TRUE;
1541 break;
1542 case 7:
1543 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1544 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1545 && name[6] == 'T')
18ea00d7
NC
1546 global = TRUE;
1547 break;
463ee0b2 1548 }
9607fc9c 1549
463ee0b2 1550 if (global)
3280af22 1551 stash = PL_defstash;
923e4eb5 1552 else if (IN_PERL_COMPILETIME) {
3280af22
NIS
1553 stash = PL_curstash;
1554 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
1555 sv_type != SVt_PVCV &&
1556 sv_type != SVt_PVGV &&
4633a7c4 1557 sv_type != SVt_PVFM &&
c07a80fd 1558 sv_type != SVt_PVIO &&
70ec6265
NC
1559 !(len == 1 && sv_type == SVt_PV &&
1560 (*name == 'a' || *name == 'b')) )
748a9306 1561 {
0be4d16f 1562 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
4633a7c4 1563 if (!gvp ||
159b6efe 1564 *gvp == (const GV *)&PL_sv_undef ||
a5f75d66
AD
1565 SvTYPE(*gvp) != SVt_PVGV)
1566 {
d4c19fe8 1567 stash = NULL;
a5f75d66 1568 }
155aba94
GS
1569 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1570 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1571 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 1572 {
ecad31f0 1573 SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
fe13d51d 1574 /* diag_listed_as: Variable "%s" is not imported%s */
413ff9f6
FC
1575 Perl_ck_warner_d(
1576 aTHX_ packWARN(WARN_MISC),
ecad31f0 1577 "Variable \"%c%"SVf"\" is not imported",
4633a7c4
LW
1578 sv_type == SVt_PVAV ? '@' :
1579 sv_type == SVt_PVHV ? '%' : '$',
ecad31f0 1580 SVfARG(namesv));
8ebc5c01 1581 if (GvCVu(*gvp))
413ff9f6
FC
1582 Perl_ck_warner_d(
1583 aTHX_ packWARN(WARN_MISC),
ecad31f0 1584 "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
413ff9f6 1585 );
d4c19fe8 1586 stash = NULL;
4633a7c4 1587 }
a0d0e21e 1588 }
85e6fe83 1589 }
463ee0b2 1590 else
1d7c1841 1591 stash = CopSTASH(PL_curcop);
463ee0b2
LW
1592 }
1593 else
3280af22 1594 stash = PL_defstash;
463ee0b2
LW
1595 }
1596
1597 /* By this point we should have a stash and a name */
1598
a0d0e21e 1599 if (!stash) {
5a844595 1600 if (add) {
9d4ba2ae 1601 SV * const err = Perl_mess(aTHX_
ecad31f0 1602 "Global symbol \"%s%"SVf"\" requires explicit package name",
5a844595
GS
1603 (sv_type == SVt_PV ? "$"
1604 : sv_type == SVt_PVAV ? "@"
1605 : sv_type == SVt_PVHV ? "%"
ecad31f0 1606 : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
e7f343b6 1607 GV *gv;
608b3986
AE
1608 if (USE_UTF8_IN_NAMES)
1609 SvUTF8_on(err);
1610 qerror(err);
76f68e9b 1611 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
e7f343b6
NC
1612 if(!gv) {
1613 /* symbol table under destruction */
1614 return NULL;
1615 }
1616 stash = GvHV(gv);
a0d0e21e 1617 }
d7aacf4e 1618 else
a0714e2c 1619 return NULL;
a0d0e21e
LW
1620 }
1621
1622 if (!SvREFCNT(stash)) /* symbol table under destruction */
a0714e2c 1623 return NULL;
a0d0e21e 1624
0be4d16f 1625 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
23496c6e
FC
1626 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1627 if (addmg) gv = (GV *)newSV(0);
1628 else return NULL;
1629 }
914ecc63
FC
1630 else gv = *gvp, addmg = 0;
1631 /* From this point on, addmg means gv has not been inserted in the
1632 symtab yet. */
1633
79072805 1634 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 1635 if (add) {
a5f75d66 1636 GvMULTI_on(gv);
e6066781 1637 gv_init_svtype(gv, sv_type);
b82b06b8
FC
1638 if (len == 1 && stash == PL_defstash) {
1639 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
44a2ac75
YO
1640 if (*name == '!')
1641 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
45cbc99a 1642 else if (*name == '-' || *name == '+')
192b9cd1 1643 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
b82b06b8 1644 }
a289ef89
FC
1645 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
1646 if (*name == '[')
b82b06b8 1647 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
a289ef89
FC
1648 else if (*name == '&' || *name == '`' || *name == '\'') {
1649 PL_sawampersand = TRUE;
1650 (void)GvSVn(gv);
1651 }
1652 }
45cbc99a 1653 }
af16de9f
FC
1654 else if (len == 3 && sv_type == SVt_PVAV
1655 && strnEQ(name, "ISA", 3)
1656 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1657 gv_magicalize_isa(gv);
a0d0e21e 1658 }
79072805 1659 return gv;
add2581e 1660 } else if (no_init) {
23496c6e 1661 assert(!addmg);
55d729e4 1662 return gv;
e26df76a 1663 } else if (no_expand && SvROK(gv)) {
23496c6e 1664 assert(!addmg);
e26df76a 1665 return gv;
79072805 1666 }
93a17b20 1667
5e0caaeb
NC
1668 /* Adding a new symbol.
1669 Unless of course there was already something non-GV here, in which case
1670 we want to behave as if there was always a GV here, containing some sort
1671 of subroutine.
1672 Otherwise we run the risk of creating things like GvIO, which can cause
1673 subtle bugs. eg the one that tripped up SQL::Translator */
1674
1675 faking_it = SvOK(gv);
93a17b20 1676
9b387841 1677 if (add & GV_ADDWARN)
ecad31f0 1678 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
f1c07be4 1679 SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
04ec7e59 1680 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
93a17b20 1681
ecad31f0
BF
1682 if ( isIDFIRST_lazy_if(name, is_utf8)
1683 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM
1684 GvMULTI_on(gv) ;
1685
93a17b20 1686 /* set up magic where warranted */
44428a46 1687 if (stash != PL_defstash) { /* not the main stash */
5fdfd519 1688 /* We only have to check for three names here: EXPORT, ISA
4aaa4757
FC
1689 and VERSION. All the others apply only to the main stash or to
1690 CORE (which is checked right after this). */
f4e68e82 1691 if (len > 2) {
b464bac0 1692 const char * const name2 = name + 1;
cc4c2da6 1693 switch (*name) {
cc4c2da6
NC
1694 case 'E':
1695 if (strnEQ(name2, "XPORT", 5))
1696 GvMULTI_on(gv);
1697 break;
1698 case 'I':
44428a46 1699 if (strEQ(name2, "SA"))
290a1700 1700 gv_magicalize_isa(gv);
cc4c2da6 1701 break;
44428a46
FC
1702 case 'V':
1703 if (strEQ(name2, "ERSION"))
1704 GvMULTI_on(gv);
1705 break;
4aaa4757
FC
1706 default:
1707 goto try_core;
1708 }
23496c6e 1709 goto add_magical_gv;
4aaa4757
FC
1710 }
1711 try_core:
1712 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1713 /* Avoid null warning: */
1714 const char * const stashname = HvNAME(stash); assert(stashname);
87566176
FC
1715 if (strnEQ(stashname, "CORE", 4))
1716 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
44428a46
FC
1717 }
1718 }
1719 else if (len > 1) {
1720#ifndef EBCDIC
1721 if (*name > 'V' ) {
1722 NOOP;
1723 /* Nothing else to do.
1724 The compiler will probably turn the switch statement into a
1725 branch table. Make sure we avoid even that small overhead for
1726 the common case of lower case variable names. */
1727 } else
1728#endif
1729 {
1730 const char * const name2 = name + 1;
1731 switch (*name) {
1732 case 'A':
1733 if (strEQ(name2, "RGV")) {
1734 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1735 }
1736 else if (strEQ(name2, "RGVOUT")) {
1737 GvMULTI_on(gv);
1738 }
1739 break;
1740 case 'E':
1741 if (strnEQ(name2, "XPORT", 5))
1742 GvMULTI_on(gv);
1743 break;
1744 case 'I':
1745 if (strEQ(name2, "SA")) {
290a1700 1746 gv_magicalize_isa(gv);
44428a46
FC
1747 }
1748 break;
cc4c2da6
NC
1749 case 'S':
1750 if (strEQ(name2, "IG")) {
1751 HV *hv;
1752 I32 i;
d525a7b2
NC
1753 if (!PL_psig_name) {
1754 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
a02a5408 1755 Newxz(PL_psig_pend, SIG_SIZE, int);
d525a7b2 1756 PL_psig_ptr = PL_psig_name + SIG_SIZE;
0bdedcb3
NC
1757 } else {
1758 /* I think that the only way to get here is to re-use an
1759 embedded perl interpreter, where the previous
1760 use didn't clean up fully because
1761 PL_perl_destruct_level was 0. I'm not sure that we
1762 "support" that, in that I suspect in that scenario
1763 there are sufficient other garbage values left in the
1764 interpreter structure that something else will crash
1765 before we get here. I suspect that this is one of
1766 those "doctor, it hurts when I do this" bugs. */
d525a7b2 1767 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
0bdedcb3 1768 Zero(PL_psig_pend, SIG_SIZE, int);
cc4c2da6
NC
1769 }
1770 GvMULTI_on(gv);
1771 hv = GvHVn(gv);
a0714e2c 1772 hv_magic(hv, NULL, PERL_MAGIC_sig);
cc4c2da6 1773 for (i = 1; i < SIG_SIZE; i++) {
551405c4 1774 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
cc4c2da6
NC
1775 if (init)
1776 sv_setsv(*init, &PL_sv_undef);
cc4c2da6
NC
1777 }
1778 }
1779 break;
1780 case 'V':
1781 if (strEQ(name2, "ERSION"))
1782 GvMULTI_on(gv);
1783 break;
e5218da5
GA
1784 case '\003': /* $^CHILD_ERROR_NATIVE */
1785 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1786 goto magicalize;
1787 break;
cc4c2da6
NC
1788 case '\005': /* $^ENCODING */
1789 if (strEQ(name2, "NCODING"))
1790 goto magicalize;
1791 break;
9ebf26ad
FR
1792 case '\007': /* $^GLOBAL_PHASE */
1793 if (strEQ(name2, "LOBAL_PHASE"))
1794 goto ro_magicalize;
1795 break;
cde0cee5
YO
1796 case '\015': /* $^MATCH */
1797 if (strEQ(name2, "ATCH"))
2fdbfb4d 1798 goto magicalize;
cc4c2da6
NC
1799 case '\017': /* $^OPEN */
1800 if (strEQ(name2, "PEN"))
1801 goto magicalize;
1802 break;
cde0cee5
YO
1803 case '\020': /* $^PREMATCH $^POSTMATCH */
1804 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
9ebf26ad
FR
1805 goto magicalize;
1806 break;
cc4c2da6
NC
1807 case '\024': /* ${^TAINT} */
1808 if (strEQ(name2, "AINT"))
1809 goto ro_magicalize;
1810 break;
7cebcbc0 1811 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
a0288114 1812 if (strEQ(name2, "NICODE"))
cc4c2da6 1813 goto ro_magicalize;
a0288114 1814 if (strEQ(name2, "TF8LOCALE"))
7cebcbc0 1815 goto ro_magicalize;
e07ea26a
NC
1816 if (strEQ(name2, "TF8CACHE"))
1817 goto magicalize;
cc4c2da6
NC
1818 break;
1819 case '\027': /* $^WARNING_BITS */
1820 if (strEQ(name2, "ARNING_BITS"))
1821 goto magicalize;
1822 break;
1823 case '1':
1824 case '2':
1825 case '3':
1826 case '4':
1827 case '5':
1828 case '6':
1829 case '7':
1830 case '8':
1831 case '9':
85e6fe83 1832 {
2fdbfb4d
AB
1833 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1834 this test */
1835 /* This snippet is taken from is_gv_magical */
cc4c2da6
NC
1836 const char *end = name + len;
1837 while (--end > name) {
23496c6e 1838 if (!isDIGIT(*end)) goto add_magical_gv;
cc4c2da6 1839 }
2fdbfb4d 1840 goto magicalize;
1d7c1841 1841 }
dc437b57 1842 }
93a17b20 1843 }
392db708
NC
1844 } else {
1845 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1846 be case '\0' in this switch statement (ie a default case) */
cc4c2da6 1847 switch (*name) {
6361f656
AB
1848 case '&': /* $& */
1849 case '`': /* $` */
1850 case '\'': /* $' */
a289ef89 1851 if (!(
cc4c2da6
NC
1852 sv_type == SVt_PVAV ||
1853 sv_type == SVt_PVHV ||
1854 sv_type == SVt_PVCV ||
1855 sv_type == SVt_PVFM ||
1856 sv_type == SVt_PVIO
a289ef89 1857 )) { PL_sawampersand = TRUE; }
2fdbfb4d 1858 goto magicalize;
cc4c2da6 1859
6361f656 1860 case ':': /* $: */
c69033f2 1861 sv_setpv(GvSVn(gv),PL_chopset);
cc4c2da6
NC
1862 goto magicalize;
1863
6361f656 1864 case '?': /* $? */
ff0cee69 1865#ifdef COMPLEX_STATUS
c69033f2 1866 SvUPGRADE(GvSVn(gv), SVt_PVLV);
ff0cee69 1867#endif
cc4c2da6 1868 goto magicalize;
ff0cee69 1869
6361f656 1870 case '!': /* $! */
67261566 1871 GvMULTI_on(gv);
44a2ac75 1872 /* If %! has been used, automatically load Errno.pm. */
d2c93421 1873
ad64d0ec 1874 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
d2c93421 1875
44a2ac75 1876 /* magicalization must be done before require_tie_mod is called */
67261566 1877 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
ffdb8bcd
FC
1878 {
1879 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1880 addmg = 0;
44a2ac75 1881 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
ffdb8bcd 1882 }
d2c93421 1883
6cef1e77 1884 break;
6361f656
AB
1885 case '-': /* $- */
1886 case '+': /* $+ */
44a2ac75
YO
1887 GvMULTI_on(gv); /* no used once warnings here */
1888 {
44a2ac75 1889 AV* const av = GvAVn(gv);
ad64d0ec 1890 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
44a2ac75 1891
ad64d0ec
NC
1892 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1893 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
67261566 1894 if (avc)
44a2ac75 1895 SvREADONLY_on(GvSVn(gv));
44a2ac75 1896 SvREADONLY_on(av);
67261566
YO
1897
1898 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
213084e4
FC
1899 {
1900 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1901 addmg = 0;
192b9cd1 1902 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
213084e4 1903 }
67261566 1904
80305961 1905 break;
cc4c2da6 1906 }
6361f656
AB
1907 case '*': /* $* */
1908 case '#': /* $# */
9b387841 1909 if (sv_type == SVt_PV)
dcbac5bb 1910 /* diag_listed_as: $* is no longer supported */
9b387841
NC
1911 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1912 "$%c is no longer supported", *name);
8ae1fe26 1913 break;
6361f656 1914 case '|': /* $| */
c69033f2 1915 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
cc4c2da6
NC
1916 goto magicalize;
1917
b3ca2e83
NC
1918 case '\010': /* $^H */
1919 {
1920 HV *const hv = GvHVn(gv);
1921 hv_magic(hv, NULL, PERL_MAGIC_hints);
1922 }
1923 goto magicalize;
b82b06b8 1924 case '[': /* $[ */
7d69d4a6 1925 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2846acbf 1926 && FEATURE_ARYBASE_IS_ENABLED) {
b82b06b8
FC
1927 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1928 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1929 addmg = 0;
1930 }
7d69d4a6 1931 else goto magicalize;
b82b06b8 1932 break;
cc4c2da6 1933 case '\023': /* $^S */
2fdbfb4d
AB
1934 ro_magicalize:
1935 SvREADONLY_on(GvSVn(gv));
1936 /* FALL THROUGH */
6361f656
AB
1937 case '0': /* $0 */
1938 case '1': /* $1 */
1939 case '2': /* $2 */
1940 case '3': /* $3 */
1941 case '4': /* $4 */
1942 case '5': /* $5 */
1943 case '6': /* $6 */
1944 case '7': /* $7 */
1945 case '8': /* $8 */
1946 case '9': /* $9 */
6361f656
AB
1947 case '^': /* $^ */
1948 case '~': /* $~ */
1949 case '=': /* $= */
1950 case '%': /* $% */
1951 case '.': /* $. */
1952 case '(': /* $( */
1953 case ')': /* $) */
1954 case '<': /* $< */
1955 case '>': /* $> */
1956 case '\\': /* $\ */
1957 case '/': /* $/ */
9cdac2a2 1958 case '$': /* $$ */
cc4c2da6
NC
1959 case '\001': /* $^A */
1960 case '\003': /* $^C */
1961 case '\004': /* $^D */
1962 case '\005': /* $^E */
1963 case '\006': /* $^F */
cc4c2da6
NC
1964 case '\011': /* $^I, NOT \t in EBCDIC */
1965 case '\016': /* $^N */
1966 case '\017': /* $^O */
1967 case '\020': /* $^P */
1968 case '\024': /* $^T */
1969 case '\027': /* $^W */
1970 magicalize:
ad64d0ec 1971 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
cc4c2da6 1972 break;
e521374c 1973
cc4c2da6 1974 case '\014': /* $^L */
76f68e9b 1975 sv_setpvs(GvSVn(gv),"\f");
c69033f2 1976 PL_formfeed = GvSVn(gv);
463ee0b2 1977 break;
6361f656 1978 case ';': /* $; */
76f68e9b 1979 sv_setpvs(GvSVn(gv),"\034");
463ee0b2 1980 break;
6361f656 1981 case ']': /* $] */
cc4c2da6 1982 {
3638bf15 1983 SV * const sv = GvSV(gv);
d7aa5382 1984 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 1985 upg_version(PL_patchlevel, TRUE);
7d54d38e
SH
1986 GvSV(gv) = vnumify(PL_patchlevel);
1987 SvREADONLY_on(GvSV(gv));
1988 SvREFCNT_dec(sv);
93a17b20
LW
1989 }
1990 break;
cc4c2da6
NC
1991 case '\026': /* $^V */
1992 {
3638bf15 1993 SV * const sv = GvSV(gv);
f9be5ac8
DM
1994 GvSV(gv) = new_version(PL_patchlevel);
1995 SvREADONLY_on(GvSV(gv));
1996 SvREFCNT_dec(sv);
16070b82
GS
1997 }
1998 break;
cc4c2da6 1999 }
79072805 2000 }
23496c6e
FC
2001 add_magical_gv:
2002 if (addmg) {
2003 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2004 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2005 ))
0f43181e 2006 (void)hv_store(stash,name,len,(SV *)gv,0);
23496c6e
FC
2007 else SvREFCNT_dec(gv), gv = NULL;
2008 }
e6066781 2009 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
93a17b20 2010 return gv;
79072805
LW
2011}
2012
2013void
35a4481c 2014Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 2015{
ed60a868 2016 const char *name;
35a4481c 2017 const HV * const hv = GvSTASH(gv);
7918f24d
NC
2018
2019 PERL_ARGS_ASSERT_GV_FULLNAME4;
2020
666ea192 2021 sv_setpv(sv, prefix ? prefix : "");
a0288114 2022
52a6327b 2023 if (hv && (name = HvNAME(hv))) {
ed60a868
FC
2024 const STRLEN len = HvNAMELEN(hv);
2025 if (keepmain || strnNE(name, "main", len)) {
2026 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
396482e1 2027 sv_catpvs(sv,"::");
ed60a868 2028 }
43693395 2029 }
ed60a868 2030 else sv_catpvs(sv,"__ANON__::");
04f3bf56 2031 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
43693395
GS
2032}
2033
2034void
35a4481c 2035Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 2036{
099be4f1 2037 const GV * const egv = GvEGVx(gv);
7918f24d
NC
2038
2039 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2040
46c461b5 2041 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
43693395
GS
2042}
2043
79072805 2044void
1146e912 2045Perl_gv_check(pTHX_ const HV *stash)
79072805 2046{
97aff369 2047 dVAR;
79072805 2048 register I32 i;
463ee0b2 2049
7918f24d
NC
2050 PERL_ARGS_ASSERT_GV_CHECK;
2051
8990e307
LW
2052 if (!HvARRAY(stash))
2053 return;
a0d0e21e 2054 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 2055 const HE *entry;
dc437b57 2056 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
b7787f18
AL
2057 register GV *gv;
2058 HV *hv;
dc437b57 2059 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
159b6efe 2060 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 2061 {
19b6c847 2062 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
2063 gv_check(hv); /* nested package */
2064 }
ecad31f0
BF
2065 else if ( *HeKEY(entry) != '_'
2066 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
e1ec3a88 2067 const char *file;
159b6efe 2068 gv = MUTABLE_GV(HeVAL(entry));
55d729e4 2069 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 2070 continue;
1d7c1841 2071 file = GvFILE(gv);
1d7c1841
GS
2072 CopLINE_set(PL_curcop, GvLINE(gv));
2073#ifdef USE_ITHREADS
dd374669 2074 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841 2075#else
9bde8eb0
NC
2076 CopFILEGV(PL_curcop)
2077 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1d7c1841 2078#endif
9014280d 2079 Perl_warner(aTHX_ packWARN(WARN_ONCE),
d0c0e7dd
FC
2080 "Name \"%"HEKf"::%"HEKf
2081 "\" used only once: possible typo",
2082 HEKfARG(HvNAME_HEK(stash)),
2083 HEKfARG(GvNAME_HEK(gv)));
463ee0b2 2084 }
79072805
LW
2085 }
2086 }
2087}
2088
2089GV *
9cc50d5b 2090Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
79072805 2091{
97aff369 2092 dVAR;
9cc50d5b 2093 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
7918f24d 2094
9cc50d5b
BF
2095 return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2096 SVfARG(newSVpvn_flags(pack, strlen(pack),
2097 SVs_TEMP | flags)),
2098 (long)PL_gensym++),
2099 GV_ADD, SVt_PVGV);
79072805
LW
2100}
2101
2102/* hopefully this is only called on local symbol table entries */
2103
2104GP*
864dbfa3 2105Perl_gp_ref(pTHX_ GP *gp)
79072805 2106{
97aff369 2107 dVAR;
1d7c1841 2108 if (!gp)
d4c19fe8 2109 return NULL;
79072805 2110 gp->gp_refcnt++;
44a8e56a
PP
2111 if (gp->gp_cv) {
2112 if (gp->gp_cvgen) {
e1a479c5
BB
2113 /* If the GP they asked for a reference to contains
2114 a method cache entry, clear it first, so that we
2115 don't infect them with our cached entry */
44a8e56a 2116 SvREFCNT_dec(gp->gp_cv);
601f1833 2117 gp->gp_cv = NULL;
44a8e56a
PP
2118 gp->gp_cvgen = 0;
2119 }
44a8e56a 2120 }
79072805 2121 return gp;
79072805
LW
2122}
2123
2124void
864dbfa3 2125Perl_gp_free(pTHX_ GV *gv)
79072805 2126{
97aff369 2127 dVAR;
79072805 2128 GP* gp;
b0d55c99 2129 int attempts = 100;
79072805 2130
f7877b28 2131 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
79072805 2132 return;
f248d071 2133 if (gp->gp_refcnt == 0) {
9b387841
NC
2134 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2135 "Attempt to free unreferenced glob pointers"
2136 pTHX__FORMAT pTHX__VALUE);
79072805
LW
2137 return;
2138 }
748a9306
LW
2139 if (--gp->gp_refcnt > 0) {
2140 if (gp->gp_egv == gv)
2141 gp->gp_egv = 0;
c43ae56f 2142 GvGP_set(gv, NULL);
79072805 2143 return;
748a9306 2144 }
79072805 2145
b0d55c99
FC
2146 while (1) {
2147 /* Copy and null out all the glob slots, so destructors do not see
2148 freed SVs. */
2149 HEK * const file_hek = gp->gp_file_hek;
2150 SV * const sv = gp->gp_sv;
2151 AV * const av = gp->gp_av;
2152 HV * const hv = gp->gp_hv;
2153 IO * const io = gp->gp_io;
2154 CV * const cv = gp->gp_cv;
2155 CV * const form = gp->gp_form;
2156
2157 gp->gp_file_hek = NULL;
2158 gp->gp_sv = NULL;
2159 gp->gp_av = NULL;
2160 gp->gp_hv = NULL;
2161 gp->gp_io = NULL;
2162 gp->gp_cv = NULL;
2163 gp->gp_form = NULL;
2164
2165 if (file_hek)
2166 unshare_hek(file_hek);
2167
2168 SvREFCNT_dec(sv);
2169 SvREFCNT_dec(av);
2170 /* FIXME - another reference loop GV -> symtab -> GV ?
2171 Somehow gp->gp_hv can end up pointing at freed garbage. */
2172 if (hv && SvTYPE(hv) == SVt_PVHV) {
c2242065
BF
2173 const HEK *hvname_hek = HvNAME_HEK(hv);
2174 if (PL_stashcache && hvname_hek)
2175 (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2176 (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2177 G_DISCARD);
b0d55c99
FC
2178 SvREFCNT_dec(hv);
2179 }
2180 SvREFCNT_dec(io);
2181 SvREFCNT_dec(cv);
2182 SvREFCNT_dec(form);
2183
2184 if (!gp->gp_file_hek
2185 && !gp->gp_sv
2186 && !gp->gp_av
2187 && !gp->gp_hv
2188 && !gp->gp_io
2189 && !gp->gp_cv
2190 && !gp->gp_form) break;
2191
2192 if (--attempts == 0) {
2193 Perl_die(aTHX_
2194 "panic: gp_free failed to free glob pointer - "
2195 "something is repeatedly re-creating entries"
2196 );
2197 }
13207a71 2198 }
748a9306 2199
79072805 2200 Safefree(gp);
c43ae56f 2201 GvGP_set(gv, NULL);
79072805
LW
2202}
2203
d460ef45
NIS
2204int
2205Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2206{
53c1dcc0
AL
2207 AMT * const amtp = (AMT*)mg->mg_ptr;
2208 PERL_UNUSED_ARG(sv);
dd374669 2209
7918f24d
NC
2210 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2211
d460ef45
NIS
2212 if (amtp && AMT_AMAGIC(amtp)) {
2213 int i;
2214 for (i = 1; i < NofAMmeth; i++) {
53c1dcc0 2215 CV * const cv = amtp->table[i];
b37c2d43 2216 if (cv) {
ad64d0ec 2217 SvREFCNT_dec(MUTABLE_SV(cv));
601f1833 2218 amtp->table[i] = NULL;
d460ef45
NIS
2219 }
2220 }
2221 }
2222 return 0;
2223}
2224
a0d0e21e 2225/* Updates and caches the CV's */
c3a9a790
RGS
2226/* Returns:
2227 * 1 on success and there is some overload
2228 * 0 if there is no overload
2229 * -1 if some error occurred and it couldn't croak
2230 */
a0d0e21e 2231
c3a9a790 2232int
242f8760 2233Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
a0d0e21e 2234{
97aff369 2235 dVAR;
ad64d0ec 2236 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
a6006777 2237 AMT amt;
9b439311 2238 const struct mro_meta* stash_meta = HvMROMETA(stash);
e1a479c5 2239 U32 newgen;
a0d0e21e 2240
7918f24d
NC
2241 PERL_ARGS_ASSERT_GV_AMUPDATE;
2242
9b439311 2243 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
14899595
NC
2244 if (mg) {
2245 const AMT * const amtp = (AMT*)mg->mg_ptr;
2246 if (amtp->was_ok_am == PL_amagic_generation
e1a479c5 2247 && amtp->was_ok_sub == newgen) {
c3a9a790 2248 return AMT_OVERLOADED(amtp) ? 1 : 0;
14899595 2249 }
ad64d0ec 2250 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
14899595 2251 }
a0d0e21e 2252
bfcb3514 2253 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
a0d0e21e 2254
d460ef45 2255 Zero(&amt,1,AMT);
3280af22 2256 amt.was_ok_am = PL_amagic_generation;
e1a479c5 2257 amt.was_ok_sub = newgen;
a6006777
PP
2258 amt.fallback = AMGfallNO;
2259 amt.flags = 0;
2260
a6006777 2261 {
32251b26
IZ
2262 int filled = 0, have_ovl = 0;
2263 int i, lim = 1;
a6006777 2264
50853fa9
FC
2265 /* The first key in PL_AMG_names is the overloadedness indicator, which
2266 allows us to skip overloading entries for non-overloaded classes. */
a6006777 2267
89ffc314 2268 /* Try to find via inheritance. */
e6919483 2269 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
53c1dcc0 2270 CV* cv;
89ffc314
IZ
2271
2272 if (!gv)
32251b26 2273 lim = DESTROY_amg; /* Skip overloading entries. */
50853fa9
FC
2274
2275 else {
2276
2277 /* The "fallback" key is special-cased here, being absent from the
2278 list in PL_AMG_names. */
2279
2280 SV *sv;
2281 gv = gv_fetchmeth_pvn(stash, "(fallback", 9, -1, 0);
2282
2283 if (!gv || !(sv = GvSV(gv)))
6f207bd3 2284 NOOP; /* Equivalent to !SvTRUE and !SvOK */
50853fa9 2285 else if (SvTRUE(sv))
89ffc314 2286 amt.fallback=AMGfallYES;
50853fa9 2287 else if (SvOK(sv))
89ffc314 2288 amt.fallback=AMGfallNEVER;
50853fa9 2289 }
a6006777 2290
32251b26 2291 for (i = 1; i < lim; i++)
601f1833 2292 amt.table[i] = NULL;
32251b26 2293 for (; i < NofAMmeth; i++) {
6136c704 2294 const char * const cooky = PL_AMG_names[i];
32251b26 2295 /* Human-readable form, for debugging: */
6136c704 2296 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
d279ab82 2297 const STRLEN l = PL_AMG_namelens[i];
89ffc314 2298
a0288114 2299 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
bfcb3514 2300 cp, HvNAME_get(stash)) );
611c1e95
IZ
2301 /* don't fill the cache while looking up!
2302 Creation of inheritance stubs in intermediate packages may
2303 conflict with the logic of runtime method substitution.
2304 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2305 then we could have created stubs for "(+0" in A and C too.
2306 But if B overloads "bool", we may want to use it for
2307 numifying instead of C's "+0". */
2308 if (i >= DESTROY_amg)
d21989ed 2309 gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
611c1e95 2310 else /* Autoload taken care of below */
e6919483 2311 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
46fc3d4c 2312 cv = 0;
89ffc314 2313 if (gv && (cv = GvCV(gv))) {
f0e9f182
FC
2314 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2315 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2316 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2317 && strEQ(hvname, "overload")) {
611c1e95
IZ
2318 /* This is a hack to support autoloading..., while
2319 knowing *which* methods were declared as overloaded. */
44a8e56a 2320 /* GvSV contains the name of the method. */
6136c704 2321 GV *ngv = NULL;
c69033f2 2322 SV *gvsv = GvSV(gv);
a0288114
AL
2323
2324 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2325 "\" for overloaded \"%s\" in package \"%.256s\"\n",
f0e9f182 2326 (void*)GvSV(gv), cp, HvNAME(stash)) );
c69033f2 2327 if (!gvsv || !SvPOK(gvsv)
7f415459 2328 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
dc848c6f 2329 {
a0288114 2330 /* Can be an import stub (created by "can"). */
242f8760 2331 if (destructing) {
c3a9a790 2332 return -1;
242f8760
RGS
2333 }
2334 else {
d66cca07
BF
2335 const SV * const name = (gvsv && SvPOK(gvsv))
2336 ? gvsv
2337 : newSVpvs_flags("???", SVs_TEMP);
dcbac5bb 2338 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
d66cca07
BF
2339 Perl_croak(aTHX_ "%s method \"%"SVf256
2340 "\" overloading \"%s\" "\
d0c0e7dd 2341 "in package \"%"HEKf256"\"",
242f8760
RGS
2342 (GvCVGEN(gv) ? "Stub found while resolving"
2343 : "Can't resolve"),
d66cca07 2344 SVfARG(name), cp,
d0c0e7dd 2345 HEKfARG(
d66cca07 2346 HvNAME_HEK(stash)
d0c0e7dd 2347 ));
242f8760 2348 }
44a8e56a 2349 }
dc848c6f 2350 cv = GvCV(gv = ngv);
f0e9f182 2351 }
44a8e56a 2352 }
b464bac0 2353 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
bfcb3514 2354 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
44a8e56a
PP
2355 GvNAME(CvGV(cv))) );
2356 filled = 1;
32251b26
IZ
2357 if (i < DESTROY_amg)
2358 have_ovl = 1;
611c1e95 2359 } else if (gv) { /* Autoloaded... */
ea726b52 2360 cv = MUTABLE_CV(gv);
611c1e95 2361 filled = 1;
44a8e56a 2362 }
ea726b52 2363 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
a0d0e21e 2364 }
a0d0e21e 2365 if (filled) {
a6006777 2366 AMT_AMAGIC_on(&amt);
32251b26
IZ
2367 if (have_ovl)
2368 AMT_OVERLOADED_on(&amt);
ad64d0ec 2369 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 2370 (char*)&amt, sizeof(AMT));
32251b26 2371 return have_ovl;
a0d0e21e
LW
2372 }
2373 }
a6006777 2374 /* Here we have no table: */
9cbac4c7 2375 /* no_table: */
a6006777 2376 AMT_AMAGIC_off(&amt);
ad64d0ec 2377 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 2378 (char*)&amt, sizeof(AMTS));
c3a9a790 2379 return 0;
a0d0e21e
LW
2380}
2381
32251b26
IZ
2382
2383CV*
2384Perl_gv_handler(pTHX_ HV *stash, I32 id)
2385{
97aff369 2386 dVAR;
3f8f4626 2387 MAGIC *mg;
32251b26 2388 AMT *amtp;
e1a479c5 2389 U32 newgen;
9b439311 2390 struct mro_meta* stash_meta;
32251b26 2391
bfcb3514 2392 if (!stash || !HvNAME_get(stash))
601f1833 2393 return NULL;
e1a479c5 2394
9b439311
BB
2395 stash_meta = HvMROMETA(stash);
2396 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
e1a479c5 2397
ad64d0ec 2398 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26
IZ
2399 if (!mg) {
2400 do_update:
242f8760
RGS
2401 /* If we're looking up a destructor to invoke, we must avoid
2402 * that Gv_AMupdate croaks, because we might be dying already */
2dcac756 2403 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
242f8760
RGS
2404 /* and if it didn't found a destructor, we fall back
2405 * to a simpler method that will only look for the
2406 * destructor instead of the whole magic */
2407 if (id == DESTROY_amg) {
2408 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2409 if (gv)
2410 return GvCV(gv);
2411 }
2412 return NULL;
2413 }
ad64d0ec 2414 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26 2415 }
a9fd4e40 2416 assert(mg);
32251b26
IZ
2417 amtp = (AMT*)mg->mg_ptr;
2418 if ( amtp->was_ok_am != PL_amagic_generation
e1a479c5 2419 || amtp->was_ok_sub != newgen )
32251b26 2420 goto do_update;
3ad83ce7 2421 if (AMT_AMAGIC(amtp)) {
b7787f18 2422 CV * const ret = amtp->table[id];
3ad83ce7
AMS
2423 if (ret && isGV(ret)) { /* Autoloading stab */
2424 /* Passing it through may have resulted in a warning
2425 "Inherited AUTOLOAD for a non-method deprecated", since
2426 our caller is going through a function call, not a method call.
2427 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
890ce7af 2428 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS
2429
2430 if (gv && GvCV(gv))
2431 return GvCV(gv);
2432 }
2433 return ret;
2434 }
a0288114 2435
601f1833 2436 return NULL;
32251b26
IZ
2437}
2438
2439
6f1401dc
DM
2440/* Implement tryAMAGICun_MG macro.
2441 Do get magic, then see if the stack arg is overloaded and if so call it.
2442 Flags:
2443 AMGf_set return the arg using SETs rather than assigning to
2444 the targ
2445 AMGf_numeric apply sv_2num to the stack arg.
2446*/
2447
2448bool
2449Perl_try_amagic_un(pTHX_ int method, int flags) {
2450 dVAR;
2451 dSP;
2452 SV* tmpsv;
2453 SV* const arg = TOPs;
2454
2455 SvGETMAGIC(arg);
2456
9f8bf298
NC
2457 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2458 AMGf_noright | AMGf_unary))) {
6f1401dc
DM
2459 if (flags & AMGf_set) {
2460 SETs(tmpsv);
2461 }
2462 else {
2463 dTARGET;
2464 if (SvPADMY(TARG)) {
2465 sv_setsv(TARG, tmpsv);
2466 SETTARG;
2467 }
2468 else
2469 SETs(tmpsv);
2470 }
2471 PUTBACK;
2472 return TRUE;
2473 }
2474
2475 if ((flags & AMGf_numeric) && SvROK(arg))
2476 *sp = sv_2num(arg);
2477 return FALSE;
2478}
2479
2480
2481/* Implement tryAMAGICbin_MG macro.
2482 Do get magic, then see if the two stack args are overloaded and if so
2483 call it.
2484 Flags:
2485 AMGf_set return the arg using SETs rather than assigning to
2486 the targ
2487 AMGf_assign op may be called as mutator (eg +=)
2488 AMGf_numeric apply sv_2num to the stack arg.
2489*/
2490
2491bool
2492Perl_try_amagic_bin(pTHX_ int method, int flags) {
2493 dVAR;
2494 dSP;
2495 SV* const left = TOPm1s;
2496 SV* const right = TOPs;
2497
2498 SvGETMAGIC(left);
2499 if (left != right)
2500 SvGETMAGIC(right);
2501
2502 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2503 SV * const tmpsv = amagic_call(left, right, method,
2504 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2505 if (tmpsv) {
2506 if (flags & AMGf_set) {
2507 (void)POPs;
2508 SETs(tmpsv);
2509 }
2510 else {
2511 dATARGET;
2512 (void)POPs;
2513 if (opASSIGN || SvPADMY(TARG)) {
2514 sv_setsv(TARG, tmpsv);
2515 SETTARG;
2516 }
2517 else
2518 SETs(tmpsv);
2519 }
2520 PUTBACK;
2521 return TRUE;
2522 }
2523 }
75ea7a12
FC
2524 if(left==right && SvGMAGICAL(left)) {
2525 SV * const left = sv_newmortal();
2526 *(sp-1) = left;
2527 /* Print the uninitialized warning now, so it includes the vari-
2528 able name. */
2529 if (!SvOK(right)) {
2530 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2531 sv_setsv_flags(left, &PL_sv_no, 0);
2532 }
2533 else sv_setsv_flags(left, right, 0);
2534 SvGETMAGIC(right);
2535 }
6f1401dc 2536 if (flags & AMGf_numeric) {
75ea7a12
FC
2537 if (SvROK(TOPm1s))
2538 *(sp-1) = sv_2num(TOPm1s);
6f1401dc
DM
2539 if (SvROK(right))
2540 *sp = sv_2num(right);
2541 }
2542 return FALSE;
2543}
2544
25a9ffce
NC
2545SV *
2546Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2547 SV *tmpsv = NULL;
2548
2549 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2550
2551 while (SvAMAGIC(ref) &&
2552 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2553 AMGf_noright | AMGf_unary))) {
2554 if (!SvROK(tmpsv))
2555 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2556 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2557 /* Bail out if it returns us the same reference. */
2558 return tmpsv;
2559 }
2560 ref = tmpsv;
2561 }
2562 return tmpsv ? tmpsv : ref;
2563}
6f1401dc 2564
8d569291
FC
2565bool
2566Perl_amagic_is_enabled(pTHX_ int method)
2567{
2568 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2569
2570 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2571
2572 if ( !lex_mask || !SvOK(lex_mask) )
2573 /* overloading lexically disabled */
2574 return FALSE;
2575 else if ( lex_mask && SvPOK(lex_mask) ) {
2576 /* we have an entry in the hints hash, check if method has been
2577 * masked by overloading.pm */
2578 STRLEN len;
2579 const int offset = method / 8;
2580 const int bit = method % 8;
2581 char *pv = SvPV(lex_mask, len);
2582
2583 /* Bit set, so this overloading operator is disabled */
2584 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2585 return FALSE;
2586 }
2587 return TRUE;
2588}
2589
a0d0e21e 2590SV*
864dbfa3 2591Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 2592{
27da23d5 2593 dVAR;
b267980d 2594 MAGIC *mg;
9c5ffd7c 2595 CV *cv=NULL;
a0d0e21e 2596 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 2597 AMT *amtp=NULL, *oamtp=NULL;
b464bac0
AL
2598 int off = 0, off1, lr = 0, notfound = 0;
2599 int postpr = 0, force_cpy = 0;
2600 int assign = AMGf_assign & flags;
2601 const int assignshift = assign ? 1 : 0;
bf5522a1 2602 int use_default_op = 0;
497b47a8
JH
2603#ifdef DEBUGGING
2604 int fl=0;
497b47a8 2605#endif
25716404 2606 HV* stash=NULL;
7918f24d
NC
2607
2608 PERL_ARGS_ASSERT_AMAGIC_CALL;
2609
e46c382e 2610 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
8d569291 2611 if (!amagic_is_enabled(method)) return NULL;
e46c382e
YK
2612 }
2613
a0d0e21e 2614 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
0a2c84ab 2615 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
ad64d0ec 2616 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2617 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2618 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2619 : NULL))
b267980d 2620 && ((cv = cvp[off=method+assignshift])
748a9306
LW
2621 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2622 * usual method */
497b47a8
JH
2623 (
2624#ifdef DEBUGGING
2625 fl = 1,
a0288114 2626#endif
497b47a8 2627 cv = cvp[off=method])))) {
a0d0e21e
LW
2628 lr = -1; /* Call method for left argument */
2629 } else {
2630 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2631 int logic;
2632
2633 /* look for substituted methods */
ee239bfe 2634 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
2635 switch (method) {
2636 case inc_amg:
ee239bfe
IZ
2637 force_cpy = 1;
2638 if ((cv = cvp[off=add_ass_amg])
2639 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 2640 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
2641 }
2642 break;
2643 case dec_amg:
ee239bfe
IZ
2644 force_cpy = 1;
2645 if ((cv = cvp[off = subtr_ass_amg])
2646 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 2647 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
2648 }
2649 break;
2650 case bool__amg:
2651 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2652 break;
2653 case numer_amg:
2654 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2655 break;
2656 case string_amg:
2657 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2658 break;
b7787f18
AL
2659 case not_amg:
2660 (void)((cv = cvp[off=bool__amg])
2661 || (cv = cvp[off=numer_amg])
2662 || (cv = cvp[off=string_amg]));
2ab54efd
MB
2663 if (cv)
2664 postpr = 1;
b7787f18 2665 break;
748a9306
LW
2666 case copy_amg:
2667 {
76e3520e
GS
2668 /*
2669 * SV* ref causes confusion with the interpreter variable of
2670 * the same name
2671 */
890ce7af 2672 SV* const tmpRef=SvRV(left);
76e3520e 2673 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
2674 /*
2675 * Just to be extra cautious. Maybe in some
2676 * additional cases sv_setsv is safe, too.
2677 */
890ce7af 2678 SV* const newref = newSVsv(tmpRef);
748a9306 2679 SvOBJECT_on(newref);
a1cd65be
FC
2680 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2681 delegate to the stash. */
85fbaab2 2682 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
748a9306
LW
2683 return newref;
2684 }
2685 }
2686 break;
a0d0e21e 2687 case abs_amg:
b267980d 2688 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 2689 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
890ce7af 2690 SV* const nullsv=sv_2mortal(newSViv(0));
a0d0e21e 2691 if (off1==lt_amg) {
890ce7af 2692 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
2693 lt_amg,AMGf_noright);
2694 logic = SvTRUE(lessp);
2695 } else {
890ce7af 2696 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
2697 ncmp_amg,AMGf_noright);
2698 logic = (SvNV(lessp) < 0);
2699 }
2700 if (logic) {
2701 if (off==subtr_amg) {
2702 right = left;
748a9306 2703 left = nullsv;
a0d0e21e
LW
2704 lr = 1;
2705 }
2706 } else {
2707 return left;
2708 }
2709 }
2710 break;
2711 case neg_amg:
155aba94 2712 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
2713 right = left;
2714 left = sv_2mortal(newSViv(0));
2715 lr = 1;
2716 }
2717 break;
f216259d 2718 case int_amg:
f5284f61 2719 case iter_amg: /* XXXX Eventually should do to_gv. */
c4c7412c 2720 case ftest_amg: /* XXXX Eventually should do to_gv. */
d4b87e75 2721 case regexp_amg:
b267980d
NIS
2722 /* FAIL safe */
2723 return NULL; /* Delegate operation to standard mechanisms. */
2724 break;
f5284f61
IZ
2725 case to_sv_amg:
2726 case to_av_amg:
2727 case to_hv_amg:
2728 case to_gv_amg:
2729 case to_cv_amg:
2730 /* FAIL safe */
b267980d 2731 return left; /* Delegate operation to standard mechanisms. */
f5284f61 2732 break;
a0d0e21e
LW
2733 default:
2734 goto not_found;
2735 }
2736 if (!cv) goto not_found;
2737 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
0a2c84ab 2738 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
ad64d0ec 2739 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2740 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2741 ? (amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2742 : NULL))
f041cf0f
RGS
2743 && ((cv = cvp[off=method+assignshift])
2744 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2745 * usual method */
2746 (
2747#ifdef DEBUGGING
2748 fl = 1,
2749#endif
2750 cv = cvp[off=method])))) { /* Method for right
2751 * argument found */
2752 lr=1;
bf5522a1
MB
2753 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2754 || (ocvp && oamtp->fallback > AMGfallNEVER))
a0d0e21e
LW
2755 && !(flags & AMGf_unary)) {
2756 /* We look for substitution for
2757 * comparison operations and
fc36a67e 2758 * concatenation */
a0d0e21e
LW
2759 if (method==concat_amg || method==concat_ass_amg
2760 || method==repeat_amg || method==repeat_ass_amg) {
2761 return NULL; /* Delegate operation to string conversion */
2762 }
2763 off = -1;
2764 switch (method) {
2765 case lt_amg:
2766 case le_amg:
2767 case gt_amg:
2768 case ge_amg:
2769 case eq_amg:
2770 case ne_amg:
2ab54efd
MB
2771 off = ncmp_amg;
2772 break;
a0d0e21e
LW
2773 case slt_amg:
2774 case sle_amg:
2775 case sgt_amg:
2776 case sge_amg:
2777 case seq_amg:
2778 case sne_amg:
2ab54efd
MB
2779 off = scmp_amg;
2780 break;
a0d0e21e 2781 }
bf5522a1
MB
2782 if (off != -1) {
2783 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2784 cv = ocvp[off];
2785 lr = -1;
2786 }
2787 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2788 cv = cvp[off];
2789 lr = 1;
2790 }
2791 }
2792 if (cv)
2ab54efd
MB
2793 postpr = 1;
2794 else
2795 goto not_found;
a0d0e21e 2796 } else {
a6006777 2797 not_found: /* No method found, either report or croak */
b267980d
NIS
2798 switch (method) {
2799 case to_sv_amg:
2800 case to_av_amg:
2801 case to_hv_amg:
2802 case to_gv_amg:
2803 case to_cv_amg:
2804 /* FAIL safe */
2805 return left; /* Delegate operation to standard mechanisms. */
2806 break;
2807 }
a0d0e21e
LW
2808 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2809 notfound = 1; lr = -1;
2810 } else if (cvp && (cv=cvp[nomethod_amg])) {
2811 notfound = 1; lr = 1;
bf5522a1
MB
2812 } else if ((use_default_op =
2813 (!ocvp || oamtp->fallback >= AMGfallYES)
2814 && (!cvp || amtp->fallback >= AMGfallYES))
2815 && !DEBUG_o_TEST) {
4cc0ca18
NC
2816 /* Skip generating the "no method found" message. */
2817 return NULL;
a0d0e21e 2818 } else {
46fc3d4c 2819 SV *msg;
774d564b 2820 if (off==-1) off=method;
b267980d 2821 msg = sv_2mortal(Perl_newSVpvf(aTHX_
d66cca07
BF
2822 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2823 AMG_id2name(method + assignshift),
2824 (flags & AMGf_unary ? " " : "\n\tleft "),
2825 SvAMAGIC(left)?
2826 "in overloaded package ":
2827 "has no overloaded magic",
2828 SvAMAGIC(left)?
2829 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2830 SVfARG(&PL_sv_no),
2831 SvAMAGIC(right)?
2832 ",\n\tright argument in overloaded package ":
2833 (flags & AMGf_unary
2834 ? ""
2835 : ",\n\tright argument has no overloaded magic"),
2836 SvAMAGIC(right)?
2837 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2838 SVfARG(&PL_sv_no)));
bf5522a1 2839 if (use_default_op) {
d66cca07 2840 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
a0d0e21e 2841 } else {
be2597df 2842 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
a0d0e21e
LW
2843 }
2844 return NULL;
2845 }
ee239bfe 2846 force_cpy = force_cpy || assign;
a0d0e21e
LW
2847 }
2848 }
497b47a8 2849#ifdef DEBUGGING
a0d0e21e 2850 if (!notfound) {
497b47a8 2851 DEBUG_o(Perl_deb(aTHX_
d66cca07 2852 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
497b47a8
JH
2853 AMG_id2name(off),
2854 method+assignshift==off? "" :
a0288114 2855 " (initially \"",
497b47a8
JH
2856 method+assignshift==off? "" :
2857 AMG_id2name(method+assignshift),
a0288114 2858 method+assignshift==off? "" : "\")",
497b47a8
JH
2859 flags & AMGf_unary? "" :
2860 lr==1 ? " for right argument": " for left argument",
2861 flags & AMGf_unary? " for argument" : "",
d66cca07 2862 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
497b47a8 2863 fl? ",\n\tassignment variant used": "") );
ee239bfe 2864 }
497b47a8 2865#endif
748a9306
LW
2866 /* Since we use shallow copy during assignment, we need
2867 * to dublicate the contents, probably calling user-supplied
2868 * version of copy operator
2869 */
ee239bfe
IZ
2870 /* We need to copy in following cases:
2871 * a) Assignment form was called.
2872 * assignshift==1, assign==T, method + 1 == off
2873 * b) Increment or decrement, called directly.
2874 * assignshift==0, assign==0, method + 0 == off
2875 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 2876 * assignshift==0, assign==T,
ee239bfe
IZ
2877 * force_cpy == T
2878 * d) Increment or decrement, translated to nomethod.
b267980d 2879 * assignshift==0, assign==0,
ee239bfe
IZ
2880 * force_cpy == T
2881 * e) Assignment form translated to nomethod.
2882 * assignshift==1, assign==T, method + 1 != off
2883 * force_cpy == T
2884 */
2885 /* off is method, method+assignshift, or a result of opcode substitution.
2886 * In the latter case assignshift==0, so only notfound case is important.
2887 */
73512201 2888 if ( (lr == -1) && ( ( (method + assignshift == off)
ee239bfe 2889 && (assign || (method == inc_amg) || (method == dec_amg)))
73512201 2890 || force_cpy) )
6f1401dc 2891 {
1b38c28e
NC
2892 /* newSVsv does not behave as advertised, so we copy missing
2893 * information by hand */
2894 SV *tmpRef = SvRV(left);
2895 SV *rv_copy;
31d632c3 2896 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
1b38c28e
NC
2897 SvRV_set(left, rv_copy);
2898 SvSETMAGIC(left);
2899 SvREFCNT_dec(tmpRef);
2900 }
6f1401dc
DM
2901 }
2902
a0d0e21e
LW
2903 {
2904 dSP;
2905 BINOP myop;
2906 SV* res;
b7787f18 2907 const bool oldcatch = CATCH_GET;
a0d0e21e 2908
54310121 2909 CATCH_SET(TRUE);
a0d0e21e
LW
2910 Zero(&myop, 1, BINOP);
2911 myop.op_last = (OP *) &myop;
b37c2d43 2912 myop.op_next = NULL;
54310121 2913 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 2914
e788e7d3 2915 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 2916 ENTER;
462e5cf6 2917 SAVEOP();
533c011a 2918 PL_op = (OP *) &myop;
3280af22 2919 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 2920 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2921 PUTBACK;
897d3989 2922 Perl_pp_pushmark(aTHX);
a0d0e21e 2923
924508f0 2924 EXTEND(SP, notfound + 5);
a0d0e21e
LW
2925 PUSHs(lr>0? right: left);
2926 PUSHs(lr>0? left: right);
3280af22 2927 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 2928 if (notfound) {
59cd0e26
NC
2929 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2930 AMG_id2namelen(method + assignshift), SVs_TEMP));
a0d0e21e 2931 }
ad64d0ec 2932 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW
2933 PUTBACK;
2934
139d0ce6 2935 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
cea2e8a9 2936 CALLRUNOPS(aTHX);
a0d0e21e
LW
2937 LEAVE;
2938 SPAGAIN;
2939
2940 res=POPs;
ebafeae7 2941 PUTBACK;
d3acc0f7 2942 POPSTACK;
54310121 2943 CATCH_SET(oldcatch);
a0d0e21e 2944
a0d0e21e 2945 if (postpr) {
b7787f18 2946 int ans;
a0d0e21e
LW
2947 switch (method) {
2948 case le_amg:
2949 case sle_amg:
2950 ans=SvIV(res)<=0; break;
2951 case lt_amg:
2952 case slt_amg:
2953 ans=SvIV(res)<0; break;
2954 case ge_amg:
2955 case sge_amg:
2956 ans=SvIV(res)>=0; break;
2957 case gt_amg:
2958 case sgt_amg:
2959 ans=SvIV(res)>0; break;
2960 case eq_amg:
2961 case seq_amg:
2962 ans=SvIV(res)==0; break;
2963 case ne_amg:
2964 case sne_amg:
2965 ans=SvIV(res)!=0; break;
2966 case inc_amg:
2967 case dec_amg:
bbce6d69 2968 SvSetSV(left,res); return left;
dc437b57 2969 case not_amg:
fe7ac86a 2970 ans=!SvTRUE(res); break;
b7787f18
AL
2971 default:
2972 ans=0; break;
a0d0e21e 2973 }
54310121 2974 return boolSV(ans);
748a9306
LW
2975 } else if (method==copy_amg) {
2976 if (!SvROK(res)) {
cea2e8a9 2977 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
2978 }
2979 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
2980 } else {
2981 return res;
2982 }
2983 }
2984}
c9d5ac95 2985
f5c1e807
NC
2986void
2987Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2988{
2989 dVAR;
acda4c6a 2990 U32 hash;
f5c1e807 2991
7918f24d 2992 PERL_ARGS_ASSERT_GV_NAME_SET;
f5c1e807 2993
acda4c6a
NC
2994 if (len > I32_MAX)
2995 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2996
ae8cc45f
NC
2997 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2998 unshare_hek(GvNAME_HEK(gv));
2999 }
3000
acda4c6a 3001 PERL_HASH(hash, name, len);
c60dbbc3 3002 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
f5c1e807
NC
3003}
3004
66610fdd 3005/*
f7461760
Z
3006=for apidoc gv_try_downgrade
3007
2867cdbc
Z
3008If the typeglob C<gv> can be expressed more succinctly, by having
3009something other than a real GV in its place in the stash, replace it
3010with the optimised form. Basic requirements for this are that C<gv>
3011is a real typeglob, is sufficiently ordinary, and is only referenced
3012from its package. This function is meant to be used when a GV has been
3013looked up in part to see what was there, causing upgrading, but based
3014on what was found it turns out that the real GV isn't required after all.
3015
3016If C<gv> is a completely empty typeglob, it is deleted from the stash.
3017
3018If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3019sub, the typeglob is replaced with a scalar-reference placeholder that
3020more compactly represents the same thing.
f7461760
Z
3021
3022=cut
3023*/
3024
3025void
3026Perl_gv_try_downgrade(pTHX_ GV *gv)
3027{
3028 HV *stash;
3029 CV *cv;
3030 HEK *namehek;
3031 SV **gvp;
3032 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
95f56751
FC
3033
3034 /* XXX Why and where does this leave dangling pointers during global
3035 destruction? */
627364f1 3036 if (PL_phase == PERL_PHASE_DESTRUCT) return;
95f56751 3037
2867cdbc 3038 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
803f2748 3039 !SvOBJECT(gv) && !SvREADONLY(gv) &&
f7461760 3040 isGV_with_GP(gv) && GvGP(gv) &&
2867cdbc 3041 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
f7461760 3042 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
099be4f1 3043 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2867cdbc 3044 return;
803f2748
DM
3045 if (SvMAGICAL(gv)) {
3046 MAGIC *mg;
3047 /* only backref magic is allowed */
3048 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3049 return;
3050 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3051 if (mg->mg_type != PERL_MAGIC_backref)
3052 return;
3053 }
3054 }
2867cdbc
Z
3055 cv = GvCV(gv);
3056 if (!cv) {
3057 HEK *gvnhek = GvNAME_HEK(gv);
3058 (void)hv_delete(stash, HEK_KEY(gvnhek),
3059 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3060 } else if (GvMULTI(gv) && cv &&
f7461760
Z
3061 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3062 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3063 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3064 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3065 (namehek = GvNAME_HEK(gv)) &&
3066 (gvp = hv_fetch(stash, HEK_KEY(namehek),
3067 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3068 *gvp == (SV*)gv) {
3069 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3070 SvREFCNT(gv) = 0;
3071 sv_clear((SV*)gv);
3072 SvREFCNT(gv) = 1;
3073 SvFLAGS(gv) = SVt_IV|SVf_ROK;
3074 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3075 STRUCT_OFFSET(XPVIV, xiv_iv));
3076 SvRV_set(gv, value);
3077 }
3078}
3079
4aaa4757
FC
3080#include "XSUB.h"
3081
3082static void
3083core_xsub(pTHX_ CV* cv)
3084{
3085 Perl_croak(aTHX_
3086 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3087 );
3088}
3089
f7461760 3090/*
66610fdd
RGS
3091 * Local variables:
3092 * c-indentation-style: bsd
3093 * c-basic-offset: 4
3094 * indent-tabs-mode: t
3095 * End:
3096 *
37442d52
RGS
3097 * ex: set ts=8 sts=4 sw=4 noet:
3098 */