gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
  13  * of your inquisitiveness, I shall spend all the rest of my days answering
  14  * you.  What more do you want to know?'
  15  *   'The names of all the stars, and of all living things, and the whole
  16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
  17  * laughed Pippin.
  18  */
  19
  20 /*
  21 =head1 GV Functions
  22
  23 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  24 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  25 corresponding to $foo, @foo, %foo.
  26
  27 GVs are usually found as values in stashes (symbol table hashes) where
  28 Perl stores its global variables.
  29
  30 =cut
  31 */
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_GV_C
  35 #include "perl.h"
  36
  37 GV *
  38 Perl_gv_AVadd(pTHX_ register GV *gv)
  39 {
  40     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  41         Perl_croak(aTHX_ "Bad symbol for array");
  42     if (!GvAV(gv))
  43         GvAV(gv) = newAV();
  44     return gv;
  45 }
  46
  47 GV *
  48 Perl_gv_HVadd(pTHX_ register GV *gv)
  49 {
  50     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  51         Perl_croak(aTHX_ "Bad symbol for hash");
  52     if (!GvHV(gv))
  53         GvHV(gv) = newHV();
  54     return gv;
  55 }
  56
  57 GV *
  58 Perl_gv_IOadd(pTHX_ register GV *gv)
  59 {
  60     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  61         Perl_croak(aTHX_ "Bad symbol for filehandle");
  62     if (!GvIOp(gv)) {
  63 #ifdef GV_UNIQUE_CHECK
  64         if (GvUNIQUE(gv)) {
  65             Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
  66         }
  67 #endif
  68         GvIOp(gv) = newIO();
  69     }
  70     return gv;
  71 }
  72
  73 GV *
  74 Perl_gv_fetchfile(pTHX_ const char *name)
  75 {
  76     char smallbuf[256];
  77     char *tmpbuf;
  78     STRLEN tmplen;
  79     GV *gv;
  80
  81     if (!PL_defstash)
  82         return Nullgv;
  83
  84     tmplen = strlen(name) + 2;
  85     if (tmplen < sizeof smallbuf)
  86         tmpbuf = smallbuf;
  87     else
  88         New(603, tmpbuf, tmplen + 1, char);
  89     /* This is where the debugger's %{"::_<$filename"} hash is created */
  90     tmpbuf[0] = '_';
  91     tmpbuf[1] = '<';
  92     strcpy(tmpbuf + 2, name);
  93     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
  94     if (!isGV(gv)) {
  95         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
  96         sv_setpv(GvSV(gv), name);
  97         if (PERLDB_LINE)
  98             hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
  99     }
 100     if (tmpbuf != smallbuf)
 101         Safefree(tmpbuf);
 102     return gv;
 103 }
 104
 105 void
 106 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 107 {
 108     register GP *gp;
 109     bool doproto = SvTYPE(gv) > SVt_NULL;
 110     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 111
 112     sv_upgrade((SV*)gv, SVt_PVGV);
 113     if (SvLEN(gv)) {
 114         if (proto) {
 115             SvPVX(gv) = NULL;
 116             SvLEN(gv) = 0;
 117             SvPOK_off(gv);
 118         } else
 119             Safefree(SvPVX(gv));
 120     }
 121     Newz(602, gp, 1, GP);
 122     GvGP(gv) = gp_ref(gp);
 123     GvSV(gv) = NEWSV(72,0);
 124     GvLINE(gv) = CopLINE(PL_curcop);
 125     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
 126     GvCVGEN(gv) = 0;
 127     GvEGV(gv) = gv;
 128     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
 129     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
 130     GvNAME(gv) = savepvn(name, len);
 131     GvNAMELEN(gv) = len;
 132     if (multi || doproto)              /* doproto means it _was_ mentioned */
 133         GvMULTI_on(gv);
 134     if (doproto) {                      /* Replicate part of newSUB here. */
 135         SvIOK_off(gv);
 136         ENTER;
 137         /* XXX unsafe for threads if eval_owner isn't held */
 138         start_subparse(0,0);            /* Create CV in compcv. */
 139         GvCV(gv) = PL_compcv;
 140         LEAVE;
 141
 142         PL_sub_generation++;
 143         CvGV(GvCV(gv)) = gv;
 144         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 145         CvSTASH(GvCV(gv)) = PL_curstash;
 146         if (proto) {
 147             sv_setpv((SV*)GvCV(gv), proto);
 148             Safefree(proto);
 149         }
 150     }
 151 }
 152
 153 STATIC void
 154 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
 155 {
 156     switch (sv_type) {
 157     case SVt_PVIO:
 158         (void)GvIOn(gv);
 159         break;
 160     case SVt_PVAV:
 161         (void)GvAVn(gv);
 162         break;
 163     case SVt_PVHV:
 164         (void)GvHVn(gv);
 165         break;
 166     }
 167 }
 168
 169 /*
 170 =for apidoc gv_fetchmeth
 171
 172 Returns the glob with the given C<name> and a defined subroutine or
 173 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 174 accessible via @ISA and UNIVERSAL::.
 175
 176 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 177 side-effect creates a glob with the given C<name> in the given C<stash>
 178 which in the case of success contains an alias for the subroutine, and sets
 179 up caching info for this glob.  Similarly for all the searched stashes.
 180
 181 This function grants C<"SUPER"> token as a postfix of the stash name. The
 182 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 183 visible to Perl code.  So when calling C<call_sv>, you should not use
 184 the GV directly; instead, you should use the method's CV, which can be
 185 obtained from the GV with the C<GvCV> macro.
 186
 187 =cut
 188 */
 189
 190 GV *
 191 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 192 {
 193     AV* av;
 194     GV* topgv;
 195     GV* gv;
 196     GV** gvp;
 197     CV* cv;
 198
 199     /* UNIVERSAL methods should be callable without a stash */
 200     if (!stash) {
 201         level = -1;  /* probably appropriate */
 202         if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
 203             return 0;
 204     }
 205
 206     if (!HvNAME(stash))
 207       Perl_croak(aTHX_
 208                  "Can't use anonymous symbol table for method lookup");
 209
 210     if ((level > 100) || (level < -100))
 211         Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 212               name, HvNAME(stash));
 213
 214     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
 215
 216     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 217     if (!gvp)
 218         topgv = Nullgv;
 219     else {
 220         topgv = *gvp;
 221         if (SvTYPE(topgv) != SVt_PVGV)
 222             gv_init(topgv, stash, name, len, TRUE);
 223         if ((cv = GvCV(topgv))) {
 224             /* If genuine method or valid cache entry, use it */
 225             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 226                 return topgv;
 227             /* Stale cached entry: junk it */
 228             SvREFCNT_dec(cv);
 229             GvCV(topgv) = cv = Nullcv;
 230             GvCVGEN(topgv) = 0;
 231         }
 232         else if (GvCVGEN(topgv) == PL_sub_generation)
 233             return 0;  /* cache indicates sub doesn't exist */
 234     }
 235
 236     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
 237     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
 238
 239     /* create and re-create @.*::SUPER::ISA on demand */
 240     if (!av || !SvMAGIC(av)) {
 241         char* packname = HvNAME(stash);
 242         STRLEN packlen = strlen(packname);
 243
 244         if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
 245             HV* basestash;
 246
 247             packlen -= 7;
 248             basestash = gv_stashpvn(packname, packlen, TRUE);
 249             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
 250             if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
 251                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
 252                 if (!gvp || !(gv = *gvp))
 253                     Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
 254                 if (SvTYPE(gv) != SVt_PVGV)
 255                     gv_init(gv, stash, "ISA", 3, TRUE);
 256                 SvREFCNT_dec(GvAV(gv));
 257                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
 258             }
 259         }
 260     }
 261
 262     if (av) {
 263         SV** svp = AvARRAY(av);
 264         /* NOTE: No support for tied ISA */
 265         I32 items = AvFILLp(av) + 1;
 266         while (items--) {
 267             SV* sv = *svp++;
 268             HV* basestash = gv_stashsv(sv, FALSE);
 269             if (!basestash) {
 270                 if (ckWARN(WARN_MISC))
 271                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 272                         sv, HvNAME(stash));
 273                 continue;
 274             }
 275             gv = gv_fetchmeth(basestash, name, len,
 276                               (level >= 0) ? level + 1 : level - 1);
 277             if (gv)
 278                 goto gotcha;
 279         }
 280     }
 281
 282     /* if at top level, try UNIVERSAL */
 283
 284     if (level == 0 || level == -1) {
 285         HV* lastchance;
 286
 287         if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
 288             if ((gv = gv_fetchmeth(lastchance, name, len,
 289                                   (level >= 0) ? level + 1 : level - 1)))
 290             {
 291           gotcha:
 292                 /*
 293                  * Cache method in topgv if:
 294                  *  1. topgv has no synonyms (else inheritance crosses wires)
 295                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 296                  */
 297                 if (topgv &&
 298                     GvREFCNT(topgv) == 1 &&
 299                     (cv = GvCV(gv)) &&
 300                     (CvROOT(cv) || CvXSUB(cv)))
 301                 {
 302                     if ((cv = GvCV(topgv)))
 303                         SvREFCNT_dec(cv);
 304                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 305                     GvCVGEN(topgv) = PL_sub_generation;
 306                 }
 307                 return gv;
 308             }
 309             else if (topgv && GvREFCNT(topgv) == 1) {
 310                 /* cache the fact that the method is not defined */
 311                 GvCVGEN(topgv) = PL_sub_generation;
 312             }
 313         }
 314     }
 315
 316     return 0;
 317 }
 318
 319 /*
 320 =for apidoc gv_fetchmeth_autoload
 321
 322 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
 323 Returns a glob for the subroutine.
 324
 325 For an autoloaded subroutine without a GV, will create a GV even
 326 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 327 of the result may be zero.
 328
 329 =cut
 330 */
 331
 332 GV *
 333 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 334 {
 335     GV *gv = gv_fetchmeth(stash, name, len, level);
 336
 337     if (!gv) {
 338         char autoload[] = "AUTOLOAD";
 339         STRLEN autolen = sizeof(autoload)-1;
 340         CV *cv;
 341         GV **gvp;
 342
 343         if (!stash)
 344             return Nullgv;      /* UNIVERSAL::AUTOLOAD could cause trouble */
 345         if (len == autolen && strnEQ(name, autoload, autolen))
 346             return Nullgv;
 347         if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 348             return Nullgv;
 349         cv = GvCV(gv);
 350         if (!(CvROOT(cv) || CvXSUB(cv)))
 351             return Nullgv;
 352         /* Have an autoload */
 353         if (level < 0)  /* Cannot do without a stub */
 354             gv_fetchmeth(stash, name, len, 0);
 355         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 356         if (!gvp)
 357             return Nullgv;
 358         return *gvp;
 359     }
 360     return gv;
 361 }
 362
 363 /*
 364 =for apidoc gv_fetchmethod
 365
 366 See L<gv_fetchmethod_autoload>.
 367
 368 =cut
 369 */
 370
 371 GV *
 372 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 373 {
 374     return gv_fetchmethod_autoload(stash, name, TRUE);
 375 }
 376
 377 /*
 378 =for apidoc gv_fetchmethod_autoload
 379
 380 Returns the glob which contains the subroutine to call to invoke the method
 381 on the C<stash>.  In fact in the presence of autoloading this may be the
 382 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 383 already setup.
 384
 385 The third parameter of C<gv_fetchmethod_autoload> determines whether
 386 AUTOLOAD lookup is performed if the given method is not present: non-zero
 387 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 388 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 389 with a non-zero C<autoload> parameter.
 390
 391 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 392 that if you want to keep the returned glob for a long time, you need to
 393 check for it being "AUTOLOAD", since at the later time the call may load a
 394 different subroutine due to $AUTOLOAD changing its value. Use the glob
 395 created via a side effect to do this.
 396
 397 These functions have the same side-effects and as C<gv_fetchmeth> with
 398 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 399 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 400 C<call_sv> apply equally to these functions.
 401
 402 =cut
 403 */
 404
 405 GV *
 406 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 407 {
 408     register const char *nend;
 409     const char *nsplit = 0;
 410     GV* gv;
 411     HV* ostash = stash;
 412
 413     if (stash && SvTYPE(stash) < SVt_PVHV)
 414         stash = Nullhv;
 415
 416     for (nend = name; *nend; nend++) {
 417         if (*nend == '\'')
 418             nsplit = nend;
 419         else if (*nend == ':' && *(nend + 1) == ':')
 420             nsplit = ++nend;
 421     }
 422     if (nsplit) {
 423         const char *origname = name;
 424         name = nsplit + 1;
 425         if (*nsplit == ':')
 426             --nsplit;
 427         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
 428             /* ->SUPER::method should really be looked up in original stash */
 429             SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 430                                                   CopSTASHPV(PL_curcop)));
 431             /* __PACKAGE__::SUPER stash should be autovivified */
 432             stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
 433             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 434                          origname, HvNAME(stash), name) );
 435         }
 436         else {
 437             /* don't autovifify if ->NoSuchStash::method */
 438             stash = gv_stashpvn(origname, nsplit - origname, FALSE);
 439
 440             /* however, explicit calls to Pkg::SUPER::method may
 441                happen, and may require autovivification to work */
 442             if (!stash && (nsplit - origname) >= 7 &&
 443                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 444                 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
 445               stash = gv_stashpvn(origname, nsplit - origname, TRUE);
 446         }
 447         ostash = stash;
 448     }
 449
 450     gv = gv_fetchmeth(stash, name, nend - name, 0);
 451     if (!gv) {
 452         if (strEQ(name,"import") || strEQ(name,"unimport"))
 453             gv = (GV*)&PL_sv_yes;
 454         else if (autoload)
 455             gv = gv_autoload4(ostash, name, nend - name, TRUE);
 456     }
 457     else if (autoload) {
 458         CV* cv = GvCV(gv);
 459         if (!CvROOT(cv) && !CvXSUB(cv)) {
 460             GV* stubgv;
 461             GV* autogv;
 462
 463             if (CvANON(cv))
 464                 stubgv = gv;
 465             else {
 466                 stubgv = CvGV(cv);
 467                 if (GvCV(stubgv) != cv)         /* orphaned import */
 468                     stubgv = gv;
 469             }
 470             autogv = gv_autoload4(GvSTASH(stubgv),
 471                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 472             if (autogv)
 473                 gv = autogv;
 474         }
 475     }
 476
 477     return gv;
 478 }
 479
 480 GV*
 481 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 482 {
 483     char autoload[] = "AUTOLOAD";
 484     STRLEN autolen = sizeof(autoload)-1;
 485     GV* gv;
 486     CV* cv;
 487     HV* varstash;
 488     GV* vargv;
 489     SV* varsv;
 490     char *packname = "";
 491
 492     if (len == autolen && strnEQ(name, autoload, autolen))
 493         return Nullgv;
 494     if (stash) {
 495         if (SvTYPE(stash) < SVt_PVHV) {
 496             packname = SvPV_nolen((SV*)stash);
 497             stash = Nullhv;
 498         }
 499         else {
 500             packname = HvNAME(stash);
 501         }
 502     }
 503     if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 504         return Nullgv;
 505     cv = GvCV(gv);
 506
 507     if (!(CvROOT(cv) || CvXSUB(cv)))
 508         return Nullgv;
 509
 510     /*
 511      * Inheriting AUTOLOAD for non-methods works ... for now.
 512      */
 513     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
 514         (GvCVGEN(gv) || GvSTASH(gv) != stash))
 515         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 516           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 517              packname, (int)len, name);
 518
 519     if (CvXSUB(cv)) {
 520         /* rather than lookup/init $AUTOLOAD here
 521          * only to have the XSUB do another lookup for $AUTOLOAD
 522          * and split that value on the last '::',
 523          * pass along the same data via some unused fields in the CV
 524          */
 525         CvSTASH(cv) = stash;
 526         SvPVX(cv) = (char *)name; /* cast to lose constness warning */
 527         SvCUR(cv) = len;
 528         return gv;
 529     }
 530
 531     /*
 532      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 533      * The subroutine's original name may not be "AUTOLOAD", so we don't
 534      * use that, but for lack of anything better we will use the sub's
 535      * original package to look up $AUTOLOAD.
 536      */
 537     varstash = GvSTASH(CvGV(cv));
 538     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
 539     ENTER;
 540
 541     if (!isGV(vargv))
 542         gv_init(vargv, varstash, autoload, autolen, FALSE);
 543     LEAVE;
 544     varsv = GvSV(vargv);
 545     sv_setpv(varsv, packname);
 546     sv_catpvn(varsv, "::", 2);
 547     sv_catpvn(varsv, name, len);
 548     SvTAINTED_off(varsv);
 549     return gv;
 550 }
 551
 552 /* The "gv" parameter should be the glob known to Perl code as *!
 553  * The scalar must already have been magicalized.
 554  */
 555 STATIC void
 556 S_require_errno(pTHX_ GV *gv)
 557 {
 558     HV* stash = gv_stashpvn("Errno",5,FALSE);
 559
 560     if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 561         dSP;
 562         PUTBACK;
 563         ENTER;
 564         save_scalar(gv); /* keep the value of $! */
 565         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 566                          newSVpvn("Errno",5), Nullsv);
 567         LEAVE;
 568         SPAGAIN;
 569         stash = gv_stashpvn("Errno",5,FALSE);
 570         if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 571             Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 572     }
 573 }
 574
 575 /*
 576 =for apidoc gv_stashpv
 577
 578 Returns a pointer to the stash for a specified package.  C<name> should
 579 be a valid UTF-8 string.  If C<create> is set then the package will be
 580 created if it does not already exist.  If C<create> is not set and the
 581 package does not exist then NULL is returned.
 582
 583 =cut
 584 */
 585
 586 HV*
 587 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 588 {
 589     return gv_stashpvn(name, strlen(name), create);
 590 }
 591
 592 HV*
 593 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 594 {
 595     char smallbuf[256];
 596     char *tmpbuf;
 597     HV *stash;
 598     GV *tmpgv;
 599
 600     if (namelen + 3 < sizeof smallbuf)
 601         tmpbuf = smallbuf;
 602     else
 603         New(606, tmpbuf, namelen + 3, char);
 604     Copy(name,tmpbuf,namelen,char);
 605     tmpbuf[namelen++] = ':';
 606     tmpbuf[namelen++] = ':';
 607     tmpbuf[namelen] = '\0';
 608     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 609     if (tmpbuf != smallbuf)
 610         Safefree(tmpbuf);
 611     if (!tmpgv)
 612         return 0;
 613     if (!GvHV(tmpgv))
 614         GvHV(tmpgv) = newHV();
 615     stash = GvHV(tmpgv);
 616     if (!HvNAME(stash))
 617         HvNAME(stash) = savepv(name);
 618     return stash;
 619 }
 620
 621 /*
 622 =for apidoc gv_stashsv
 623
 624 Returns a pointer to the stash for a specified package, which must be a
 625 valid UTF-8 string.  See C<gv_stashpv>.
 626
 627 =cut
 628 */
 629
 630 HV*
 631 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 632 {
 633     register char *ptr;
 634     STRLEN len;
 635     ptr = SvPV(sv,len);
 636     return gv_stashpvn(ptr, len, create);
 637 }
 638
 639
 640 GV *
 641 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 642 {
 643     register const char *name = nambeg;
 644     register GV *gv = 0;
 645     GV**gvp;
 646     I32 len;
 647     register const char *namend;
 648     HV *stash = 0;
 649
 650     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 651         name++;
 652
 653     for (namend = name; *namend; namend++) {
 654         if ((*namend == ':' && namend[1] == ':')
 655             || (*namend == '\'' && namend[1]))
 656         {
 657             if (!stash)
 658                 stash = PL_defstash;
 659             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 660                 return Nullgv;
 661
 662             len = namend - name;
 663             if (len > 0) {
 664                 char smallbuf[256];
 665                 char *tmpbuf;
 666
 667                 if (len + 3 < sizeof (smallbuf))
 668                     tmpbuf = smallbuf;
 669                 else
 670                     New(601, tmpbuf, len+3, char);
 671                 Copy(name, tmpbuf, len, char);
 672                 tmpbuf[len++] = ':';
 673                 tmpbuf[len++] = ':';
 674                 tmpbuf[len] = '\0';
 675                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 676                 gv = gvp ? *gvp : Nullgv;
 677                 if (gv && gv != (GV*)&PL_sv_undef) {
 678                     if (SvTYPE(gv) != SVt_PVGV)
 679                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 680                     else
 681                         GvMULTI_on(gv);
 682                 }
 683                 if (tmpbuf != smallbuf)
 684                     Safefree(tmpbuf);
 685                 if (!gv || gv == (GV*)&PL_sv_undef)
 686                     return Nullgv;
 687
 688                 if (!(stash = GvHV(gv)))
 689                     stash = GvHV(gv) = newHV();
 690
 691                 if (!HvNAME(stash))
 692                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
 693             }
 694
 695             if (*namend == ':')
 696                 namend++;
 697             namend++;
 698             name = namend;
 699             if (!*name)
 700                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 701         }
 702     }
 703     len = namend - name;
 704
 705     /* $_ should always be in main:: even when our'ed */
 706     if (*name == '_' && !name[1])
 707         stash = PL_defstash;
 708
 709     /* No stash in name, so see how we can default */
 710
 711     if (!stash) {
 712         if (isIDFIRST_lazy(name)) {
 713             bool global = FALSE;
 714
 715             if (isUPPER(*name)) {
 716                 if (*name == 'S' && (
 717                     strEQ(name, "SIG") ||
 718                     strEQ(name, "STDIN") ||
 719                     strEQ(name, "STDOUT") ||
 720                     strEQ(name, "STDERR")))
 721                     global = TRUE;
 722                 else if (*name == 'I' && strEQ(name, "INC"))
 723                     global = TRUE;
 724                 else if (*name == 'E' && strEQ(name, "ENV"))
 725                     global = TRUE;
 726                 else if (*name == 'A' && (
 727                   strEQ(name, "ARGV") ||
 728                   strEQ(name, "ARGVOUT")))
 729                     global = TRUE;
 730             }
 731             else if (*name == '_' && !name[1])
 732                 global = TRUE;
 733
 734             if (global)
 735                 stash = PL_defstash;
 736             else if (IN_PERL_COMPILETIME) {
 737                 stash = PL_curstash;
 738                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 739                     sv_type != SVt_PVCV &&
 740                     sv_type != SVt_PVGV &&
 741                     sv_type != SVt_PVFM &&
 742                     sv_type != SVt_PVIO &&
 743                     !(len == 1 && sv_type == SVt_PV &&
 744                       (*name == 'a' || *name == 'b')) )
 745                 {
 746                     gvp = (GV**)hv_fetch(stash,name,len,0);
 747                     if (!gvp ||
 748                         *gvp == (GV*)&PL_sv_undef ||
 749                         SvTYPE(*gvp) != SVt_PVGV)
 750                     {
 751                         stash = 0;
 752                     }
 753                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 754                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 755                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 756                     {
 757                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 758                             sv_type == SVt_PVAV ? '@' :
 759                             sv_type == SVt_PVHV ? '%' : '$',
 760                             name);
 761                         if (GvCVu(*gvp))
 762                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 763                         stash = 0;
 764                     }
 765                 }
 766             }
 767             else
 768                 stash = CopSTASH(PL_curcop);
 769         }
 770         else
 771             stash = PL_defstash;
 772     }
 773
 774     /* By this point we should have a stash and a name */
 775
 776     if (!stash) {
 777         if (add) {
 778             register SV *err = Perl_mess(aTHX_
 779                  "Global symbol \"%s%s\" requires explicit package name",
 780                  (sv_type == SVt_PV ? "$"
 781                   : sv_type == SVt_PVAV ? "@"
 782                   : sv_type == SVt_PVHV ? "%"
 783                   : ""), name);
 784             if (USE_UTF8_IN_NAMES)
 785                 SvUTF8_on(err);
 786             qerror(err);
 787             stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
 788         }
 789         else
 790             return Nullgv;
 791     }
 792
 793     if (!SvREFCNT(stash))       /* symbol table under destruction */
 794         return Nullgv;
 795
 796     gvp = (GV**)hv_fetch(stash,name,len,add);
 797     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 798         return Nullgv;
 799     gv = *gvp;
 800     if (SvTYPE(gv) == SVt_PVGV) {
 801         if (add) {
 802             GvMULTI_on(gv);
 803             gv_init_sv(gv, sv_type);
 804             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 805                 require_errno(gv);
 806         }
 807         return gv;
 808     } else if (add & GV_NOINIT) {
 809         return gv;
 810     }
 811
 812     /* Adding a new symbol */
 813
 814     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 815         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 816     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 817     gv_init_sv(gv, sv_type);
 818
 819     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 820                                             : (PL_dowarn & G_WARN_ON ) ) )
 821         GvMULTI_on(gv) ;
 822
 823     /* set up magic where warranted */
 824     switch (*name) {
 825     case 'A':
 826         if (strEQ(name, "ARGV")) {
 827             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 828         }
 829         break;
 830     case 'E':
 831         if (strnEQ(name, "EXPORT", 6))
 832             GvMULTI_on(gv);
 833         break;
 834     case 'I':
 835         if (strEQ(name, "ISA")) {
 836             AV* av = GvAVn(gv);
 837             GvMULTI_on(gv);
 838             sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 839             /* NOTE: No support for tied ISA */
 840             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 841                 && AvFILLp(av) == -1)
 842             {
 843                 char *pname;
 844                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 845                 gv_stashpvn(pname, 9, TRUE);
 846                 av_push(av, newSVpvn(pname = "DB_File",7));
 847                 gv_stashpvn(pname, 7, TRUE);
 848                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 849                 gv_stashpvn(pname, 9, TRUE);
 850                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 851                 gv_stashpvn(pname, 9, TRUE);
 852                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 853                 gv_stashpvn(pname, 9, TRUE);
 854             }
 855         }
 856         break;
 857     case 'O':
 858         if (strEQ(name, "OVERLOAD")) {
 859             HV* hv = GvHVn(gv);
 860             GvMULTI_on(gv);
 861             hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 862         }
 863         break;
 864     case 'S':
 865         if (strEQ(name, "SIG")) {
 866             HV *hv;
 867             I32 i;
 868             if (!PL_psig_ptr) {
 869                 Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 870                 Newz(73, PL_psig_name, SIG_SIZE, SV*);
 871                 Newz(73, PL_psig_pend, SIG_SIZE, int);
 872             }
 873             GvMULTI_on(gv);
 874             hv = GvHVn(gv);
 875             hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 876             for (i = 1; i < SIG_SIZE; i++) {
 877                 SV ** init;
 878                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 879                 if (init)
 880                     sv_setsv(*init, &PL_sv_undef);
 881                 PL_psig_ptr[i] = 0;
 882                 PL_psig_name[i] = 0;
 883                 PL_psig_pend[i] = 0;
 884             }
 885         }
 886         break;
 887     case 'V':
 888         if (strEQ(name, "VERSION"))
 889             GvMULTI_on(gv);
 890         break;
 891
 892     case '&':
 893     case '`':
 894     case '\'':
 895        if (
 896            len > 1 ||
 897            sv_type == SVt_PVAV ||
 898            sv_type == SVt_PVHV ||
 899            sv_type == SVt_PVCV ||
 900            sv_type == SVt_PVFM ||
 901            sv_type == SVt_PVIO
 902        ) { break; }
 903         PL_sawampersand = TRUE;
 904         goto ro_magicalize;
 905
 906     case ':':
 907         if (len > 1)
 908             break;
 909         sv_setpv(GvSV(gv),PL_chopset);
 910         goto magicalize;
 911
 912     case '?':
 913         if (len > 1)
 914             break;
 915 #ifdef COMPLEX_STATUS
 916         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 917 #endif
 918         goto magicalize;
 919
 920     case '!':
 921         if (len > 1)
 922             break;
 923
 924         /* If %! has been used, automatically load Errno.pm.
 925            The require will itself set errno, so in order to
 926            preserve its value we have to set up the magic
 927            now (rather than going to magicalize)
 928         */
 929
 930         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 931
 932         if (sv_type == SVt_PVHV)
 933             require_errno(gv);
 934
 935         break;
 936     case '-':
 937         if (len > 1)
 938             break;
 939         else {
 940             AV* av = GvAVn(gv);
 941             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
 942             SvREADONLY_on(av);
 943         }
 944         goto magicalize;
 945     case '*':
 946         if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 947             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 948                     "$* is no longer supported");
 949         break;
 950     case '#':
 951         if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 952             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 953                     "Use of $# is deprecated");
 954         /* FALL THROUGH */
 955     case '[':
 956     case '^':
 957     case '~':
 958     case '=':
 959     case '%':
 960     case '.':
 961     case '(':
 962     case ')':
 963     case '<':
 964     case '>':
 965     case ',':
 966     case '\\':
 967     case '/':
 968     case '\001':        /* $^A */
 969     case '\003':        /* $^C */
 970     case '\004':        /* $^D */
 971     case '\006':        /* $^F */
 972     case '\010':        /* $^H */
 973     case '\011':        /* $^I, NOT \t in EBCDIC */
 974     case '\016':        /* $^N */
 975     case '\020':        /* $^P */
 976         if (len > 1)
 977             break;
 978         goto magicalize;
 979     case '|':
 980         if (len > 1)
 981             break;
 982         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 983         goto magicalize;
 984     case '\005':        /* $^E && $^ENCODING */
 985         if (len > 1 && strNE(name, "\005NCODING"))
 986             break;
 987         goto magicalize;
 988
 989     case '\017':        /* $^O & $^OPEN */
 990         if (len > 1 && strNE(name, "\017PEN"))
 991             break;
 992         goto magicalize;
 993     case '\023':        /* $^S */
 994         if (len > 1)
 995             break;
 996         goto ro_magicalize;
 997     case '\024':        /* $^T, ${^TAINT} */
 998         if (len == 1)
 999             goto magicalize;
