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