gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (c) 1991-1994, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
  12  * of your inquisitiveness, I shall spend all the rest of my days answering
  13  * you.  What more do you want to know?'
  14  *   'The names of all the stars, and of all living things, and the whole
  15  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
  16  * laughed Pippin.
  17  */
  18
  19 #include "EXTERN.h"
  20 #include "perl.h"
  21
  22 extern char rcsid[];
  23
  24 GV *
  25 gv_AVadd(gv)
  26 register GV *gv;
  27 {
  28     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  29         croak("Bad symbol for array");
  30     if (!GvAV(gv))
  31         GvAV(gv) = newAV();
  32     return gv;
  33 }
  34
  35 GV *
  36 gv_HVadd(gv)
  37 register GV *gv;
  38 {
  39     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  40         croak("Bad symbol for hash");
  41     if (!GvHV(gv))
  42         GvHV(gv) = newHV();
  43     return gv;
  44 }
  45
  46 GV *
  47 gv_IOadd(gv)
  48 register GV *gv;
  49 {
  50     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  51         croak("Bad symbol for filehandle");
  52     if (!GvIOp(gv))
  53         GvIOp(gv) = newIO();
  54     return gv;
  55 }
  56
  57 GV *
  58 gv_fetchfile(name)
  59 char *name;
  60 {
  61     char tmpbuf[1200];
  62     GV *gv;
  63
  64     sprintf(tmpbuf,"::_<%s", name);
  65     gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
  66     sv_setpv(GvSV(gv), name);
  67     if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm")))
  68         SvMULTI_on(gv);
  69     if (perldb)
  70         hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
  71     return gv;
  72 }
  73
  74 void
  75 gv_init(gv, stash, name, len, multi)
  76 GV *gv;
  77 HV *stash;
  78 char *name;
  79 STRLEN len;
  80 int multi;
  81 {
  82     register GP *gp;
  83
  84     sv_upgrade(gv, SVt_PVGV);
  85     if (SvLEN(gv))
  86         Safefree(SvPVX(gv));
  87     Newz(602,gp, 1, GP);
  88     GvGP(gv) = gp_ref(gp);
  89     GvREFCNT(gv) = 1;
  90     GvSV(gv) = NEWSV(72,0);
  91     GvLINE(gv) = curcop->cop_line;
  92     GvFILEGV(gv) = curcop->cop_filegv;
  93     GvEGV(gv) = gv;
  94     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
  95     GvSTASH(gv) = stash;
  96     GvNAME(gv) = savepvn(name, len);
  97     GvNAMELEN(gv) = len;
  98     if (multi)
  99         SvMULTI_on(gv);
 100 }
 101
 102 static void
 103 gv_init_sv(gv, sv_type)
 104 GV* gv;
 105 I32 sv_type;
 106 {
 107     switch (sv_type) {
 108     case SVt_PVIO:
 109         (void)GvIOn(gv);
 110         break;
 111     case SVt_PVAV:
 112         (void)GvAVn(gv);
 113         break;
 114     case SVt_PVHV:
 115         (void)GvHVn(gv);
 116         break;
 117     }
 118 }
 119
 120 GV *
 121 gv_fetchmeth(stash, name, len, level)
 122 HV* stash;
 123 char* name;
 124 STRLEN len;
 125 I32 level;
 126 {
 127     AV* av;
 128     GV* topgv;
 129     GV* gv;
 130     GV** gvp;
 131     HV* lastchance;
 132     CV* cv;
 133
 134     if (!stash)
 135         return 0;
 136     if (level > 100)
 137         croak("Recursive inheritance detected");
 138
 139     gvp = (GV**)hv_fetch(stash, name, len, TRUE);
 140
 141     DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
 142     topgv = *gvp;
 143     if (SvTYPE(topgv) != SVt_PVGV)
 144         gv_init(topgv, stash, name, len, TRUE);
 145
 146     if (cv=GvCV(topgv)) {
 147         if (GvCVGEN(topgv) >= sub_generation)
 148             return topgv;       /* valid cached inheritance */
 149         if (!GvCVGEN(topgv)) {  /* not an inheritance cache */
 150             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 */