gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (c) 1991-1997, 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 EXT 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     STRLEN tmplen;
  63     GV *gv;
  64
  65     sprintf(tmpbuf, "_<%s", name);
  66     tmplen = strlen(tmpbuf);
  67     gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE);
  68     if (!isGV(gv))
  69         gv_init(gv, defstash, tmpbuf, tmplen, FALSE);
  70     sv_setpv(GvSV(gv), name);
  71     if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
  72         GvMULTI_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((SV*)gv, SVt_PVGV);
  89     if (SvLEN(gv))
  90         Safefree(SvPVX(gv));
  91     Newz(602, gp, 1, GP);
  92     GvGP(gv) = gp_ref(gp);
  93     GvSV(gv) = NEWSV(72,0);
  94     GvLINE(gv) = curcop->cop_line;
  95     GvFILEGV(gv) = curcop->cop_filegv;
  96     GvEGV(gv) = gv;
  97     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
  98     GvSTASH(gv) = stash;
  99     GvNAME(gv) = savepvn(name, len);
 100     GvNAMELEN(gv) = len;
 101     if (multi)
 102         GvMULTI_on(gv);
 103 }
 104
 105 static void
 106 gv_init_sv(gv, sv_type)
 107 GV* gv;
 108 I32 sv_type;
 109 {
 110     switch (sv_type) {
 111     case SVt_PVIO:
 112         (void)GvIOn(gv);
 113         break;
 114     case SVt_PVAV:
 115         (void)GvAVn(gv);
 116         break;
 117     case SVt_PVHV:
 118         (void)GvHVn(gv);
 119         break;
 120     }
 121 }
 122
 123 GV *
 124 gv_fetchmeth(stash, name, len, level)
 125 HV* stash;
 126 char* name;
 127 STRLEN len;
 128 I32 level;
 129 {
 130     AV* av;
 131     GV* topgv;
 132     GV* gv;
 133     GV** gvp;
 134     CV* cv;
 135
 136     if (!stash)
 137         return 0;
 138     if ((level > 100) || (level < -100))
 139         croak("Recursive inheritance detected");
 140
 141     DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
 142
 143     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 144     if (!gvp)
 145         topgv = Nullgv;
 146     else {
 147         topgv = *gvp;
 148         if (SvTYPE(topgv) != SVt_PVGV)
 149             gv_init(topgv, stash, name, len, TRUE);
 150         if (cv = GvCV(topgv)) {
 151             /* If genuine method or valid cache entry, use it */
 152             if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
 153                 return topgv;
 154             /* Stale cached entry: junk it */
 155             SvREFCNT_dec(cv);
 156             GvCV(topgv) = cv = Nullcv;
 157             GvCVGEN(topgv) = 0;
 158         }
 159     }
 160
 161     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
 162     av = (gvp && (gv = *gvp) && gv != (GV*)&sv_undef) ? GvAV(gv) : Nullav;
 163
 164     /* create @.*::SUPER::ISA on demand */
 165     if (!av) {
 166         char* packname = HvNAME(stash);
 167         STRLEN packlen = strlen(packname);
 168
 169         if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
 170             HV* basestash;
 171
 172             packlen -= 7;
 173             basestash = gv_stashpvn(packname, packlen, TRUE);
 174             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
 175             if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
 176                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
 177                 if (!gvp || !(gv = *gvp))
 178                     croak("Cannot create %s::ISA", HvNAME(stash));
 179                 if (SvTYPE(gv) != SVt_PVGV)
 180                     gv_init(gv, stash, "ISA", 3, TRUE);
 181                 SvREFCNT_dec(GvAV(gv));
 182                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
 183             }
 184         }
 185     }
 186
 187     if (av) {
 188         SV** svp = AvARRAY(av);
 189         I32 items = AvFILL(av) + 1;
 190         while (items--) {
 191             SV* sv = *svp++;
 192             HV* basestash = gv_stashsv(sv, FALSE);
 193             if (!basestash) {
 194                 if (dowarn)
 195                     warn("Can't locate package %s for @%s::ISA",
 196                         SvPVX(sv), HvNAME(stash));
 197                 continue;
 198             }
 199             gv = gv_fetchmeth(basestash, name, len,
 200                               (level >= 0) ? level + 1 : level - 1);
 201             if (gv)
 202                 goto gotcha;
 203         }
 204     }
 205
 206     /* if at top level, try UNIVERSAL */
 207
 208     if (level == 0 || level == -1) {
 209         HV* lastchance;
 210
 211         if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
 212             if (gv = gv_fetchmeth(lastchance, name, len,
 213                                   (level >= 0) ? level + 1 : level - 1)) {
 214           gotcha:
 215                 /*
 216                  * Cache method in topgv if:
 217                  *  1. topgv has no synonyms (else inheritance crosses wires)
 218                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 219                  */
 220                 if (topgv &&
 221                     GvREFCNT(topgv) == 1 &&
 222                     (cv = GvCV(gv)) &&
 223                     (CvROOT(cv) || CvXSUB(cv)))
 224                 {
 225                     if (cv = GvCV(topgv))
 226                         SvREFCNT_dec(cv);
 227                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 228                     GvCVGEN(topgv) = sub_generation;
 229                 }
 230                 return gv;
 231             }
 232         }
 233     }
 234
 235     return 0;
 236 }
 237
 238 GV *
 239 gv_fetchmethod(stash, name)
 240 HV* stash;
 241 char* name;
 242 {
 243     return gv_fetchmethod_autoload(stash, name, TRUE);
 244 }
 245
 246 GV *
 247 gv_fetchmethod_autoload(stash, name, autoload)
 248 HV* stash;
 249 char* name;
 250 I32 autoload;
 251 {
 252     register char *nend;
 253     char *nsplit = 0;
 254     GV* gv;
 255
 256     for (nend = name; *nend; nend++) {
 257         if (*nend == '\'')
 258             nsplit = nend;
 259         else if (*nend == ':' && *(nend + 1) == ':')
 260             nsplit = ++nend;
 261     }
 262     if (nsplit) {
 263         char *origname = name;
 264         name = nsplit + 1;
 265         if (*nsplit == ':')
 266             --nsplit;
 267         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
 268             /* ->SUPER::method should really be looked up in original stash */
 269             SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash), 0));
 270             sv_catpvn(tmpstr, "::SUPER", 7);
 271             stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
 272             DEBUG_o( deb("Treating %s as %s::%s\n",
 273                          origname, HvNAME(stash), name) );
 274         }
 275         else
 276             stash = gv_stashpvn(origname, nsplit - origname, TRUE);
 277     }
 278
 279     gv = gv_fetchmeth(stash, name, nend - name, 0);
 280     if (!gv) {
 281         if (strEQ(name,"import"))
 282             gv = (GV*)&sv_yes;
 283         else if (autoload)
 284             gv = gv_autoload4(stash, name, nend - name, TRUE);
 285     }
 286     else if (autoload) {
 287         CV* cv = GvCV(gv);
 288         if (!CvROOT(cv) && !CvXSUB(cv)) {
 289             GV* stubgv;
 290             GV* autogv;
 291
 292             if (CvANON(cv))
 293                 stubgv = gv;
 294             else {
 295                 stubgv = CvGV(cv);
 296                 if (GvCV(stubgv) != cv)         /* orphaned import */
 297                     stubgv = gv;
 298             }
 299             autogv = gv_autoload4(GvSTASH(stubgv),
 300                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 301             if (autogv)
 302                 gv = autogv;
 303         }
 304     }
 305
 306     return gv;
 307 }
 308
 309 GV*
 310 gv_autoload4(stash, name, len, method)
 311 HV* stash;
 312 char* name;
 313 STRLEN len;
 314 I32 method;
 315 {
 316     static char autoload[] = "AUTOLOAD";
 317     static STRLEN autolen = 8;
 318     GV* gv;
 319     CV* cv;
 320     HV* varstash;
 321     GV* vargv;
 322     SV* varsv;
 323
 324     if (len == autolen && strnEQ(name, autoload, autolen))
 325         return Nullgv;
 326     if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 327         return Nullgv;
 328     cv = GvCV(gv);
 329
 330     /*
 331      * Inheriting AUTOLOAD for non-methods works ... for now.
 332      */
 333     if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
 334         warn(
 335           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 336              HvNAME(stash), (int)len, name);
 337
 338     /*
 339      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 340      * The subroutine's original name may not be "AUTOLOAD", so we don't
 341      * use that, but for lack of anything better we will use the sub's
 342      * original package to look up $AUTOLOAD.
 343      */
 344     varstash = GvSTASH(CvGV(cv));
 345     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
 346     if (!isGV(vargv))
 347         gv_init(vargv, varstash, autoload, autolen, FALSE);
 348     varsv = GvSV(vargv);
 349     sv_setpv(varsv, HvNAME(stash));
 350     sv_catpvn(varsv, "::", 2);
 351     sv_catpvn(varsv, name, len);
 352     SvTAINTED_off(varsv);
 353     return gv;
 354 }
 355
 356 HV*
 357 gv_stashpv(name,create)
 358 char *name;
 359 I32 create;
 360 {
 361     return gv_stashpvn(name, strlen(name), create);
 362 }
 363
 364 HV*
 365 gv_stashpvn(name,namelen,create)
 366 char *name;
 367 U32 namelen;
 368 I32 create;
 369 {
 370     char tmpbuf[1203];
 371     HV *stash;
 372     GV *tmpgv;
 373
 374     if (namelen > 1200) {
 375         namelen = 1200;
 376 #ifdef VMS
 377         warn("Weird package name \"%s\" truncated", name);
 378 #else
 379         warn("Weird package name \"%.*s...\" truncated", (int)namelen, name);
 380 #endif
 381     }
 382     Copy(name,tmpbuf,namelen,char);
 383     tmpbuf[namelen++] = ':';
 384     tmpbuf[namelen++] = ':';
 385     tmpbuf[namelen] = '\0';
 386     tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
 387     if (!tmpgv)
 388         return 0;
 389     if (!GvHV(tmpgv))
 390         GvHV(tmpgv) = newHV();
 391     stash = GvHV(tmpgv);
 392     if (!HvNAME(stash))
 393         HvNAME(stash) = savepv(name);
 394     return stash;
 395 }
 396
 397 HV*
 398 gv_stashsv(sv,create)
 399 SV *sv;
 400 I32 create;
 401 {
 402     register char *ptr;
 403     STRLEN len;
 404     ptr = SvPV(sv,len);
 405     return gv_stashpvn(ptr, len, create);
 406 }
 407
 408
 409 GV *
 410 gv_fetchpv(nambeg,add,sv_type)
 411 char *nambeg;
 412 I32 add;
 413 I32 sv_type;
 414 {
 415     register char *name = nambeg;
 416     register GV *gv = 0;
 417     GV**gvp;
 418     I32 len;
 419     register char *namend;
 420     HV *stash = 0;
 421     U32 add_gvflags = 0;
 422     char *tmpbuf;
 423
 424     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 425         name++;
 426
 427     for (namend = name; *namend; namend++) {
 428         if ((*namend == '\'' && namend[1]) ||
 429             (*namend == ':' && namend[1] == ':'))
 430         {
 431             if (!stash)
 432                 stash = defstash;
 433             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 434                 return Nullgv;
 435
 436             len = namend - name;
 437             if (len > 0) {
 438                 New(601, tmpbuf, len+3, char);
 439                 Copy(name, tmpbuf, len, char);
 440                 tmpbuf[len++] = ':';
 441                 tmpbuf[len++] = ':';
 442                 tmpbuf[len] = '\0';
 443                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 444                 Safefree(tmpbuf);
 445                 if (!gvp || *gvp == (GV*)&sv_undef)
 446                     return Nullgv;
 447                 gv = *gvp;
 448
 449                 if (SvTYPE(gv) == SVt_PVGV)
 450                     GvMULTI_on(gv);
 451                 else if (!add)
 452                     return Nullgv;
 453                 else
 454                     gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
 455
 456                 if (!(stash = GvHV(gv)))
 457                     stash = GvHV(gv) = newHV();
 458
 459                 if (!HvNAME(stash))
 460                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
 461             }
 462
 463             if (*namend == ':')
 464                 namend++;
 465             namend++;
 466             name = namend;
 467             if (!*name)
 468                 return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE);
 469         }
 470     }
 471     len = namend - name;
 472     if (!len)
 473         len = 1;
 474
 475     /* No stash in name, so see how we can default */
 476
 477     if (!stash) {
 478         if (isIDFIRST(*name)) {
 479             bool global = FALSE;
 480
 481             if (isUPPER(*name)) {
 482                 if (*name > 'I') {
 483                     if (*name == 'S' && (
 484                       strEQ(name, "SIG") ||
 485                       strEQ(name, "STDIN") ||
 486                       strEQ(name, "STDOUT") ||
 487                       strEQ(name, "STDERR") ))
 488                         global = TRUE;
 489                 }
 490                 else if (*name > 'E') {
 491                     if (*name == 'I' && strEQ(name, "INC"))
 492                         global = TRUE;
 493                 }
 494                 else if (*name > 'A') {
 495                     if (*name == 'E' && strEQ(name, "ENV"))
 496                         global = TRUE;
 497                 }
 498                 else if (*name == 'A' && (
 499                   strEQ(name, "ARGV") ||
 500                   strEQ(name, "ARGVOUT") ))
 501                     global = TRUE;
 502             }
 503             else if (*name == '_' && !name[1])
 504                 global = TRUE;
 505
 506             if (global)
 507                 stash = defstash;
 508             else if ((COP*)curcop == &compiling) {
 509                 stash = curstash;
 510                 if (add && (hints & HINT_STRICT_VARS) &&
 511                     sv_type != SVt_PVCV &&
 512                     sv_type != SVt_PVGV &&
 513                     sv_type != SVt_PVFM &&
 514                     sv_type != SVt_PVIO &&
 515                     !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
 516                 {
 517                     gvp = (GV**)hv_fetch(stash,name,len,0);
 518                     if (!gvp ||
 519                         *gvp == (GV*)&sv_undef ||
 520                         SvTYPE(*gvp) != SVt_PVGV)
 521                     {
 522                         stash = 0;
 523                     }
 524                     else if (sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp) ||
 525                              sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
 526                              sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
 527                     {
 528                         warn("Variable \"%c%s\" is not imported",
 529                             sv_type == SVt_PVAV ? '@' :
 530                             sv_type == SVt_PVHV ? '%' : '$',
 531                             name);
 532                         if (GvCVu(*gvp))
 533                             warn("(Did you mean &%s instead?)\n", name);
 534                         stash = 0;
 535                     }
 536                 }
 537             }
 538             else
 539                 stash = curcop->cop_stash;
 540         }
 541         else
 542             stash = defstash;
 543     }
 544
 545     /* By this point we should have a stash and a name */
 546
 547     if (!stash) {
 548         if (add) {
 549             warn("Global symbol \"%s\" requires explicit package name", name);
 550             ++error_count;
 551             stash = curstash ? curstash : defstash;     /* avoid core dumps */
 552             add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
 553                            : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
 554                            : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
 555                            : 0);
 556         }
 557         else
 558             return Nullgv;
 559     }
 560
 561     if (!SvREFCNT(stash))       /* symbol table under destruction */
 562         return Nullgv;
 563
 564     gvp = (GV**)hv_fetch(stash,name,len,add);
 565     if (!gvp || *gvp == (GV*)&sv_undef)
 566         return Nullgv;
 567     gv = *gvp;
 568     if (SvTYPE(gv) == SVt_PVGV) {
 569         if (add) {
 570             GvMULTI_on(gv);
 571             gv_init_sv(gv, sv_type);
 572         }
 573         return gv;
 574     }
 575
 576     /* Adding a new symbol */
 577
 578     if (add & 4)
 579         warn("Had to create %s unexpectedly", nambeg);
 580     gv_init(gv, stash, name, len, add & 2);
 581     gv_init_sv(gv, sv_type);
 582     GvFLAGS(gv) |= add_gvflags;
 583
 584     /* set up magic where warranted */
 585     switch (*name) {
 586     case 'A':
 587         if (strEQ(name, "ARGV")) {
 588             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 589         }
 590         break;
 591
 592     case 'a':
 593     case 'b':
 594         if (len == 1)
 595             GvMULTI_on(gv);
 596         break;
 597     case 'E':
 598         if (strnEQ(name, "EXPORT", 6))
 599             GvMULTI_on(gv);
 600         break;
 601     case 'I':
 602         if (strEQ(name, "ISA")) {
 603             AV* av = GvAVn(gv);
 604             GvMULTI_on(gv);
 605             sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
 606             if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
 607             {
 608                 char *pname;
 609                 av_push(av, newSVpv(pname = "NDBM_File",0));
 610                 gv_stashpvn(pname, 9, TRUE);
 611                 av_push(av, newSVpv(pname = "DB_File",0));
 612                 gv_stashpvn(pname, 7, TRUE);
 613                 av_push(av, newSVpv(pname = "GDBM_File",0));
 614                 gv_stashpvn(pname, 9, TRUE);
 615                 av_push(av, newSVpv(pname = "SDBM_File",0));
 616                 gv_stashpvn(pname, 9, TRUE);
 617                 av_push(av, newSVpv(pname = "ODBM_File",0));
 618                 gv_stashpvn(pname, 9, TRUE);
 619             }
 620         }
 621         break;
 622 #ifdef OVERLOAD
 623     case 'O':
 624         if (strEQ(name, "OVERLOAD")) {
 625             HV* hv = GvHVn(gv);
 626             GvMULTI_on(gv);
 627             sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
 628         }
 629         break;
 630 #endif /* OVERLOAD */
 631     case 'S':
 632         if (strEQ(name, "SIG")) {
 633             HV *hv;
 634             I32 i;
 635             siggv = gv;
 636             GvMULTI_on(siggv);
 637             hv = GvHVn(siggv);
 638             hv_magic(hv, siggv, 'S');
 639             for(i=1;sig_name[i];i++) {
 640                 SV ** init;
 641                 init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1);
 642                 if(init)
 643                         sv_setsv(*init,&sv_undef);
 644                 psig_ptr[i] = 0;
 645                 psig_name[i] = 0;
 646             }
 647             /* initialize signal stack */
 648             signalstack = newAV();
 649             AvREAL_off(signalstack);
 650             av_extend(signalstack, 30);
 651             av_fill(signalstack, 0);
 652         }
 653         break;
 654
 655     case '&':
 656         if (len > 1)
 657             break;
 658         ampergv = gv;
 659         sawampersand = TRUE;
 660         goto ro_magicalize;
 661
 662     case '`':
 663         if (len > 1)
 664             break;
 665         leftgv = gv;
 666         sawampersand = TRUE;
 667         goto ro_magicalize;
 668
 669     case '\'':
 670         if (len > 1)
 671             break;
 672         rightgv = gv;
 673         sawampersand = TRUE;
 674         goto ro_magicalize;
 675
 676     case ':':
 677         if (len > 1)
 678             break;
 679         sv_setpv(GvSV(gv),chopset);
 680         goto magicalize;
 681
 682     case '?':
 683         if (len > 1)
 684             break;
 685 #ifdef COMPLEX_STATUS
 686         sv_upgrade(GvSV(gv), SVt_PVLV);
 687 #endif
 688         goto magicalize;
 689
 690     case '#':
 691     case '*':
 692         if (dowarn && len == 1 && sv_type == SVt_PV)
 693             warn("Use of $%s is deprecated", name);
 694         /* FALL THROUGH */
 695     case '[':
 696     case '!':
 697     case '^':
 698     case '~':
 699     case '=':
 700     case '-':
 701     case '%':
 702     case '.':
 703     case '(':
 704     case ')':
 705     case '<':
 706     case '>':
 707     case ',':
 708     case '\\':
 709     case '/':
 710     case '|':
 711     case '\001':
 712     case '\004':
 713     case '\005':
 714     case '\006':
 715     case '\010':
 716     case '\017':
 717     case '\t':
 718     case '\020':
 719     case '\024':
 720     case '\027':
 721         if (len > 1)
 722             break;
 723         goto magicalize;
 724
 725     case '+':
 726     case '1':
 727     case '2':
 728     case '3':
 729     case '4':
 730     case '5':
 731     case '6':
 732     case '7':
 733     case '8':
 734     case '9':
 735       ro_magicalize:
 736         SvREADONLY_on(GvSV(gv));
 737       magicalize:
 738         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 739         break;
 740
 741     case '\014':
 742         if (len > 1)
 743             break;
 744         sv_setpv(GvSV(gv),"\f");
 745         formfeed = GvSV(gv);
 746         break;
 747     case ';':
 748         if (len > 1)
 749             break;
 750         sv_setpv(GvSV(gv),"\034");
 751         break;
 752     case ']':
 753         if (len == 1) {
 754             SV *sv = GvSV(gv);
 755             sv_upgrade(sv, SVt_PVNV);
 756             sv_setpv(sv, patchlevel);
 757             (void)sv_2nv(sv);
 758             SvREADONLY_on(sv);
 759         }
 760         break;
 761     }
 762     return gv;
 763 }
 764
 765 void
 766 gv_fullname3(sv, gv, prefix)
 767 SV *sv;
 768 GV *gv;
 769 char *prefix;
 770 {
 771     HV *hv = GvSTASH(gv);
 772     if (!hv) {
 773         SvOK_off(sv);
 774         return;
 775     }
 776     sv_setpv(sv, prefix ? prefix : "");
 777     sv_catpv(sv,HvNAME(hv));
 778     sv_catpvn(sv,"::", 2);
 779     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 780 }
 781
 782 void
 783 gv_efullname3(sv, gv, prefix)
 784 SV *sv;
 785 GV *gv;
 786 char *prefix;
 787 {
 788     GV *egv = GvEGV(gv);
 789     if (!egv)
 790         egv = gv;
 791     gv_fullname3(sv, egv, prefix);
 792 }
 793
 794 /* XXX compatibility with versions <= 5.003. */
 795 void
 796 gv_fullname(sv,gv)
 797 SV *sv;
 798 GV *gv;
 799 {
 800     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 801 }
 802
 803 /* XXX compatibility with versions <= 5.003. */
 804 void
 805 gv_efullname(sv,gv)
 806 SV *sv;
 807 GV *gv;
 808 {
 809     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 810 }
 811
 812 IO *
 813 newIO()
 814 {
 815     IO *io;
 816     GV *iogv;
 817
 818     io = (IO*)NEWSV(0,0);
 819     sv_upgrade((SV *)io,SVt_PVIO);
 820     SvREFCNT(io) = 1;
 821     SvOBJECT_on(io);
 822     iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
 823     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
 824     return io;
 825 }
 826
 827 void
 828 gv_check(stash)
 829 HV* stash;
 830 {
 831     register HE *entry;
 832     register I32 i;
 833     register GV *gv;
 834     HV *hv;
 835     GV *filegv;
 836
 837     if (!HvARRAY(stash))
 838         return;
 839     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 840         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 841             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
 842                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
 843             {
 844                 if (hv != defstash)
 845                      gv_check(hv);              /* nested package */
 846             }
 847             else if (isALPHA(*HeKEY(entry))) {
 848                 gv = (GV*)HeVAL(entry);
 849                 if (GvMULTI(gv))
 850                     continue;
 851                 curcop->cop_line = GvLINE(gv);
 852                 filegv = GvFILEGV(gv);
 853                 curcop->cop_filegv = filegv;
 854                 if (filegv && GvMULTI(filegv))  /* Filename began with slash */
 855                     continue;
 856                 warn("Name \"%s::%s\" used only once: possible typo",
 857                         HvNAME(stash), GvNAME(gv));
 858             }
 859         }
 860     }
 861 }
 862
 863 GV *
 864 newGVgen(pack)
 865 char *pack;
 866 {
 867     (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++);
 868     return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
 869 }
 870
 871 /* hopefully this is only called on local symbol table entries */
 872
 873 GP*
 874 gp_ref(gp)
 875 GP* gp;
 876 {
 877     gp->gp_refcnt++;
 878     if (gp->gp_cv) {
 879         if (gp->gp_cvgen) {
 880             /* multi-named GPs cannot be used for method cache */
 881             SvREFCNT_dec(gp->gp_cv);
 882             gp->gp_cv = Nullcv;
 883             gp->gp_cvgen = 0;
 884         }
 885         else {
 886             /* Adding a new name to a subroutine invalidates method cache */
 887             sub_generation++;
 888         }
 889     }
 890     return gp;
 891 }
 892
 893 void
 894 gp_free(gv)
 895 GV* gv;
 896 {
 897     GP* gp;
 898     CV* cv;
 899
 900     if (!gv || !(gp = GvGP(gv)))
 901         return;
 902     if (gp->gp_refcnt == 0) {
 903         warn("Attempt to free unreferenced glob pointers");
 904         return;
 905     }
 906     if (gp->gp_cv) {
 907         /* Deleting the name of a subroutine invalidates method cache */
 908         sub_generation++;
 909     }
 910     if (--gp->gp_refcnt > 0) {
 911         if (gp->gp_egv == gv)
 912             gp->gp_egv = 0;
 913         return;
 914     }
 915
 916     SvREFCNT_dec(gp->gp_sv);
 917     SvREFCNT_dec(gp->gp_av);
 918     SvREFCNT_dec(gp->gp_hv);
 919     SvREFCNT_dec(gp->gp_io);
 920     SvREFCNT_dec(gp->gp_cv);
 921     SvREFCNT_dec(gp->gp_form);
 922
 923     Safefree(gp);
 924     GvGP(gv) = 0;
 925 }
 926
 927 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
 928 #define MICROPORT
 929 #endif
 930
 931 #ifdef  MICROPORT       /* Microport 2.4 hack */
 932 AV *GvAVn(gv)
 933 register GV *gv;
 934 {
 935     if (GvGP(gv)->gp_av)
 936         return GvGP(gv)->gp_av;
 937     else
 938         return GvGP(gv_AVadd(gv))->gp_av;
 939 }
 940
 941 HV *GvHVn(gv)
 942 register GV *gv;
 943 {
 944     if (GvGP(gv)->gp_hv)
 945         return GvGP(gv)->gp_hv;
 946     else
 947         return GvGP(gv_HVadd(gv))->gp_hv;
 948 }
 949 #endif                  /* Microport 2.4 hack */
 950
 951 #ifdef OVERLOAD
 952 /* Updates and caches the CV's */
 953
 954 bool
 955 Gv_AMupdate(stash)
 956 HV* stash;
 957 {
 958   GV** gvp;
 959   HV* hv;
 960   GV* gv;
 961   CV* cv;
 962   MAGIC* mg=mg_find((SV*)stash,'c');
 963   AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
 964   AMT amt;
 965
 966   if (mg && amtp->was_ok_am == amagic_generation
 967       && amtp->was_ok_sub == sub_generation)
 968       return AMT_AMAGIC(amtp);
 969   if (amtp && AMT_AMAGIC(amtp)) {       /* Have table. */
 970     int i;
 971     for (i=1; i<NofAMmeth; i++) {
 972       if (amtp->table[i]) {
 973         SvREFCNT_dec(amtp->table[i]);
 974       }
 975     }
 976   }
 977   sv_unmagic((SV*)stash, 'c');
 978
 979   DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
 980
 981   amt.was_ok_am = amagic_generation;
 982   amt.was_ok_sub = sub_generation;
 983   amt.fallback = AMGfallNO;
 984   amt.flags = 0;
 985
 986 #ifdef OVERLOAD_VIA_HASH
 987   gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
 988   if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) {
 989     int filled=0;
 990     int i;
 991     char *cp;
 992     SV* sv;
 993     SV** svp;
 994
 995     /* Work with "fallback" key, which we assume to be first in AMG_names */
 996
 997     if (( cp = (char *)AMG_names[0] ) &&
 998         (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
 999       if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1000       else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1001     }
1002     for (i = 1; i < NofAMmeth; i++) {
1003       cv = 0;
1004       cp = (char *)AMG_names[i];
1005
1006         svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1007         if (svp && ((sv = *svp) != &sv_undef)) {
1008           switch (SvTYPE(sv)) {
1009             default:
1010               if (!SvROK(sv)) {
1011                 if (!SvOK(sv)) break;
1012                 gv = gv_fetchmethod(stash, SvPV(sv, na));
1013                 if (gv) cv = GvCV(gv);
1014                 break;
1015               }
1016               cv = (CV*)SvRV(sv);
1017               if (SvTYPE(cv) == SVt_PVCV)
1018                   break;
1019                 /* FALL THROUGH */
1020             case SVt_PVHV:
1021             case SVt_PVAV:
1022               croak("Not a subroutine reference in overload table");
1023               return FALSE;
1024             case SVt_PVCV:
1025               cv = (CV*)sv;
1026               break;
1027             case SVt_PVGV:
1028               if (!(cv = GvCVu((GV*)sv)))
1029                 cv = sv_2cv(sv, &stash, &gv, TRUE);
1030               break;
1031           }
1032           if (cv) filled=1;
1033           else {
1034             croak("Method for operation %s not found in package %.256s during blessing\n",
1035                 cp,HvNAME(stash));
1036             return FALSE;
1037           }
1038         }
1039 #else
1040   {
1041     int filled = 0;
1042     int i;
1043     const char *cp;
1044     SV* sv = NULL;
1045     SV** svp;
1046
1047     /* Work with "fallback" key, which we assume to be first in AMG_names */
1048
1049     if ( cp = AMG_names[0] ) {
1050         /* Try to find via inheritance. */
1051         gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1052         if (gv) sv = GvSV(gv);
1053
1054         if (!gv) goto no_table;
1055         else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1056         else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1057     }
1058
1059     for (i = 1; i < NofAMmeth; i++) {
1060         cv = 0;
1061         cp = AMG_names[i];
1062
1063         *buf = '(';                     /* A cookie: "(". */
1064         strcpy(buf + 1, cp);
1065         DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
1066                      cp, HvNAME(stash)) );
1067         gv = gv_fetchmeth(stash, buf, strlen(buf), -1); /* no filling stash! */
1068         if(gv && (cv = GvCV(gv))) {
1069             char *name = buf;
1070             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1071                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1072                 /* GvSV contains the name of the method. */
1073                 GV *ngv;
1074
1075                 DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1076                              SvPV(GvSV(gv), na), cp, HvNAME(stash)) );
1077                 if (!SvPOK(GvSV(gv))
1078                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1079                                                        FALSE)))
1080                 {
1081                     /* Can be an import stub (created by `can'). */
1082                     if (GvCVGEN(gv)) {
1083                         croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1084                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1085                               cp, HvNAME(stash));
1086                     } else
1087                         croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'",
1088                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1089                               cp, HvNAME(stash));
1090                 }
1091                 name = SvPVX(GvSV(gv));
1092                 cv = GvCV(gv = ngv);
1093             }
1094             DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1095                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1096                          GvNAME(CvGV(cv))) );
1097             filled = 1;
1098         }
1099 #endif
1100         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1101     }
1102     if (filled) {
1103       AMT_AMAGIC_on(&amt);
1104       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1105       return TRUE;
1106     }
1107   }
1108   /* Here we have no table: */
1109  no_table:
1110   AMT_AMAGIC_off(&amt);
1111   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1112   return FALSE;
1113 }
1114
1115 /* During call to this subroutine stack can be reallocated. It is
1116  * advised to call SPAGAIN macro in your code after call */
1117
1118 SV*
1119 amagic_call(left,right,method,flags)
1120 SV* left;
1121 SV* right;
1122 int method;
1123 int flags;
1124 {
1125   MAGIC *mg;
1126   CV *cv;
1127   CV **cvp=NULL, **ocvp=NULL;
1128   AMT *amtp, *oamtp;
1129   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1130   int postpr=0, inc_dec_ass=0, assignshift=assign?1:0;
1131   HV* stash;
1132   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1133       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1134       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1135                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1136                         : NULL))
1137       && ((cv = cvp[off=method+assignshift])
1138           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1139                                                           * usual method */
1140                   (fl = 1, cv = cvp[off=method])))) {
1141     lr = -1;                    /* Call method for left argument */
1142   } else {
1143     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1144       int logic;
1145
1146       /* look for substituted methods */
1147          switch (method) {
1148          case inc_amg:
1149            if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1))
1150                || ((cv = cvp[off=add_amg]) && (postpr=1))) {
1151              right = &sv_yes; lr = -1; assign = 1;
1152            }
1153            break;
1154          case dec_amg:
1155            if (((cv = cvp[off=subtr_ass_amg])  && (inc_dec_ass=1))
1156                || ((cv = cvp[off=subtr_amg]) && (postpr=1))) {
1157              right = &sv_yes; lr = -1; assign = 1;
1158            }
1159            break;
1160          case bool__amg:
1161            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1162            break;
1163          case numer_amg:
1164            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1165            break;
1166          case string_amg:
1167            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1168            break;
1169  case not_amg:
1170    (void)((cv = cvp[off=bool__amg])
1171           || (cv = cvp[off=numer_amg])
1172           || (cv = cvp[off=string_amg]));
1173    postpr = 1;
1174    break;
1175          case copy_amg:
1176            {
1177              SV* ref=SvRV(left);
1178              if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be
1179                                                       * extra
1180                                                       * causious,
1181                                                       * maybe in some
1182                                                       * additional
1183                                                       * cases sv_setsv
1184                                                       * is safe too */
1185                 SV* newref = newSVsv(ref);
1186                 SvOBJECT_on(newref);
1187                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
1188                 return newref;
1189              }
1190            }
1191            break;
1192          case abs_amg:
1193            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1194                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1195              SV* nullsv=sv_2mortal(newSViv(0));
1196              if (off1==lt_amg) {
1197                SV* lessp = amagic_call(left,nullsv,
1198                                        lt_amg,AMGf_noright);
1199                logic = SvTRUE(lessp);
1200              } else {
1201                SV* lessp = amagic_call(left,nullsv,
1202                                        ncmp_amg,AMGf_noright);
1203                logic = (SvNV(lessp) < 0);
1204              }
1205              if (logic) {
1206                if (off==subtr_amg) {
1207                  right = left;
1208                  left = nullsv;
1209                  lr = 1;
1210                }
1211              } else {
1212                return left;
1213              }
1214            }
1215            break;
1216          case neg_amg:
1217            if (cv = cvp[off=subtr_amg]) {
1218              right = left;
1219              left = sv_2mortal(newSViv(0));
1220              lr = 1;
1221            }
1222            break;
1223          default:
1224            goto not_found;
1225          }
1226          if (!cv) goto not_found;
1227     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1228                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1229                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1230                           ? (amtp = (AMT*)mg->mg_ptr)->table
1231                           : NULL))
1232                && (cv = cvp[off=method])) { /* Method for right
1233                                              * argument found */
1234       lr=1;
1235     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1236                  && (cvp=ocvp) && (lr = -1))
1237                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1238                && !(flags & AMGf_unary)) {
1239                                 /* We look for substitution for
1240                                  * comparison operations and
1241                                  * concatendation */
1242       if (method==concat_amg || method==concat_ass_amg
1243           || method==repeat_amg || method==repeat_ass_amg) {
1244         return NULL;            /* Delegate operation to string conversion */
1245       }
1246       off = -1;
1247       switch (method) {
1248          case lt_amg:
1249          case le_amg:
1250          case gt_amg:
1251          case ge_amg:
1252          case eq_amg:
1253          case ne_amg:
1254            postpr = 1; off=ncmp_amg; break;
1255          case slt_amg:
1256          case sle_amg:
1257          case sgt_amg:
1258          case sge_amg:
1259          case seq_amg:
1260          case sne_amg:
1261            postpr = 1; off=scmp_amg; break;
1262          }
1263       if (off != -1) cv = cvp[off];
1264       if (!cv) {
1265         goto not_found;
1266       }
1267     } else {
1268     not_found:                  /* No method found, either report or croak */
1269       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1270         notfound = 1; lr = -1;
1271       } else if (cvp && (cv=cvp[nomethod_amg])) {
1272         notfound = 1; lr = 1;
1273       } else {
1274         if (off==-1) off=method;
1275         sprintf(buf,
1276                 "Operation `%s': no method found,%sargument %s%.256s%s%.256s",
1277                       AMG_names[method + assignshift],
1278                       (flags & AMGf_unary ? " " : "\n\tleft "),
1279                       SvAMAGIC(left)?
1280                         "in overloaded package ":
1281                         "has no overloaded magic",
1282                       SvAMAGIC(left)?
1283                         HvNAME(SvSTASH(SvRV(left))):
1284                         "",
1285                       SvAMAGIC(right)?
1286                         ",\n\tright argument in overloaded package ":
1287                         (flags & AMGf_unary
1288                          ? ""
1289                          : ",\n\tright argument has no overloaded magic"),
1290                       SvAMAGIC(right)?
1291                         HvNAME(SvSTASH(SvRV(right))):
1292                         "");
1293         if (amtp && amtp->fallback >= AMGfallYES) {
1294           DEBUG_o( deb(buf) );
1295         } else {
1296           croak(buf);
1297         }
1298         return NULL;
1299       }
1300     }
1301   }
1302   if (!notfound) {
1303     DEBUG_o( deb(
1304   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
1305                  AMG_names[off],
1306                  method+assignshift==off? "" :
1307                              " (initially `",
1308                  method+assignshift==off? "" :
1309                              AMG_names[method+assignshift],
1310                  method+assignshift==off? "" : "')",
1311                  flags & AMGf_unary? "" :
1312                    lr==1 ? " for right argument": " for left argument",
1313                  flags & AMGf_unary? " for argument" : "",
1314                  HvNAME(stash),
1315                  fl? ",\n\tassignment variant used": "") );
1316     /* Since we use shallow copy during assignment, we need
1317      * to dublicate the contents, probably calling user-supplied
1318      * version of copy operator
1319      */
1320     if ((method + assignshift==off
1321          && (assign || method==inc_amg || method==dec_amg))
1322         || inc_dec_ass) RvDEEPCP(left);
1323   }
1324   {
1325     dSP;
1326     BINOP myop;
1327     SV* res;
1328     bool oldcatch = CATCH_GET;
1329
1330     CATCH_SET(TRUE);
1331     Zero(&myop, 1, BINOP);
1332     myop.op_last = (OP *) &myop;
1333     myop.op_next = Nullop;
1334     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1335
1336     ENTER;
1337     SAVESPTR(op);
1338     op = (OP *) &myop;
1339     if (perldb && curstash != debstash)
1340         op->op_private |= OPpENTERSUB_DB;
1341     PUTBACK;
1342     pp_pushmark();
1343
1344     EXTEND(sp, notfound + 5);
1345     PUSHs(lr>0? right: left);
1346     PUSHs(lr>0? left: right);
1347     PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no ));
1348     if (notfound) {
1349       PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
1350     }
1351     PUSHs((SV*)cv);
1352     PUTBACK;
1353
1354     if (op = pp_entersub())
1355       runops();
1356     LEAVE;
1357     SPAGAIN;
1358
1359     res=POPs;
1360     PUTBACK;
1361     CATCH_SET(oldcatch);
1362
1363     if (postpr) {
1364       int ans;
1365       switch (method) {
1366       case le_amg:
1367       case sle_amg:
1368         ans=SvIV(res)<=0; break;
1369       case lt_amg:
1370       case slt_amg:
1371         ans=SvIV(res)<0; break;
1372       case ge_amg:
1373       case sge_amg:
1374         ans=SvIV(res)>=0; break;
1375       case gt_amg:
1376       case sgt_amg:
1377         ans=SvIV(res)>0; break;
1378       case eq_amg:
1379       case seq_amg:
1380         ans=SvIV(res)==0; break;
1381       case ne_amg:
1382       case sne_amg:
1383         ans=SvIV(res)!=0; break;
1384       case inc_amg:
1385       case dec_amg:
1386         SvSetSV(left,res); return left;
1387       case not_amg:
1388         ans=!SvOK(res); break;
1389       }
1390       return boolSV(ans);
1391     } else if (method==copy_amg) {
1392       if (!SvROK(res)) {
1393         croak("Copy method did not return a reference");
1394       }
1395       return SvREFCNT_inc(SvRV(res));
1396     } else {
1397       return res;
1398     }
1399   }
1400 }
1401 #endif /* OVERLOAD */