This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PL_ prefix to all perlvars, part1
[perl5.git] / gv.c
1 /*    gv.c
2  *
3  *    Copyright (c) 1991-1997, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
12  * of your inquisitiveness, I shall spend all the rest of my days answering
13  * you.  What more do you want to know?'
14  *   'The names of all the stars, and of all living things, and the whole
15  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
16  * laughed Pippin.
17  */
18
19 #include "EXTERN.h"
20 #include "perl.h"
21
22 EXT char rcsid[];
23
24 GV *
25 gv_AVadd(register GV *gv)
26 {
27     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
28         croak("Bad symbol for array");
29     if (!GvAV(gv))
30         GvAV(gv) = newAV();
31     return gv;
32 }
33
34 GV *
35 gv_HVadd(register GV *gv)
36 {
37     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
38         croak("Bad symbol for hash");
39     if (!GvHV(gv))
40         GvHV(gv) = newHV();
41     return gv;
42 }
43
44 GV *
45 gv_IOadd(register GV *gv)
46 {
47     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
48         croak("Bad symbol for filehandle");
49     if (!GvIOp(gv))
50         GvIOp(gv) = newIO();
51     return gv;
52 }
53
54 GV *
55 gv_fetchfile(char *name)
56 {
57     dTHR;
58     char smallbuf[256];
59     char *tmpbuf;
60     STRLEN tmplen;
61     GV *gv;
62
63     tmplen = strlen(name) + 2;
64     if (tmplen < sizeof smallbuf)
65         tmpbuf = smallbuf;
66     else
67         New(603, tmpbuf, tmplen + 1, char);
68     tmpbuf[0] = '_';
69     tmpbuf[1] = '<';
70     strcpy(tmpbuf + 2, name);
71     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
72     if (!isGV(gv))
73         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
74     if (tmpbuf != smallbuf)
75         Safefree(tmpbuf);
76     sv_setpv(GvSV(gv), name);
77     if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
78         GvMULTI_on(gv);
79     if (PERLDB_LINE)
80         hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
81     return gv;
82 }
83
84 void
85 gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi)
86 {
87     dTHR;
88     register GP *gp;
89     bool doproto = SvTYPE(gv) > SVt_NULL;
90     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
91
92     sv_upgrade((SV*)gv, SVt_PVGV);
93     if (SvLEN(gv)) {
94         if (proto) {
95             SvPVX(gv) = NULL;
96             SvLEN(gv) = 0;
97             SvPOK_off(gv);
98         } else
99             Safefree(SvPVX(gv));
100     }
101     Newz(602, gp, 1, GP);
102     GvGP(gv) = gp_ref(gp);
103     GvSV(gv) = NEWSV(72,0);
104     GvLINE(gv) = PL_curcop->cop_line;
105     GvFILEGV(gv) = PL_curcop->cop_filegv;
106     GvCVGEN(gv) = 0;
107     GvEGV(gv) = gv;
108     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
109     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
110     GvNAME(gv) = savepvn(name, len);
111     GvNAMELEN(gv) = len;
112     if (multi)
113         GvMULTI_on(gv);
114     if (doproto) {                      /* Replicate part of newSUB here. */
115         SvIOK_off(gv);
116         ENTER;
117         start_subparse(0,0);            /* Create CV in compcv. */
118         GvCV(gv) = PL_compcv;
119         LEAVE;
120
121         PL_sub_generation++;
122         CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
123         CvFILEGV(GvCV(gv)) = PL_curcop->cop_filegv;
124         CvSTASH(GvCV(gv)) = PL_curstash;
125 #ifdef USE_THREADS
126         CvOWNER(GvCV(gv)) = 0;
127         if (!CvMUTEXP(GvCV(gv)))
128             New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
129         MUTEX_INIT(CvMUTEXP(GvCV(gv)));
130 #endif /* USE_THREADS */
131         if (proto) {
132             sv_setpv((SV*)GvCV(gv), proto);
133             Safefree(proto);
134         }
135     }
136 }
137
138 STATIC void
139 gv_init_sv(GV *gv, I32 sv_type)
140 {
141     switch (sv_type) {
142     case SVt_PVIO:
143         (void)GvIOn(gv);
144         break;
145     case SVt_PVAV:
146         (void)GvAVn(gv);
147         break;
148     case SVt_PVHV:
149         (void)GvHVn(gv);
150         break;
151     }
152 }
153
154 GV *
155 gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level)
156 {
157     AV* av;
158     GV* topgv;
159     GV* gv;
160     GV** gvp;
161     CV* cv;
162
163     if (!stash)
164         return 0;
165     if ((level > 100) || (level < -100))
166         croak("Recursive inheritance detected while looking for method '%s' in package '%s'",
167               name, HvNAME(stash));
168
169     DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
170
171     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
172     if (!gvp)
173         topgv = Nullgv;
174     else {
175         topgv = *gvp;
176         if (SvTYPE(topgv) != SVt_PVGV)
177             gv_init(topgv, stash, name, len, TRUE);
178         if (cv = GvCV(topgv)) {
179             /* If genuine method or valid cache entry, use it */
180             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
181                 return topgv;
182             /* Stale cached entry: junk it */
183             SvREFCNT_dec(cv);
184             GvCV(topgv) = cv = Nullcv;
185             GvCVGEN(topgv) = 0;
186         }
187         else if (GvCVGEN(topgv) == PL_sub_generation)
188             return 0;  /* cache indicates sub doesn't exist */
189     }
190
191     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
192     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
193
194     /* create and re-create @.*::SUPER::ISA on demand */
195     if (!av || !SvMAGIC(av)) {
196         char* packname = HvNAME(stash);
197         STRLEN packlen = strlen(packname);
198
199         if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
200             HV* basestash;
201
202             packlen -= 7;
203             basestash = gv_stashpvn(packname, packlen, TRUE);
204             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
205             if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
206                 dTHR;           /* just for SvREFCNT_dec */
207                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
208                 if (!gvp || !(gv = *gvp))
209                     croak("Cannot create %s::ISA", HvNAME(stash));
210                 if (SvTYPE(gv) != SVt_PVGV)
211                     gv_init(gv, stash, "ISA", 3, TRUE);
212                 SvREFCNT_dec(GvAV(gv));
213                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
214             }
215         }
216     }
217
218     if (av) {
219         SV** svp = AvARRAY(av);
220         /* NOTE: No support for tied ISA */
221         I32 items = AvFILLp(av) + 1;
222         while (items--) {
223             SV* sv = *svp++;
224             HV* basestash = gv_stashsv(sv, FALSE);
225             if (!basestash) {
226                 if (PL_dowarn)
227                     warn("Can't locate package %s for @%s::ISA",
228                         SvPVX(sv), HvNAME(stash));
229                 continue;
230             }
231             gv = gv_fetchmeth(basestash, name, len,
232                               (level >= 0) ? level + 1 : level - 1);
233             if (gv)
234                 goto gotcha;
235         }
236     }
237
238     /* if at top level, try UNIVERSAL */
239
240     if (level == 0 || level == -1) {
241         HV* lastchance;
242
243         if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
244             if (gv = gv_fetchmeth(lastchance, name, len,
245                                   (level >= 0) ? level + 1 : level - 1)) {
246           gotcha:
247                 /*
248                  * Cache method in topgv if:
249                  *  1. topgv has no synonyms (else inheritance crosses wires)
250                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
251                  */
252                 if (topgv &&
253                     GvREFCNT(topgv) == 1 &&
254                     (cv = GvCV(gv)) &&
255                     (CvROOT(cv) || CvXSUB(cv)))
256                 {
257                     if (cv = GvCV(topgv))
258                         SvREFCNT_dec(cv);
259                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
260                     GvCVGEN(topgv) = PL_sub_generation;
261                 }
262                 return gv;
263             }
264             else if (topgv && GvREFCNT(topgv) == 1) {
265                 /* cache the fact that the method is not defined */
266                 GvCVGEN(topgv) = PL_sub_generation;
267             }
268         }
269     }
270
271     return 0;
272 }
273
274 GV *
275 gv_fetchmethod(HV *stash, char *name)
276 {
277     return gv_fetchmethod_autoload(stash, name, TRUE);
278 }
279
280 GV *
281 gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload)
282 {
283     dTHR;
284     register char *nend;
285     char *nsplit = 0;
286     GV* gv;
287     
288     for (nend = name; *nend; nend++) {
289         if (*nend == '\'')
290             nsplit = nend;
291         else if (*nend == ':' && *(nend + 1) == ':')
292             nsplit = ++nend;
293     }
294     if (nsplit) {
295         char *origname = name;
296         name = nsplit + 1;
297         if (*nsplit == ':')
298             --nsplit;
299         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
300             /* ->SUPER::method should really be looked up in original stash */
301             SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER",
302                                              HvNAME(PL_curcop->cop_stash)));
303             stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
304             DEBUG_o( deb("Treating %s as %s::%s\n",
305                          origname, HvNAME(stash), name) );
306         }
307         else
308             stash = gv_stashpvn(origname, nsplit - origname, TRUE);
309     }
310
311     gv = gv_fetchmeth(stash, name, nend - name, 0);
312     if (!gv) {
313         if (strEQ(name,"import"))
314             gv = (GV*)&PL_sv_yes;
315         else if (autoload)
316             gv = gv_autoload4(stash, name, nend - name, TRUE);
317     }
318     else if (autoload) {
319         CV* cv = GvCV(gv);
320         if (!CvROOT(cv) && !CvXSUB(cv)) {
321             GV* stubgv;
322             GV* autogv;
323
324             if (CvANON(cv))
325                 stubgv = gv;
326             else {
327                 stubgv = CvGV(cv);
328                 if (GvCV(stubgv) != cv)         /* orphaned import */
329                     stubgv = gv;
330             }
331             autogv = gv_autoload4(GvSTASH(stubgv),
332                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
333             if (autogv)
334                 gv = autogv;
335         }
336     }
337
338     return gv;
339 }
340
341 GV*
342 gv_autoload4(HV *stash, char *name, STRLEN len, I32 method)
343 {
344     static char autoload[] = "AUTOLOAD";
345     static STRLEN autolen = 8;
346     GV* gv;
347     CV* cv;
348     HV* varstash;
349     GV* vargv;
350     SV* varsv;
351
352     if (len == autolen && strnEQ(name, autoload, autolen))
353         return Nullgv;
354     if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
355         return Nullgv;
356     cv = GvCV(gv);
357
358     /*
359      * Inheriting AUTOLOAD for non-methods works ... for now.
360      */
361     if (PL_dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
362         warn(
363           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
364              HvNAME(stash), (int)len, name);
365
366     /*
367      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
368      * The subroutine's original name may not be "AUTOLOAD", so we don't
369      * use that, but for lack of anything better we will use the sub's
370      * original package to look up $AUTOLOAD.
371      */
372     varstash = GvSTASH(CvGV(cv));
373     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
374     if (!isGV(vargv))
375         gv_init(vargv, varstash, autoload, autolen, FALSE);
376     varsv = GvSV(vargv);
377     sv_setpv(varsv, HvNAME(stash));
378     sv_catpvn(varsv, "::", 2);
379     sv_catpvn(varsv, name, len);
380     SvTAINTED_off(varsv);
381     return gv;
382 }
383
384 HV*
385 gv_stashpv(char *name, I32 create)
386 {
387     return gv_stashpvn(name, strlen(name), create);
388 }
389
390 HV*
391 gv_stashpvn(char *name, U32 namelen, I32 create)
392 {
393     char smallbuf[256];
394     char *tmpbuf;
395     HV *stash;
396     GV *tmpgv;
397
398     if (namelen + 3 < sizeof smallbuf)
399         tmpbuf = smallbuf;
400     else
401         New(606, tmpbuf, namelen + 3, char);
402     Copy(name,tmpbuf,namelen,char);
403     tmpbuf[namelen++] = ':';
404     tmpbuf[namelen++] = ':';
405     tmpbuf[namelen] = '\0';
406     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
407     if (tmpbuf != smallbuf)
408         Safefree(tmpbuf);
409     if (!tmpgv)
410         return 0;
411     if (!GvHV(tmpgv))
412         GvHV(tmpgv) = newHV();
413     stash = GvHV(tmpgv);
414     if (!HvNAME(stash))
415         HvNAME(stash) = savepv(name);
416     return stash;
417 }
418
419 HV*
420 gv_stashsv(SV *sv, I32 create)
421 {
422     register char *ptr;
423     STRLEN len;
424     ptr = SvPV(sv,len);
425     return gv_stashpvn(ptr, len, create);
426 }
427
428
429 GV *
430 gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
431 {
432     dTHR;
433     register char *name = nambeg;
434     register GV *gv = 0;
435     GV**gvp;
436     I32 len;
437     register char *namend;
438     HV *stash = 0;
439     U32 add_gvflags = 0;
440
441     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
442         name++;
443
444     for (namend = name; *namend; namend++) {
445         if ((*namend == '\'' && namend[1]) ||
446             (*namend == ':' && namend[1] == ':'))
447         {
448             if (!stash)
449                 stash = PL_defstash;
450             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
451                 return Nullgv;
452
453             len = namend - name;
454             if (len > 0) {
455                 char smallbuf[256];
456                 char *tmpbuf;
457
458                 if (len + 3 < sizeof smallbuf)
459                     tmpbuf = smallbuf;
460                 else
461                     New(601, tmpbuf, len+3, char);
462                 Copy(name, tmpbuf, len, char);
463                 tmpbuf[len++] = ':';
464                 tmpbuf[len++] = ':';
465                 tmpbuf[len] = '\0';
466                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
467                 gv = gvp ? *gvp : Nullgv;
468                 if (gv && gv != (GV*)&PL_sv_undef) {
469                     if (SvTYPE(gv) != SVt_PVGV)
470                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
471                     else
472                         GvMULTI_on(gv);
473                 }
474                 if (tmpbuf != smallbuf)
475                     Safefree(tmpbuf);
476                 if (!gv || gv == (GV*)&PL_sv_undef)
477                     return Nullgv;
478
479                 if (!(stash = GvHV(gv)))
480                     stash = GvHV(gv) = newHV();
481
482                 if (!HvNAME(stash))
483                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
484             }
485
486             if (*namend == ':')
487                 namend++;
488             namend++;
489             name = namend;
490             if (!*name)
491                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
492         }
493     }
494     len = namend - name;
495     if (!len)
496         len = 1;
497
498     /* No stash in name, so see how we can default */
499
500     if (!stash) {
501         if (isIDFIRST(*name)) {
502             bool global = FALSE;
503
504             if (isUPPER(*name)) {
505                 if (*name > 'I') {
506                     if (*name == 'S' && (
507                       strEQ(name, "SIG") ||
508                       strEQ(name, "STDIN") ||
509                       strEQ(name, "STDOUT") ||
510                       strEQ(name, "STDERR") ))
511                         global = TRUE;
512                 }
513                 else if (*name > 'E') {
514                     if (*name == 'I' && strEQ(name, "INC"))
515                         global = TRUE;
516                 }
517                 else if (*name > 'A') {
518                     if (*name == 'E' && strEQ(name, "ENV"))
519                         global = TRUE;
520                 }
521                 else if (*name == 'A' && (
522                   strEQ(name, "ARGV") ||
523                   strEQ(name, "ARGVOUT") ))
524                     global = TRUE;
525             }
526             else if (*name == '_' && !name[1])
527                 global = TRUE;
528
529             if (global)
530                 stash = PL_defstash;
531             else if ((COP*)PL_curcop == &PL_compiling) {
532                 stash = PL_curstash;
533                 if (add && (PL_hints & HINT_STRICT_VARS) &&
534                     sv_type != SVt_PVCV &&
535                     sv_type != SVt_PVGV &&
536                     sv_type != SVt_PVFM &&
537                     sv_type != SVt_PVIO &&
538                     !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
539                 {
540                     gvp = (GV**)hv_fetch(stash,name,len,0);
541                     if (!gvp ||
542                         *gvp == (GV*)&PL_sv_undef ||
543                         SvTYPE(*gvp) != SVt_PVGV)
544                     {
545                         stash = 0;
546                     }
547                     else if (sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp) ||
548                              sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
549                              sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
550                     {
551                         warn("Variable \"%c%s\" is not imported",
552                             sv_type == SVt_PVAV ? '@' :
553                             sv_type == SVt_PVHV ? '%' : '$',
554                             name);
555                         if (GvCVu(*gvp))
556                             warn("(Did you mean &%s instead?)\n", name);
557                         stash = 0;
558                     }
559                 }
560             }
561             else
562                 stash = PL_curcop->cop_stash;
563         }
564         else
565             stash = PL_defstash;
566     }
567
568     /* By this point we should have a stash and a name */
569
570     if (!stash) {
571         if (!add)
572             return Nullgv;
573         if (add & ~GV_ADDMULTI) {
574             char sv_type_char = ((sv_type == SVt_PV) ? '$'
575                                  : (sv_type == SVt_PVAV) ? '@'
576                                  : (sv_type == SVt_PVHV) ? '%'
577                                  : 0);
578             if (sv_type_char) 
579                 warn("Global symbol \"%c%s\" requires explicit package name",
580                      sv_type_char, name);
581             else
582                 warn("Global symbol \"%s\" requires explicit package name",
583                      name);
584         }
585         ++PL_error_count;
586         stash = PL_curstash ? PL_curstash : PL_defstash;        /* avoid core dumps */
587         add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
588                        : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
589                        : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
590                        : 0);
591     }
592
593     if (!SvREFCNT(stash))       /* symbol table under destruction */
594         return Nullgv;
595
596     gvp = (GV**)hv_fetch(stash,name,len,add);
597     if (!gvp || *gvp == (GV*)&PL_sv_undef)
598         return Nullgv;
599     gv = *gvp;
600     if (SvTYPE(gv) == SVt_PVGV) {
601         if (add) {
602             GvMULTI_on(gv);
603             gv_init_sv(gv, sv_type);
604         }
605         return gv;
606     } else if (add & GV_NOINIT) {
607         return gv;
608     }
609
610     /* Adding a new symbol */
611
612     if (add & GV_ADDWARN)
613         warn("Had to create %s unexpectedly", nambeg);
614     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
615     gv_init_sv(gv, sv_type);
616     GvFLAGS(gv) |= add_gvflags;
617
618     /* set up magic where warranted */
619     switch (*name) {
620     case 'A':
621         if (strEQ(name, "ARGV")) {
622             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
623         }
624         break;
625
626     case 'a':
627     case 'b':
628         if (len == 1)
629             GvMULTI_on(gv);
630         break;
631     case 'E':
632         if (strnEQ(name, "EXPORT", 6))
633             GvMULTI_on(gv);
634         break;
635     case 'I':
636         if (strEQ(name, "ISA")) {
637             AV* av = GvAVn(gv);
638             GvMULTI_on(gv);
639             sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
640             /* NOTE: No support for tied ISA */
641             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
642                 && AvFILLp(av) == -1)
643             {
644                 char *pname;
645                 av_push(av, newSVpv(pname = "NDBM_File",0));
646                 gv_stashpvn(pname, 9, TRUE);
647                 av_push(av, newSVpv(pname = "DB_File",0));
648                 gv_stashpvn(pname, 7, TRUE);
649                 av_push(av, newSVpv(pname = "GDBM_File",0));
650                 gv_stashpvn(pname, 9, TRUE);
651                 av_push(av, newSVpv(pname = "SDBM_File",0));
652                 gv_stashpvn(pname, 9, TRUE);
653                 av_push(av, newSVpv(pname = "ODBM_File",0));
654                 gv_stashpvn(pname, 9, TRUE);
655             }
656         }
657         break;
658 #ifdef OVERLOAD
659     case 'O':
660         if (strEQ(name, "OVERLOAD")) {
661             HV* hv = GvHVn(gv);
662             GvMULTI_on(gv);
663             hv_magic(hv, gv, 'A');
664         }
665         break;
666 #endif /* OVERLOAD */
667     case 'S':
668         if (strEQ(name, "SIG")) {
669             HV *hv;
670             I32 i;
671             PL_siggv = gv;
672             GvMULTI_on(PL_siggv);
673             hv = GvHVn(PL_siggv);
674             hv_magic(hv, PL_siggv, 'S');
675             for(i=1;sig_name[i];i++) {
676                 SV ** init;
677                 init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1);
678                 if(init)
679                         sv_setsv(*init,&PL_sv_undef);
680                 psig_ptr[i] = 0;
681                 psig_name[i] = 0;
682             }
683         }
684         break;
685
686     case '&':
687         if (len > 1)
688             break;
689         PL_ampergv = gv;
690         PL_sawampersand = TRUE;
691         goto ro_magicalize;
692
693     case '`':
694         if (len > 1)
695             break;
696         PL_leftgv = gv;
697         PL_sawampersand = TRUE;
698         goto ro_magicalize;
699
700     case '\'':
701         if (len > 1)
702             break;
703         PL_rightgv = gv;
704         PL_sawampersand = TRUE;
705         goto ro_magicalize;
706
707     case ':':
708         if (len > 1)
709             break;
710         sv_setpv(GvSV(gv),PL_chopset);
711         goto magicalize;
712
713     case '?':
714         if (len > 1)
715             break;
716 #ifdef COMPLEX_STATUS
717         sv_upgrade(GvSV(gv), SVt_PVLV);
718 #endif
719         goto magicalize;
720
721     case '!':
722         if (len > 1)
723             break;
724         if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
725             HV* stash = gv_stashpvn("Errno",5,FALSE);
726             if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
727                 dSP;
728                 PUTBACK;
729                 perl_require_pv("Errno.pm");
730                 SPAGAIN;
731                 stash = gv_stashpvn("Errno",5,FALSE);
732                 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
733                     croak("Can't use %%! because Errno.pm is not available");
734             }
735         }
736         goto magicalize;
737     case '#':
738     case '*':
739         if (PL_dowarn && len == 1 && sv_type == SVt_PV)
740             warn("Use of $%s is deprecated", name);
741         /* FALL THROUGH */
742     case '[':
743     case '^':
744     case '~':
745     case '=':
746     case '-':
747     case '%':
748     case '.':
749     case '(':
750     case ')':
751     case '<':
752     case '>':
753     case ',':
754     case '\\':
755     case '/':
756     case '|':
757     case '\001':
758     case '\004':
759     case '\005':
760     case '\006':
761     case '\010':
762     case '\017':
763     case '\t':
764     case '\020':
765     case '\024':
766     case '\027':
767         if (len > 1)
768             break;
769         goto magicalize;
770
771     case '+':
772     case '1':
773     case '2':
774     case '3':
775     case '4':
776     case '5':
777     case '6':
778     case '7':
779     case '8':
780     case '9':
781     case '\023':
782       ro_magicalize:
783         SvREADONLY_on(GvSV(gv));
784       magicalize:
785         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
786         break;
787
788     case '\014':
789         if (len > 1)
790             break;
791         sv_setpv(GvSV(gv),"\f");
792         PL_formfeed = GvSV(gv);
793         break;
794     case ';':
795         if (len > 1)
796             break;
797         sv_setpv(GvSV(gv),"\034");
798         break;
799     case ']':
800         if (len == 1) {
801             SV *sv = GvSV(gv);
802             sv_upgrade(sv, SVt_PVNV);
803             sv_setpv(sv, PL_patchlevel);
804             (void)sv_2nv(sv);
805             SvREADONLY_on(sv);
806         }
807         break;
808     }
809     return gv;
810 }
811
812 void
813 gv_fullname3(SV *sv, GV *gv, char *prefix)
814 {
815     HV *hv = GvSTASH(gv);
816     if (!hv) {
817         SvOK_off(sv);
818         return;
819     }
820     sv_setpv(sv, prefix ? prefix : "");
821     sv_catpv(sv,HvNAME(hv));
822     sv_catpvn(sv,"::", 2);
823     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
824 }
825
826 void
827 gv_efullname3(SV *sv, GV *gv, char *prefix)
828 {
829     GV *egv = GvEGV(gv);
830     if (!egv)
831         egv = gv;
832     gv_fullname3(sv, egv, prefix);
833 }
834
835 /* XXX compatibility with versions <= 5.003. */
836 void
837 gv_fullname(SV *sv, GV *gv)
838 {
839     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
840 }
841
842 /* XXX compatibility with versions <= 5.003. */
843 void
844 gv_efullname(SV *sv, GV *gv)
845 {
846     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
847 }
848
849 IO *
850 newIO(void)
851 {
852     dTHR;
853     IO *io;
854     GV *iogv;
855
856     io = (IO*)NEWSV(0,0);
857     sv_upgrade((SV *)io,SVt_PVIO);
858     SvREFCNT(io) = 1;
859     SvOBJECT_on(io);
860     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
861     if (!iogv)
862       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
863     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
864     return io;
865 }
866
867 void
868 gv_check(HV *stash)
869 {
870     dTHR;
871     register HE *entry;
872     register I32 i;
873     register GV *gv;
874     HV *hv;
875     GV *filegv;
876
877     if (!HvARRAY(stash))
878         return;
879     for (i = 0; i <= (I32) HvMAX(stash); i++) {
880         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
881             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
882                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
883             {
884                 if (hv != PL_defstash)
885                      gv_check(hv);              /* nested package */
886             }
887             else if (isALPHA(*HeKEY(entry))) {
888                 gv = (GV*)HeVAL(entry);
889                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
890                     continue;
891                 PL_curcop->cop_line = GvLINE(gv);
892                 filegv = GvFILEGV(gv);
893                 PL_curcop->cop_filegv = filegv;
894                 if (filegv && GvMULTI(filegv))  /* Filename began with slash */
895                     continue;
896                 warn("Name \"%s::%s\" used only once: possible typo",
897                         HvNAME(stash), GvNAME(gv));
898             }
899         }
900     }
901 }
902
903 GV *
904 newGVgen(char *pack)
905 {
906     return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)PL_gensym++),
907                       TRUE, SVt_PVGV);
908 }
909
910 /* hopefully this is only called on local symbol table entries */
911
912 GP*
913 gp_ref(GP *gp)
914 {
915     gp->gp_refcnt++;
916     if (gp->gp_cv) {
917         if (gp->gp_cvgen) {
918             /* multi-named GPs cannot be used for method cache */
919             SvREFCNT_dec(gp->gp_cv);
920             gp->gp_cv = Nullcv;
921             gp->gp_cvgen = 0;
922         }
923         else {
924             /* Adding a new name to a subroutine invalidates method cache */
925             PL_sub_generation++;
926         }
927     }
928     return gp;
929 }
930
931 void
932 gp_free(GV *gv)
933 {
934     GP* gp;
935     CV* cv;
936
937     if (!gv || !(gp = GvGP(gv)))
938         return;
939     if (gp->gp_refcnt == 0) {
940         warn("Attempt to free unreferenced glob pointers");
941         return;
942     }
943     if (gp->gp_cv) {
944         /* Deleting the name of a subroutine invalidates method cache */
945         PL_sub_generation++;
946     }
947     if (--gp->gp_refcnt > 0) {
948         if (gp->gp_egv == gv)
949             gp->gp_egv = 0;
950         return;
951     }
952
953     SvREFCNT_dec(gp->gp_sv);
954     SvREFCNT_dec(gp->gp_av);
955     SvREFCNT_dec(gp->gp_hv);
956     SvREFCNT_dec(gp->gp_io);
957     SvREFCNT_dec(gp->gp_cv);
958     SvREFCNT_dec(gp->gp_form);
959
960     Safefree(gp);
961     GvGP(gv) = 0;
962 }
963
964 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
965 #define MICROPORT
966 #endif
967
968 #ifdef  MICROPORT       /* Microport 2.4 hack */
969 AV *GvAVn(gv)
970 register GV *gv;
971 {
972     if (GvGP(gv)->gp_av) 
973         return GvGP(gv)->gp_av;
974     else
975         return GvGP(gv_AVadd(gv))->gp_av;
976 }
977
978 HV *GvHVn(gv)
979 register GV *gv;
980 {
981     if (GvGP(gv)->gp_hv)
982         return GvGP(gv)->gp_hv;
983     else
984         return GvGP(gv_HVadd(gv))->gp_hv;
985 }
986 #endif                  /* Microport 2.4 hack */
987
988 #ifdef OVERLOAD
989 /* Updates and caches the CV's */
990
991 bool
992 Gv_AMupdate(HV *stash)
993 {
994   dTHR;  
995   GV** gvp;
996   HV* hv;
997   GV* gv;
998   CV* cv;
999   MAGIC* mg=mg_find((SV*)stash,'c');
1000   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1001   AMT amt;
1002
1003   if (mg && amtp->was_ok_am == PL_amagic_generation
1004       && amtp->was_ok_sub == PL_sub_generation)
1005       return AMT_AMAGIC(amtp);
1006   if (amtp && AMT_AMAGIC(amtp)) {       /* Have table. */
1007     int i;
1008     for (i=1; i<NofAMmeth; i++) {
1009       if (amtp->table[i]) {
1010         SvREFCNT_dec(amtp->table[i]);
1011       }
1012     }
1013   }
1014   sv_unmagic((SV*)stash, 'c');
1015
1016   DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
1017
1018   amt.was_ok_am = PL_amagic_generation;
1019   amt.was_ok_sub = PL_sub_generation;
1020   amt.fallback = AMGfallNO;
1021   amt.flags = 0;
1022
1023 #ifdef OVERLOAD_VIA_HASH
1024   gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1025   if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1026     int filled=0;
1027     int i;
1028     char *cp;
1029     SV* sv;
1030     SV** svp;
1031
1032     /* Work with "fallback" key, which we assume to be first in AMG_names */
1033
1034     if (( cp = (char *)AMG_names[0] ) &&
1035         (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1036       if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1037       else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1038     }
1039     for (i = 1; i < NofAMmeth; i++) {
1040       cv = 0;
1041       cp = (char *)AMG_names[i];
1042       
1043         svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1044         if (svp && ((sv = *svp) != &PL_sv_undef)) {
1045           switch (SvTYPE(sv)) {
1046             default:
1047               if (!SvROK(sv)) {
1048                 if (!SvOK(sv)) break;
1049                 gv = gv_fetchmethod(stash, SvPV(sv, na));
1050                 if (gv) cv = GvCV(gv);
1051                 break;
1052               }
1053               cv = (CV*)SvRV(sv);
1054               if (SvTYPE(cv) == SVt_PVCV)
1055                   break;
1056                 /* FALL THROUGH */
1057             case SVt_PVHV:
1058             case SVt_PVAV:
1059               croak("Not a subroutine reference in overload table");
1060               return FALSE;
1061             case SVt_PVCV:
1062               cv = (CV*)sv;
1063               break;
1064             case SVt_PVGV:
1065               if (!(cv = GvCVu((GV*)sv)))
1066                 cv = sv_2cv(sv, &stash, &gv, TRUE);
1067               break;
1068           }
1069           if (cv) filled=1;
1070           else {
1071             croak("Method for operation %s not found in package %.256s during blessing\n",
1072                 cp,HvNAME(stash));
1073             return FALSE;
1074           }
1075         }
1076 #else
1077   {
1078     int filled = 0;
1079     int i;
1080     const char *cp;
1081     SV* sv = NULL;
1082     SV** svp;
1083
1084     /* Work with "fallback" key, which we assume to be first in AMG_names */
1085
1086     if ( cp = AMG_names[0] ) {
1087         /* Try to find via inheritance. */
1088         gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1089         if (gv) sv = GvSV(gv);
1090
1091         if (!gv) goto no_table;
1092         else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1093         else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1094     }
1095
1096     for (i = 1; i < NofAMmeth; i++) {
1097         SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
1098         DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
1099                      cp, HvNAME(stash)) );
1100         /* don't fill the cache while looking up! */
1101         gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1102         cv = 0;
1103         if(gv && (cv = GvCV(gv))) {
1104             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1105                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1106                 /* GvSV contains the name of the method. */
1107                 GV *ngv;
1108                 
1109                 DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", 
1110                              SvPV(GvSV(gv), PL_na), cp, HvNAME(stash)) );
1111                 if (!SvPOK(GvSV(gv)) 
1112                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1113                                                        FALSE)))
1114                 {
1115                     /* Can be an import stub (created by `can'). */
1116                     if (GvCVGEN(gv)) {
1117                         croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", 
1118                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1119                               cp, HvNAME(stash));
1120                     } else
1121                         croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'", 
1122                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1123                               cp, HvNAME(stash));
1124                 }
1125                 cv = GvCV(gv = ngv);
1126             }
1127             DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1128                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1129                          GvNAME(CvGV(cv))) );
1130             filled = 1;
1131         }
1132 #endif 
1133         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1134     }
1135     if (filled) {
1136       AMT_AMAGIC_on(&amt);
1137       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1138       return TRUE;
1139     }
1140   }
1141   /* Here we have no table: */
1142  no_table:
1143   AMT_AMAGIC_off(&amt);
1144   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1145   return FALSE;
1146 }
1147
1148 SV*
1149 amagic_call(SV *left, SV *right, int method, int flags)
1150 {
1151   dTHR;
1152   MAGIC *mg; 
1153   CV *cv; 
1154   CV **cvp=NULL, **ocvp=NULL;
1155   AMT *amtp, *oamtp;
1156   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1157   int postpr=0, inc_dec_ass=0, assignshift=assign?1:0;
1158   HV* stash;
1159   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1160       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1161       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 
1162                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1163                         : (CV **) NULL))
1164       && ((cv = cvp[off=method+assignshift]) 
1165           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1166                                                           * usual method */
1167                   (fl = 1, cv = cvp[off=method])))) {
1168     lr = -1;                    /* Call method for left argument */
1169   } else {
1170     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1171       int logic;
1172
1173       /* look for substituted methods */
1174          switch (method) {
1175          case inc_amg:
1176            if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1))
1177                || ((cv = cvp[off=add_amg]) && (postpr=1))) {
1178              right = &PL_sv_yes; lr = -1; assign = 1;
1179            }
1180            break;
1181          case dec_amg:
1182            if (((cv = cvp[off=subtr_ass_amg])  && (inc_dec_ass=1))
1183                || ((cv = cvp[off=subtr_amg]) && (postpr=1))) {
1184              right = &PL_sv_yes; lr = -1; assign = 1;
1185            }
1186            break;
1187          case bool__amg:
1188            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1189            break;
1190          case numer_amg:
1191            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1192            break;
1193          case string_amg:
1194            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1195            break;
1196  case not_amg:
1197    (void)((cv = cvp[off=bool__amg]) 
1198           || (cv = cvp[off=numer_amg])
1199           || (cv = cvp[off=string_amg]));
1200    postpr = 1;
1201    break;
1202          case copy_amg:
1203            {
1204              /*
1205                   * SV* ref causes confusion with the interpreter variable of
1206                   * the same name
1207                   */
1208              SV* tmpRef=SvRV(left);
1209              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1210                 /*
1211                  * Just to be extra cautious.  Maybe in some
1212                  * additional cases sv_setsv is safe, too.
1213                  */
1214                 SV* newref = newSVsv(tmpRef);
1215                 SvOBJECT_on(newref);
1216                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1217                 return newref;
1218              }
1219            }
1220            break;
1221          case abs_amg:
1222            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 
1223                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1224              SV* nullsv=sv_2mortal(newSViv(0));
1225              if (off1==lt_amg) {
1226                SV* lessp = amagic_call(left,nullsv,
1227                                        lt_amg,AMGf_noright);
1228                logic = SvTRUE(lessp);
1229              } else {
1230                SV* lessp = amagic_call(left,nullsv,
1231                                        ncmp_amg,AMGf_noright);
1232                logic = (SvNV(lessp) < 0);
1233              }
1234              if (logic) {
1235                if (off==subtr_amg) {
1236                  right = left;
1237                  left = nullsv;
1238                  lr = 1;
1239                }
1240              } else {
1241                return left;
1242              }
1243            }
1244            break;
1245          case neg_amg:
1246            if (cv = cvp[off=subtr_amg]) {
1247              right = left;
1248              left = sv_2mortal(newSViv(0));
1249              lr = 1;
1250            }
1251            break;
1252          default:
1253            goto not_found;
1254          }
1255          if (!cv) goto not_found;
1256     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1257                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1258                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 
1259                           ? (amtp = (AMT*)mg->mg_ptr)->table
1260                           : (CV **) NULL))
1261                && (cv = cvp[off=method])) { /* Method for right
1262                                              * argument found */
1263       lr=1;
1264     } else if (((ocvp && oamtp->fallback > AMGfallNEVER 
1265                  && (cvp=ocvp) && (lr = -1)) 
1266                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1267                && !(flags & AMGf_unary)) {
1268                                 /* We look for substitution for
1269                                  * comparison operations and
1270                                  * concatenation */
1271       if (method==concat_amg || method==concat_ass_amg
1272           || method==repeat_amg || method==repeat_ass_amg) {
1273         return NULL;            /* Delegate operation to string conversion */
1274       }
1275       off = -1;
1276       switch (method) {
1277          case lt_amg:
1278          case le_amg:
1279          case gt_amg:
1280          case ge_amg:
1281          case eq_amg:
1282          case ne_amg:
1283            postpr = 1; off=ncmp_amg; break;
1284          case slt_amg:
1285          case sle_amg:
1286          case sgt_amg:
1287          case sge_amg:
1288          case seq_amg:
1289          case sne_amg:
1290            postpr = 1; off=scmp_amg; break;
1291          }
1292       if (off != -1) cv = cvp[off];
1293       if (!cv) {
1294         goto not_found;
1295       }
1296     } else {
1297     not_found:                  /* No method found, either report or croak */
1298       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1299         notfound = 1; lr = -1;
1300       } else if (cvp && (cv=cvp[nomethod_amg])) {
1301         notfound = 1; lr = 1;
1302       } else {
1303         SV *msg;
1304         if (off==-1) off=method;
1305         msg = sv_2mortal(newSVpvf(
1306                       "Operation `%s': no method found,%sargument %s%s%s%s",
1307                       AMG_names[method + assignshift],
1308                       (flags & AMGf_unary ? " " : "\n\tleft "),
1309                       SvAMAGIC(left)? 
1310                         "in overloaded package ":
1311                         "has no overloaded magic",
1312                       SvAMAGIC(left)? 
1313                         HvNAME(SvSTASH(SvRV(left))):
1314                         "",
1315                       SvAMAGIC(right)? 
1316                         ",\n\tright argument in overloaded package ":
1317                         (flags & AMGf_unary 
1318                          ? ""
1319                          : ",\n\tright argument has no overloaded magic"),
1320                       SvAMAGIC(right)? 
1321                         HvNAME(SvSTASH(SvRV(right))):
1322                         ""));
1323         if (amtp && amtp->fallback >= AMGfallYES) {
1324           DEBUG_o( deb("%s", SvPVX(msg)) );
1325         } else {
1326           croak("%_", msg);
1327         }
1328         return NULL;
1329       }
1330     }
1331   }
1332   if (!notfound) {
1333     DEBUG_o( deb(
1334   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1335                  AMG_names[off],
1336                  method+assignshift==off? "" :
1337                              " (initially `",
1338                  method+assignshift==off? "" :
1339                              AMG_names[method+assignshift],
1340                  method+assignshift==off? "" : "')",
1341                  flags & AMGf_unary? "" :
1342                    lr==1 ? " for right argument": " for left argument",
1343                  flags & AMGf_unary? " for argument" : "",
1344                  HvNAME(stash), 
1345                  fl? ",\n\tassignment variant used": "") );
1346     /* Since we use shallow copy during assignment, we need
1347      * to dublicate the contents, probably calling user-supplied
1348      * version of copy operator
1349      */
1350     if ((method + assignshift==off 
1351          && (assign || method==inc_amg || method==dec_amg))
1352         || inc_dec_ass) RvDEEPCP(left);
1353   }
1354   {
1355     dSP;
1356     BINOP myop;
1357     SV* res;
1358     bool oldcatch = CATCH_GET;
1359
1360     CATCH_SET(TRUE);
1361     Zero(&myop, 1, BINOP);
1362     myop.op_last = (OP *) &myop;
1363     myop.op_next = Nullop;
1364     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1365
1366     PUSHSTACKi(PERLSI_OVERLOAD);
1367     ENTER;
1368     SAVEOP();
1369     op = (OP *) &myop;
1370     if (PERLDB_SUB && PL_curstash != PL_debstash)
1371         op->op_private |= OPpENTERSUB_DB;
1372     PUTBACK;
1373     pp_pushmark(ARGS);
1374
1375     EXTEND(SP, notfound + 5);
1376     PUSHs(lr>0? right: left);
1377     PUSHs(lr>0? left: right);
1378     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1379     if (notfound) {
1380       PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
1381     }
1382     PUSHs((SV*)cv);
1383     PUTBACK;
1384
1385     if (op = pp_entersub(ARGS))
1386       CALLRUNOPS();
1387     LEAVE;
1388     SPAGAIN;
1389
1390     res=POPs;
1391     POPSTACK;
1392     CATCH_SET(oldcatch);
1393
1394     if (postpr) {
1395       int ans;
1396       switch (method) {
1397       case le_amg:
1398       case sle_amg:
1399         ans=SvIV(res)<=0; break;
1400       case lt_amg:
1401       case slt_amg:
1402         ans=SvIV(res)<0; break;
1403       case ge_amg:
1404       case sge_amg:
1405         ans=SvIV(res)>=0; break;
1406       case gt_amg:
1407       case sgt_amg:
1408         ans=SvIV(res)>0; break;
1409       case eq_amg:
1410       case seq_amg:
1411         ans=SvIV(res)==0; break;
1412       case ne_amg:
1413       case sne_amg:
1414         ans=SvIV(res)!=0; break;
1415       case inc_amg:
1416       case dec_amg:
1417         SvSetSV(left,res); return left;
1418       case not_amg:
1419         ans=!SvOK(res); break;
1420       }
1421       return boolSV(ans);
1422     } else if (method==copy_amg) {
1423       if (!SvROK(res)) {
1424         croak("Copy method did not return a reference");
1425       }
1426       return SvREFCNT_inc(SvRV(res));
1427     } else {
1428       return res;
1429     }
1430   }
1431 }
1432 #endif /* OVERLOAD */
1433