This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Proper use of enums
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
acde74e1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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
13 * of your inquisitiveness, I shall spend all the rest of my days answering
14 * you. What more do you want to know?'
15 * 'The names of all the stars, and of all living things, and the whole
16 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
17 * laughed Pippin.
79072805
LW
18 */
19
ccfc67b7
JH
20/*
21=head1 GV Functions
166f8a29
DM
22
23A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
24It is a structure that holds a pointer to a scalar, an array, a hash etc,
25corresponding to $foo, @foo, %foo.
26
27GVs are usually found as values in stashes (symbol table hashes) where
28Perl stores its global variables.
29
30=cut
ccfc67b7
JH
31*/
32
79072805 33#include "EXTERN.h"
864dbfa3 34#define PERL_IN_GV_C
79072805
LW
35#include "perl.h"
36
f54cb97a
AL
37static const char S_autoload[] = "AUTOLOAD";
38static const STRLEN S_autolen = sizeof(S_autoload)-1;
5c7983e5 39
c69033f2
NC
40
41#ifdef PERL_DONT_CREATE_GVSV
42GV *
43Perl_gv_SVadd(pTHX_ GV *gv)
44{
45 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
46 Perl_croak(aTHX_ "Bad symbol for scalar");
47 if (!GvSV(gv))
561b68a9 48 GvSV(gv) = newSV(0);
c69033f2
NC
49 return gv;
50}
51#endif
52
79072805 53GV *
864dbfa3 54Perl_gv_AVadd(pTHX_ register GV *gv)
79072805 55{
a0d0e21e 56 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 57 Perl_croak(aTHX_ "Bad symbol for array");
79072805
LW
58 if (!GvAV(gv))
59 GvAV(gv) = newAV();
60 return gv;
61}
62
63GV *
864dbfa3 64Perl_gv_HVadd(pTHX_ register GV *gv)
79072805 65{
a0d0e21e 66 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 67 Perl_croak(aTHX_ "Bad symbol for hash");
79072805 68 if (!GvHV(gv))
463ee0b2 69 GvHV(gv) = newHV();
79072805
LW
70 return gv;
71}
72
73GV *
864dbfa3 74Perl_gv_IOadd(pTHX_ register GV *gv)
a0d0e21e 75{
97aff369 76 dVAR;
8b5be85c
SP
77 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
78
79 /*
80 * if it walks like a dirhandle, then let's assume that
81 * this is a dirhandle.
82 */
b37c2d43
AL
83 const char * const fh =
84 PL_op->op_type == OP_READDIR ||
8b5be85c
SP
85 PL_op->op_type == OP_TELLDIR ||
86 PL_op->op_type == OP_SEEKDIR ||
87 PL_op->op_type == OP_REWINDDIR ||
88 PL_op->op_type == OP_CLOSEDIR ?
89 "dirhandle" : "filehandle";
90 Perl_croak(aTHX_ "Bad symbol for %s", fh);
91 }
92
5bd07a3d 93 if (!GvIOp(gv)) {
7fb37951
AMS
94#ifdef GV_UNIQUE_CHECK
95 if (GvUNIQUE(gv)) {
96 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
5bd07a3d
DM
97 }
98#endif
a0d0e21e 99 GvIOp(gv) = newIO();
5bd07a3d 100 }
a0d0e21e
LW
101 return gv;
102}
103
104GV *
864dbfa3 105Perl_gv_fetchfile(pTHX_ const char *name)
79072805 106{
97aff369 107 dVAR;
eacec437 108 char smallbuf[256];
53d95988 109 char *tmpbuf;
8ebc5c01 110 STRLEN tmplen;
79072805
LW
111 GV *gv;
112
1d7c1841 113 if (!PL_defstash)
a0714e2c 114 return NULL;
1d7c1841 115
53d95988
CS
116 tmplen = strlen(name) + 2;
117 if (tmplen < sizeof smallbuf)
118 tmpbuf = smallbuf;
119 else
a02a5408 120 Newx(tmpbuf, tmplen + 1, char);
0ac0412a 121 /* This is where the debugger's %{"::_<$filename"} hash is created */
53d95988
CS
122 tmpbuf[0] = '_';
123 tmpbuf[1] = '<';
490a0e98 124 memcpy(tmpbuf + 2, name, tmplen - 1);
3280af22 125 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
1d7c1841 126 if (!isGV(gv)) {
3280af22 127 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
c69033f2
NC
128#ifdef PERL_DONT_CREATE_GVSV
129 GvSV(gv) = newSVpvn(name, tmplen - 2);
130#else
131 sv_setpvn(GvSV(gv), name, tmplen - 2);
132#endif
1d7c1841 133 if (PERLDB_LINE)
a0714e2c 134 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
1d7c1841 135 }
53d95988
CS
136 if (tmpbuf != smallbuf)
137 Safefree(tmpbuf);
79072805
LW
138 return gv;
139}
140
62d55b22
NC
141/*
142=for apidoc gv_const_sv
143
144If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
145inlining, or C<gv> is a placeholder reference that would be promoted to such
146a typeglob, then returns the value returned by the sub. Otherwise, returns
147NULL.
148
149=cut
150*/
151
152SV *
153Perl_gv_const_sv(pTHX_ GV *gv)
154{
155 if (SvTYPE(gv) == SVt_PVGV)
156 return cv_const_sv(GvCVu(gv));
157 return SvROK(gv) ? SvRV(gv) : NULL;
158}
159
12816592
NC
160GP *
161Perl_newGP(pTHX_ GV *const gv)
162{
163 GP *gp;
f4890806
NC
164 const char *const file = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
165 STRLEN len = strlen(file);
166 U32 hash;
167
168 PERL_HASH(hash, file, len);
169
12816592
NC
170 Newxz(gp, 1, GP);
171
172#ifndef PERL_DONT_CREATE_GVSV
173 gp->gv_sv = newSV(0);
174#endif
175
176 gp->gp_line = CopLINE(PL_curcop);
177 /* XXX Ideally this cast would be replaced with a change to const char*
178 in the struct. */
f4890806 179 gp->gp_file_hek = share_hek(file, len, hash);
12816592
NC
180 gp->gp_egv = gv;
181 gp->gp_refcnt = 1;
182
183 return gp;
184}
185
463ee0b2 186void
864dbfa3 187Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
463ee0b2 188{
27da23d5 189 dVAR;
3b6733bf
NC
190 const U32 old_type = SvTYPE(gv);
191 const bool doproto = old_type > SVt_NULL;
b15aece3 192 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
756cb477
NC
193 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
194
195 assert (!(proto && has_constant));
196
197 if (has_constant) {
5c1f4d79
NC
198 /* The constant has to be a simple scalar type. */
199 switch (SvTYPE(has_constant)) {
200 case SVt_PVAV:
201 case SVt_PVHV:
202 case SVt_PVCV:
203 case SVt_PVFM:
204 case SVt_PVIO:
205 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
206 sv_reftype(has_constant, 0));
42d0e0b7 207 default: NOOP;
5c1f4d79 208 }
756cb477
NC
209 SvRV_set(gv, NULL);
210 SvROK_off(gv);
211 }
463ee0b2 212
3b6733bf
NC
213
214 if (old_type < SVt_PVGV) {
215 if (old_type >= SVt_PV)
216 SvCUR_set(gv, 0);
217 sv_upgrade((SV*)gv, SVt_PVGV);
218 }
55d729e4
GS
219 if (SvLEN(gv)) {
220 if (proto) {
f880fe2f 221 SvPV_set(gv, NULL);
b162af07 222 SvLEN_set(gv, 0);
55d729e4
GS
223 SvPOK_off(gv);
224 } else
94010e71 225 Safefree(SvPVX_mutable(gv));
55d729e4 226 }
f7877b28 227 SvSCREAM_on(gv);
12816592
NC
228
229 GvGP(gv) = Perl_newGP(aTHX_ gv);
e15faf7d
NC
230 GvSTASH(gv) = stash;
231 if (stash)
232 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
ae8cc45f 233 gv_name_set(gv, name, len, GV_ADD);
23ad5bf5 234 if (multi || doproto) /* doproto means it _was_ mentioned */
a5f75d66 235 GvMULTI_on(gv);
55d729e4 236 if (doproto) { /* Replicate part of newSUB here. */
57ff9a15 237 SvIOK_off(gv);
55d729e4 238 ENTER;
756cb477
NC
239 if (has_constant) {
240 /* newCONSTSUB takes ownership of the reference from us. */
241 GvCV(gv) = newCONSTSUB(stash, name, has_constant);
242 } else {
243 /* XXX unsafe for threads if eval_owner isn't held */
244 (void) start_subparse(0,0); /* Create empty CV in compcv. */
245 GvCV(gv) = PL_compcv;
246 }
55d729e4
GS
247 LEAVE;
248
3280af22 249 PL_sub_generation++;
65c50114 250 CvGV(GvCV(gv)) = gv;
e0d088d0 251 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
3280af22 252 CvSTASH(GvCV(gv)) = PL_curstash;
55d729e4
GS
253 if (proto) {
254 sv_setpv((SV*)GvCV(gv), proto);
255 Safefree(proto);
256 }
257 }
463ee0b2
LW
258}
259
76e3520e 260STATIC void
cea2e8a9 261S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
a0d0e21e
LW
262{
263 switch (sv_type) {
264 case SVt_PVIO:
265 (void)GvIOn(gv);
266 break;
267 case SVt_PVAV:
268 (void)GvAVn(gv);
269 break;
270 case SVt_PVHV:
271 (void)GvHVn(gv);
272 break;
c69033f2
NC
273#ifdef PERL_DONT_CREATE_GVSV
274 case SVt_NULL:
275 case SVt_PVCV:
276 case SVt_PVFM:
e654831b 277 case SVt_PVGV:
c69033f2
NC
278 break;
279 default:
280 (void)GvSVn(gv);
281#endif
a0d0e21e
LW
282 }
283}
284
954c1994
GS
285/*
286=for apidoc gv_fetchmeth
287
288Returns the glob with the given C<name> and a defined subroutine or
289C<NULL>. The glob lives in the given C<stash>, or in the stashes
07766739 290accessible via @ISA and UNIVERSAL::.
954c1994
GS
291
292The argument C<level> should be either 0 or -1. If C<level==0>, as a
293side-effect creates a glob with the given C<name> in the given C<stash>
294which in the case of success contains an alias for the subroutine, and sets
b267980d 295up caching info for this glob. Similarly for all the searched stashes.
954c1994
GS
296
297This function grants C<"SUPER"> token as a postfix of the stash name. The
298GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
4929bf7b 299visible to Perl code. So when calling C<call_sv>, you should not use
954c1994 300the GV directly; instead, you should use the method's CV, which can be
b267980d 301obtained from the GV with the C<GvCV> macro.
954c1994
GS
302
303=cut
304*/
305
79072805 306GV *
864dbfa3 307Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
79072805 308{
97aff369 309 dVAR;
79072805 310 AV* av;
463ee0b2 311 GV* topgv;
79072805 312 GV* gv;
463ee0b2 313 GV** gvp;
748a9306 314 CV* cv;
bfcb3514 315 const char *hvname;
a0d0e21e 316
af09ea45
IK
317 /* UNIVERSAL methods should be callable without a stash */
318 if (!stash) {
319 level = -1; /* probably appropriate */
89529cee 320 if(!(stash = gv_stashpvs("UNIVERSAL", FALSE)))
af09ea45
IK
321 return 0;
322 }
323
bfcb3514
NC
324 hvname = HvNAME_get(stash);
325 if (!hvname)
e27ad1f2
AV
326 Perl_croak(aTHX_
327 "Can't use anonymous symbol table for method lookup");
328
44a8e56a 329 if ((level > 100) || (level < -100))
cea2e8a9 330 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
bfcb3514 331 name, hvname);
463ee0b2 332
bfcb3514 333 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
44a8e56a
PP
334
335 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
336 if (!gvp)
a0714e2c 337 topgv = NULL;
44a8e56a
PP
338 else {
339 topgv = *gvp;
340 if (SvTYPE(topgv) != SVt_PVGV)
341 gv_init(topgv, stash, name, len, TRUE);
155aba94 342 if ((cv = GvCV(topgv))) {
44a8e56a 343 /* If genuine method or valid cache entry, use it */
3280af22 344 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
7a4c00b4 345 return topgv;
44a8e56a
PP
346 /* Stale cached entry: junk it */
347 SvREFCNT_dec(cv);
601f1833 348 GvCV(topgv) = cv = NULL;
44a8e56a 349 GvCVGEN(topgv) = 0;
748a9306 350 }
3280af22 351 else if (GvCVGEN(topgv) == PL_sub_generation)
005a453c 352 return 0; /* cache indicates sub doesn't exist */
463ee0b2 353 }
79072805 354
017a3ce5 355 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
7d49f689 356 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
9607fc9c 357
fb73857a
PP
358 /* create and re-create @.*::SUPER::ISA on demand */
359 if (!av || !SvMAGIC(av)) {
7423f6db 360 STRLEN packlen = HvNAMELEN_get(stash);
9607fc9c 361
bfcb3514 362 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
9607fc9c
PP
363 HV* basestash;
364
365 packlen -= 7;
bfcb3514 366 basestash = gv_stashpvn(hvname, packlen, TRUE);
017a3ce5 367 gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
3280af22 368 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
017a3ce5 369 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
9607fc9c 370 if (!gvp || !(gv = *gvp))
bfcb3514 371 Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
9607fc9c
PP
372 if (SvTYPE(gv) != SVt_PVGV)
373 gv_init(gv, stash, "ISA", 3, TRUE);
374 SvREFCNT_dec(GvAV(gv));
b37c2d43 375 GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
9607fc9c
PP
376 }
377 }
378 }
379
380 if (av) {
79072805 381 SV** svp = AvARRAY(av);
93965878
NIS
382 /* NOTE: No support for tied ISA */
383 I32 items = AvFILLp(av) + 1;
79072805 384 while (items--) {
823a54a3
AL
385 SV* const sv = *svp++;
386 HV* const basestash = gv_stashsv(sv, FALSE);
9bbf4081 387 if (!basestash) {
599cee73 388 if (ckWARN(WARN_MISC))
35c1215d 389 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
95b63a38 390 (void*)sv, hvname);
79072805
LW
391 continue;
392 }
44a8e56a
PP
393 gv = gv_fetchmeth(basestash, name, len,
394 (level >= 0) ? level + 1 : level - 1);
395 if (gv)
396 goto gotcha;
79072805
LW
397 }
398 }
a0d0e21e 399
9607fc9c
PP
400 /* if at top level, try UNIVERSAL */
401
44a8e56a 402 if (level == 0 || level == -1) {
89529cee 403 HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE);
9607fc9c 404
823a54a3 405 if (lastchance) {
155aba94
GS
406 if ((gv = gv_fetchmeth(lastchance, name, len,
407 (level >= 0) ? level + 1 : level - 1)))
408 {
44a8e56a 409 gotcha:
dc848c6f
PP
410 /*
411 * Cache method in topgv if:
412 * 1. topgv has no synonyms (else inheritance crosses wires)
413 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
414 */
415 if (topgv &&
416 GvREFCNT(topgv) == 1 &&
417 (cv = GvCV(gv)) &&
418 (CvROOT(cv) || CvXSUB(cv)))
419 {
155aba94 420 if ((cv = GvCV(topgv)))
44a8e56a
PP
421 SvREFCNT_dec(cv);
422 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
3280af22 423 GvCVGEN(topgv) = PL_sub_generation;
44a8e56a 424 }
a0d0e21e
LW
425 return gv;
426 }
005a453c
JP
427 else if (topgv && GvREFCNT(topgv) == 1) {
428 /* cache the fact that the method is not defined */
3280af22 429 GvCVGEN(topgv) = PL_sub_generation;
005a453c 430 }
a0d0e21e
LW
431 }
432 }
433
79072805
LW
434 return 0;
435}
436
954c1994 437/*
611c1e95
IZ
438=for apidoc gv_fetchmeth_autoload
439
440Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
441Returns a glob for the subroutine.
442
443For an autoloaded subroutine without a GV, will create a GV even
444if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
445of the result may be zero.
446
447=cut
448*/
449
450GV *
451Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
452{
453 GV *gv = gv_fetchmeth(stash, name, len, level);
454
455 if (!gv) {
611c1e95
IZ
456 CV *cv;
457 GV **gvp;
458
459 if (!stash)
6136c704 460 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
5c7983e5 461 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
6136c704 462 return NULL;
5c7983e5 463 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
6136c704 464 return NULL;
611c1e95
IZ
465 cv = GvCV(gv);
466 if (!(CvROOT(cv) || CvXSUB(cv)))
6136c704 467 return NULL;
611c1e95
IZ
468 /* Have an autoload */
469 if (level < 0) /* Cannot do without a stub */
470 gv_fetchmeth(stash, name, len, 0);
471 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
472 if (!gvp)
6136c704 473 return NULL;
611c1e95
IZ
474 return *gvp;
475 }
476 return gv;
477}
478
479/*
954c1994
GS
480=for apidoc gv_fetchmethod_autoload
481
482Returns the glob which contains the subroutine to call to invoke the method
483on the C<stash>. In fact in the presence of autoloading this may be the
484glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
b267980d 485already setup.
954c1994
GS
486
487The third parameter of C<gv_fetchmethod_autoload> determines whether
488AUTOLOAD lookup is performed if the given method is not present: non-zero
b267980d 489means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
954c1994 490Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
b267980d 491with a non-zero C<autoload> parameter.
954c1994
GS
492
493These functions grant C<"SUPER"> token as a prefix of the method name. Note
494that if you want to keep the returned glob for a long time, you need to
495check for it being "AUTOLOAD", since at the later time the call may load a
496different subroutine due to $AUTOLOAD changing its value. Use the glob
b267980d 497created via a side effect to do this.
954c1994
GS
498
499These functions have the same side-effects and as C<gv_fetchmeth> with
500C<level==0>. C<name> should be writable if contains C<':'> or C<'
501''>. The warning against passing the GV returned by C<gv_fetchmeth> to
b267980d 502C<call_sv> apply equally to these functions.
954c1994
GS
503
504=cut
505*/
506
dc848c6f 507GV *
864dbfa3 508Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
dc848c6f 509{
97aff369 510 dVAR;
08105a92 511 register const char *nend;
c445ea15 512 const char *nsplit = NULL;
a0d0e21e 513 GV* gv;
0dae17bd
GS
514 HV* ostash = stash;
515
516 if (stash && SvTYPE(stash) < SVt_PVHV)
5c284bb0 517 stash = NULL;
b267980d 518
463ee0b2 519 for (nend = name; *nend; nend++) {
9607fc9c 520 if (*nend == '\'')
a0d0e21e 521 nsplit = nend;
9607fc9c
PP
522 else if (*nend == ':' && *(nend + 1) == ':')
523 nsplit = ++nend;
a0d0e21e
LW
524 }
525 if (nsplit) {
9d4ba2ae 526 const char * const origname = name;
a0d0e21e 527 name = nsplit + 1;
a0d0e21e
LW
528 if (*nsplit == ':')
529 --nsplit;
9607fc9c
PP
530 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
531 /* ->SUPER::method should really be looked up in original stash */
b37c2d43 532 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
1d7c1841 533 CopSTASHPV(PL_curcop)));
af09ea45 534 /* __PACKAGE__::SUPER stash should be autovivified */
b15aece3 535 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
cea2e8a9 536 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
bfcb3514 537 origname, HvNAME_get(stash), name) );
4633a7c4 538 }
e189a56d 539 else {
af09ea45
IK
540 /* don't autovifify if ->NoSuchStash::method */
541 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
e189a56d
IK
542
543 /* however, explicit calls to Pkg::SUPER::method may
544 happen, and may require autovivification to work */
545 if (!stash && (nsplit - origname) >= 7 &&
546 strnEQ(nsplit - 7, "::SUPER", 7) &&
547 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
548 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
549 }
0dae17bd 550 ostash = stash;
4633a7c4
LW
551 }
552
9607fc9c 553 gv = gv_fetchmeth(stash, name, nend - name, 0);
a0d0e21e 554 if (!gv) {
2f6e0fe7 555 if (strEQ(name,"import") || strEQ(name,"unimport"))
3280af22 556 gv = (GV*)&PL_sv_yes;
dc848c6f 557 else if (autoload)
0dae17bd 558 gv = gv_autoload4(ostash, name, nend - name, TRUE);
463ee0b2 559 }
dc848c6f 560 else if (autoload) {
9d4ba2ae 561 CV* const cv = GvCV(gv);
09280a33
CS
562 if (!CvROOT(cv) && !CvXSUB(cv)) {
563 GV* stubgv;
564 GV* autogv;
565
566 if (CvANON(cv))
567 stubgv = gv;
568 else {
569 stubgv = CvGV(cv);
570 if (GvCV(stubgv) != cv) /* orphaned import */
571 stubgv = gv;
572 }
573 autogv = gv_autoload4(GvSTASH(stubgv),
574 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
dc848c6f
PP
575 if (autogv)
576 gv = autogv;
577 }
578 }
44a8e56a
PP
579
580 return gv;
581}
582
583GV*
864dbfa3 584Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
44a8e56a 585{
27da23d5 586 dVAR;
44a8e56a
PP
587 GV* gv;
588 CV* cv;
589 HV* varstash;
590 GV* vargv;
591 SV* varsv;
e1ec3a88 592 const char *packname = "";
eae70eaa 593 STRLEN packname_len = 0;
44a8e56a 594
5c7983e5 595 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
a0714e2c 596 return NULL;
0dae17bd
GS
597 if (stash) {
598 if (SvTYPE(stash) < SVt_PVHV) {
e62f0680 599 packname = SvPV_const((SV*)stash, packname_len);
5c284bb0 600 stash = NULL;
0dae17bd
GS
601 }
602 else {
bfcb3514 603 packname = HvNAME_get(stash);
7423f6db 604 packname_len = HvNAMELEN_get(stash);
0dae17bd
GS
605 }
606 }
5c7983e5 607 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
a0714e2c 608 return NULL;
dc848c6f
PP
609 cv = GvCV(gv);
610
adb5a9ae 611 if (!(CvROOT(cv) || CvXSUB(cv)))
a0714e2c 612 return NULL;
ed850460 613
dc848c6f
PP
614 /*
615 * Inheriting AUTOLOAD for non-methods works ... for now.
616 */
041457d9
DM
617 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
618 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
619 )
12bcd1a6 620 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
dc848c6f 621 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
0dae17bd 622 packname, (int)len, name);
44a8e56a 623
aed2304a 624 if (CvISXSUB(cv)) {
adb5a9ae
DM
625 /* rather than lookup/init $AUTOLOAD here
626 * only to have the XSUB do another lookup for $AUTOLOAD
627 * and split that value on the last '::',
628 * pass along the same data via some unused fields in the CV
629 */
630 CvSTASH(cv) = stash;
f880fe2f 631 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
b162af07 632 SvCUR_set(cv, len);
adb5a9ae
DM
633 return gv;
634 }
adb5a9ae 635
44a8e56a
PP
636 /*
637 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
638 * The subroutine's original name may not be "AUTOLOAD", so we don't
639 * use that, but for lack of anything better we will use the sub's
640 * original package to look up $AUTOLOAD.
641 */
642 varstash = GvSTASH(CvGV(cv));
5c7983e5 643 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
3d35f11b
GS
644 ENTER;
645
c69033f2 646 if (!isGV(vargv)) {
5c7983e5 647 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
c69033f2 648#ifdef PERL_DONT_CREATE_GVSV
561b68a9 649 GvSV(vargv) = newSV(0);
c69033f2
NC
650#endif
651 }
3d35f11b 652 LEAVE;
e203899d 653 varsv = GvSVn(vargv);
7423f6db 654 sv_setpvn(varsv, packname, packname_len);
396482e1 655 sv_catpvs(varsv, "::");
44a8e56a
PP
656 sv_catpvn(varsv, name, len);
657 SvTAINTED_off(varsv);
a0d0e21e
LW
658 return gv;
659}
660
d2c93421
RH
661/* The "gv" parameter should be the glob known to Perl code as *!
662 * The scalar must already have been magicalized.
663 */
664STATIC void
665S_require_errno(pTHX_ GV *gv)
666{
27da23d5 667 dVAR;
89529cee 668 HV* stash = gv_stashpvs("Errno", FALSE);
d2c93421 669
a0288114 670 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
d2c93421
RH
671 dSP;
672 PUTBACK;
673 ENTER;
674 save_scalar(gv); /* keep the value of $! */
84f1fa11 675 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 676 newSVpvs("Errno"), NULL);
d2c93421
RH
677 LEAVE;
678 SPAGAIN;
89529cee 679 stash = gv_stashpvs("Errno", FALSE);
d2c93421
RH
680 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
681 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
682 }
683}
684
954c1994
GS
685/*
686=for apidoc gv_stashpv
687
386d01d6 688Returns a pointer to the stash for a specified package. C<name> should
bc96cb06
SH
689be a valid UTF-8 string and must be null-terminated. If C<create> is set
690then the package will be created if it does not already exist. If C<create>
691is not set and the package does not exist then NULL is returned.
954c1994
GS
692
693=cut
694*/
695
a0d0e21e 696HV*
864dbfa3 697Perl_gv_stashpv(pTHX_ const char *name, I32 create)
a0d0e21e 698{
dc437b57
PP
699 return gv_stashpvn(name, strlen(name), create);
700}
701
bc96cb06
SH
702/*
703=for apidoc gv_stashpvn
704
705Returns a pointer to the stash for a specified package. C<name> should
706be a valid UTF-8 string. The C<namelen> parameter indicates the length of
707the C<name>, in bytes. If C<create> is set then the package will be
708created if it does not already exist. If C<create> is not set and the
709package does not exist then NULL is returned.
710
711=cut
712*/
713
dc437b57 714HV*
864dbfa3 715Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
dc437b57 716{
0cea0058 717 char smallbuf[128];
46fc3d4c 718 char *tmpbuf;
a0d0e21e
LW
719 HV *stash;
720 GV *tmpgv;
dc437b57 721
46fc3d4c
PP
722 if (namelen + 3 < sizeof smallbuf)
723 tmpbuf = smallbuf;
724 else
a02a5408 725 Newx(tmpbuf, namelen + 3, char);
dc437b57
PP
726 Copy(name,tmpbuf,namelen,char);
727 tmpbuf[namelen++] = ':';
728 tmpbuf[namelen++] = ':';
729 tmpbuf[namelen] = '\0';
9fb9dfd8 730 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV);
46fc3d4c
PP
731 if (tmpbuf != smallbuf)
732 Safefree(tmpbuf);
a0d0e21e
LW
733 if (!tmpgv)
734 return 0;
735 if (!GvHV(tmpgv))
736 GvHV(tmpgv) = newHV();
737 stash = GvHV(tmpgv);
bfcb3514 738 if (!HvNAME_get(stash))
51a37f80 739 hv_name_set(stash, name, namelen, 0);
a0d0e21e 740 return stash;
463ee0b2
LW
741}
742
954c1994
GS
743/*
744=for apidoc gv_stashsv
745
386d01d6
GS
746Returns a pointer to the stash for a specified package, which must be a
747valid UTF-8 string. See C<gv_stashpv>.
954c1994
GS
748
749=cut
750*/
751
a0d0e21e 752HV*
864dbfa3 753Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
a0d0e21e 754{
dc437b57 755 STRLEN len;
9d4ba2ae 756 const char * const ptr = SvPV_const(sv,len);
dc437b57 757 return gv_stashpvn(ptr, len, create);
a0d0e21e
LW
758}
759
760
463ee0b2 761GV *
7a5fd60d 762Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
b7787f18 763 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
7a5fd60d
NC
764}
765
766GV *
767Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
768 STRLEN len;
9d4ba2ae 769 const char * const nambeg = SvPV_const(name, len);
7a5fd60d
NC
770 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
771}
772
773GV *
774Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
775 I32 sv_type)
79072805 776{
97aff369 777 dVAR;
08105a92 778 register const char *name = nambeg;
c445ea15 779 register GV *gv = NULL;
79072805 780 GV**gvp;
79072805 781 I32 len;
b3d904f3 782 register const char *name_cursor;
c445ea15 783 HV *stash = NULL;
add2581e 784 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
e26df76a 785 const I32 no_expand = flags & GV_NOEXPAND;
fafc274c
NC
786 const I32 add =
787 flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL;
b3d904f3
NC
788 const char *const name_end = nambeg + full_len;
789 const char *const name_em1 = name_end - 1;
79072805 790
fafc274c
NC
791 if (flags & GV_NOTQUAL) {
792 /* Caller promised that there is no stash, so we can skip the check. */
793 len = full_len;
794 goto no_stash;
795 }
796
b208e10c
NC
797 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
798 /* accidental stringify on a GV? */
c07a80fd 799 name++;
b208e10c 800 }
c07a80fd 801
b3d904f3
NC
802 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
803 if ((*name_cursor == ':' && name_cursor < name_em1
804 && name_cursor[1] == ':')
805 || (*name_cursor == '\'' && name_cursor[1]))
463ee0b2 806 {
463ee0b2 807 if (!stash)
3280af22 808 stash = PL_defstash;
dc437b57 809 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
a0714e2c 810 return NULL;
463ee0b2 811
b3d904f3 812 len = name_cursor - name;
85e6fe83 813 if (len > 0) {
0cea0058 814 char smallbuf[128];
62b57502 815 char *tmpbuf;
62b57502 816
bb7a0f54 817 if (len + 3 < (I32)sizeof (smallbuf))
3c78fafa 818 tmpbuf = smallbuf;
62b57502 819 else
a02a5408 820 Newx(tmpbuf, len+3, char);
a0d0e21e
LW
821 Copy(name, tmpbuf, len, char);
822 tmpbuf[len++] = ':';
823 tmpbuf[len++] = ':';
824 tmpbuf[len] = '\0';
463ee0b2 825 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
a0714e2c 826 gv = gvp ? *gvp : NULL;
3280af22 827 if (gv && gv != (GV*)&PL_sv_undef) {
6fa846a0 828 if (SvTYPE(gv) != SVt_PVGV)
0f303493 829 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
6fa846a0
GS
830 else
831 GvMULTI_on(gv);
832 }
3c78fafa 833 if (tmpbuf != smallbuf)
62b57502 834 Safefree(tmpbuf);
3280af22 835 if (!gv || gv == (GV*)&PL_sv_undef)
a0714e2c 836 return NULL;
85e6fe83 837
463ee0b2
LW
838 if (!(stash = GvHV(gv)))
839 stash = GvHV(gv) = newHV();
85e6fe83 840
bfcb3514 841 if (!HvNAME_get(stash))
b3d904f3 842 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
463ee0b2
LW
843 }
844
b3d904f3
NC
845 if (*name_cursor == ':')
846 name_cursor++;
847 name_cursor++;
848 name = name_cursor;
ad6bfa9d 849 if (name == name_end)
017a3ce5 850 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
79072805 851 }
79072805 852 }
b3d904f3 853 len = name_cursor - name;
463ee0b2
LW
854
855 /* No stash in name, so see how we can default */
856
857 if (!stash) {
fafc274c 858 no_stash:
8ccce9ae 859 if (len && isIDFIRST_lazy(name)) {
9607fc9c
PP
860 bool global = FALSE;
861
8ccce9ae
NC
862 switch (len) {
863 case 1:
18ea00d7 864 if (*name == '_')
9d116dd7 865 global = TRUE;
18ea00d7 866 break;
8ccce9ae
NC
867 case 3:
868 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
869 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
870 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
9d116dd7 871 global = TRUE;
18ea00d7 872 break;
8ccce9ae
NC
873 case 4:
874 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
875 && name[3] == 'V')
9d116dd7 876 global = TRUE;
18ea00d7 877 break;
8ccce9ae
NC
878 case 5:
879 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
880 && name[3] == 'I' && name[4] == 'N')
463ee0b2 881 global = TRUE;
18ea00d7 882 break;
8ccce9ae
NC
883 case 6:
884 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
885 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
886 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
887 global = TRUE;
888 break;
889 case 7:
890 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
891 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
892 && name[6] == 'T')
18ea00d7
NC
893 global = TRUE;
894 break;
463ee0b2 895 }
9607fc9c 896
463ee0b2 897 if (global)
3280af22 898 stash = PL_defstash;
923e4eb5 899 else if (IN_PERL_COMPILETIME) {
3280af22
NIS
900 stash = PL_curstash;
901 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
902 sv_type != SVt_PVCV &&
903 sv_type != SVt_PVGV &&
4633a7c4 904 sv_type != SVt_PVFM &&
c07a80fd 905 sv_type != SVt_PVIO &&
70ec6265
NC
906 !(len == 1 && sv_type == SVt_PV &&
907 (*name == 'a' || *name == 'b')) )
748a9306 908 {
4633a7c4
LW
909 gvp = (GV**)hv_fetch(stash,name,len,0);
910 if (!gvp ||
3280af22 911 *gvp == (GV*)&PL_sv_undef ||
a5f75d66
AD
912 SvTYPE(*gvp) != SVt_PVGV)
913 {
d4c19fe8 914 stash = NULL;
a5f75d66 915 }
155aba94
GS
916 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
917 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
918 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 919 {
cea2e8a9 920 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
921 sv_type == SVt_PVAV ? '@' :
922 sv_type == SVt_PVHV ? '%' : '$',
923 name);
8ebc5c01 924 if (GvCVu(*gvp))
cc507455 925 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
d4c19fe8 926 stash = NULL;
4633a7c4 927 }
a0d0e21e 928 }
85e6fe83 929 }
463ee0b2 930 else
1d7c1841 931 stash = CopSTASH(PL_curcop);
463ee0b2
LW
932 }
933 else
3280af22 934 stash = PL_defstash;
463ee0b2
LW
935 }
936
937 /* By this point we should have a stash and a name */
938
a0d0e21e 939 if (!stash) {
5a844595 940 if (add) {
9d4ba2ae 941 SV * const err = Perl_mess(aTHX_
5a844595
GS
942 "Global symbol \"%s%s\" requires explicit package name",
943 (sv_type == SVt_PV ? "$"
944 : sv_type == SVt_PVAV ? "@"
945 : sv_type == SVt_PVHV ? "%"
608b3986 946 : ""), name);
e7f343b6 947 GV *gv;
608b3986
AE
948 if (USE_UTF8_IN_NAMES)
949 SvUTF8_on(err);
950 qerror(err);
e7f343b6
NC
951 gv = gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV);
952 if(!gv) {
953 /* symbol table under destruction */
954 return NULL;
955 }
956 stash = GvHV(gv);
a0d0e21e 957 }
d7aacf4e 958 else
a0714e2c 959 return NULL;
a0d0e21e
LW
960 }
961
962 if (!SvREFCNT(stash)) /* symbol table under destruction */
a0714e2c 963 return NULL;
a0d0e21e 964
79072805 965 gvp = (GV**)hv_fetch(stash,name,len,add);
3280af22 966 if (!gvp || *gvp == (GV*)&PL_sv_undef)
a0714e2c 967 return NULL;
79072805
LW
968 gv = *gvp;
969 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 970 if (add) {
a5f75d66 971 GvMULTI_on(gv);
a0d0e21e 972 gv_init_sv(gv, sv_type);
d2c93421
RH
973 if (*name=='!' && sv_type == SVt_PVHV && len==1)
974 require_errno(gv);
a0d0e21e 975 }
79072805 976 return gv;
add2581e 977 } else if (no_init) {
55d729e4 978 return gv;
e26df76a
NC
979 } else if (no_expand && SvROK(gv)) {
980 return gv;
79072805 981 }
93a17b20
LW
982
983 /* Adding a new symbol */
984
0453d815 985 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
9014280d 986 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
55d729e4 987 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
a0d0e21e 988 gv_init_sv(gv, sv_type);
93a17b20 989
a0288114 990 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
7272584d 991 : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM
992 GvMULTI_on(gv) ;
993
93a17b20 994 /* set up magic where warranted */
cc4c2da6 995 if (len > 1) {
9431620d 996#ifndef EBCDIC
cc4c2da6 997 if (*name > 'V' ) {
6f207bd3 998 NOOP;
cc4c2da6 999 /* Nothing else to do.
91f565cb 1000 The compiler will probably turn the switch statement into a
cc4c2da6
NC
1001 branch table. Make sure we avoid even that small overhead for
1002 the common case of lower case variable names. */
9431620d
NC
1003 } else
1004#endif
1005 {
b464bac0 1006 const char * const name2 = name + 1;
cc4c2da6
NC
1007 switch (*name) {
1008 case 'A':
1009 if (strEQ(name2, "RGV")) {
1010 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1011 }
7b8203e3
YST
1012 else if (strEQ(name2, "RGVOUT")) {
1013 GvMULTI_on(gv);
1014 }
cc4c2da6
NC
1015 break;
1016 case 'E':
1017 if (strnEQ(name2, "XPORT", 5))
1018 GvMULTI_on(gv);
1019 break;
1020 case 'I':
1021 if (strEQ(name2, "SA")) {
9d4ba2ae 1022 AV* const av = GvAVn(gv);
cc4c2da6 1023 GvMULTI_on(gv);
bd61b366 1024 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
cc4c2da6
NC
1025 /* NOTE: No support for tied ISA */
1026 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1027 && AvFILLp(av) == -1)
1028 {
e1ec3a88 1029 const char *pname;
cc4c2da6
NC
1030 av_push(av, newSVpvn(pname = "NDBM_File",9));
1031 gv_stashpvn(pname, 9, TRUE);
1032 av_push(av, newSVpvn(pname = "DB_File",7));
1033 gv_stashpvn(pname, 7, TRUE);
1034 av_push(av, newSVpvn(pname = "GDBM_File",9));
1035 gv_stashpvn(pname, 9, TRUE);
1036 av_push(av, newSVpvn(pname = "SDBM_File",9));
1037 gv_stashpvn(pname, 9, TRUE);
1038 av_push(av, newSVpvn(pname = "ODBM_File",9));
1039 gv_stashpvn(pname, 9, TRUE);
1040 }
1041 }
1042 break;
1043 case 'O':
1044 if (strEQ(name2, "VERLOAD")) {
9d4ba2ae 1045 HV* const hv = GvHVn(gv);
cc4c2da6 1046 GvMULTI_on(gv);
a0714e2c 1047 hv_magic(hv, NULL, PERL_MAGIC_overload);
cc4c2da6
NC
1048 }
1049 break;
1050 case 'S':
1051 if (strEQ(name2, "IG")) {
1052 HV *hv;
1053 I32 i;
1054 if (!PL_psig_ptr) {
a02a5408
JC
1055 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
1056 Newxz(PL_psig_name, SIG_SIZE, SV*);
1057 Newxz(PL_psig_pend, SIG_SIZE, int);
cc4c2da6
NC
1058 }
1059 GvMULTI_on(gv);
1060 hv = GvHVn(gv);
a0714e2c 1061 hv_magic(hv, NULL, PERL_MAGIC_sig);
cc4c2da6 1062 for (i = 1; i < SIG_SIZE; i++) {
551405c4 1063 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
cc4c2da6
NC
1064 if (init)
1065 sv_setsv(*init, &PL_sv_undef);
1066 PL_psig_ptr[i] = 0;
1067 PL_psig_name[i] = 0;
1068 PL_psig_pend[i] = 0;
1069 }
1070 }
1071 break;
1072 case 'V':
1073 if (strEQ(name2, "ERSION"))
1074 GvMULTI_on(gv);
1075 break;
e5218da5
GA
1076 case '\003': /* $^CHILD_ERROR_NATIVE */
1077 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1078 goto magicalize;
1079 break;
cc4c2da6
NC
1080 case '\005': /* $^ENCODING */
1081 if (strEQ(name2, "NCODING"))
1082 goto magicalize;
1083 break;
1084 case '\017': /* $^OPEN */
1085 if (strEQ(name2, "PEN"))
1086 goto magicalize;
1087 break;
1088 case '\024': /* ${^TAINT} */
1089 if (strEQ(name2, "AINT"))
1090 goto ro_magicalize;
1091 break;
7cebcbc0 1092 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
a0288114 1093 if (strEQ(name2, "NICODE"))
cc4c2da6 1094 goto ro_magicalize;
a0288114 1095 if (strEQ(name2, "TF8LOCALE"))
7cebcbc0 1096 goto ro_magicalize;
e07ea26a
NC
1097 if (strEQ(name2, "TF8CACHE"))
1098 goto magicalize;
cc4c2da6
NC
1099 break;
1100 case '\027': /* $^WARNING_BITS */
1101 if (strEQ(name2, "ARNING_BITS"))
1102 goto magicalize;
1103 break;
1104 case '1':
1105 case '2':
1106 case '3':
1107 case '4':
1108 case '5':
1109 case '6':
1110 case '7':
1111 case '8':
1112 case '9':
85e6fe83 1113 {
cc4c2da6
NC
1114 /* ensures variable is only digits */
1115 /* ${"1foo"} fails this test (and is thus writeable) */
1116 /* added by japhy, but borrowed from is_gv_magical */
1117 const char *end = name + len;
1118 while (--end > name) {
1119 if (!isDIGIT(*end)) return gv;
1120 }
1121 goto ro_magicalize;
1d7c1841 1122 }
dc437b57 1123 }
93a17b20 1124 }
392db708
NC
1125 } else {
1126 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1127 be case '\0' in this switch statement (ie a default case) */
cc4c2da6
NC
1128 switch (*name) {
1129 case '&':
1130 case '`':
1131 case '\'':
1132 if (
1133 sv_type == SVt_PVAV ||
1134 sv_type == SVt_PVHV ||
1135 sv_type == SVt_PVCV ||
1136 sv_type == SVt_PVFM ||
1137 sv_type == SVt_PVIO
1138 ) { break; }
1139 PL_sawampersand = TRUE;
1140 goto ro_magicalize;
1141
1142 case ':':
c69033f2 1143 sv_setpv(GvSVn(gv),PL_chopset);
cc4c2da6
NC
1144 goto magicalize;
1145
1146 case '?':
ff0cee69 1147#ifdef COMPLEX_STATUS
c69033f2 1148 SvUPGRADE(GvSVn(gv), SVt_PVLV);
ff0cee69 1149#endif
cc4c2da6 1150 goto magicalize;
ff0cee69 1151
cc4c2da6 1152 case '!':
d2c93421 1153
cc4c2da6
NC
1154 /* If %! has been used, automatically load Errno.pm.
1155 The require will itself set errno, so in order to
1156 preserve its value we have to set up the magic
1157 now (rather than going to magicalize)
1158 */
d2c93421 1159
c69033f2 1160 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
d2c93421 1161
cc4c2da6
NC
1162 if (sv_type == SVt_PVHV)
1163 require_errno(gv);
d2c93421 1164
6cef1e77 1165 break;
cc4c2da6
NC
1166 case '-':
1167 {
9d4ba2ae 1168 AV* const av = GvAVn(gv);
a0714e2c 1169 sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0);
03a27ae7 1170 SvREADONLY_on(av);
cc4c2da6
NC
1171 goto magicalize;
1172 }
1173 case '*':
cc4c2da6
NC
1174 case '#':
1175 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1176 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
8ae1fe26
RGS
1177 "$%c is no longer supported", *name);
1178 break;
cc4c2da6 1179 case '|':
c69033f2 1180 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
cc4c2da6
NC
1181 goto magicalize;
1182
b3ca2e83
NC
1183 case '\010': /* $^H */
1184 {
1185 HV *const hv = GvHVn(gv);
1186 hv_magic(hv, NULL, PERL_MAGIC_hints);
1187 }
1188 goto magicalize;
1189
cc4c2da6
NC
1190 case '+':
1191 {
9d4ba2ae 1192 AV* const av = GvAVn(gv);
bd61b366 1193 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
03a27ae7 1194 SvREADONLY_on(av);
cc4c2da6 1195 /* FALL THROUGH */
e521374c 1196 }
cc4c2da6
NC
1197 case '\023': /* $^S */
1198 case '1':
1199 case '2':
1200 case '3':
1201 case '4':
1202 case '5':
1203 case '6':
1204 case '7':
1205 case '8':
1206 case '9':
1207 ro_magicalize:
c69033f2 1208 SvREADONLY_on(GvSVn(gv));
cc4c2da6
NC
1209 /* FALL THROUGH */
1210 case '[':
1211 case '^':
1212 case '~':
1213 case '=':
1214 case '%':
1215 case '.':
1216 case '(':
1217 case ')':
1218 case '<':
1219 case '>':
1220 case ',':
1221 case '\\':
1222 case '/':
1223 case '\001': /* $^A */
1224 case '\003': /* $^C */
1225 case '\004': /* $^D */
1226 case '\005': /* $^E */
1227 case '\006': /* $^F */
cc4c2da6
NC
1228 case '\011': /* $^I, NOT \t in EBCDIC */
1229 case '\016': /* $^N */
1230 case '\017': /* $^O */
1231 case '\020': /* $^P */
1232 case '\024': /* $^T */
1233 case '\027': /* $^W */
1234 magicalize:
c69033f2 1235 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
cc4c2da6 1236 break;
e521374c 1237
cc4c2da6 1238 case '\014': /* $^L */
c69033f2
NC
1239 sv_setpvn(GvSVn(gv),"\f",1);
1240 PL_formfeed = GvSVn(gv);
463ee0b2 1241 break;
cc4c2da6 1242 case ';':
c69033f2 1243 sv_setpvn(GvSVn(gv),"\034",1);
463ee0b2 1244 break;
cc4c2da6
NC
1245 case ']':
1246 {
c69033f2 1247 SV * const sv = GvSVn(gv);
d7aa5382 1248 if (!sv_derived_from(PL_patchlevel, "version"))
7a5b473e 1249 upg_version(PL_patchlevel);
7d54d38e
SH
1250 GvSV(gv) = vnumify(PL_patchlevel);
1251 SvREADONLY_on(GvSV(gv));
1252 SvREFCNT_dec(sv);
93a17b20
LW
1253 }
1254 break;
cc4c2da6
NC
1255 case '\026': /* $^V */
1256 {
c69033f2 1257 SV * const sv = GvSVn(gv);
f9be5ac8
DM
1258 GvSV(gv) = new_version(PL_patchlevel);
1259 SvREADONLY_on(GvSV(gv));
1260 SvREFCNT_dec(sv);
16070b82
GS
1261 }
1262 break;
cc4c2da6 1263 }
79072805 1264 }
93a17b20 1265 return gv;
79072805
LW
1266}
1267
1268void
35a4481c 1269Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1270{
35a4481c 1271 const char *name;
7423f6db 1272 STRLEN namelen;
35a4481c 1273 const HV * const hv = GvSTASH(gv);
43693395 1274 if (!hv) {
0c34ef67 1275 SvOK_off(sv);
43693395
GS
1276 return;
1277 }
1278 sv_setpv(sv, prefix ? prefix : "");
a0288114 1279
bfcb3514 1280 name = HvNAME_get(hv);
7423f6db
NC
1281 if (name) {
1282 namelen = HvNAMELEN_get(hv);
1283 } else {
e27ad1f2 1284 name = "__ANON__";
7423f6db
NC
1285 namelen = 8;
1286 }
a0288114 1287
e27ad1f2 1288 if (keepmain || strNE(name, "main")) {
7423f6db 1289 sv_catpvn(sv,name,namelen);
396482e1 1290 sv_catpvs(sv,"::");
43693395 1291 }
257984c0 1292 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
43693395
GS
1293}
1294
1295void
35a4481c 1296Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1297{
46c461b5
AL
1298 const GV * const egv = GvEGV(gv);
1299 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
43693395
GS
1300}
1301
79072805 1302IO *
864dbfa3 1303Perl_newIO(pTHX)
79072805 1304{
97aff369 1305 dVAR;
8990e307 1306 GV *iogv;
561b68a9 1307 IO * const io = (IO*)newSV(0);
8990e307 1308
a0d0e21e 1309 sv_upgrade((SV *)io,SVt_PVIO);
158623e7
NC
1310 /* This used to read SvREFCNT(io) = 1;
1311 It's not clear why the reference count needed an explicit reset. NWC
1312 */
1313 assert (SvREFCNT(io) == 1);
8990e307 1314 SvOBJECT_on(io);
b464bac0 1315 /* Clear the stashcache because a new IO could overrule a package name */
081fc587 1316 hv_clear(PL_stashcache);
71315bf2 1317 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
5f2d631d
GS
1318 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1319 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
71315bf2 1320 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
b162af07 1321 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
79072805
LW
1322 return io;
1323}
1324
1325void
1146e912 1326Perl_gv_check(pTHX_ const HV *stash)
79072805 1327{
97aff369 1328 dVAR;
79072805 1329 register I32 i;
463ee0b2 1330
8990e307
LW
1331 if (!HvARRAY(stash))
1332 return;
a0d0e21e 1333 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 1334 const HE *entry;
dc437b57 1335 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
b7787f18
AL
1336 register GV *gv;
1337 HV *hv;
dc437b57 1338 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
b862623f 1339 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1340 {
19b6c847 1341 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1342 gv_check(hv); /* nested package */
1343 }
dc437b57 1344 else if (isALPHA(*HeKEY(entry))) {
e1ec3a88 1345 const char *file;
dc437b57 1346 gv = (GV*)HeVAL(entry);
55d729e4 1347 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1348 continue;
1d7c1841
GS
1349 file = GvFILE(gv);
1350 /* performance hack: if filename is absolute and it's a standard
1351 * module, don't bother warning */
6eb630b7 1352#ifdef MACOS_TRADITIONAL
551405c4 1353# define LIB_COMPONENT ":lib:"
6eb630b7 1354#else
551405c4 1355# define LIB_COMPONENT "/lib/"
6eb630b7 1356#endif
551405c4
AL
1357 if (file
1358 && PERL_FILE_IS_ABSOLUTE(file)
1359 && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1d7c1841 1360 {
8990e307 1361 continue;
1d7c1841
GS
1362 }
1363 CopLINE_set(PL_curcop, GvLINE(gv));
1364#ifdef USE_ITHREADS
dd374669 1365 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841
GS
1366#else
1367 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1368#endif
9014280d 1369 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1370 "Name \"%s::%s\" used only once: possible typo",
bfcb3514 1371 HvNAME_get(stash), GvNAME(gv));
463ee0b2 1372 }
79072805
LW
1373 }
1374 }
1375}
1376
1377GV *
e1ec3a88 1378Perl_newGVgen(pTHX_ const char *pack)
79072805 1379{
97aff369 1380 dVAR;
cea2e8a9 1381 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
6fd99bb3 1382 GV_ADD, SVt_PVGV);
79072805
LW
1383}
1384
1385/* hopefully this is only called on local symbol table entries */
1386
1387GP*
864dbfa3 1388Perl_gp_ref(pTHX_ GP *gp)
79072805 1389{
97aff369 1390 dVAR;
1d7c1841 1391 if (!gp)
d4c19fe8 1392 return NULL;
79072805 1393 gp->gp_refcnt++;
44a8e56a
PP
1394 if (gp->gp_cv) {
1395 if (gp->gp_cvgen) {
1396 /* multi-named GPs cannot be used for method cache */
1397 SvREFCNT_dec(gp->gp_cv);
601f1833 1398 gp->gp_cv = NULL;
44a8e56a
PP
1399 gp->gp_cvgen = 0;
1400 }
1401 else {
1402 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1403 PL_sub_generation++;
44a8e56a
PP
1404 }
1405 }
79072805 1406 return gp;
79072805
LW
1407}
1408
1409void
864dbfa3 1410Perl_gp_free(pTHX_ GV *gv)
79072805 1411{
97aff369 1412 dVAR;
79072805
LW
1413 GP* gp;
1414
f7877b28 1415 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
79072805 1416 return;
f248d071
GS
1417 if (gp->gp_refcnt == 0) {
1418 if (ckWARN_d(WARN_INTERNAL))
9014280d 1419 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
472d47bc
SB
1420 "Attempt to free unreferenced glob pointers"
1421 pTHX__FORMAT pTHX__VALUE);
79072805
LW
1422 return;
1423 }
44a8e56a
PP
1424 if (gp->gp_cv) {
1425 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1426 PL_sub_generation++;
44a8e56a 1427 }
748a9306
LW
1428 if (--gp->gp_refcnt > 0) {
1429 if (gp->gp_egv == gv)
1430 gp->gp_egv = 0;
dd38834b 1431 GvGP(gv) = 0;
79072805 1432 return;
748a9306 1433 }
79072805 1434
f4890806 1435 unshare_hek(gp->gp_file_hek);
c9da69fb
AL
1436 SvREFCNT_dec(gp->gp_sv);
1437 SvREFCNT_dec(gp->gp_av);
bfcb3514
NC
1438 /* FIXME - another reference loop GV -> symtab -> GV ?
1439 Somehow gp->gp_hv can end up pointing at freed garbage. */
1440 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
bfcb3514
NC
1441 const char *hvname = HvNAME_get(gp->gp_hv);
1442 if (PL_stashcache && hvname)
7423f6db
NC
1443 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1444 G_DISCARD);
bfcb3514 1445 SvREFCNT_dec(gp->gp_hv);
13207a71 1446 }
c9da69fb
AL
1447 SvREFCNT_dec(gp->gp_io);
1448 SvREFCNT_dec(gp->gp_cv);
1449 SvREFCNT_dec(gp->gp_form);
748a9306 1450
79072805
LW
1451 Safefree(gp);
1452 GvGP(gv) = 0;
1453}
1454
d460ef45
NIS
1455int
1456Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1457{
53c1dcc0
AL
1458 AMT * const amtp = (AMT*)mg->mg_ptr;
1459 PERL_UNUSED_ARG(sv);
dd374669 1460
d460ef45
NIS
1461 if (amtp && AMT_AMAGIC(amtp)) {
1462 int i;
1463 for (i = 1; i < NofAMmeth; i++) {
53c1dcc0 1464 CV * const cv = amtp->table[i];
b37c2d43 1465 if (cv) {
d460ef45 1466 SvREFCNT_dec((SV *) cv);
601f1833 1467 amtp->table[i] = NULL;
d460ef45
NIS
1468 }
1469 }
1470 }
1471 return 0;
1472}
1473
a0d0e21e
LW
1474/* Updates and caches the CV's */
1475
1476bool
864dbfa3 1477Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1478{
97aff369 1479 dVAR;
53c1dcc0 1480 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
a6006777 1481 AMT amt;
a0d0e21e 1482
14899595
NC
1483 if (mg) {
1484 const AMT * const amtp = (AMT*)mg->mg_ptr;
1485 if (amtp->was_ok_am == PL_amagic_generation
1486 && amtp->was_ok_sub == PL_sub_generation) {
1487 return (bool)AMT_OVERLOADED(amtp);
1488 }
1489 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1490 }
a0d0e21e 1491
bfcb3514 1492 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
a0d0e21e 1493
d460ef45 1494 Zero(&amt,1,AMT);
3280af22
NIS
1495 amt.was_ok_am = PL_amagic_generation;
1496 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1497 amt.fallback = AMGfallNO;
1498 amt.flags = 0;
1499
a6006777 1500 {
32251b26
IZ
1501 int filled = 0, have_ovl = 0;
1502 int i, lim = 1;
a6006777 1503
22c35a8c 1504 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1505
89ffc314 1506 /* Try to find via inheritance. */
53c1dcc0
AL
1507 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1508 SV * const sv = gv ? GvSV(gv) : NULL;
1509 CV* cv;
89ffc314
IZ
1510
1511 if (!gv)
32251b26 1512 lim = DESTROY_amg; /* Skip overloading entries. */
c69033f2
NC
1513#ifdef PERL_DONT_CREATE_GVSV
1514 else if (!sv) {
6f207bd3 1515 NOOP; /* Equivalent to !SvTRUE and !SvOK */
c69033f2
NC
1516 }
1517#endif
89ffc314
IZ
1518 else if (SvTRUE(sv))
1519 amt.fallback=AMGfallYES;
1520 else if (SvOK(sv))
1521 amt.fallback=AMGfallNEVER;
a6006777 1522
32251b26 1523 for (i = 1; i < lim; i++)
601f1833 1524 amt.table[i] = NULL;
32251b26 1525 for (; i < NofAMmeth; i++) {
6136c704 1526 const char * const cooky = PL_AMG_names[i];
32251b26 1527 /* Human-readable form, for debugging: */
6136c704 1528 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
e1ec3a88 1529 const STRLEN l = strlen(cooky);
89ffc314 1530
a0288114 1531 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
bfcb3514 1532 cp, HvNAME_get(stash)) );
611c1e95
IZ
1533 /* don't fill the cache while looking up!
1534 Creation of inheritance stubs in intermediate packages may
1535 conflict with the logic of runtime method substitution.
1536 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1537 then we could have created stubs for "(+0" in A and C too.
1538 But if B overloads "bool", we may want to use it for
1539 numifying instead of C's "+0". */
1540 if (i >= DESTROY_amg)
1541 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1542 else /* Autoload taken care of below */
1543 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 1544 cv = 0;
89ffc314 1545 if (gv && (cv = GvCV(gv))) {
bfcb3514 1546 const char *hvname;
44a8e56a 1547 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
bfcb3514 1548 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
611c1e95
IZ
1549 /* This is a hack to support autoloading..., while
1550 knowing *which* methods were declared as overloaded. */
44a8e56a 1551 /* GvSV contains the name of the method. */
6136c704 1552 GV *ngv = NULL;
c69033f2 1553 SV *gvsv = GvSV(gv);
a0288114
AL
1554
1555 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1556 "\" for overloaded \"%s\" in package \"%.256s\"\n",
ca0270c4 1557 (void*)GvSV(gv), cp, hvname) );
c69033f2
NC
1558 if (!gvsv || !SvPOK(gvsv)
1559 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
dc848c6f
PP
1560 FALSE)))
1561 {
a0288114 1562 /* Can be an import stub (created by "can"). */
c69033f2 1563 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
a0288114
AL
1564 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1565 "in package \"%.256s\"",
35c1215d
NC
1566 (GvCVGEN(gv) ? "Stub found while resolving"
1567 : "Can't resolve"),
bfcb3514 1568 name, cp, hvname);
44a8e56a 1569 }
dc848c6f 1570 cv = GvCV(gv = ngv);
44a8e56a 1571 }
b464bac0 1572 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
bfcb3514 1573 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
44a8e56a
PP
1574 GvNAME(CvGV(cv))) );
1575 filled = 1;
32251b26
IZ
1576 if (i < DESTROY_amg)
1577 have_ovl = 1;
611c1e95
IZ
1578 } else if (gv) { /* Autoloaded... */
1579 cv = (CV*)gv;
1580 filled = 1;
44a8e56a 1581 }
b37c2d43 1582 amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
a0d0e21e 1583 }
a0d0e21e 1584 if (filled) {
a6006777 1585 AMT_AMAGIC_on(&amt);
32251b26
IZ
1586 if (have_ovl)
1587 AMT_OVERLOADED_on(&amt);
14befaf4
DM
1588 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1589 (char*)&amt, sizeof(AMT));
32251b26 1590 return have_ovl;
a0d0e21e
LW
1591 }
1592 }
a6006777 1593 /* Here we have no table: */
9cbac4c7 1594 /* no_table: */
a6006777 1595 AMT_AMAGIC_off(&amt);
14befaf4
DM
1596 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1597 (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1598 return FALSE;
1599}
1600
32251b26
IZ
1601
1602CV*
1603Perl_gv_handler(pTHX_ HV *stash, I32 id)
1604{
97aff369 1605 dVAR;
3f8f4626 1606 MAGIC *mg;
32251b26
IZ
1607 AMT *amtp;
1608
bfcb3514 1609 if (!stash || !HvNAME_get(stash))
601f1833 1610 return NULL;
14befaf4 1611 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1612 if (!mg) {
1613 do_update:
1614 Gv_AMupdate(stash);
14befaf4 1615 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26 1616 }
a9fd4e40 1617 assert(mg);
32251b26
IZ
1618 amtp = (AMT*)mg->mg_ptr;
1619 if ( amtp->was_ok_am != PL_amagic_generation
1620 || amtp->was_ok_sub != PL_sub_generation )
1621 goto do_update;
3ad83ce7 1622 if (AMT_AMAGIC(amtp)) {
b7787f18 1623 CV * const ret = amtp->table[id];
3ad83ce7
AMS
1624 if (ret && isGV(ret)) { /* Autoloading stab */
1625 /* Passing it through may have resulted in a warning
1626 "Inherited AUTOLOAD for a non-method deprecated", since
1627 our caller is going through a function call, not a method call.
1628 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
890ce7af 1629 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS
1630
1631 if (gv && GvCV(gv))
1632 return GvCV(gv);
1633 }
1634 return ret;
1635 }
a0288114 1636
601f1833 1637 return NULL;
32251b26
IZ
1638}
1639
1640
a0d0e21e 1641SV*
864dbfa3 1642Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1643{
27da23d5 1644 dVAR;
b267980d 1645 MAGIC *mg;
9c5ffd7c 1646 CV *cv=NULL;
a0d0e21e 1647 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 1648 AMT *amtp=NULL, *oamtp=NULL;
b464bac0
AL
1649 int off = 0, off1, lr = 0, notfound = 0;
1650 int postpr = 0, force_cpy = 0;
1651 int assign = AMGf_assign & flags;
1652 const int assignshift = assign ? 1 : 0;
497b47a8
JH
1653#ifdef DEBUGGING
1654 int fl=0;
497b47a8 1655#endif
25716404 1656 HV* stash=NULL;
a0d0e21e 1657 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404
GS
1658 && (stash = SvSTASH(SvRV(left)))
1659 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1660 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1661 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 1662 : NULL))
b267980d 1663 && ((cv = cvp[off=method+assignshift])
748a9306
LW
1664 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1665 * usual method */
497b47a8
JH
1666 (
1667#ifdef DEBUGGING
1668 fl = 1,
a0288114 1669#endif
497b47a8 1670 cv = cvp[off=method])))) {
a0d0e21e
LW
1671 lr = -1; /* Call method for left argument */
1672 } else {
1673 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1674 int logic;
1675
1676 /* look for substituted methods */
ee239bfe 1677 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1678 switch (method) {
1679 case inc_amg:
ee239bfe
IZ
1680 force_cpy = 1;
1681 if ((cv = cvp[off=add_ass_amg])
1682 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1683 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1684 }
1685 break;
1686 case dec_amg:
ee239bfe
IZ
1687 force_cpy = 1;
1688 if ((cv = cvp[off = subtr_ass_amg])
1689 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1690 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1691 }
1692 break;
1693 case bool__amg:
1694 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1695 break;
1696 case numer_amg:
1697 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1698 break;
1699 case string_amg:
1700 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1701 break;
b7787f18
AL
1702 case not_amg:
1703 (void)((cv = cvp[off=bool__amg])
1704 || (cv = cvp[off=numer_amg])
1705 || (cv = cvp[off=string_amg]));
1706 postpr = 1;
1707 break;
748a9306
LW
1708 case copy_amg:
1709 {
76e3520e
GS
1710 /*
1711 * SV* ref causes confusion with the interpreter variable of
1712 * the same name
1713 */
890ce7af 1714 SV* const tmpRef=SvRV(left);
76e3520e 1715 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1716 /*
1717 * Just to be extra cautious. Maybe in some
1718 * additional cases sv_setsv is safe, too.
1719 */
890ce7af 1720 SV* const newref = newSVsv(tmpRef);
748a9306 1721 SvOBJECT_on(newref);
b162af07 1722 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
748a9306
LW
1723 return newref;
1724 }
1725 }
1726 break;
a0d0e21e 1727 case abs_amg:
b267980d 1728 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1729 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
890ce7af 1730 SV* const nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1731 if (off1==lt_amg) {
890ce7af 1732 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1733 lt_amg,AMGf_noright);
1734 logic = SvTRUE(lessp);
1735 } else {
890ce7af 1736 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1737 ncmp_amg,AMGf_noright);
1738 logic = (SvNV(lessp) < 0);
1739 }
1740 if (logic) {
1741 if (off==subtr_amg) {
1742 right = left;
748a9306 1743 left = nullsv;
a0d0e21e
LW
1744 lr = 1;
1745 }
1746 } else {
1747 return left;
1748 }
1749 }
1750 break;
1751 case neg_amg:
155aba94 1752 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1753 right = left;
1754 left = sv_2mortal(newSViv(0));
1755 lr = 1;
1756 }
1757 break;
f216259d 1758 case int_amg:
f5284f61 1759 case iter_amg: /* XXXX Eventually should do to_gv. */
b267980d
NIS
1760 /* FAIL safe */
1761 return NULL; /* Delegate operation to standard mechanisms. */
1762 break;
f5284f61
IZ
1763 case to_sv_amg:
1764 case to_av_amg:
1765 case to_hv_amg:
1766 case to_gv_amg:
1767 case to_cv_amg:
1768 /* FAIL safe */
b267980d 1769 return left; /* Delegate operation to standard mechanisms. */
f5284f61 1770 break;
a0d0e21e
LW
1771 default:
1772 goto not_found;
1773 }
1774 if (!cv) goto not_found;
1775 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404
GS
1776 && (stash = SvSTASH(SvRV(right)))
1777 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1778 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1779 ? (amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 1780 : NULL))
a0d0e21e
LW
1781 && (cv = cvp[off=method])) { /* Method for right
1782 * argument found */
1783 lr=1;
b267980d
NIS
1784 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1785 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1786 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1787 && !(flags & AMGf_unary)) {
1788 /* We look for substitution for
1789 * comparison operations and
fc36a67e 1790 * concatenation */
a0d0e21e
LW
1791 if (method==concat_amg || method==concat_ass_amg
1792 || method==repeat_amg || method==repeat_ass_amg) {
1793 return NULL; /* Delegate operation to string conversion */
1794 }
1795 off = -1;
1796 switch (method) {
1797 case lt_amg:
1798 case le_amg:
1799 case gt_amg:
1800 case ge_amg:
1801 case eq_amg:
1802 case ne_amg:
1803 postpr = 1; off=ncmp_amg; break;
1804 case slt_amg:
1805 case sle_amg:
1806 case sgt_amg:
1807 case sge_amg:
1808 case seq_amg:
1809 case sne_amg:
1810 postpr = 1; off=scmp_amg; break;
1811 }
1812 if (off != -1) cv = cvp[off];
1813 if (!cv) {
1814 goto not_found;
1815 }
1816 } else {
a6006777 1817 not_found: /* No method found, either report or croak */
b267980d
NIS
1818 switch (method) {
1819 case to_sv_amg:
1820 case to_av_amg:
1821 case to_hv_amg:
1822 case to_gv_amg:
1823 case to_cv_amg:
1824 /* FAIL safe */
1825 return left; /* Delegate operation to standard mechanisms. */
1826 break;
1827 }
a0d0e21e
LW
1828 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1829 notfound = 1; lr = -1;
1830 } else if (cvp && (cv=cvp[nomethod_amg])) {
1831 notfound = 1; lr = 1;
1832 } else {
46fc3d4c 1833 SV *msg;
774d564b 1834 if (off==-1) off=method;
b267980d 1835 msg = sv_2mortal(Perl_newSVpvf(aTHX_
a0288114 1836 "Operation \"%s\": no method found,%sargument %s%s%s%s",
89ffc314 1837 AMG_id2name(method + assignshift),
e7ea3e70 1838 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 1839 SvAMAGIC(left)?
a0d0e21e
LW
1840 "in overloaded package ":
1841 "has no overloaded magic",
b267980d 1842 SvAMAGIC(left)?
bfcb3514 1843 HvNAME_get(SvSTASH(SvRV(left))):
a0d0e21e 1844 "",
b267980d 1845 SvAMAGIC(right)?
e7ea3e70 1846 ",\n\tright argument in overloaded package ":
b267980d 1847 (flags & AMGf_unary
e7ea3e70
IZ
1848 ? ""
1849 : ",\n\tright argument has no overloaded magic"),
b267980d 1850 SvAMAGIC(right)?
bfcb3514 1851 HvNAME_get(SvSTASH(SvRV(right))):
46fc3d4c 1852 ""));
a0d0e21e 1853 if (amtp && amtp->fallback >= AMGfallYES) {
b15aece3 1854 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
a0d0e21e 1855 } else {
95b63a38 1856 Perl_croak(aTHX_ "%"SVf, (void*)msg);
a0d0e21e
LW
1857 }
1858 return NULL;
1859 }
ee239bfe 1860 force_cpy = force_cpy || assign;
a0d0e21e
LW
1861 }
1862 }
497b47a8 1863#ifdef DEBUGGING
a0d0e21e 1864 if (!notfound) {
497b47a8 1865 DEBUG_o(Perl_deb(aTHX_
a0288114 1866 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
497b47a8
JH
1867 AMG_id2name(off),
1868 method+assignshift==off? "" :
a0288114 1869 " (initially \"",
497b47a8
JH
1870 method+assignshift==off? "" :
1871 AMG_id2name(method+assignshift),
a0288114 1872 method+assignshift==off? "" : "\")",
497b47a8
JH
1873 flags & AMGf_unary? "" :
1874 lr==1 ? " for right argument": " for left argument",
1875 flags & AMGf_unary? " for argument" : "",
bfcb3514 1876 stash ? HvNAME_get(stash) : "null",
497b47a8 1877 fl? ",\n\tassignment variant used": "") );
ee239bfe 1878 }
497b47a8 1879#endif
748a9306
LW
1880 /* Since we use shallow copy during assignment, we need
1881 * to dublicate the contents, probably calling user-supplied
1882 * version of copy operator
1883 */
ee239bfe
IZ
1884 /* We need to copy in following cases:
1885 * a) Assignment form was called.
1886 * assignshift==1, assign==T, method + 1 == off
1887 * b) Increment or decrement, called directly.
1888 * assignshift==0, assign==0, method + 0 == off
1889 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 1890 * assignshift==0, assign==T,
ee239bfe
IZ
1891 * force_cpy == T
1892 * d) Increment or decrement, translated to nomethod.
b267980d 1893 * assignshift==0, assign==0,
ee239bfe
IZ
1894 * force_cpy == T
1895 * e) Assignment form translated to nomethod.
1896 * assignshift==1, assign==T, method + 1 != off
1897 * force_cpy == T
1898 */
1899 /* off is method, method+assignshift, or a result of opcode substitution.
1900 * In the latter case assignshift==0, so only notfound case is important.
1901 */
1902 if (( (method + assignshift == off)
1903 && (assign || (method == inc_amg) || (method == dec_amg)))
1904 || force_cpy)
1905 RvDEEPCP(left);
a0d0e21e
LW
1906 {
1907 dSP;
1908 BINOP myop;
1909 SV* res;
b7787f18 1910 const bool oldcatch = CATCH_GET;
a0d0e21e 1911
54310121 1912 CATCH_SET(TRUE);
a0d0e21e
LW
1913 Zero(&myop, 1, BINOP);
1914 myop.op_last = (OP *) &myop;
b37c2d43 1915 myop.op_next = NULL;
54310121 1916 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1917
e788e7d3 1918 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1919 ENTER;
462e5cf6 1920 SAVEOP();
533c011a 1921 PL_op = (OP *) &myop;
3280af22 1922 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1923 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1924 PUTBACK;
cea2e8a9 1925 pp_pushmark();
a0d0e21e 1926
924508f0 1927 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1928 PUSHs(lr>0? right: left);
1929 PUSHs(lr>0? left: right);
3280af22 1930 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1931 if (notfound) {
89ffc314 1932 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
a0d0e21e
LW
1933 }
1934 PUSHs((SV*)cv);
1935 PUTBACK;
1936
155aba94 1937 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1938 CALLRUNOPS(aTHX);
a0d0e21e
LW
1939 LEAVE;
1940 SPAGAIN;
1941
1942 res=POPs;
ebafeae7 1943 PUTBACK;
d3acc0f7 1944 POPSTACK;
54310121 1945 CATCH_SET(oldcatch);
a0d0e21e 1946
a0d0e21e 1947 if (postpr) {
b7787f18 1948 int ans;
a0d0e21e
LW
1949 switch (method) {
1950 case le_amg:
1951 case sle_amg:
1952 ans=SvIV(res)<=0; break;
1953 case lt_amg:
1954 case slt_amg:
1955 ans=SvIV(res)<0; break;
1956 case ge_amg:
1957 case sge_amg:
1958 ans=SvIV(res)>=0; break;
1959 case gt_amg:
1960 case sgt_amg:
1961 ans=SvIV(res)>0; break;
1962 case eq_amg:
1963 case seq_amg:
1964 ans=SvIV(res)==0; break;
1965 case ne_amg:
1966 case sne_amg:
1967 ans=SvIV(res)!=0; break;
1968 case inc_amg:
1969 case dec_amg:
bbce6d69 1970 SvSetSV(left,res); return left;
dc437b57 1971 case not_amg:
fe7ac86a 1972 ans=!SvTRUE(res); break;
b7787f18
AL
1973 default:
1974 ans=0; break;
a0d0e21e 1975 }
54310121 1976 return boolSV(ans);
748a9306
LW
1977 } else if (method==copy_amg) {
1978 if (!SvROK(res)) {
cea2e8a9 1979 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1980 }
1981 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1982 } else {
1983 return res;
1984 }
1985 }
1986}
c9d5ac95
GS
1987
1988/*
7fc63493 1989=for apidoc is_gv_magical_sv
c9d5ac95 1990
7a5fd60d
NC
1991Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1992
1993=cut
1994*/
1995
1996bool
1997Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1998{
1999 STRLEN len;
b64e5050 2000 const char * const temp = SvPV_const(name, len);
7a5fd60d
NC
2001 return is_gv_magical(temp, len, flags);
2002}
2003
2004/*
2005=for apidoc is_gv_magical
2006
c9d5ac95
GS
2007Returns C<TRUE> if given the name of a magical GV.
2008
2009Currently only useful internally when determining if a GV should be
2010created even in rvalue contexts.
2011
2012C<flags> is not used at present but available for future extension to
2013allow selecting particular classes of magical variable.
2014
b9b0e72c
NC
2015Currently assumes that C<name> is NUL terminated (as well as len being valid).
2016This assumption is met by all callers within the perl core, which all pass
2017pointers returned by SvPV.
2018
c9d5ac95
GS
2019=cut
2020*/
2021bool
7fc63493 2022Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
c9d5ac95 2023{
b37c2d43 2024 PERL_UNUSED_CONTEXT;
9d4ba2ae
AL
2025 PERL_UNUSED_ARG(flags);
2026
b9b0e72c 2027 if (len > 1) {
b464bac0 2028 const char * const name1 = name + 1;
b9b0e72c
NC
2029 switch (*name) {
2030 case 'I':
9431620d 2031 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
b9b0e72c
NC
2032 goto yes;
2033 break;
2034 case 'O':
9431620d 2035 if (len == 8 && strEQ(name1, "VERLOAD"))
b9b0e72c
NC
2036 goto yes;
2037 break;
2038 case 'S':
9431620d 2039 if (len == 3 && name[1] == 'I' && name[2] == 'G')
b9b0e72c
NC
2040 goto yes;
2041 break;
2042 /* Using ${^...} variables is likely to be sufficiently rare that
2043 it seems sensible to avoid the space hit of also checking the
2044 length. */
2045 case '\017': /* ${^OPEN} */
9431620d 2046 if (strEQ(name1, "PEN"))
b9b0e72c
NC
2047 goto yes;
2048 break;
2049 case '\024': /* ${^TAINT} */
9431620d 2050 if (strEQ(name1, "AINT"))
b9b0e72c
NC
2051 goto yes;
2052 break;
2053 case '\025': /* ${^UNICODE} */
9431620d 2054 if (strEQ(name1, "NICODE"))
b9b0e72c 2055 goto yes;
a0288114 2056 if (strEQ(name1, "TF8LOCALE"))
7cebcbc0 2057 goto yes;
b9b0e72c
NC
2058 break;
2059 case '\027': /* ${^WARNING_BITS} */
9431620d 2060 if (strEQ(name1, "ARNING_BITS"))
b9b0e72c
NC
2061 goto yes;
2062 break;
2063 case '1':
2064 case '2':
2065 case '3':
2066 case '4':
2067 case '5':
2068 case '6':
2069 case '7':
2070 case '8':
2071 case '9':
c9d5ac95 2072 {
7fc63493 2073 const char *end = name + len;
c9d5ac95
GS
2074 while (--end > name) {
2075 if (!isDIGIT(*end))
2076 return FALSE;
2077 }
b9b0e72c
NC
2078 goto yes;
2079 }
2080 }
2081 } else {
2082 /* Because we're already assuming that name is NUL terminated
2083 below, we can treat an empty name as "\0" */
2084 switch (*name) {
2085 case '&':
2086 case '`':
2087 case '\'':
2088 case ':':
2089 case '?':
2090 case '!':
2091 case '-':
2092 case '#':
2093 case '[':
2094 case '^':
2095 case '~':
2096 case '=':
2097 case '%':
2098 case '.':
2099 case '(':
2100 case ')':
2101 case '<':
2102 case '>':
2103 case ',':
2104 case '\\':
2105 case '/':
2106 case '|':
2107 case '+':
2108 case ';':
2109 case ']':
2110 case '\001': /* $^A */
2111 case '\003': /* $^C */
2112 case '\004': /* $^D */
2113 case '\005': /* $^E */
2114 case '\006': /* $^F */
2115 case '\010': /* $^H */
2116 case '\011': /* $^I, NOT \t in EBCDIC */
2117 case '\014': /* $^L */
2118 case '\016': /* $^N */
2119 case '\017': /* $^O */
2120 case '\020': /* $^P */
2121 case '\023': /* $^S */
2122 case '\024': /* $^T */
2123 case '\026': /* $^V */
2124 case '\027': /* $^W */
2125 case '1':
2126 case '2':
2127 case '3':
2128 case '4':
2129 case '5':
2130 case '6':
2131 case '7':
2132 case '8':
2133 case '9':
2134 yes:
2135 return TRUE;
2136 default:
2137 break;
c9d5ac95 2138 }
c9d5ac95
GS
2139 }
2140 return FALSE;
2141}
66610fdd 2142
f5c1e807
NC
2143void
2144Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2145{
2146 dVAR;
acda4c6a 2147 U32 hash;
f5c1e807 2148
9f616d01 2149 assert(name);
f5c1e807
NC
2150 PERL_UNUSED_ARG(flags);
2151
acda4c6a
NC
2152 if (len > I32_MAX)
2153 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2154
ae8cc45f
NC
2155 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2156 unshare_hek(GvNAME_HEK(gv));
2157 }
2158
acda4c6a 2159 PERL_HASH(hash, name, len);
9f616d01 2160 GvNAME_HEK(gv) = share_hek(name, len, hash);
f5c1e807
NC
2161}
2162
66610fdd
RGS
2163/*
2164 * Local variables:
2165 * c-indentation-style: bsd
2166 * c-basic-offset: 4
2167 * indent-tabs-mode: t
2168 * End:
2169 *
37442d52
RGS
2170 * ex: set ts=8 sts=4 sw=4 noet:
2171 */