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