This is my patch patch.1i for perl5.001.
[perl.git] / gv.c
1 /*    gv.c
2  *
3  *    Copyright (c) 1991-1994, 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 extern char rcsid[];
23
24 GV *
25 gv_AVadd(gv)
26 register GV *gv;
27 {
28     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
29         croak("Bad symbol for array");
30     if (!GvAV(gv))
31         GvAV(gv) = newAV();
32     return gv;
33 }
34
35 GV *
36 gv_HVadd(gv)
37 register GV *gv;
38 {
39     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
40         croak("Bad symbol for hash");
41     if (!GvHV(gv))
42         GvHV(gv) = newHV();
43     return gv;
44 }
45
46 GV *
47 gv_IOadd(gv)
48 register GV *gv;
49 {
50     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
51         croak("Bad symbol for filehandle");
52     if (!GvIOp(gv))
53         GvIOp(gv) = newIO();
54     return gv;
55 }
56
57 GV *
58 gv_fetchfile(name)
59 char *name;
60 {
61     char tmpbuf[1200];
62     GV *gv;
63
64     sprintf(tmpbuf,"::_<%s", name);
65     gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
66     sv_setpv(GvSV(gv), name);
67     if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm")))
68         SvMULTI_on(gv);
69     if (perldb)
70         hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
71     return gv;
72 }
73
74 void
75 gv_init(gv, stash, name, len, multi)
76 GV *gv;
77 HV *stash;
78 char *name;
79 STRLEN len;
80 int multi;
81 {
82     register GP *gp;
83
84     sv_upgrade(gv, SVt_PVGV);
85     if (SvLEN(gv))
86         Safefree(SvPVX(gv));
87     Newz(602,gp, 1, GP);
88     GvGP(gv) = gp_ref(gp);
89     GvREFCNT(gv) = 1;
90     GvSV(gv) = NEWSV(72,0);
91     GvLINE(gv) = curcop->cop_line;
92     GvFILEGV(gv) = curcop->cop_filegv;
93     GvEGV(gv) = gv;
94     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
95     GvSTASH(gv) = stash;
96     GvNAME(gv) = savepvn(name, len);
97     GvNAMELEN(gv) = len;
98     if (multi)
99         SvMULTI_on(gv);
100 }
101
102 static void
103 gv_init_sv(gv, sv_type)
104 GV* gv;
105 I32 sv_type;
106 {
107     switch (sv_type) {
108     case SVt_PVIO:
109         (void)GvIOn(gv);
110         break;
111     case SVt_PVAV:
112         (void)GvAVn(gv);
113         break;
114     case SVt_PVHV:
115         (void)GvHVn(gv);
116         break;
117     }
118 }
119
120 GV *
121 gv_fetchmeth(stash, name, len, level)
122 HV* stash;
123 char* name;
124 STRLEN len;
125 I32 level;
126 {
127     AV* av;
128     GV* topgv;
129     GV* gv;
130     GV** gvp;
131     HV* lastchance;
132     CV* cv;
133
134     if (!stash)
135         return 0;
136     if (level > 100)
137         croak("Recursive inheritance detected");
138
139     gvp = (GV**)hv_fetch(stash, name, len, TRUE);
140
141     DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
142     topgv = *gvp;
143     if (SvTYPE(topgv) != SVt_PVGV)
144         gv_init(topgv, stash, name, len, TRUE);
145
146     if (cv=GvCV(topgv)) {
147         if (GvCVGEN(topgv) >= sub_generation)
148             return topgv;       /* valid cached inheritance */
149         if (!GvCVGEN(topgv)) {  /* not an inheritance cache */
150             return topgv;
151         }
152         else {
153             /* stale cached entry, just junk it */
154             GvCV(topgv) = cv = 0;
155             GvCVGEN(topgv) = 0;
156         }
157     }
158     /* if cv is still set, we have to free it if we find something to cache */
159
160     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
161     if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
162         SV** svp = AvARRAY(av);
163         I32 items = AvFILL(av) + 1;
164         while (items--) {
165             SV* sv = *svp++;
166             HV* basestash = gv_stashsv(sv, FALSE);
167             if (!basestash) {
168                 if (dowarn)
169                     warn("Can't locate package %s for @%s::ISA",
170                         SvPVX(sv), HvNAME(stash));
171                 continue;
172             }
173             gv = gv_fetchmeth(basestash, name, len, level + 1);
174             if (gv) {
175                 if (cv) {                               /* junk old undef */
176                     assert(SvREFCNT(topgv) > 1);
177                     SvREFCNT_dec(topgv);
178                     SvREFCNT_dec(cv);
179                 }
180                 GvCV(topgv) = GvCV(gv);                 /* cache the CV */
181                 GvCVGEN(topgv) = sub_generation;        /* valid for now */
182                 return gv;
183             }
184         }
185     }
186
187     if (!level) {
188         if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) {
189             if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
190                 if (cv) {                               /* junk old undef */
191                     assert(SvREFCNT(topgv) > 1);
192                     SvREFCNT_dec(topgv);
193                     SvREFCNT_dec(cv);
194                 }
195                 GvCV(topgv) = GvCV(gv);                 /* cache the CV */
196                 GvCVGEN(topgv) = sub_generation;        /* valid for now */
197                 return gv;
198             }
199         }
200     }
201
202     return 0;
203 }
204
205 GV *
206 gv_fetchmethod(stash, name)
207 HV* stash;
208 char* name;
209 {
210     register char *nend;
211     char *nsplit = 0;
212     GV* gv;
213     
214     for (nend = name; *nend; nend++) {
215         if (*nend == ':' || *nend == '\'')
216             nsplit = nend;
217     }
218     if (nsplit) {
219         char ch;
220         char *origname = name;
221         name = nsplit + 1;
222         ch = *nsplit;
223         if (*nsplit == ':')
224             --nsplit;
225         *nsplit = '\0';
226         stash = gv_stashpv(origname,TRUE);
227         *nsplit = ch;
228     }
229     gv = gv_fetchmeth(stash, name, nend - name, 0);
230     if (!gv) {
231         CV* cv;
232
233         if (strEQ(name,"import") || strEQ(name,"unimport"))
234             gv = &sv_yes;
235         else if (strNE(name, "AUTOLOAD")) {
236             gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
237             if (gv && (cv = GvCV(gv))) { /* One more chance... */
238                 SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
239                 sv_catpvn(tmpstr,"::", 2);
240                 sv_catpvn(tmpstr, name, nend - name);
241                 sv_setsv(GvSV(CvGV(cv)), tmpstr);
242             }
243         }
244     }
245     return gv;
246 }
247
248 HV*
249 gv_stashpv(name,create)
250 char *name;
251 I32 create;
252 {
253     char tmpbuf[1234];
254     HV *stash;
255     GV *tmpgv;
256     sprintf(tmpbuf,"%.*s::",1200,name);
257     tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
258     if (!tmpgv)
259         return 0;
260     if (!GvHV(tmpgv))
261         GvHV(tmpgv) = newHV();
262     stash = GvHV(tmpgv);
263     if (!HvNAME(stash))
264         HvNAME(stash) = savepv(name);
265     return stash;
266 }
267
268 HV*
269 gv_stashsv(sv,create)
270 SV *sv;
271 I32 create;
272 {
273     return gv_stashpv(SvPV(sv,na), create);
274 }
275
276
277 GV *
278 gv_fetchpv(nambeg,add,sv_type)
279 char *nambeg;
280 I32 add;
281 I32 sv_type;
282 {
283     register char *name = nambeg;
284     register GV *gv = 0;
285     GV**gvp;
286     I32 len;
287     register char *namend;
288     HV *stash = 0;
289     bool global = FALSE;
290     char *tmpbuf;
291
292     for (namend = name; *namend; namend++) {
293         if ((*namend == '\'' && namend[1]) ||
294             (*namend == ':' && namend[1] == ':'))
295         {
296             if (!stash)
297                 stash = defstash;
298             if (!SvREFCNT(stash))       /* symbol table under destruction */
299                 return Nullgv;
300
301             len = namend - name;
302             if (len > 0) {
303                 New(601, tmpbuf, len+3, char);
304                 Copy(name, tmpbuf, len, char);
305                 tmpbuf[len++] = ':';
306                 tmpbuf[len++] = ':';
307                 tmpbuf[len] = '\0';
308                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
309                 Safefree(tmpbuf);
310                 if (!gvp || *gvp == (GV*)&sv_undef)
311                     return Nullgv;
312                 gv = *gvp;
313
314                 if (SvTYPE(gv) == SVt_PVGV)
315                     SvMULTI_on(gv);
316                 else if (!add)
317                     return Nullgv;
318                 else
319                     gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
320
321                 if (!(stash = GvHV(gv)))
322                     stash = GvHV(gv) = newHV();
323
324                 if (!HvNAME(stash))
325                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
326             }
327
328             if (*namend == ':')
329                 namend++;
330             namend++;
331             name = namend;
332             if (!*name)
333                 return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE);
334         }
335     }
336     len = namend - name;
337     if (!len)
338         len = 1;
339
340     /* No stash in name, so see how we can default */
341
342     if (!stash) {
343         if (isIDFIRST(*name)) {
344             if (isUPPER(*name)) {
345                 if (*name > 'I') {
346                     if (*name == 'S' && (
347                       strEQ(name, "SIG") ||
348                       strEQ(name, "STDIN") ||
349                       strEQ(name, "STDOUT") ||
350                       strEQ(name, "STDERR") ))
351                         global = TRUE;
352                 }
353                 else if (*name > 'E') {
354                     if (*name == 'I' && strEQ(name, "INC"))
355                         global = TRUE;
356                 }
357                 else if (*name > 'A') {
358                     if (*name == 'E' && strEQ(name, "ENV"))
359                         global = TRUE;
360                 }
361                 else if (*name == 'A' && (
362                   strEQ(name, "ARGV") ||
363                   strEQ(name, "ARGVOUT") ))
364                     global = TRUE;
365             }
366             else if (*name == '_' && !name[1])
367                 global = TRUE;
368             if (global)
369                 stash = defstash;
370             else if ((COP*)curcop == &compiling) {
371                 stash = curstash;
372                 if (add && (hints & HINT_STRICT_VARS) &&
373                     sv_type != SVt_PVCV &&
374                     sv_type != SVt_PVGV &&
375                     sv_type != SVt_PVIO)
376                 {
377                         stash = 0;
378                 }
379             }
380             else
381                 stash = curcop->cop_stash;
382         }
383         else
384             stash = defstash;
385     }
386
387     /* By this point we should have a stash and a name */
388
389     if (!stash) {
390         if (add) {
391             warn("Global symbol \"%s\" requires explicit package name", name);
392             ++error_count;
393             stash = curstash ? curstash : defstash;     /* avoid core dumps */
394         }
395         else
396             return Nullgv;
397     }
398
399     if (!SvREFCNT(stash))       /* symbol table under destruction */
400         return Nullgv;
401
402     gvp = (GV**)hv_fetch(stash,name,len,add);
403     if (!gvp || *gvp == (GV*)&sv_undef)
404         return Nullgv;
405     gv = *gvp;
406     if (SvTYPE(gv) == SVt_PVGV) {
407         if (add) {
408             SvMULTI_on(gv);
409             gv_init_sv(gv, sv_type);
410         }
411         return gv;
412     }
413
414     /* Adding a new symbol */
415
416     if (add & 4)
417         warn("Had to create %s unexpectedly", nambeg);
418     gv_init(gv, stash, name, len, add & 2);
419     gv_init_sv(gv, sv_type);
420
421     /* set up magic where warranted */
422     switch (*name) {
423     case 'A':
424         if (strEQ(name, "ARGV")) {
425             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
426         }
427         break;
428
429     case 'a':
430     case 'b':
431         if (len == 1)
432             SvMULTI_on(gv);
433         break;
434     case 'E':
435         if (strnEQ(name, "EXPORT", 6))
436             SvMULTI_on(gv);
437         break;
438     case 'I':
439         if (strEQ(name, "ISA")) {
440             AV* av = GvAVn(gv);
441             SvMULTI_on(gv);
442             sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
443             if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
444             {
445                 char *pname;
446                 av_push(av, newSVpv(pname = "NDBM_File",0));
447                 gv_stashpv(pname, TRUE);
448                 av_push(av, newSVpv(pname = "DB_File",0));
449                 gv_stashpv(pname, TRUE);
450                 av_push(av, newSVpv(pname = "GDBM_File",0));
451                 gv_stashpv(pname, TRUE);
452                 av_push(av, newSVpv(pname = "SDBM_File",0));
453                 gv_stashpv(pname, TRUE);
454                 av_push(av, newSVpv(pname = "ODBM_File",0));
455                 gv_stashpv(pname, TRUE);
456             }
457         }
458         break;
459 #ifdef OVERLOAD
460     case 'O':
461         if (strEQ(name, "OVERLOAD")) {
462             HV* hv = GvHVn(gv);
463             SvMULTI_on(gv);
464             sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
465         }
466         break;
467 #endif /* OVERLOAD */
468     case 'S':
469         if (strEQ(name, "SIG")) {
470             HV *hv;
471             siggv = gv;
472             SvMULTI_on(siggv);
473             hv = GvHVn(siggv);
474             hv_magic(hv, siggv, 'S');
475
476             /* initialize signal stack */
477             signalstack = newAV();
478             AvREAL_off(signalstack);
479             av_extend(signalstack, 30);
480             av_fill(signalstack, 0);
481         }
482         break;
483
484     case '&':
485         if (len > 1)
486             break;
487         ampergv = gv;
488         sawampersand = TRUE;
489         goto ro_magicalize;
490
491     case '`':
492         if (len > 1)
493             break;
494         leftgv = gv;
495         sawampersand = TRUE;
496         goto ro_magicalize;
497
498     case '\'':
499         if (len > 1)
500             break;
501         rightgv = gv;
502         sawampersand = TRUE;
503         goto ro_magicalize;
504
505     case ':':
506         if (len > 1)
507             break;
508         sv_setpv(GvSV(gv),chopset);
509         goto magicalize;
510
511     case '#':
512     case '*':
513         if (dowarn && len == 1 && sv_type == SVt_PV)
514             warn("Use of $%s is deprecated", name);
515         /* FALL THROUGH */
516     case '[':
517     case '!':
518     case '?':
519     case '^':
520     case '~':
521     case '=':
522     case '-':
523     case '%':
524     case '.':
525     case '(':
526     case ')':
527     case '<':
528     case '>':
529     case ',':
530     case '\\':
531     case '/':
532     case '|':
533     case '\001':
534     case '\004':
535     case '\006':
536     case '\010':
537     case '\t':
538     case '\020':
539     case '\024':
540     case '\027':
541         if (len > 1)
542             break;
543         goto magicalize;
544
545     case '+':
546     case '1':
547     case '2':
548     case '3':
549     case '4':
550     case '5':
551     case '6':
552     case '7':
553     case '8':
554     case '9':
555       ro_magicalize:
556         SvREADONLY_on(GvSV(gv));
557       magicalize:
558         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
559         break;
560
561     case '\014':
562         if (len > 1)
563             break;
564         sv_setpv(GvSV(gv),"\f");
565         formfeed = GvSV(gv);
566         break;
567     case ';':
568         if (len > 1)
569             break;
570         sv_setpv(GvSV(gv),"\034");
571         break;
572     case ']':
573         if (len == 1) {
574             SV *sv;
575             sv = GvSV(gv);
576             sv_upgrade(sv, SVt_PVNV);
577             sv_setpv(sv, patchlevel);
578         }
579         break;
580     }
581     return gv;
582 }
583
584 void
585 gv_fullname(sv,gv)
586 SV *sv;
587 GV *gv;
588 {
589     HV *hv = GvSTASH(gv);
590
591     if (!hv)
592         return;
593     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
594     sv_catpv(sv,HvNAME(hv));
595     sv_catpvn(sv,"::", 2);
596     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
597 }
598
599 void
600 gv_efullname(sv,gv)
601 SV *sv;
602 GV *gv;
603 {
604     GV* egv = GvEGV(gv);
605     HV *hv;
606     
607     if (!egv)
608         egv = gv;
609     hv = GvSTASH(egv);
610     if (!hv)
611         return;
612
613     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
614     sv_catpv(sv,HvNAME(hv));
615     sv_catpvn(sv,"::", 2);
616     sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
617 }
618
619 IO *
620 newIO()
621 {
622     IO *io;
623     GV *iogv;
624
625     io = (IO*)NEWSV(0,0);
626     sv_upgrade((SV *)io,SVt_PVIO);
627     SvREFCNT(io) = 1;
628     SvOBJECT_on(io);
629     iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO);
630     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
631     return io;
632 }
633
634 void
635 gv_check(stash)
636 HV* stash;
637 {
638     register HE *entry;
639     register I32 i;
640     register GV *gv;
641     HV *hv;
642     GV *filegv;
643
644     if (!HvARRAY(stash))
645         return;
646     for (i = 0; i <= (I32) HvMAX(stash); i++) {
647         for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
648             if (entry->hent_key[entry->hent_klen-1] == ':' &&
649                 (gv = (GV*)entry->hent_val) && (hv = GvHV(gv)) && HvNAME(hv))
650             {
651                 if (hv != defstash)
652                      gv_check(hv);              /* nested package */
653             }
654             else if (isALPHA(*entry->hent_key)) {
655                 gv = (GV*)entry->hent_val;
656                 if (SvMULTI(gv))
657                     continue;
658                 curcop->cop_line = GvLINE(gv);
659                 filegv = GvFILEGV(gv);
660                 curcop->cop_filegv = filegv;
661                 if (filegv && SvMULTI(filegv))  /* Filename began with slash */
662                     continue;
663                 warn("Identifier \"%s::%s\" used only once: possible typo",
664                         HvNAME(stash), GvNAME(gv));
665             }
666         }
667     }
668 }
669
670 GV *
671 newGVgen(pack)
672 char *pack;
673 {
674     (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++);
675     return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
676 }
677
678 /* hopefully this is only called on local symbol table entries */
679
680 GP*
681 gp_ref(gp)
682 GP* gp;
683 {
684     gp->gp_refcnt++;
685     return gp;
686
687 }
688
689 void
690 gp_free(gv)
691 GV* gv;
692 {
693     IO *io;
694     CV *cv;
695     GP* gp;
696
697     if (!gv || !(gp = GvGP(gv)))
698         return;
699     if (gp->gp_refcnt == 0) {
700         warn("Attempt to free unreferenced glob pointers");
701         return;
702     }
703     if (--gp->gp_refcnt > 0) {
704         if (gp->gp_egv == gv)
705             gp->gp_egv = 0;
706         return;
707     }
708
709     SvREFCNT_dec(gp->gp_sv);
710     SvREFCNT_dec(gp->gp_av);
711     SvREFCNT_dec(gp->gp_hv);
712     if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
713         do_close(gv,FALSE);
714         SvREFCNT_dec(io);
715     }
716     if ((cv = gp->gp_cv) && !GvCVGEN(gv))
717         SvREFCNT_dec(cv);
718     SvREFCNT_dec(gp->gp_form);
719
720     Safefree(gp);
721     GvGP(gv) = 0;
722 }
723
724 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
725 #define MICROPORT
726 #endif
727
728 #ifdef  MICROPORT       /* Microport 2.4 hack */
729 AV *GvAVn(gv)
730 register GV *gv;
731 {
732     if (GvGP(gv)->gp_av) 
733         return GvGP(gv)->gp_av;
734     else
735         return GvGP(gv_AVadd(gv))->gp_av;
736 }
737
738 HV *GvHVn(gv)
739 register GV *gv;
740 {
741     if (GvGP(gv)->gp_hv)
742         return GvGP(gv)->gp_hv;
743     else
744         return GvGP(gv_HVadd(gv))->gp_hv;
745 }
746 #endif                  /* Microport 2.4 hack */
747
748 #ifdef OVERLOAD
749 /* Updates and caches the CV's */
750
751 bool
752 Gv_AMupdate(stash)
753 HV* stash;
754 {
755   GV** gvp;
756   HV* hv;
757   GV* gv;
758   CV* cv;
759   MAGIC* mg=mg_find((SV*)stash,'c');
760   AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
761
762   if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation &&
763              amtp->was_ok_sub == sub_generation)
764       return HV_AMAGIC(stash)? TRUE: FALSE;
765   gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);
766   if (amtp && amtp->table) {
767     int i;
768     for (i=1;i<NofAMmeth*2;i++) {
769       if (amtp->table[i]) {
770         SvREFCNT_dec(amtp->table[i]);
771       }
772     }
773   }
774   sv_unmagic((SV*)stash, 'c');
775
776   DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
777
778   if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) {
779     int filled=0;
780     int i;
781     char *cp;
782     AMT amt;
783     SV* sv;
784     SV** svp;
785
786 /*  if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) {
787       DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash))
788 );
789       return HV_AMAGIC(stash)? TRUE: FALSE;
790     }*/
791
792     amt.was_ok_am=amagic_generation;
793     amt.was_ok_sub=sub_generation;
794     amt.fallback=AMGfallNO;
795
796     /* Work with "fallback" key, which we assume to be first in AMG_names */
797
798     if ((cp=((char**)(*AMG_names))[0]) &&
799         (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
800       if (SvTRUE(sv)) amt.fallback=AMGfallYES;
801       else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
802     }
803
804     for (i=1;i<NofAMmeth*2;i++) {
805       cv=0;
806
807       if ( (cp=((char**)(*AMG_names))[i]) ) {
808         svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
809         if (svp && ((sv = *svp) != (GV*)&sv_undef)) {
810           switch (SvTYPE(sv)) {
811             default:
812               if (!SvROK(sv)) {
813                 if (!SvOK(sv)) break;
814                 gv = gv_fetchmethod(stash, SvPV(sv, na));
815                 if (gv) cv = GvCV(gv);
816                 break;
817               }
818               cv = (CV*)SvRV(sv);
819               if (SvTYPE(cv) == SVt_PVCV)
820                   break;
821                 /* FALL THROUGH */
822             case SVt_PVHV:
823             case SVt_PVAV:
824               die("Not a subroutine reference in %%OVERLOAD");
825               return FALSE;
826             case SVt_PVCV:
827                 cv = (CV*)sv;
828                 break;
829             case SVt_PVGV:
830                 if (!(cv = GvCV((GV*)sv)))
831                     cv = sv_2cv(sv, &stash, &gv, TRUE);
832                 break;
833           }
834           if (cv) filled=1;
835           else {
836             die("Method for operation %s not found in package %.200s during blessing\n",
837                 cp,HvNAME(stash));
838             return FALSE;
839           }
840         }
841       }
842       amt.table[i]=(CV*)SvREFCNT_inc(cv);
843     }
844     sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt));
845     if (filled) {
846 /*    HV_badAMAGIC_off(stash);*/
847       HV_AMAGIC_on(stash);
848       return TRUE;
849     }
850   }
851 /*HV_badAMAGIC_off(stash);*/
852   HV_AMAGIC_off(stash);
853   return FALSE;
854 }
855
856 /* During call to this subroutine stack can be reallocated. It is
857  * advised to call SPAGAIN macro in your code after call */
858
859 SV*
860 amagic_call(left,right,method,flags)
861 SV* left;
862 SV* right;
863 int method;
864 int flags; 
865 {
866   MAGIC *mg; 
867   CV *cv; 
868   CV **cvp=NULL, **ocvp=NULL;
869   AMT *amtp, *oamtp;
870   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
871   int postpr=0, inc_dec_ass=0, assignshift=assign?1:0;
872   HV* stash;
873   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
874       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
875       && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table))
876       && ((cv = cvp[off=method+assignshift]) 
877           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
878                                                           * usual method */
879                   (fl = 1, cv = cvp[off=method])))) {
880     lr = -1;                    /* Call method for left argument */
881   } else {
882     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
883       int logic;
884
885       /* look for substituted methods */
886          switch (method) {
887          case inc_amg:
888            if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1))
889                || ((cv = cvp[off=add_amg]) && (postpr=1))) {
890              right = &sv_yes; lr = -1; assign = 1;
891            }
892            break;
893          case dec_amg:
894            if (((cv = cvp[off=subtr_ass_amg])  && (inc_dec_ass=1))
895                || ((cv = cvp[off=subtr_amg]) && (postpr=1))) {
896              right = &sv_yes; lr = -1; assign = 1;
897            }
898            break;
899          case bool__amg:
900            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
901            break;
902          case numer_amg:
903            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
904            break;
905          case string_amg:
906            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
907            break;
908          case copy_amg:
909            {
910              SV* ref=SvRV(left);
911              if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be
912                                                       * extra
913                                                       * causious,
914                                                       * maybe in some
915                                                       * additional
916                                                       * cases sv_setsv
917                                                       * is safe too */
918                 SV* newref = newSVsv(ref);
919                 SvOBJECT_on(newref);
920                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
921                 return newref;
922              }
923            }
924            break;
925          case abs_amg:
926            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 
927                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
928              SV* nullsv=sv_2mortal(newSViv(0));
929              if (off1==lt_amg) {
930                SV* lessp = amagic_call(left,nullsv,
931                                        lt_amg,AMGf_noright);
932                logic = SvTRUE(lessp);
933              } else {
934                SV* lessp = amagic_call(left,nullsv,
935                                        ncmp_amg,AMGf_noright);
936                logic = (SvNV(lessp) < 0);
937              }
938              if (logic) {
939                if (off==subtr_amg) {
940                  right = left;
941                  left = nullsv;
942                  lr = 1;
943                }
944              } else {
945                return left;
946              }
947            }
948            break;
949          case neg_amg:
950            if (cv = cvp[off=subtr_amg]) {
951              right = left;
952              left = sv_2mortal(newSViv(0));
953              lr = 1;
954            }
955            break;
956          default:
957            goto not_found;
958          }
959          if (!cv) goto not_found;
960     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
961                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
962                && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table))
963                && (cv = cvp[off=method])) { /* Method for right
964                                              * argument found */
965       lr=1;
966     } else if (((ocvp && oamtp->fallback > AMGfallNEVER 
967                  && (cvp=ocvp) && (lr=-1)) 
968                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
969                && !(flags & AMGf_unary)) {
970                                 /* We look for substitution for
971                                  * comparison operations and
972                                  * concatendation */
973       if (method==concat_amg || method==concat_ass_amg
974           || method==repeat_amg || method==repeat_ass_amg) {
975         return NULL;            /* Delegate operation to string conversion */
976       }
977       off = -1;
978       switch (method) {
979          case lt_amg:
980          case le_amg:
981          case gt_amg:
982          case ge_amg:
983          case eq_amg:
984          case ne_amg:
985            postpr = 1; off=ncmp_amg; break;
986          case slt_amg:
987          case sle_amg:
988          case sgt_amg:
989          case sge_amg:
990          case seq_amg:
991          case sne_amg:
992            postpr = 1; off=scmp_amg; break;
993          }
994       if (off != -1) cv = cvp[off];
995       if (!cv) {
996         goto not_found;
997       }
998     } else {
999     not_found:                  /* No method found, either report or die */
1000       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1001         notfound = 1; lr = -1;
1002       } else if (cvp && (cv=cvp[nomethod_amg])) {
1003         notfound = 1; lr = 1;
1004       } else {
1005         char tmpstr[512];
1006         if (off==-1) off=method;
1007         sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%.200s,\n\tright argument %s%.200s",
1008                       ((char**)AMG_names)[off],
1009                       SvAMAGIC(left)? 
1010                         "in overloaded package ":
1011                         "has no overloaded magic",
1012                       SvAMAGIC(left)? 
1013                         HvNAME(SvSTASH(SvRV(left))):
1014                         "",
1015                       SvAMAGIC(right)? 
1016                         "in overloaded package ":
1017                         "has no overloaded magic",
1018                       SvAMAGIC(right)? 
1019                         HvNAME(SvSTASH(SvRV(right))):
1020                         "");
1021         if (amtp && amtp->fallback >= AMGfallYES) {
1022           DEBUG_o( deb(tmpstr) );
1023         } else {
1024           die(tmpstr);
1025         }
1026         return NULL;
1027       }
1028     }
1029   }
1030   if (!notfound) {
1031     DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.200s%s\n",
1032                  ((char**)AMG_names)[off],
1033                  method+assignshift==off? "" :
1034                              " (initially `",
1035                  method+assignshift==off? "" :
1036                              ((char**)AMG_names)[method+assignshift],
1037                  method+assignshift==off? "" : "')",
1038                  flags & AMGf_unary? "" :
1039                    lr==1 ? " for right argument": " for left argument",
1040                  flags & AMGf_unary? " for argument" : "",
1041                  HvNAME(stash), 
1042                  fl? ",\n\tassignment variant used": "") );
1043     /* Since we use shallow copy during assignment, we need
1044      * to dublicate the contents, probably calling user-supplied
1045      * version of copy operator
1046      */
1047     if ((method+assignshift==off 
1048          && (assign || method==inc_amg || method==dec_amg))
1049         || inc_dec_ass) RvDEEPCP(left);
1050   }
1051   {
1052     dSP;
1053     BINOP myop;
1054     SV* res;
1055
1056     Zero(&myop, 1, BINOP);
1057     myop.op_last = (OP *) &myop;
1058     myop.op_next = Nullop;
1059     myop.op_flags = OPf_KNOW|OPf_STACKED;
1060
1061     ENTER;
1062     SAVESPTR(op);
1063     op = (OP *) &myop;
1064     PUTBACK;
1065     pp_pushmark();
1066
1067     EXTEND(sp, notfound + 5);
1068     PUSHs(lr>0? right: left);
1069     PUSHs(lr>0? left: right);
1070     PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
1071     if (notfound) {
1072       PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[off],0)) );
1073     }
1074     PUSHs((SV*)cv);
1075     PUTBACK;
1076
1077     if (op = pp_entersub())
1078       run();
1079     LEAVE;
1080     SPAGAIN;
1081
1082     res=POPs;
1083     PUTBACK;
1084
1085     if (notfound) {
1086       /* sv_2mortal(res); */
1087       return NULL;
1088     }
1089
1090     if (postpr) {
1091       int ans;
1092       switch (method) {
1093       case le_amg:
1094       case sle_amg:
1095         ans=SvIV(res)<=0; break;
1096       case lt_amg:
1097       case slt_amg:
1098         ans=SvIV(res)<0; break;
1099       case ge_amg:
1100       case sge_amg:
1101         ans=SvIV(res)>=0; break;
1102       case gt_amg:
1103       case sgt_amg:
1104         ans=SvIV(res)>0; break;
1105       case eq_amg:
1106       case seq_amg:
1107         ans=SvIV(res)==0; break;
1108       case ne_amg:
1109       case sne_amg:
1110         ans=SvIV(res)!=0; break;
1111       case inc_amg:
1112       case dec_amg:
1113         SvSetSV(left,res); return res; break;
1114       }
1115       return ans? &sv_yes: &sv_no;
1116     } else if (method==copy_amg) {
1117       if (!SvROK(res)) {
1118         die("Copy method did not return a reference");
1119       }
1120       return SvREFCNT_inc(SvRV(res));
1121     } else {
1122       return res;
1123     }
1124   }
1125 }
1126 #endif /* OVERLOAD */