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