1000         else if (strEQ(name, "\024AINT"))
1001             goto ro_magicalize;
1002         else
1003             break;
1004     case '\025':
1005         if (len > 1 && strNE(name, "\025NICODE"))
1006             break;
1007         goto ro_magicalize;
1008
1009     case '\027':        /* $^W & $^WARNING_BITS */
1010         if (len > 1
1011             && strNE(name, "\027ARNING_BITS")
1012             )
1013             break;
1014         goto magicalize;
1015
1016     case '+':
1017         if (len > 1)
1018             break;
1019         else {
1020             AV* av = GvAVn(gv);
1021             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1022             SvREADONLY_on(av);
1023         }
1024         /* FALL THROUGH */
1025     case '1':
1026     case '2':
1027     case '3':
1028     case '4':
1029     case '5':
1030     case '6':
1031     case '7':
1032     case '8':
1033     case '9':
1034         /* ensures variable is only digits */
1035         /* ${"1foo"} fails this test (and is thus writeable) */
1036         /* added by japhy, but borrowed from is_gv_magical */
1037
1038         if (len > 1) {
1039             const char *end = name + len;
1040             while (--end > name) {
1041                 if (!isDIGIT(*end)) return gv;
1042             }
1043         }
1044
1045       ro_magicalize:
1046         SvREADONLY_on(GvSV(gv));
1047       magicalize:
1048         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1049         break;
1050
1051     case '\014':        /* $^L */
1052         if (len > 1)
1053             break;
1054         sv_setpv(GvSV(gv),"\f");
1055         PL_formfeed = GvSV(gv);
1056         break;
1057     case ';':
1058         if (len > 1)
1059             break;
1060         sv_setpv(GvSV(gv),"\034");
1061         break;
1062     case ']':
1063         if (len == 1) {
1064             SV *sv = GvSV(gv);
1065             if (!sv_derived_from(PL_patchlevel, "version"))
1066                 (void *)upg_version(PL_patchlevel);
1067             GvSV(gv) = vnumify(PL_patchlevel);
1068             SvREADONLY_on(GvSV(gv));
1069             SvREFCNT_dec(sv);
1070         }
1071         break;
1072     case '\026':        /* $^V */
1073         if (len == 1) {
1074             SV *sv = GvSV(gv);
1075             GvSV(gv) = new_version(PL_patchlevel);
1076             SvREADONLY_on(GvSV(gv));
1077             SvREFCNT_dec(sv);
1078         }
1079         break;
1080     }
1081     return gv;
1082 }
1083
1084 void
1085 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1086 {
1087     char *name;
1088     HV *hv = GvSTASH(gv);
1089     if (!hv) {
1090         SvOK_off(sv);
1091         return;
1092     }
1093     sv_setpv(sv, prefix ? prefix : "");
1094
1095     name = HvNAME(hv);
1096     if (!name)
1097         name = "__ANON__";
1098
1099     if (keepmain || strNE(name, "main")) {
1100         Perl_sv_catpvf(aTHX_ sv,"%s::", name);
1101     }
1102     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1103 }
1104
1105 void
1106 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1107 {
1108     gv_fullname4(sv, gv, prefix, TRUE);
1109 }
1110
1111 void
1112 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1113 {
1114     GV *egv = GvEGV(gv);
1115     if (!egv)
1116         egv = gv;
1117     gv_fullname4(sv, egv, prefix, keepmain);
1118 }
1119
1120 void
1121 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1122 {
1123     gv_efullname4(sv, gv, prefix, TRUE);
1124 }
1125
1126 /* XXX compatibility with versions <= 5.003. */
1127 void
1128 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1129 {
1130     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1131 }
1132
1133 /* XXX compatibility with versions <= 5.003. */
1134 void
1135 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1136 {
1137     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1138 }
1139
1140 IO *
1141 Perl_newIO(pTHX)
1142 {
1143     IO *io;
1144     GV *iogv;
1145
1146     io = (IO*)NEWSV(0,0);
1147     sv_upgrade((SV *)io,SVt_PVIO);
1148     SvREFCNT(io) = 1;
1149     SvOBJECT_on(io);
1150     /* Clear the stashcache because a new IO could overrule a
1151        package name */
1152     hv_clear(PL_stashcache);
1153     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1154     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1155     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1156       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1157     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1158     return io;
1159 }
1160
1161 void
1162 Perl_gv_check(pTHX_ HV *stash)
1163 {
1164     register HE *entry;
1165     register I32 i;
1166     register GV *gv;
1167     HV *hv;
1168
1169     if (!HvARRAY(stash))
1170         return;
1171     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1172         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1173             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1174                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1175             {
1176                 if (hv != PL_defstash && hv != stash)
1177                      gv_check(hv);              /* nested package */
1178             }
1179             else if (isALPHA(*HeKEY(entry))) {
1180                 char *file;
1181                 gv = (GV*)HeVAL(entry);
1182                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1183                     continue;
1184                 file = GvFILE(gv);
1185                 /* performance hack: if filename is absolute and it's a standard
1186                  * module, don't bother warning */
1187                 if (file
1188                     && PERL_FILE_IS_ABSOLUTE(file)
1189 #ifdef MACOS_TRADITIONAL
1190                     && (instr(file, ":lib:")
1191 #else
1192                     && (instr(file, "/lib/")
1193 #endif
1194                     || instr(file, ".pm")))
1195                 {
1196                     continue;
1197                 }
1198                 CopLINE_set(PL_curcop, GvLINE(gv));
1199 #ifdef USE_ITHREADS
1200                 CopFILE(PL_curcop) = file;      /* set for warning */
1201 #else
1202                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1203 #endif
1204                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1205                         "Name \"%s::%s\" used only once: possible typo",
1206                         HvNAME(stash), GvNAME(gv));
1207             }
1208         }
1209     }
1210 }
1211
1212 GV *
1213 Perl_newGVgen(pTHX_ char *pack)
1214 {
1215     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1216                       TRUE, SVt_PVGV);
1217 }
1218
1219 /* hopefully this is only called on local symbol table entries */
1220
1221 GP*
1222 Perl_gp_ref(pTHX_ GP *gp)
1223 {
1224     if (!gp)
1225         return (GP*)NULL;
1226     gp->gp_refcnt++;
1227     if (gp->gp_cv) {
1228         if (gp->gp_cvgen) {
1229             /* multi-named GPs cannot be used for method cache */
1230             SvREFCNT_dec(gp->gp_cv);
1231             gp->gp_cv = Nullcv;
1232             gp->gp_cvgen = 0;
1233         }
1234         else {
1235             /* Adding a new name to a subroutine invalidates method cache */
1236             PL_sub_generation++;
1237         }
1238     }
1239     return gp;
1240 }
1241
1242 void
1243 Perl_gp_free(pTHX_ GV *gv)
1244 {
1245     GP* gp;
1246
1247     if (!gv || !(gp = GvGP(gv)))
1248         return;
1249     if (gp->gp_refcnt == 0) {
1250         if (ckWARN_d(WARN_INTERNAL))
1251             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1252                         "Attempt to free unreferenced glob pointers"
1253                         pTHX__FORMAT pTHX__VALUE);
1254         return;
1255     }
1256     if (gp->gp_cv) {
1257         /* Deleting the name of a subroutine invalidates method cache */
1258         PL_sub_generation++;
1259     }
1260     if (--gp->gp_refcnt > 0) {
1261         if (gp->gp_egv == gv)
1262             gp->gp_egv = 0;
1263         return;
1264     }
1265
1266     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1267     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1268     if (gp->gp_hv) {
1269          if (PL_stashcache && HvNAME(gp->gp_hv))
1270               hv_delete(PL_stashcache,
1271                         HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1272                         G_DISCARD);
1273          SvREFCNT_dec(gp->gp_hv);
1274     }
1275     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1276     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1277     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1278
1279     Safefree(gp);
1280     GvGP(gv) = 0;
1281 }
1282
1283 int
1284 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1285 {
1286     AMT *amtp = (AMT*)mg->mg_ptr;
1287     if (amtp && AMT_AMAGIC(amtp)) {
1288         int i;
1289         for (i = 1; i < NofAMmeth; i++) {
1290             CV *cv = amtp->table[i];
1291             if (cv != Nullcv) {
1292                 SvREFCNT_dec((SV *) cv);
1293                 amtp->table[i] = Nullcv;
1294             }
1295         }
1296     }
1297  return 0;
1298 }
1299
1300 /* Updates and caches the CV's */
1301
1302 bool
1303 Perl_Gv_AMupdate(pTHX_ HV *stash)
1304 {
1305   GV* gv;
1306   CV* cv;
1307   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1308   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1309   AMT amt;
1310
1311   if (mg && amtp->was_ok_am == PL_amagic_generation
1312       && amtp->was_ok_sub == PL_sub_generation)
1313       return (bool)AMT_OVERLOADED(amtp);
1314   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1315
1316   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1317
1318   Zero(&amt,1,AMT);
1319   amt.was_ok_am = PL_amagic_generation;
1320   amt.was_ok_sub = PL_sub_generation;
1321   amt.fallback = AMGfallNO;
1322   amt.flags = 0;
1323
1324   {
1325     int filled = 0, have_ovl = 0;
1326     int i, lim = 1;
1327     SV* sv = NULL;
1328
1329     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1330
1331     /* Try to find via inheritance. */
1332     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1333     if (gv)
1334         sv = GvSV(gv);
1335
1336     if (!gv)
1337         lim = DESTROY_amg;              /* Skip overloading entries. */
1338     else if (SvTRUE(sv))
1339         amt.fallback=AMGfallYES;
1340     else if (SvOK(sv))
1341         amt.fallback=AMGfallNEVER;
1342
1343     for (i = 1; i < lim; i++)
1344         amt.table[i] = Nullcv;
1345     for (; i < NofAMmeth; i++) {
1346         char *cooky = (char*)PL_AMG_names[i];
1347         /* Human-readable form, for debugging: */
1348         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1349         STRLEN l = strlen(cooky);
1350
1351         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1352                      cp, HvNAME(stash)) );
1353         /* don't fill the cache while looking up!
1354            Creation of inheritance stubs in intermediate packages may
1355            conflict with the logic of runtime method substitution.
1356            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1357            then we could have created stubs for "(+0" in A and C too.
1358            But if B overloads "bool", we may want to use it for
1359            numifying instead of C's "+0". */
1360         if (i >= DESTROY_amg)
1361             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1362         else                            /* Autoload taken care of below */
1363             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1364         cv = 0;
1365         if (gv && (cv = GvCV(gv))) {
1366             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1367                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1368                 /* This is a hack to support autoloading..., while
1369                    knowing *which* methods were declared as overloaded. */
1370                 /* GvSV contains the name of the method. */
1371                 GV *ngv = Nullgv;
1372
1373                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1374                         "' for overloaded `%s' in package `%.256s'\n",
1375                              GvSV(gv), cp, HvNAME(stash)) );
1376                 if (!SvPOK(GvSV(gv))
1377                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1378                                                        FALSE)))
1379                 {
1380                     /* Can be an import stub (created by `can'). */
1381                     SV *gvsv = GvSV(gv);
1382                     const char *name = SvPOK(gvsv) ?  SvPVX(gvsv) : "???";
1383                     Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1384                                 "in package `%.256s'",
1385                                (GvCVGEN(gv) ? "Stub found while resolving"
1386                                 : "Can't resolve"),
1387                                name, cp, HvNAME(stash));
1388                 }
1389                 cv = GvCV(gv = ngv);
1390             }
1391             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1392                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1393                          GvNAME(CvGV(cv))) );
1394             filled = 1;
1395             if (i < DESTROY_amg)
1396                 have_ovl = 1;
1397         } else if (gv) {                /* Autoloaded... */
1398             cv = (CV*)gv;
1399             filled = 1;
1400         }
1401         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1402     }
1403     if (filled) {
1404       AMT_AMAGIC_on(&amt);
1405       if (have_ovl)
1406           AMT_OVERLOADED_on(&amt);
1407       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1408                                                 (char*)&amt, sizeof(AMT));
1409       return have_ovl;
1410     }
1411   }
1412   /* Here we have no table: */
1413   /* no_table: */
1414   AMT_AMAGIC_off(&amt);
1415   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1416                                                 (char*)&amt, sizeof(AMTS));
1417   return FALSE;
1418 }
1419
1420
1421 CV*
1422 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1423 {
1424     MAGIC *mg;
1425     AMT *amtp;
1426     CV *ret;
1427
1428     if (!stash || !HvNAME(stash))
1429         return Nullcv;
1430     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1431     if (!mg) {
1432       do_update:
1433         Gv_AMupdate(stash);
1434         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1435     }
1436     amtp = (AMT*)mg->mg_ptr;
1437     if ( amtp->was_ok_am != PL_amagic_generation
1438          || amtp->was_ok_sub != PL_sub_generation )
1439         goto do_update;
1440     if (AMT_AMAGIC(amtp)) {
1441         ret = amtp->table[id];
1442         if (ret && isGV(ret)) {         /* Autoloading stab */
1443             /* Passing it through may have resulted in a warning
1444                "Inherited AUTOLOAD for a non-method deprecated", since
1445                our caller is going through a function call, not a method call.
1446                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1447             GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1448
1449             if (gv && GvCV(gv))
1450                 return GvCV(gv);
1451         }
1452         return ret;
1453     }
1454
1455     return Nullcv;
1456 }
1457
1458
1459 SV*
1460 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1461 {
1462   MAGIC *mg;
1463   CV *cv=NULL;
1464   CV **cvp=NULL, **ocvp=NULL;
1465   AMT *amtp=NULL, *oamtp=NULL;
1466   int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1467   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1468 #ifdef DEBUGGING
1469   int fl=0;
1470 #endif
1471   HV* stash=NULL;
1472   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1473       && (stash = SvSTASH(SvRV(left)))
1474       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1475       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1476                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1477                         : (CV **) NULL))
1478       && ((cv = cvp[off=method+assignshift])
1479           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1480                                                           * usual method */
1481                   (
1482 #ifdef DEBUGGING
1483                    fl = 1,
1484 #endif
1485                    cv = cvp[off=method])))) {
1486     lr = -1;                    /* Call method for left argument */
1487   } else {
1488     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1489       int logic;
1490
1491       /* look for substituted methods */
1492       /* In all the covered cases we should be called with assign==0. */
1493          switch (method) {
1494          case inc_amg:
1495            force_cpy = 1;
1496            if ((cv = cvp[off=add_ass_amg])
1497                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1498              right = &PL_sv_yes; lr = -1; assign = 1;
1499            }
1500            break;
1501          case dec_amg:
1502            force_cpy = 1;
1503            if ((cv = cvp[off = subtr_ass_amg])
1504                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1505              right = &PL_sv_yes; lr = -1; assign = 1;
1506            }
1507            break;
1508          case bool__amg:
1509            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1510            break;
1511          case numer_amg:
1512            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1513            break;
1514          case string_amg:
1515            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1516            break;
1517  case not_amg:
1518    (void)((cv = cvp[off=bool__amg])
1519           || (cv = cvp[off=numer_amg])
1520           || (cv = cvp[off=string_amg]));
1521    postpr = 1;
1522    break;
1523          case copy_amg:
1524            {
1525              /*
1526                   * SV* ref causes confusion with the interpreter variable of
1527                   * the same name
1528                   */
1529              SV* tmpRef=SvRV(left);
1530              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1531                 /*
1532                  * Just to be extra cautious.  Maybe in some
1533                  * additional cases sv_setsv is safe, too.
1534                  */
1535                 SV* newref = newSVsv(tmpRef);
1536                 SvOBJECT_on(newref);
1537                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1538                 return newref;
1539              }
1540            }
1541            break;
1542          case abs_amg:
1543            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1544                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1545              SV* nullsv=sv_2mortal(newSViv(0));
1546              if (off1==lt_amg) {
1547                SV* lessp = amagic_call(left,nullsv,
1548                                        lt_amg,AMGf_noright);
1549                logic = SvTRUE(lessp);
1550              } else {
1551                SV* lessp = amagic_call(left,nullsv,
1552                                        ncmp_amg,AMGf_noright);
1553                logic = (SvNV(lessp) < 0);
1554              }
1555              if (logic) {
1556                if (off==subtr_amg) {
1557                  right = left;
1558                  left = nullsv;
1559                  lr = 1;
1560                }
1561              } else {
1562                return left;
1563              }
1564            }
1565            break;
1566          case neg_amg:
1567            if ((cv = cvp[off=subtr_amg])) {
1568              right = left;
1569              left = sv_2mortal(newSViv(0));
1570              lr = 1;
1571            }
1572            break;
1573          case int_amg:
1574          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1575              /* FAIL safe */
1576              return NULL;       /* Delegate operation to standard mechanisms. */
1577              break;
1578          case to_sv_amg:
1579          case to_av_amg:
1580          case to_hv_amg:
1581          case to_gv_amg:
1582          case to_cv_amg:
1583              /* FAIL safe */
1584              return left;       /* Delegate operation to standard mechanisms. */
1585              break;
1586          default:
1587            goto not_found;
1588          }
1589          if (!cv) goto not_found;
1590     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1591                && (stash = SvSTASH(SvRV(right)))
1592                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1593                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1594                           ? (amtp = (AMT*)mg->mg_ptr)->table
1595                           : (CV **) NULL))
1596                && (cv = cvp[off=method])) { /* Method for right
1597                                              * argument found */
1598       lr=1;
1599     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1600                  && (cvp=ocvp) && (lr = -1))
1601                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1602                && !(flags & AMGf_unary)) {
1603                                 /* We look for substitution for
1604                                  * comparison operations and
1605                                  * concatenation */
1606       if (method==concat_amg || method==concat_ass_amg
1607           || method==repeat_amg || method==repeat_ass_amg) {
1608         return NULL;            /* Delegate operation to string conversion */
1609       }
1610       off = -1;
1611       switch (method) {
1612          case lt_amg:
1613          case le_amg:
1614          case gt_amg:
1615          case ge_amg:
1616          case eq_amg:
1617          case ne_amg:
1618            postpr = 1; off=ncmp_amg; break;
1619          case slt_amg:
1620          case sle_amg:
1621          case sgt_amg:
1622          case sge_amg:
1623          case seq_amg:
1624          case sne_amg:
1625            postpr = 1; off=scmp_amg; break;
1626          }
1627       if (off != -1) cv = cvp[off];
1628       if (!cv) {
1629         goto not_found;
1630       }
1631     } else {
1632     not_found:                  /* No method found, either report or croak */
1633       switch (method) {
1634          case to_sv_amg:
1635          case to_av_amg:
1636          case to_hv_amg:
1637          case to_gv_amg:
1638          case to_cv_amg:
1639              /* FAIL safe */
1640              return left;       /* Delegate operation to standard mechanisms. */
1641              break;
1642       }
1643       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1644         notfound = 1; lr = -1;
1645       } else if (cvp && (cv=cvp[nomethod_amg])) {
1646         notfound = 1; lr = 1;
1647       } else {
1648         SV *msg;
1649         if (off==-1) off=method;
1650         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1651                       "Operation `%s': no method found,%sargument %s%s%s%s",
1652                       AMG_id2name(method + assignshift),
1653                       (flags & AMGf_unary ? " " : "\n\tleft "),
1654                       SvAMAGIC(left)?
1655                         "in overloaded package ":
1656                         "has no overloaded magic",
1657                       SvAMAGIC(left)?
1658                         HvNAME(SvSTASH(SvRV(left))):
1659                         "",
1660                       SvAMAGIC(right)?
1661                         ",\n\tright argument in overloaded package ":
1662                         (flags & AMGf_unary
1663                          ? ""
1664                          : ",\n\tright argument has no overloaded magic"),
1665                       SvAMAGIC(right)?
1666                         HvNAME(SvSTASH(SvRV(right))):
1667                         ""));
1668         if (amtp && amtp->fallback >= AMGfallYES) {
1669           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1670         } else {
1671           Perl_croak(aTHX_ "%"SVf, msg);
1672         }
1673         return NULL;
1674       }
1675       force_cpy = force_cpy || assign;
1676     }
1677   }
1678 #ifdef DEBUGGING
1679   if (!notfound) {
1680     DEBUG_o(Perl_deb(aTHX_
1681                      "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1682                      AMG_id2name(off),
1683                      method+assignshift==off? "" :
1684                      " (initially `",
1685                      method+assignshift==off? "" :
1686                      AMG_id2name(method+assignshift),
1687                      method+assignshift==off? "" : "')",
1688                      flags & AMGf_unary? "" :
1689                      lr==1 ? " for right argument": " for left argument",
1690                      flags & AMGf_unary? " for argument" : "",
1691                      stash ? HvNAME(stash) : "null",
1692                      fl? ",\n\tassignment variant used": "") );
1693   }
1694 #endif
1695     /* Since we use shallow copy during assignment, we need
1696      * to dublicate the contents, probably calling user-supplied
1697      * version of copy operator
1698      */
1699     /* We need to copy in following cases:
1700      * a) Assignment form was called.
1701      *          assignshift==1,  assign==T, method + 1 == off
1702      * b) Increment or decrement, called directly.
1703      *          assignshift==0,  assign==0, method + 0 == off
1704      * c) Increment or decrement, translated to assignment add/subtr.
1705      *          assignshift==0,  assign==T,
1706      *          force_cpy == T
1707      * d) Increment or decrement, translated to nomethod.
1708      *          assignshift==0,  assign==0,
1709      *          force_cpy == T
1710      * e) Assignment form translated to nomethod.
1711      *          assignshift==1,  assign==T, method + 1 != off
1712      *          force_cpy == T
1713      */
1714     /*  off is method, method+assignshift, or a result of opcode substitution.
1715      *  In the latter case assignshift==0, so only notfound case is important.
1716      */
1717   if (( (method + assignshift == off)
1718         && (assign || (method == inc_amg) || (method == dec_amg)))
1719       || force_cpy)
1720     RvDEEPCP(left);
1721   {
1722     dSP;
1723     BINOP myop;
1724     SV* res;
1725     bool oldcatch = CATCH_GET;
1726
1727     CATCH_SET(TRUE);
1728     Zero(&myop, 1, BINOP);
1729     myop.op_last = (OP *) &myop;
1730     myop.op_next = Nullop;
1731     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1732
1733     PUSHSTACKi(PERLSI_OVERLOAD);
1734     ENTER;
1735     SAVEOP();
1736     PL_op = (OP *) &myop;
1737     if (PERLDB_SUB && PL_curstash != PL_debstash)
1738         PL_op->op_private |= OPpENTERSUB_DB;
1739     PUTBACK;
1740     pp_pushmark();
1741
1742     EXTEND(SP, notfound + 5);
1743     PUSHs(lr>0? right: left);
1744     PUSHs(lr>0? left: right);
1745     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1746     if (notfound) {
1747       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1748     }
1749     PUSHs((SV*)cv);
1750     PUTBACK;
1751
1752     if ((PL_op = Perl_pp_entersub(aTHX)))
1753       CALLRUNOPS(aTHX);
1754     LEAVE;
1755     SPAGAIN;
1756
1757     res=POPs;
1758     PUTBACK;
1759     POPSTACK;
1760     CATCH_SET(oldcatch);
1761
1762     if (postpr) {
1763       int ans=0;
1764       switch (method) {
1765       case le_amg:
1766       case sle_amg:
1767         ans=SvIV(res)<=0; break;
1768       case lt_amg:
1769       case slt_amg:
1770         ans=SvIV(res)<0; break;
1771       case ge_amg:
1772       case sge_amg:
1773         ans=SvIV(res)>=0; break;
1774       case gt_amg:
1775       case sgt_amg:
1776         ans=SvIV(res)>0; break;
1777       case eq_amg:
1778       case seq_amg:
1779         ans=SvIV(res)==0; break;
1780       case ne_amg:
1781       case sne_amg:
1782         ans=SvIV(res)!=0; break;
1783       case inc_amg:
1784       case dec_amg:
1785         SvSetSV(left,res); return left;
1786       case not_amg:
1787         ans=!SvTRUE(res); break;
1788       }
1789       return boolSV(ans);
1790     } else if (method==copy_amg) {
1791       if (!SvROK(res)) {
1792         Perl_croak(aTHX_ "Copy method did not return a reference");
1793       }
1794       return SvREFCNT_inc(SvRV(res));
1795     } else {
1796       return res;
1797     }
1798   }
1799 }
1800
1801 /*
1802 =for apidoc is_gv_magical
1803
1804 Returns C<TRUE> if given the name of a magical GV.
1805
1806 Currently only useful internally when determining if a GV should be
1807 created even in rvalue contexts.
1808
1809 C<flags> is not used at present but available for future extension to
1810 allow selecting particular classes of magical variable.
1811
1812 =cut
1813 */
1814 bool
1815 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1816 {
1817     if (!len)
1818         return FALSE;
1819
1820     switch (*name) {
1821     case 'I':
1822         if (len == 3 && strEQ(name, "ISA"))
1823             goto yes;
1824         break;
1825     case 'O':
1826         if (len == 8 && strEQ(name, "OVERLOAD"))
1827             goto yes;
1828         break;
1829     case 'S':
1830         if (len == 3 && strEQ(name, "SIG"))
1831             goto yes;
1832         break;
1833     case '\017':   /* $^O & $^OPEN */
1834         if (len == 1
1835             || (len == 4 && strEQ(name, "\017PEN")))
1836         {
1837             goto yes;
1838         }
1839         break;
1840     case '\025':
1841         if (len > 1 && strEQ(name, "\025NICODE"))
1842             goto yes;
1843     case '\027':   /* $^W & $^WARNING_BITS */
1844         if (len == 1
1845             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1846             )
1847         {
1848             goto yes;
1849         }
1850         break;
1851
1852     case '&':
1853     case '`':
1854     case '\'':
1855     case ':':
1856     case '?':
1857     case '!':
1858     case '-':
1859     case '#':
1860     case '[':
1861     case '^':
1862     case '~':
1863     case '=':
1864     case '%':
1865     case '.':
1866     case '(':
1867     case ')':
1868     case '<':
1869     case '>':
1870     case ',':
1871     case '\\':
1872     case '/':
1873     case '|':
1874     case '+':
1875     case ';':
1876     case ']':
1877     case '\001':   /* $^A */
1878     case '\003':   /* $^C */
1879     case '\004':   /* $^D */
1880     case '\005':   /* $^E */
1881     case '\006':   /* $^F */
1882     case '\010':   /* $^H */
1883     case '\011':   /* $^I, NOT \t in EBCDIC */
1884     case '\014':   /* $^L */
1885     case '\016':   /* $^N */
1886     case '\020':   /* $^P */
1887     case '\023':   /* $^S */
1888     case '\026':   /* $^V */
1889         if (len == 1)
1890             goto yes;
1891         break;
1892     case '\024':   /* $^T, ${^TAINT} */
1893         if (len == 1 || strEQ(name, "\024AINT"))
1894             goto yes;
1895         break;
1896     case '1':
1897     case '2':
1898     case '3':
1899     case '4':
1900     case '5':
1901     case '6':
1902     case '7':
1903     case '8':
1904     case '9':
1905         if (len > 1) {
1906             char *end = name + len;
1907             while (--end > name) {
1908                 if (!isDIGIT(*end))
1909                     return FALSE;
1910             }
1911         }
1912     yes:
1913         return TRUE;
1914     default:
1915         break;
1916     }
1917     return FALSE;
1918 }