pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (c) 1991-1994, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  12  * shaking the air.
  13  *
  14  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  15  *                     Fire, Foes!  Awake!
  16  */
  17
  18 #include "EXTERN.h"
  19 #include "perl.h"
  20
  21 /* Hot code. */
  22
  23 #ifdef USE_THREADS
  24 static void
  25 unset_cvowner(cvarg)
  26 void *cvarg;
  27 {
  28     register CV* cv = (CV *) cvarg;
  29 #ifdef DEBUGGING
  30     dTHR;
  31 #endif /* DEBUGGING */
  32
  33     DEBUG_L((fprintf(stderr, "0x%lx unsetting CvOWNER of 0x%lx:%s\n",
  34                      (unsigned long)thr, (unsigned long)cv, SvPEEK((SV*)cv))));
  35     MUTEX_LOCK(CvMUTEXP(cv));
  36     assert(CvDEPTH(cv) == 0);
  37     assert(thr == CvOWNER(cv));
  38     CvOWNER(cv) = 0;
  39     if (CvCONDP(cv))
  40         COND_SIGNAL(CvCONDP(cv)); /* next please */
  41     MUTEX_UNLOCK(CvMUTEXP(cv));
  42     SvREFCNT_dec(cv);
  43 }
  44
  45 #if 0
  46 void
  47 mutex_unlock(m)
  48 void *m;
  49 {
  50 #ifdef DEBUGGING
  51     dTHR;
  52     DEBUG_L((fprintf(stderr, "0x%lx unlocking mutex 0x%lx\n",
  53                          (unsigned long) thr, (unsigned long) m)));
  54 #endif /* DEBUGGING */
  55     MUTEX_UNLOCK((pthread_mutex_t *) m);
  56 }
  57 #endif
  58 #endif /* USE_THREADS */
  59
  60 PP(pp_const)
  61 {
  62     dSP;
  63     XPUSHs(cSVOP->op_sv);
  64     RETURN;
  65 }
  66
  67 PP(pp_nextstate)
  68 {
  69     curcop = (COP*)op;
  70     TAINT_NOT;          /* Each statement is presumed innocent */
  71     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
  72     FREETMPS;
  73     return NORMAL;
  74 }
  75
  76 PP(pp_gvsv)
  77 {
  78     dSP;
  79     EXTEND(sp,1);
  80     if (op->op_private & OPpLVAL_INTRO)
  81         PUSHs(save_scalar(cGVOP->op_gv));
  82     else
  83         PUSHs(GvSV(cGVOP->op_gv));
  84     RETURN;
  85 }
  86
  87 PP(pp_null)
  88 {
  89     return NORMAL;
  90 }
  91
  92 PP(pp_pushmark)
  93 {
  94     PUSHMARK(stack_sp);
  95     return NORMAL;
  96 }
  97
  98 PP(pp_stringify)
  99 {
 100     dSP; dTARGET;
 101     STRLEN len;
 102     char *s;
 103     s = SvPV(TOPs,len);
 104     sv_setpvn(TARG,s,len);
 105     SETTARG;
 106     RETURN;
 107 }
 108
 109 PP(pp_gv)
 110 {
 111     dSP;
 112     XPUSHs((SV*)cGVOP->op_gv);
 113     RETURN;
 114 }
 115
 116 PP(pp_gelem)
 117 {
 118     GV *gv;
 119     SV *sv;
 120     SV *ref;
 121     char *elem;
 122     dSP;
 123
 124     sv = POPs;
 125     elem = SvPV(sv, na);
 126     gv = (GV*)POPs;
 127     ref = Nullsv;
 128     sv = Nullsv;
 129     switch (elem ? *elem : '\0')
 130     {
 131     case 'A':
 132         if (strEQ(elem, "ARRAY"))
 133             ref = (SV*)GvAV(gv);
 134         break;
 135     case 'C':
 136         if (strEQ(elem, "CODE"))
 137             ref = (SV*)GvCV(gv);
 138         break;
 139     case 'F':
 140         if (strEQ(elem, "FILEHANDLE"))
 141             ref = (SV*)GvIOp(gv);
 142         break;
 143     case 'G':
 144         if (strEQ(elem, "GLOB"))
 145             ref = (SV*)gv;
 146         break;
 147     case 'H':
 148         if (strEQ(elem, "HASH"))
 149             ref = (SV*)GvHV(gv);
 150         break;
 151     case 'N':
 152         if (strEQ(elem, "NAME"))
 153             sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
 154         break;
 155     case 'P':
 156         if (strEQ(elem, "PACKAGE"))
 157             sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
 158         break;
 159     case 'S':
 160         if (strEQ(elem, "SCALAR"))
 161             ref = GvSV(gv);
 162         break;
 163     }
 164     if (ref)
 165         sv = newRV(ref);
 166     if (sv)
 167         sv_2mortal(sv);
 168     else
 169         sv = &sv_undef;
 170     XPUSHs(sv);
 171     RETURN;
 172 }
 173
 174 PP(pp_and)
 175 {
 176     dSP;
 177     if (!SvTRUE(TOPs))
 178         RETURN;
 179     else {
 180         --SP;
 181         RETURNOP(cLOGOP->op_other);
 182     }
 183 }
 184
 185 PP(pp_sassign)
 186 {
 187     dSP; dPOPTOPssrl;
 188     MAGIC *mg;
 189
 190     if (op->op_private & OPpASSIGN_BACKWARDS) {
 191         SV *temp;
 192         temp = left; left = right; right = temp;
 193     }
 194     if (tainting && tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) ||
 195                                 !((mg = mg_find(left, 't')) && mg->mg_len & 1)))
 196     {
 197         TAINT_NOT;
 198     }
 199     SvSetSV(right, left);
 200     SvSETMAGIC(right);
 201     SETs(right);
 202     RETURN;
 203 }
 204
 205 PP(pp_cond_expr)
 206 {
 207     dSP;
 208     if (SvTRUEx(POPs))
 209         RETURNOP(cCONDOP->op_true);
 210     else
 211         RETURNOP(cCONDOP->op_false);
 212 }
 213
 214 PP(pp_unstack)
 215 {
 216     I32 oldsave;
 217     TAINT_NOT;          /* Each statement is presumed innocent */
 218     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
 219     FREETMPS;
 220     oldsave = scopestack[scopestack_ix - 1];
 221     LEAVE_SCOPE(oldsave);
 222     return NORMAL;
 223 }
 224
 225 PP(pp_seq)
 226 {
 227     dSP; tryAMAGICbinSET(seq,0);
 228     {
 229       dPOPTOPssrl;
 230       SETs( sv_eq(left, right) ? &sv_yes : &sv_no );
 231       RETURN;
 232     }
 233 }
 234
 235 PP(pp_concat)
 236 {
 237   dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 238   {
 239     dPOPTOPssrl;
 240     STRLEN len;
 241     char *s;
 242     if (TARG != left) {
 243         s = SvPV(left,len);
 244         sv_setpvn(TARG,s,len);
 245     }
 246     else if (SvGMAGICAL(TARG))
 247         mg_get(TARG);
 248     else if (!SvOK(TARG)) {
 249         s = SvPV_force(TARG, len);
 250         sv_setpv(TARG, "");     /* Suppress warning. */
 251     }
 252     s = SvPV(right,len);
 253     sv_catpvn(TARG,s,len);
 254     SETTARG;
 255     RETURN;
 256   }
 257 }
 258
 259 PP(pp_padsv)
 260 {
 261     dSP; dTARGET;
 262     XPUSHs(TARG);
 263     if (op->op_flags & OPf_MOD) {
 264         if (op->op_private & OPpLVAL_INTRO)
 265             SAVECLEARSV(curpad[op->op_targ]);
 266         else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
 267             provide_ref(op, curpad[op->op_targ]);
 268     }
 269     RETURN;
 270 }
 271
 272 PP(pp_readline)
 273 {
 274     last_in_gv = (GV*)(*stack_sp--);
 275     return do_readline();
 276 }
 277
 278 PP(pp_eq)
 279 {
 280     dSP; tryAMAGICbinSET(eq,0);
 281     {
 282       dPOPnv;
 283       SETs((TOPn == value) ? &sv_yes : &sv_no);
 284       RETURN;
 285     }
 286 }
 287
 288 PP(pp_preinc)
 289 {
 290     dSP;
 291     if (SvIOK(TOPs)) {
 292         ++SvIVX(TOPs);
 293         SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
 294     }
 295     else
 296         sv_inc(TOPs);
 297     SvSETMAGIC(TOPs);
 298     return NORMAL;
 299 }
 300
 301 PP(pp_or)
 302 {
 303     dSP;
 304     if (SvTRUE(TOPs))
 305         RETURN;
 306     else {
 307         --SP;
 308         RETURNOP(cLOGOP->op_other);
 309     }
 310 }
 311
 312 PP(pp_add)
 313 {
 314     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
 315     {
 316       dPOPTOPnnrl;
 317       SETn( left + right );
 318       RETURN;
 319     }
 320 }
 321
 322 PP(pp_aelemfast)
 323 {
 324     dSP;
 325     AV *av = GvAV((GV*)cSVOP->op_sv);
 326     SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
 327     PUSHs(svp ? *svp : &sv_undef);
 328     RETURN;
 329 }
 330
 331 PP(pp_join)
 332 {
 333     dSP; dMARK; dTARGET;
 334     MARK++;
 335     do_join(TARG, *MARK, MARK, SP);
 336     SP = MARK;
 337     SETs(TARG);
 338     RETURN;
 339 }
 340
 341 PP(pp_pushre)
 342 {
 343     dSP;
 344     XPUSHs((SV*)op);
 345     RETURN;
 346 }
 347
 348 /* Oversized hot code. */
 349
 350 PP(pp_print)
 351 {
 352     dSP; dMARK; dORIGMARK;
 353     GV *gv;
 354     IO *io;
 355     register FILE *fp;
 356
 357     if (op->op_flags & OPf_STACKED)
 358         gv = (GV*)*++MARK;
 359     else
 360         gv = defoutgv;
 361     if (!(io = GvIO(gv))) {
 362         if (dowarn) {
 363             SV* sv = sv_newmortal();
 364             gv_fullname(sv,gv);
 365             warn("Filehandle %s never opened", SvPV(sv,na));
 366         }
 367
 368         SETERRNO(EBADF,RMS$_IFI);
 369         goto just_say_no;
 370     }
 371     else if (!(fp = IoOFP(io))) {
 372         if (dowarn)  {
 373             SV* sv = sv_newmortal();
 374             gv_fullname(sv,gv);
 375             if (IoIFP(io))
 376                 warn("Filehandle %s opened only for input", SvPV(sv,na));
 377             else
 378                 warn("print on closed filehandle %s", SvPV(sv,na));
 379         }
 380         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
 381         goto just_say_no;
 382     }
 383     else {
 384         MARK++;
 385         if (ofslen) {
 386             while (MARK <= SP) {
 387                 if (!do_print(*MARK, fp))
 388                     break;
 389                 MARK++;
 390                 if (MARK <= SP) {
 391                     if (fwrite1(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
 392                         MARK--;
 393                         break;
 394                     }
 395                 }
 396             }
 397         }
 398         else {
 399             while (MARK <= SP) {
 400                 if (!do_print(*MARK, fp))
 401                     break;
 402                 MARK++;
 403             }
 404         }
 405         if (MARK <= SP)
 406             goto just_say_no;
 407         else {
 408             if (orslen)
 409                 if (fwrite1(ors, 1, orslen, fp) == 0 || ferror(fp))
 410                     goto just_say_no;
 411
 412             if (IoFLAGS(io) & IOf_FLUSH)
 413                 if (Fflush(fp) == EOF)
 414                     goto just_say_no;
 415         }
 416     }
 417     SP = ORIGMARK;
 418     PUSHs(&sv_yes);
 419     RETURN;
 420
 421   just_say_no:
 422     SP = ORIGMARK;
 423     PUSHs(&sv_undef);
 424     RETURN;
 425 }
 426
 427 PP(pp_rv2av)
 428 {
 429     dSP; dPOPss;
 430
 431     AV *av;
 432
 433     if (SvROK(sv)) {
 434       wasref:
 435         av = (AV*)SvRV(sv);
 436         if (SvTYPE(av) != SVt_PVAV)
 437             DIE("Not an ARRAY reference");
 438         if (op->op_private & OPpLVAL_INTRO)
 439             av = (AV*)save_svref((SV**)sv);
 440         if (op->op_flags & OPf_REF) {
 441             PUSHs((SV*)av);
 442             RETURN;
 443         }
 444     }
 445     else {
 446         if (SvTYPE(sv) == SVt_PVAV) {
 447             av = (AV*)sv;
 448             if (op->op_flags & OPf_REF) {
 449                 PUSHs((SV*)av);
 450                 RETURN;
 451             }
 452         }
 453         else {
 454             if (SvTYPE(sv) != SVt_PVGV) {
 455                 char *sym;
 456
 457                 if (SvGMAGICAL(sv)) {
 458                     mg_get(sv);
 459                     if (SvROK(sv))
 460                         goto wasref;
 461                 }
 462                 if (!SvOK(sv)) {
 463                     if (op->op_flags & OPf_REF ||
 464                       op->op_private & HINT_STRICT_REFS)
 465                         DIE(no_usym, "an ARRAY");
 466                     if (GIMME == G_ARRAY)
 467                         RETURN;
 468                     RETPUSHUNDEF;
 469                 }
 470                 sym = SvPV(sv,na);
 471                 if (op->op_private & HINT_STRICT_REFS)
 472                     DIE(no_symref, sym, "an ARRAY");
 473                 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
 474             }
 475             av = GvAVn(sv);
 476             if (op->op_private & OPpLVAL_INTRO)
 477                 av = save_ary(sv);
 478             if (op->op_flags & OPf_REF) {
 479                 PUSHs((SV*)av);
 480                 RETURN;
 481             }
 482         }
 483     }
 484
 485     if (GIMME == G_ARRAY) {
 486         I32 maxarg = AvFILL(av) + 1;
 487         EXTEND(SP, maxarg);
 488         Copy(AvARRAY(av), SP+1, maxarg, SV*);
 489         SP += maxarg;
 490     }
 491     else {
 492         dTARGET;
 493         I32 maxarg = AvFILL(av) + 1;
 494         PUSHi(maxarg);
 495     }
 496     RETURN;
 497 }
 498
 499 PP(pp_rv2hv)
 500 {
 501
 502     dSP; dTOPss;
 503
 504     HV *hv;
 505
 506     if (SvROK(sv)) {
 507       wasref:
 508         hv = (HV*)SvRV(sv);
 509         if (SvTYPE(hv) != SVt_PVHV)
 510             DIE("Not a HASH reference");
 511         if (op->op_private & OPpLVAL_INTRO)
 512             hv = (HV*)save_svref((SV**)sv);
 513         if (op->op_flags & OPf_REF) {
 514             SETs((SV*)hv);
 515             RETURN;
 516         }
 517     }
 518     else {
 519         if (SvTYPE(sv) == SVt_PVHV) {
 520             hv = (HV*)sv;
 521             if (op->op_flags & OPf_REF) {
 522                 SETs((SV*)hv);
 523                 RETURN;
 524             }
 525         }
 526         else {
 527             if (SvTYPE(sv) != SVt_PVGV) {
 528                 char *sym;
 529
 530                 if (SvGMAGICAL(sv)) {
 531                     mg_get(sv);
 532                     if (SvROK(sv))
 533                         goto wasref;
 534                 }
 535                 if (!SvOK(sv)) {
 536                     if (op->op_flags & OPf_REF ||
 537                       op->op_private & HINT_STRICT_REFS)
 538                         DIE(no_usym, "a HASH");
 539                     if (GIMME == G_ARRAY) {
 540                         SP--;
 541                         RETURN;
 542                     }
 543                     RETSETUNDEF;
 544                 }
 545                 sym = SvPV(sv,na);
 546                 if (op->op_private & HINT_STRICT_REFS)
 547                     DIE(no_symref, sym, "a HASH");
 548                 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
 549             }
 550             hv = GvHVn(sv);
 551             if (op->op_private & OPpLVAL_INTRO)
 552                 hv = save_hash(sv);
 553             if (op->op_flags & OPf_REF) {
 554                 SETs((SV*)hv);
 555                 RETURN;
 556             }
 557         }
 558     }
 559
 560     if (GIMME == G_ARRAY) { /* array wanted */
 561         *stack_sp = (SV*)hv;
 562         return do_kv(ARGS);
 563     }
 564     else {
 565         dTARGET;
 566         if (HvFILL(hv)) {
 567             sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1);
 568             sv_setpv(TARG, buf);
 569         }
 570         else
 571             sv_setiv(TARG, 0);
 572         SETTARG;
 573         RETURN;
 574     }
 575 }
 576
 577 PP(pp_aassign)
 578 {
 579     dSP;
 580     SV **lastlelem = stack_sp;
 581     SV **lastrelem = stack_base + POPMARK;
 582     SV **firstrelem = stack_base + POPMARK + 1;
 583     SV **firstlelem = lastrelem + 1;
 584
 585     register SV **relem;
 586     register SV **lelem;
 587
 588     register SV *sv;
 589     register AV *ary;
 590
 591     HV *hash;
 592     I32 i;
 593     int magic;
 594
 595     delaymagic = DM_DELAY;              /* catch simultaneous items */
 596
 597     /* If there's a common identifier on both sides we have to take
 598      * special care that assigning the identifier on the left doesn't
 599      * clobber a value on the right that's used later in the list.
 600      */
 601     if (op->op_private & OPpASSIGN_COMMON) {
 602         for (relem = firstrelem; relem <= lastrelem; relem++) {
 603             /*SUPPRESS 560*/
 604             if (sv = *relem)
 605                 *relem = sv_mortalcopy(sv);
 606         }
 607     }
 608
 609     relem = firstrelem;
 610     lelem = firstlelem;
 611     ary = Null(AV*);
 612     hash = Null(HV*);
 613     while (lelem <= lastlelem) {
 614         tainted = 0;            /* Each item stands on its own, taintwise. */
 615         sv = *lelem++;
 616         switch (SvTYPE(sv)) {
 617         case SVt_PVAV:
 618             ary = (AV*)sv;
 619             magic = SvMAGICAL(ary) != 0;
 620
 621             av_clear(ary);
 622             i = 0;
 623             while (relem <= lastrelem) {        /* gobble up all the rest */
 624                 sv = NEWSV(28,0);
 625                 assert(*relem);
 626                 sv_setsv(sv,*relem);
 627                 *(relem++) = sv;
 628                 (void)av_store(ary,i++,sv);
 629                 if (magic)
 630                     mg_set(sv);
 631                 tainted = 0;
 632             }
 633             break;
 634         case SVt_PVHV: {
 635                 char *tmps;
 636                 SV *tmpstr;
 637
 638                 hash = (HV*)sv;
 639                 magic = SvMAGICAL(hash) != 0;
 640                 hv_clear(hash);
 641
 642                 while (relem < lastrelem) {     /* gobble up all the rest */
 643                     STRLEN len;
 644                     if (*relem)
 645                         sv = *(relem++);
 646                     else
 647                         sv = &sv_no, relem++;
 648                     tmps = SvPV(sv, len);
 649                     tmpstr = NEWSV(29,0);
 650                     if (*relem)
 651                         sv_setsv(tmpstr,*relem);        /* value */
 652                     *(relem++) = tmpstr;
 653                     (void)hv_store(hash,tmps,len,tmpstr,0);
 654                     if (magic)
 655                         mg_set(tmpstr);
 656                     tainted = 0;
 657                 }
 658             }
 659             break;
 660         default:
 661             if (SvTHINKFIRST(sv)) {
 662                 if (SvREADONLY(sv) && curcop != &compiling) {
 663                     if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
 664                         DIE(no_modify);
 665                     if (relem <= lastrelem)
 666                         relem++;
 667                     break;
 668                 }
 669                 if (SvROK(sv))
 670                     sv_unref(sv);
 671             }
 672             if (relem <= lastrelem) {
 673                 sv_setsv(sv, *relem);
 674                 *(relem++) = sv;
 675             }
 676             else
 677                 sv_setsv(sv, &sv_undef);
 678             SvSETMAGIC(sv);
 679             break;
 680         }
 681     }
 682     if (delaymagic & ~DM_DELAY) {
 683         if (delaymagic & DM_UID) {
 684 #ifdef HAS_SETRESUID
 685             (void)setresuid(uid,euid,(Uid_t)-1);
 686 #else
 687 #  ifdef HAS_SETREUID
 688             (void)setreuid(uid,euid);
 689 #  else
 690 #    ifdef HAS_SETRUID
 691             if ((delaymagic & DM_UID) == DM_RUID) {
 692                 (void)setruid(uid);
 693                 delaymagic &= ~DM_RUID;
 694             }
 695 #    endif /* HAS_SETRUID */
 696 #    ifdef HAS_SETEUID
 697             if ((delaymagic & DM_UID) == DM_EUID) {
 698                 (void)seteuid(uid);
 699                 delaymagic &= ~DM_EUID;
 700             }
 701 #    endif /* HAS_SETEUID */
 702             if (delaymagic & DM_UID) {
 703                 if (uid != euid)
 704                     DIE("No setreuid available");
 705                 (void)setuid(uid);
 706             }
 707 #  endif /* HAS_SETREUID */
 708 #endif /* HAS_SETRESUID */
 709             uid = (int)getuid();
 710             euid = (int)geteuid();
 711         }
 712         if (delaymagic & DM_GID) {
 713 #ifdef HAS_SETRESGID
 714             (void)setresgid(gid,egid,(Gid_t)-1);
 715 #else
 716 #  ifdef HAS_SETREGID
 717             (void)setregid(gid,egid);
 718 #  else
 719 #    ifdef HAS_SETRGID
 720             if ((delaymagic & DM_GID) == DM_RGID) {
 721                 (void)setrgid(gid);
 722                 delaymagic &= ~DM_RGID;
 723             }
 724 #    endif /* HAS_SETRGID */
 725 #    ifdef HAS_SETEGID
 726             if ((delaymagic & DM_GID) == DM_EGID) {
 727                 (void)setegid(gid);
 728                 delaymagic &= ~DM_EGID;
 729             }
 730 #    endif /* HAS_SETEGID */
 731             if (delaymagic & DM_GID) {
 732                 if (gid != egid)
 733                     DIE("No setregid available");
 734                 (void)setgid(gid);
 735             }
 736 #  endif /* HAS_SETREGID */
 737 #endif /* HAS_SETRESGID */
 738             gid = (int)getgid();
 739             egid = (int)getegid();
 740         }
 741         tainting |= (uid && (euid != uid || egid != gid));
 742     }
 743     delaymagic = 0;
 744     if (GIMME == G_ARRAY) {
 745         if (ary || hash)
 746             SP = lastrelem;
 747         else
 748             SP = firstrelem + (lastlelem - firstlelem);
 749         RETURN;
 750     }
 751     else {
 752         dTARGET;
 753         SP = firstrelem;
 754
 755         SETi(lastrelem - firstrelem + 1);
 756         RETURN;
 757     }
 758 }
 759
 760 PP(pp_match)
 761 {
 762     dSP; dTARG;
 763     register PMOP *pm = cPMOP;
 764     register char *t;
 765     register char *s;
 766     char *strend;
 767     I32 global;
 768     I32 safebase;
 769     char *truebase;
 770     register REGEXP *rx = pm->op_pmregexp;
 771     I32 gimme = GIMME;
 772     STRLEN len;
 773     I32 minmatch = 0;
 774     I32 oldsave = savestack_ix;
 775
 776     if (op->op_flags & OPf_STACKED)
 777         TARG = POPs;
 778     else {
 779         TARG = GvSV(defgv);
 780         EXTEND(SP,1);
 781     }
 782     s = SvPV(TARG, len);
 783     strend = s + len;
 784     if (!s)
 785         DIE("panic: do_match");
 786
 787     if (pm->op_pmflags & PMf_USED) {
 788         if (gimme == G_ARRAY)
 789             RETURN;
 790         RETPUSHNO;
 791     }
 792
 793     if (!rx->prelen && curpm) {
 794         pm = curpm;
 795         rx = pm->op_pmregexp;
 796     }
 797     truebase = t = s;
 798     if (global = pm->op_pmflags & PMf_GLOBAL) {
 799         rx->startp[0] = 0;
 800         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
 801             MAGIC* mg = mg_find(TARG, 'g');
 802             if (mg && mg->mg_len >= 0) {
 803                 rx->endp[0] = rx->startp[0] = s + mg->mg_len;
 804                 minmatch = (mg->mg_flags & MGf_MINMATCH);
 805             }
 806         }
 807     }
 808     if (!rx->nparens && !global)
 809         gimme = G_SCALAR;                       /* accidental array context? */
 810     safebase = (gimme == G_ARRAY) || global;
 811     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
 812         SAVEINT(multiline);
 813         multiline = pm->op_pmflags & PMf_MULTILINE;
 814     }
 815
 816 play_it_again:
 817     if (global && rx->startp[0]) {
 818         t = s = rx->endp[0];
 819         if (s > strend)
 820             goto nope;
 821         minmatch = (s == rx->startp[0]);
 822     }
 823     if (pm->op_pmshort) {
 824         if (pm->op_pmflags & PMf_SCANFIRST) {
 825             if (SvSCREAM(TARG)) {
 826                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
 827                     goto nope;
 828                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
 829                     goto nope;
 830                 else if (pm->op_pmflags & PMf_ALL)
 831                     goto yup;
 832             }
 833             else if (!(s = fbm_instr((unsigned char*)s,
 834               (unsigned char*)strend, pm->op_pmshort)))
 835                 goto nope;
 836             else if (pm->op_pmflags & PMf_ALL)
 837                 goto yup;
 838             if (s && rx->regback >= 0) {
 839                 ++BmUSEFUL(pm->op_pmshort);
 840                 s -= rx->regback;
 841                 if (s < t)
 842                     s = t;
 843             }
 844             else
 845                 s = t;
 846         }
 847         else if (!multiline) {
 848             if (*SvPVX(pm->op_pmshort) != *s ||
 849               bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
 850                 if (pm->op_pmflags & PMf_FOLD) {
 851                     if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) )
 852                         goto nope;
 853                 }
 854                 else
 855                     goto nope;
 856             }
 857         }
 858         if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
 859             SvREFCNT_dec(pm->op_pmshort);
 860             pm->op_pmshort = Nullsv;    /* opt is being useless */
 861         }
 862     }
 863     if (pregexec(rx, s, strend, truebase, minmatch,
 864       SvSCREAM(TARG) ? TARG : Nullsv,
 865       safebase)) {
 866         curpm = pm;
 867         if (pm->op_pmflags & PMf_ONCE)
 868             pm->op_pmflags |= PMf_USED;
 869         goto gotcha;
 870     }
 871     else
 872         goto ret_no;
 873     /*NOTREACHED*/
 874
 875   gotcha:
 876     if (gimme == G_ARRAY) {
 877         I32 iters, i, len;
 878
 879         iters = rx->nparens;
 880         if (global && !iters)
 881             i = 1;
 882         else
 883             i = 0;
 884         EXTEND(SP, iters + i);
 885         for (i = !i; i <= iters; i++) {
 886             PUSHs(sv_newmortal());
 887             /*SUPPRESS 560*/
 888             if ((s = rx->startp[i]) && rx->endp[i] ) {
 889                 len = rx->endp[i] - s;
 890                 sv_setpvn(*SP, s, len);
 891             }
 892         }
 893         if (global) {
 894             truebase = rx->subbeg;
 895             if (rx->startp[0] && rx->startp[0] == rx->endp[0])
 896                 ++rx->endp[0];
 897             goto play_it_again;
 898         }
 899         LEAVE_SCOPE(oldsave);
 900         RETURN;
 901     }
 902     else {
 903         if (global) {
 904             MAGIC* mg = 0;
 905             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
 906                 mg = mg_find(TARG, 'g');
 907             if (!mg) {
 908                 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
 909                 mg = mg_find(TARG, 'g');
 910             }
 911             if (rx->startp[0]) {
 912                 mg->mg_len = rx->endp[0] - truebase;
 913                 if (rx->startp[0] == rx->endp[0])
 914                     mg->mg_flags |= MGf_MINMATCH;
 915                 else
 916                     mg->mg_flags &= ~MGf_MINMATCH;
 917             }
 918             else
 919                 mg->mg_len = -1;
 920         }
 921         LEAVE_SCOPE(oldsave);
 922         RETPUSHYES;
 923     }
 924
 925 yup:
 926     ++BmUSEFUL(pm->op_pmshort);
 927     curpm = pm;
 928     if (pm->op_pmflags & PMf_ONCE)
 929         pm->op_pmflags |= PMf_USED;
 930     if (global) {
 931         rx->subbeg = truebase;
 932         rx->subend = strend;
 933         rx->startp[0] = s;
 934         rx->endp[0] = s + SvCUR(pm->op_pmshort);
 935         goto gotcha;
 936     }
 937     if (sawampersand) {
 938         char *tmps;
 939
 940         if (rx->subbase)
 941             Safefree(rx->subbase);
 942         tmps = rx->subbase = savepvn(t, strend-t);
 943         rx->subbeg = tmps;
 944         rx->subend = tmps + (strend-t);
 945         tmps = rx->startp[0] = tmps + (s - t);
 946         rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
 947     }
 948     LEAVE_SCOPE(oldsave);
 949     RETPUSHYES;
 950
 951 nope:
 952     if (pm->op_pmshort)
 953         ++BmUSEFUL(pm->op_pmshort);
 954
 955 ret_no:
 956     if (global) {
 957         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
 958             MAGIC* mg = mg_find(TARG, 'g');
 959             if (mg)
 960                 mg->mg_len = -1;
 961         }
 962     }
 963     LEAVE_SCOPE(oldsave);
 964     if (gimme == G_ARRAY)
 965         RETURN;
 966     RETPUSHNO;
 967 }
 968
 969 OP *
 970 do_readline()
 971 {
 972     dTHR;
 973     dSP; dTARGETSTACKED;
 974     register SV *sv;
 975     STRLEN tmplen = 0;
 976     STRLEN offset;
 977     FILE *fp;
 978     register IO *io = GvIO(last_in_gv);
 979     register I32 type = op->op_type;
 980
 981     fp = Nullfp;
 982     if (io) {
 983         fp = IoIFP(io);
 984         if (!fp) {
 985             if (IoFLAGS(io) & IOf_ARGV) {
 986                 if (IoFLAGS(io) & IOf_START) {
 987                     IoFLAGS(io) &= ~IOf_START;
 988                     IoLINES(io) = 0;
 989                     if (av_len(GvAVn(last_in_gv)) < 0) {
 990                         SV *tmpstr = newSVpv("-", 1); /* assume stdin */
 991                         av_push(GvAVn(last_in_gv), tmpstr);
 992                     }
 993                 }
 994                 fp = nextargv(last_in_gv);
 995                 if (!fp) { /* Note: fp != IoIFP(io) */
 996                     (void)do_close(last_in_gv, FALSE); /* now it does*/
 997                     IoFLAGS(io) |= IOf_START;
 998                 }
 999             }
1000             else if (type == OP_GLOB) {
1001                 SV *tmpcmd = NEWSV(55, 0);
1002                 SV *tmpglob = POPs;
1003                 ENTER;
1004                 SAVEFREESV(tmpcmd);
1005 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
1006            /* since spawning off a process is a real performance hit */
1007                 {
1008 #include <descrip.h>
1009 #include <lib$routines.h>
1010 #include <nam.h>
1011 #include <rmsdef.h>
1012                     char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
1013                     char vmsspec[NAM$C_MAXRSS+1];
1014                     char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
1015                     char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
1016                     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
1017                     FILE *tmpfp;
1018                     STRLEN i;
1019                     struct dsc$descriptor_s wilddsc
1020                        = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1021                     struct dsc$descriptor_vs rsdsc
1022                        = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
1023                     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
1024
1025                     /* We could find out if there's an explicit dev/dir or version
1026                        by peeking into lib$find_file's internal context at
1027                        ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
1028                        but that's unsupported, so I don't want to do it now and
1029                        have it bite someone in the future. */
1030                     strcat(tmpfnam,tmpnam(NULL));
1031                     cp = SvPV(tmpglob,i);
1032                     for (; i; i--) {
1033                        if (cp[i] == ';') hasver = 1;
1034                        if (cp[i] == '.') {
1035                            if (sts) hasver = 1;
1036                            else sts = 1;
1037                        }
1038                        if (cp[i] == '/') {
1039                           hasdir = isunix = 1;
1040                           break;
1041                        }
1042                        if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
1043                            hasdir = 1;
1044                            break;
1045                        }
1046                     }
1047                     if ((tmpfp = fopen(tmpfnam,"w+","fop=dlt")) != NULL) {
1048                         ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
1049                         if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
1050                         while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
1051                                                     &dfltdsc,NULL,NULL,NULL))&1)) {
1052                             end = rstr + (unsigned long int) *rslt;
1053                             if (!hasver) while (*end != ';') end--;
1054                             *(end++) = '\n';  *end = '\0';
1055                             for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
1056                             if (hasdir) {
1057                               if (isunix) trim_unixpath(rstr,SvPVX(tmpglob));
1058                               begin = rstr;
1059                             }
1060                             else {
1061                                 begin = end;
1062                                 while (*(--begin) != ']' && *begin != '>') ;
1063                                 ++begin;
1064                             }
1065                             ok = (fputs(begin,tmpfp) != EOF);
1066                         }
1067                         if (cxt) (void)lib$find_file_end(&cxt);
1068                         if (ok && sts != RMS$_NMF &&
1069                             sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
1070                         if (!ok) {
1071                             if (!(sts & 1)) {
1072                               SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
1073                             }
1074                             fclose(tmpfp);
1075                             fp = NULL;
1076                         }
1077                         else {
1078                            rewind(tmpfp);
1079                            IoTYPE(io) = '<';
1080                            IoIFP(io) = fp = tmpfp;
1081                         }
1082                     }
1083                 }
1084 #else /* !VMS */
1085 #ifdef DOSISH
1086                 sv_setpv(tmpcmd, "perlglob ");
1087                 sv_catsv(tmpcmd, tmpglob);
1088                 sv_catpv(tmpcmd, " |");
1089 #else
1090 #ifdef CSH
1091                 sv_setpvn(tmpcmd, cshname, cshlen);
1092                 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
1093                 sv_catsv(tmpcmd, tmpglob);
1094                 sv_catpv(tmpcmd, "' 2>/dev/null |");
1095 #else
1096                 sv_setpv(tmpcmd, "echo ");
1097                 sv_catsv(tmpcmd, tmpglob);
1098 #if 'z' - 'a' == 25
1099                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
1100 #else
1101                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
1102 #endif
1103 #endif /* !CSH */
1104 #endif /* !MSDOS */
1105                 (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
1106                               FALSE, 0, 0, Nullfp);
1107                 fp = IoIFP(io);
1108 #endif /* !VMS */
1109                 LEAVE;
1110             }
1111         }
1112         else if (type == OP_GLOB)
1113             SP--;
1114     }
1115     if (!fp) {
1116         if (dowarn && io && !(IoFLAGS(io) & IOf_START))
1117             warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
1118         if (GIMME == G_SCALAR) {
1119             (void)SvOK_off(TARG);
1120             PUSHTARG;
1121         }
1122         RETURN;
1123     }
1124     if (GIMME == G_ARRAY) {
1125         sv = sv_2mortal(NEWSV(57, 80));
1126         offset = 0;
1127     }
1128     else {
1129         sv = TARG;
1130         (void)SvUPGRADE(sv, SVt_PV);
1131         tmplen = SvLEN(sv);     /* remember if already alloced */
1132         if (!tmplen)
1133             Sv_Grow(sv, 80);    /* try short-buffering it */
1134         if (type == OP_RCATLINE)
1135             offset = SvCUR(sv);
1136         else
1137             offset = 0;
1138     }
1139     for (;;) {
1140         if (!sv_gets(sv, fp, offset)) {
1141             clearerr(fp);
1142             if (IoFLAGS(io) & IOf_ARGV) {
1143                 fp = nextargv(last_in_gv);
1144                 if (fp)
1145                     continue;
1146                 (void)do_close(last_in_gv, FALSE);
1147                 IoFLAGS(io) |= IOf_START;
1148             }
1149             else if (type == OP_GLOB) {
1150                 (void)do_close(last_in_gv, FALSE);
1151             }
1152             if (GIMME == G_SCALAR) {
1153                 (void)SvOK_off(TARG);
1154                 PUSHTARG;
1155             }
1156             RETURN;
1157         }
1158         IoLINES(io)++;
1159         XPUSHs(sv);
1160         if (tainting) {
1161             tainted = TRUE;
1162             SvTAINT(sv); /* Anything from the outside world...*/
1163         }
1164         if (type == OP_GLOB) {
1165             char *tmps;
1166
1167             if (SvCUR(sv) > 0 && SvCUR(rs) > 0) {
1168                 tmps = SvEND(sv) - 1;
1169                 if (*tmps == *SvPVX(rs)) {
1170                     *tmps = '\0';
1171                     SvCUR(sv)--;
1172                 }
1173             }
1174             for (tmps = SvPVX(sv); *tmps; tmps++)
1175                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1176                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1177                         break;
1178             if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) {
1179                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1180                 continue;
1181             }
1182         }
1183         if (GIMME == G_ARRAY) {
1184             if (SvLEN(sv) - SvCUR(sv) > 20) {
1185                 SvLEN_set(sv, SvCUR(sv)+1);
1186                 Renew(SvPVX(sv), SvLEN(sv), char);
1187             }
1188             sv = sv_2mortal(NEWSV(58, 80));
1189             continue;
1190         }
1191         else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1192             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1193             if (SvCUR(sv) < 60)
1194                 SvLEN_set(sv, 80);
1195             else
1196                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1197             Renew(SvPVX(sv), SvLEN(sv), char);
1198         }
1199         RETURN;
1200     }
1201 }
1202
1203 PP(pp_enter)
1204 {
1205     dSP;
1206     register CONTEXT *cx;
1207     I32 gimme;
1208
1209     /*
1210      * We don't just use the GIMME macro here because it assumes there's
1211      * already a context, which ain't necessarily so at initial startup.
1212      */
1213
1214     if (op->op_flags & OPf_KNOW)
1215         gimme = op->op_flags & OPf_LIST;
1216     else if (cxstack_ix >= 0)
1217         gimme = cxstack[cxstack_ix].blk_gimme;
1218     else
1219         gimme = G_SCALAR;
1220
1221     ENTER;
1222
1223     SAVETMPS;
1224     PUSHBLOCK(cx, CXt_BLOCK, sp);
1225
1226     RETURN;
1227 }
1228
1229 PP(pp_helem)
1230 {
1231     dSP;
1232     SV** svp;
1233     SV *keysv = POPs;
1234     STRLEN keylen;
1235     char *key = SvPV(keysv, keylen);
1236     HV *hv = (HV*)POPs;
1237     I32 lval = op->op_flags & OPf_MOD;
1238
1239     if (SvTYPE(hv) != SVt_PVHV)
1240         RETPUSHUNDEF;
1241     svp = hv_fetch(hv, key, keylen, lval);
1242     if (lval) {
1243         if (!svp || *svp == &sv_undef)
1244             DIE(no_helem, key);
1245         if (op->op_private & OPpLVAL_INTRO)
1246             save_svref(svp);
1247         else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
1248             provide_ref(op, *svp);
1249     }
1250     PUSHs(svp ? *svp : &sv_undef);
1251     RETURN;
1252 }
1253
1254 PP(pp_leave)
1255 {
1256     dSP;
1257     register CONTEXT *cx;
1258     register SV **mark;
1259     SV **newsp;
1260     PMOP *newpm;
1261     I32 gimme;
1262
1263     if (op->op_flags & OPf_SPECIAL) {
1264         cx = &cxstack[cxstack_ix];
1265         cx->blk_oldpm = curpm;  /* fake block should preserve $1 et al */
1266     }
1267
1268     POPBLOCK(cx,newpm);
1269
1270     if (op->op_flags & OPf_KNOW)
1271         gimme = op->op_flags & OPf_LIST;
1272     else if (cxstack_ix >= 0)
1273         gimme = cxstack[cxstack_ix].blk_gimme;
1274     else
1275         gimme = G_SCALAR;
1276
1277     if (gimme == G_SCALAR) {
1278         if (op->op_private & OPpLEAVE_VOID)
1279             SP = newsp;
1280         else {
1281             MARK = newsp + 1;
1282             if (MARK <= SP)
1283                 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1284                     *MARK = TOPs;
1285                 else
1286                     *MARK = sv_mortalcopy(TOPs);
1287             else {
1288                 MEXTEND(mark,0);
1289                 *MARK = &sv_undef;
1290             }
1291             SP = MARK;
1292         }
1293     }
1294     else {
1295         for (mark = newsp + 1; mark <= SP; mark++)
1296             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
1297                 *mark = sv_mortalcopy(*mark);
1298                 /* in case LEAVE wipes old return values */
1299     }
1300     curpm = newpm;      /* Don't pop $1 et al till now */
1301
1302     LEAVE;
1303
1304     RETURN;
1305 }
1306
1307 PP(pp_iter)
1308 {
1309     dSP;
1310     register CONTEXT *cx;
1311     SV *sv;
1312     AV* av;
1313
1314     EXTEND(sp, 1);
1315     cx = &cxstack[cxstack_ix];
1316     if (cx->cx_type != CXt_LOOP)
1317         DIE("panic: pp_iter");
1318     av = cx->blk_loop.iterary;
1319     if (av == stack && cx->blk_loop.iterix >= cx->blk_oldsp)
1320         RETPUSHNO;
1321
1322     if (cx->blk_loop.iterix >= AvFILL(av))
1323         RETPUSHNO;
1324
1325     if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) {
1326         SvTEMP_off(sv);
1327         *cx->blk_loop.itervar = sv;
1328     }
1329     else
1330         *cx->blk_loop.itervar = &sv_undef;
1331
1332     RETPUSHYES;
1333 }
1334
1335 PP(pp_subst)
1336 {
1337     dSP; dTARG;
1338     register PMOP *pm = cPMOP;
1339     PMOP *rpm = pm;
1340     register SV *dstr;
1341     register char *s;
1342     char *strend;
1343     register char *m;
1344     char *c;
1345     register char *d;
1346     STRLEN clen;
1347     I32 iters = 0;
1348     I32 maxiters;
1349     register I32 i;
1350     bool once;
1351     char *orig;
1352     I32 safebase;
1353     register REGEXP *rx = pm->op_pmregexp;
1354     STRLEN len;
1355     int force_on_match = 0;
1356     I32 oldsave = savestack_ix;
1357
1358     if (pm->op_pmflags & PMf_CONST)     /* known replacement string? */
1359         dstr = POPs;
1360     if (op->op_flags & OPf_STACKED)
1361         TARG = POPs;
1362     else {
1363         TARG = GvSV(defgv);
1364         EXTEND(SP,1);
1365     }
1366     s = SvPV(TARG, len);
1367     if (!SvPOKp(TARG) || SvREADONLY(TARG) || (SvTYPE(TARG) == SVt_PVGV))
1368         force_on_match = 1;
1369
1370   force_it:
1371     if (!pm || !s)
1372         DIE("panic: do_subst");
1373
1374     strend = s + len;
1375     maxiters = (strend - s) + 10;
1376
1377     if (!rx->prelen && curpm) {
1378         pm = curpm;
1379         rx = pm->op_pmregexp;
1380     }
1381     safebase = ((!rx || !rx->nparens) && !sawampersand);
1382     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1383         SAVEINT(multiline);
1384         multiline = pm->op_pmflags & PMf_MULTILINE;
1385     }
1386     orig = m = s;
1387     if (pm->op_pmshort) {
1388         if (pm->op_pmflags & PMf_SCANFIRST) {
1389             if (SvSCREAM(TARG)) {
1390                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
1391                     goto nope;
1392                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
1393                     goto nope;
1394             }
1395             else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
1396               pm->op_pmshort)))
1397                 goto nope;
1398             if (s && rx->regback >= 0) {
1399                 ++BmUSEFUL(pm->op_pmshort);
1400                 s -= rx->regback;
1401                 if (s < m)
1402                     s = m;
1403             }
1404             else
1405                 s = m;
1406         }
1407         else if (!multiline) {
1408             if (*SvPVX(pm->op_pmshort) != *s ||
1409               bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
1410                 if (pm->op_pmflags & PMf_FOLD) {
1411                     if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) )
1412                         goto nope;
1413                 }
1414                 else
1415                     goto nope;
1416             }
1417         }
1418         if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
1419             SvREFCNT_dec(pm->op_pmshort);
1420             pm->op_pmshort = Nullsv;    /* opt is being useless */
1421         }
1422     }
1423     once = !(rpm->op_pmflags & PMf_GLOBAL);
1424     if (rpm->op_pmflags & PMf_CONST) {  /* known replacement string? */
1425         c = SvPV(dstr, clen);
1426         if (clen <= rx->minlen) {
1427                                         /* can do inplace substitution */
1428             if (pregexec(rx, s, strend, orig, 0,
1429               SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1430                 if (force_on_match) {
1431                     force_on_match = 0;
1432                     s = SvPV_force(TARG, len);
1433                     goto force_it;
1434                 }
1435                 if (rx->subbase)        /* oops, no we can't */
1436                     goto long_way;
1437                 d = s;
1438                 curpm = pm;
1439                 SvSCREAM_off(TARG);     /* disable possible screamer */
1440                 if (once) {
1441                     m = rx->startp[0];
1442                     d = rx->endp[0];
1443                     s = orig;
1444                     if (m - s > strend - d) {   /* faster to shorten from end */
1445                         if (clen) {
1446                             Copy(c, m, clen, char);
1447                             m += clen;
1448                         }
1449                         i = strend - d;
1450                         if (i > 0) {
1451                             Move(d, m, i, char);
1452                             m += i;
1453                         }
1454                         *m = '\0';
1455                         SvCUR_set(TARG, m - s);
1456                         (void)SvPOK_only(TARG);
1457                         SvSETMAGIC(TARG);
1458                         PUSHs(&sv_yes);
1459                         LEAVE_SCOPE(oldsave);
1460                         RETURN;
1461                     }
1462                     /*SUPPRESS 560*/
1463                     else if (i = m - s) {       /* faster from front */
1464                         d -= clen;
1465                         m = d;
1466                         sv_chop(TARG, d-i);
1467                         s += i;
1468                         while (i--)
1469                             *--d = *--s;
1470                         if (clen)
1471                             Copy(c, m, clen, char);
1472                         (void)SvPOK_only(TARG);
1473                         SvSETMAGIC(TARG);
1474                         PUSHs(&sv_yes);
1475                         LEAVE_SCOPE(oldsave);
1476                         RETURN;
1477                     }
1478                     else if (clen) {
1479                         d -= clen;
1480                         sv_chop(TARG, d);
1481                         Copy(c, d, clen, char);
1482                         (void)SvPOK_only(TARG);
1483                         SvSETMAGIC(TARG);
1484                         PUSHs(&sv_yes);
1485                         LEAVE_SCOPE(oldsave);
1486                         RETURN;
1487                     }
1488                     else {
1489                         sv_chop(TARG, d);
1490                         (void)SvPOK_only(TARG);
1491                         SvSETMAGIC(TARG);
1492                         PUSHs(&sv_yes);
1493                         LEAVE_SCOPE(oldsave);
1494                         RETURN;
1495                     }
1496                     /* NOTREACHED */
1497                 }
1498                 do {
1499                     if (iters++ > maxiters)
1500                         DIE("Substitution loop");
1501                     m = rx->startp[0];
1502                     /*SUPPRESS 560*/
1503                     if (i = m - s) {
1504                         if (s != d)
1505                             Move(s, d, i, char);
1506                         d += i;
1507                     }
1508                     if (clen) {
1509                         Copy(c, d, clen, char);
1510                         d += clen;
1511                     }
1512                     s = rx->endp[0];
1513                 } while (pregexec(rx, s, strend, orig, s == m,
1514                     Nullsv, TRUE));     /* (don't match same null twice) */
1515                 if (s != d) {
1516                     i = strend - s;
1517                     SvCUR_set(TARG, d - SvPVX(TARG) + i);
1518                     Move(s, d, i+1, char);              /* include the Null */
1519                 }
1520                 (void)SvPOK_only(TARG);
1521                 SvSETMAGIC(TARG);
1522                 PUSHs(sv_2mortal(newSViv((I32)iters)));
1523                 LEAVE_SCOPE(oldsave);
1524                 RETURN;
1525             }
1526             PUSHs(&sv_no);
1527             LEAVE_SCOPE(oldsave);
1528             RETURN;
1529         }
1530     }
1531     else
1532         c = Nullch;
1533     if (pregexec(rx, s, strend, orig, 0,
1534       SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1535     long_way:
1536         if (force_on_match) {
1537             force_on_match = 0;
1538             s = SvPV_force(TARG, len);
1539             goto force_it;
1540         }
1541         dstr = NEWSV(25, sv_len(TARG));
1542         sv_setpvn(dstr, m, s-m);
1543         curpm = pm;
1544         if (!c) {
1545             register CONTEXT *cx;
1546             PUSHSUBST(cx);
1547             RETURNOP(cPMOP->op_pmreplroot);
1548         }
1549         do {
1550             if (iters++ > maxiters)
1551                 DIE("Substitution loop");
1552             if (rx->subbase && rx->subbase != orig) {
1553                 m = s;
1554                 s = orig;
1555                 orig = rx->subbase;
1556                 s = orig + (m - s);
1557                 strend = s + (strend - m);
1558             }
1559             m = rx->startp[0];
1560             sv_catpvn(dstr, s, m-s);
1561             s = rx->endp[0];
1562             if (clen)
1563                 sv_catpvn(dstr, c, clen);
1564             if (once)
1565                 break;
1566         } while (pregexec(rx, s, strend, orig, s == m, Nullsv,
1567             safebase));
1568         sv_catpvn(dstr, s, strend - s);
1569
1570         (void)SvOOK_off(TARG);
1571         Safefree(SvPVX(TARG));
1572         SvPVX(TARG) = SvPVX(dstr);
1573         SvCUR_set(TARG, SvCUR(dstr));
1574         SvLEN_set(TARG, SvLEN(dstr));
1575         SvPVX(dstr) = 0;
1576         sv_free(dstr);
1577
1578         (void)SvPOK_only(TARG);
1579         SvSETMAGIC(TARG);
1580         PUSHs(sv_2mortal(newSViv((I32)iters)));
1581         LEAVE_SCOPE(oldsave);
1582         RETURN;
1583     }
1584     PUSHs(&sv_no);
1585     LEAVE_SCOPE(oldsave);
1586     RETURN;
1587
1588 nope:
1589     ++BmUSEFUL(pm->op_pmshort);
1590     PUSHs(&sv_no);
1591     LEAVE_SCOPE(oldsave);
1592     RETURN;
1593 }
1594
1595 PP(pp_grepwhile)
1596 {
1597     dSP;
1598
1599     if (SvTRUEx(POPs))
1600         stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
1601     ++*markstack_ptr;
1602     LEAVE;                                      /* exit inner scope */
1603
1604     /* All done yet? */
1605     if (stack_base + *markstack_ptr > sp) {
1606         I32 items;
1607
1608         LEAVE;                                  /* exit outer scope */
1609         (void)POPMARK;                          /* pop src */
1610         items = --*markstack_ptr - markstack_ptr[-1];
1611         (void)POPMARK;                          /* pop dst */
1612         SP = stack_base + POPMARK;              /* pop original mark */
1613         if (GIMME != G_ARRAY) {
1614             dTARGET;
1615             XPUSHi(items);
1616             RETURN;
1617         }
1618         SP += items;
1619         RETURN;
1620     }
1621     else {
1622         SV *src;
1623
1624         ENTER;                                  /* enter inner scope */
1625         SAVESPTR(curpm);
1626
1627         src = stack_base[*markstack_ptr];
1628         SvTEMP_off(src);
1629         GvSV(defgv) = src;
1630
1631         RETURNOP(cLOGOP->op_other);
1632     }
1633 }
1634
1635 PP(pp_leavesub)
1636 {
1637     dSP;
1638     SV **mark;
1639     SV **newsp;
1640     PMOP *newpm;
1641     I32 gimme;
1642     register CONTEXT *cx;
1643
1644     POPBLOCK(cx,newpm);
1645     POPSUB(cx);
1646
1647     if (gimme == G_SCALAR) {
1648         MARK = newsp + 1;
1649         if (MARK <= SP)
1650             if (SvFLAGS(TOPs) & SVs_TEMP)
1651                 *MARK = TOPs;
1652             else
1653                 *MARK = sv_mortalcopy(TOPs);
1654         else {
1655             MEXTEND(mark,0);
1656             *MARK = &sv_undef;
1657         }
1658         SP = MARK;
1659     }
1660     else {
1661         for (mark = newsp + 1; mark <= SP; mark++)
1662             if (!(SvFLAGS(*mark) & SVs_TEMP))
1663                 *mark = sv_mortalcopy(*mark);
1664                 /* in case LEAVE wipes old return values */
1665     }
1666
1667     if (cx->blk_sub.hasargs) {          /* You don't exist; go away. */
1668         AV* av = cx->blk_sub.argarray;
1669
1670         av_clear(av);
1671         AvREAL_off(av);
1672     }
1673     curpm = newpm;      /* Don't pop $1 et al till now */
1674
1675     LEAVE;
1676     PUTBACK;
1677     return pop_return();
1678 }
1679
1680 PP(pp_entersub)
1681 {
1682     dSP; dPOPss;
1683     GV *gv;
1684     HV *stash;
1685     register CV *cv;
1686     register CONTEXT *cx;
1687     I32 gimme;
1688
1689     if (!sv)
1690         DIE("Not a CODE reference");
1691     switch (SvTYPE(sv)) {
1692     default:
1693         if (!SvROK(sv)) {
1694             char *sym;
1695
1696             if (sv == &sv_yes)          /* unfound import, ignore */
1697                 RETURN;
1698             if (!SvOK(sv))
1699                 DIE(no_usym, "a subroutine");
1700             sym = SvPV(sv,na);
1701             if (op->op_private & HINT_STRICT_REFS)
1702                 DIE(no_symref, sym, "a subroutine");
1703             cv = perl_get_cv(sym, TRUE);
1704             break;
1705         }
1706         cv = (CV*)SvRV(sv);
1707         if (SvTYPE(cv) == SVt_PVCV)
1708             break;
1709         /* FALL THROUGH */
1710     case SVt_PVHV:
1711     case SVt_PVAV:
1712         DIE("Not a CODE reference");
1713     case SVt_PVCV:
1714         cv = (CV*)sv;
1715         break;
1716     case SVt_PVGV:
1717         if (!(cv = GvCV((GV*)sv)))
1718             cv = sv_2cv(sv, &stash, &gv, TRUE);
1719         break;
1720     }
1721
1722     ENTER;
1723     SAVETMPS;
1724
1725   retry:
1726     if (!cv)
1727         DIE("Not a CODE reference");
1728
1729     if (!CvROOT(cv) && !CvXSUB(cv)) {
1730         if (gv = CvGV(cv)) {
1731             SV *tmpstr;
1732             GV *ngv;
1733             if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */
1734                 cv = GvCV(gv);
1735                 if (SvTYPE(sv) == SVt_PVGV) {
1736                     SvREFCNT_dec(GvCV((GV*)sv));
1737                     GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv);
1738                 }
1739                 goto retry;
1740             }
1741             tmpstr = sv_newmortal();
1742             gv_efullname(tmpstr, gv);
1743             ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD");
1744             if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */
1745                 gv = ngv;
1746                 sv_setsv(GvSV(CvGV(cv)), tmpstr);       /* Set CV's $AUTOLOAD */
1747                 if (tainting)
1748                     sv_unmagic(GvSV(CvGV(cv)), 't');
1749                 goto retry;
1750             }
1751             else
1752                 DIE("Undefined subroutine &%s called",SvPVX(tmpstr));
1753         }
1754         DIE("Undefined subroutine called");
1755     }
1756
1757     gimme = GIMME;
1758     if ((op->op_private & OPpENTERSUB_DB) && !CvXSUB(cv)) {
1759         sv = GvSV(DBsub);
1760         save_item(sv);
1761         if (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) {
1762             /* GV is potentially non-unique */
1763             sv_setsv(sv, newRV((SV*)cv));
1764         }
1765         else {
1766             gv = CvGV(cv);
1767             gv_efullname(sv,gv);
1768         }
1769         cv = GvCV(DBsub);
1770         if (!cv)
1771             DIE("No DBsub routine");
1772     }
1773
1774 #ifdef USE_THREADS
1775     MUTEX_LOCK(CvMUTEXP(cv));
1776     if (!CvCONDP(cv)) {
1777 #ifdef DEBUGGING
1778         DEBUG_L((fprintf(stderr, "0x%lx entering fast %s\n",
1779                                  (unsigned long)thr, SvPEEK((SV*)cv))));
1780 #endif /* DEBUGGING */
1781         MUTEX_UNLOCK(CvMUTEXP(cv)); /* fast sub wants neither sync nor clone */
1782     }
1783     else if (SvFLAGS(cv) & SVp_SYNC) {
1784         /*
1785          * It's a synchronised CV. Wait until it's free unless
1786          * we own it already (in which case we're recursing).
1787          */
1788         if (CvOWNER(cv) && CvOWNER(cv) != thr) {
1789             do {
1790                 DEBUG_L((fprintf(stderr, "0x%lx wait for 0x%lx to leave %s\n",
1791                                  (unsigned long)thr,(unsigned long)CvOWNER(cv),
1792                                  SvPEEK((SV*)cv))));
1793                 COND_WAIT(CvCONDP(cv), CvMUTEXP(cv)); /* yawn */
1794             } while (CvOWNER(cv));
1795         }
1796         CvOWNER(cv) = thr;      /* Assert ownership */
1797         SvREFCNT_inc(cv);
1798         MUTEX_UNLOCK(CvMUTEXP(cv));
1799         if (CvDEPTH(cv) == 0)
1800             SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1801     }
1802     else {
1803         /*
1804          * It's an ordinary unsynchronised CV so we must distinguish
1805          * three cases. (1) It's ours already (and we're recursing);
1806          * (2) it's free (but we may already be using a cached clone);
1807          * (3) another thread owns it. Case (1) is easy: we just use it.
1808          * Case (2) means we look for a clone--if we have one, use it
1809          * otherwise grab ownership of cv. Case (3) means look we for a
1810          * clone and have to create one if we don't already have one.
1811          * Why look for a clone in case (2) when we could just grab
1812          * ownership of cv straight away? Well, we could be recursing,
1813          * i.e. we originally tried to enter cv while another thread
1814          * owned it (hence we used a clone) but it has been freed up
1815          * and we're now recursing into it. It may or may not be "better"
1816          * to use the clone but at least CvDEPTH can be trusted.
1817          */
1818         if (CvOWNER(cv) == thr)
1819             MUTEX_UNLOCK(CvMUTEXP(cv));
1820         else {
1821             /* Case (2) or (3) */
1822             SV **svp;
1823
1824             /*
1825              * XXX Might it be better to release CvMUTEXP(cv) while we
1826              * do the hv_fetch? We might find someone has pinched it
1827              * when we look again, in which case we would be in case
1828              * (3) instead of (2) so we'd have to clone. Would the fact
1829              * that we released the mutex more quickly make up for this?
1830              */
1831             svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE);
1832             if (svp) {
1833                 /* We already have a clone to use */
1834                 MUTEX_UNLOCK(CvMUTEXP(cv));
1835                 cv = *(CV**)svp;
1836                 DEBUG_L(fprintf(stderr,
1837                                 "entersub: 0x%lx already has clone 0x%lx:%s\n",
1838                                 (unsigned long) thr, (unsigned long) cv,
1839                                 SvPEEK((SV*)cv)));
1840                 CvOWNER(cv) = thr;
1841                 SvREFCNT_inc(cv);
1842                 if (CvDEPTH(cv) == 0)
1843                     SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1844             }
1845             else {
1846                 /* (2) => grab ownership of cv. (3) => make clone */
1847                 if (!CvOWNER(cv)) {
1848                     CvOWNER(cv) = thr;
1849                     SvREFCNT_inc(cv);
1850                     MUTEX_UNLOCK(CvMUTEXP(cv));
1851                     DEBUG_L(fprintf(stderr,
1852                                     "entersub: 0x%lx grabbing 0x%lx:%s\n",
1853                                     (unsigned long) thr, (unsigned long) cv,
1854                                     SvPEEK((SV*)cv)));
1855                 } else {
1856                     /* Make a new clone. */
1857                     CV *clonecv;
1858                     SvREFCNT_inc(cv); /* don't let it vanish from under us */
1859                     MUTEX_UNLOCK(CvMUTEXP(cv));
1860                     DEBUG_L((fprintf(stderr,
1861                                      "entersub: 0x%lx cloning 0x%lx:%s\n",
1862                                      (unsigned long) thr, (unsigned long) cv,
1863                                      SvPEEK((SV*)cv))));
1864                     /*
1865                      * We're creating a new clone so there's no race
1866                      * between the original MUTEX_UNLOCK and the
1867                      * SvREFCNT_inc since no one will be trying to undef
1868                      * it out from underneath us. At least, I don't think
1869                      * there's a race...
1870                      */
1871                     clonecv = cv_clone(cv);
1872                     SvREFCNT_dec(cv); /* finished with this */
1873                     hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
1874                     CvOWNER(clonecv) = thr;
1875                     cv = clonecv;
1876                     SvREFCNT_inc(cv);
1877                 }
1878                 assert(CvDEPTH(cv) == 0);
1879                 SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1880             }
1881         }
1882     }
1883 #endif /* USE_THREADS */
1884
1885     gimme = GIMME;
1886
1887     if (CvXSUB(cv)) {
1888         if (CvOLDSTYLE(cv)) {
1889             I32 (*fp3)_((int,int,int));
1890             dMARK;
1891             register I32 items = SP - MARK;
1892             while (sp > mark) {
1893                 sp[1] = sp[0];
1894                 sp--;
1895             }
1896             stack_sp = mark + 1;
1897             fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1898             items = (*fp3)(CvXSUBANY(cv).any_i32,
1899                            MARK - stack_base + 1,
1900                            items);
1901             stack_sp = stack_base + items;
1902         }
1903         else {
1904             I32 markix = TOPMARK;
1905
1906             PUTBACK;
1907             (void)(*CvXSUB(cv))(cv);
1908
1909             /* Enforce some sanity in scalar context. */
1910             if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) {
1911                 if (markix > stack_sp - stack_base)
1912                     *(stack_base + markix) = &sv_undef;
1913                 else
1914                     *(stack_base + markix) = *stack_sp;
1915                 stack_sp = stack_base + markix;
1916             }
1917         }
1918         LEAVE;
1919         return NORMAL;
1920     }
1921     else {
1922         dMARK;
1923         register I32 items = SP - MARK;
1924         I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
1925         AV* padlist = CvPADLIST(cv);
1926         SV** svp = AvARRAY(padlist);
1927         push_return(op->op_next);
1928         PUSHBLOCK(cx, CXt_SUB, MARK);
1929         PUSHSUB(cx);
1930         CvDEPTH(cv)++;
1931         if (CvDEPTH(cv) < 2)
1932             (void)SvREFCNT_inc(cv);
1933         else {  /* save temporaries on recursion? */
1934             if (CvDEPTH(cv) == 100 && dowarn)
1935                 warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv)));
1936             if (CvDEPTH(cv) > AvFILL(padlist)) {
1937                 AV *av;
1938                 AV *newpad = newAV();
1939                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1940                 I32 ix = AvFILL((AV*)svp[1]);
1941                 svp = AvARRAY(svp[0]);
1942                 for ( ;ix > 0; ix--) {
1943                     if (svp[ix] != &sv_undef) {
1944                         char *name = SvPVX(svp[ix]);
1945                         if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* outer lexical? */
1946                             av_store(newpad, ix,
1947                                 SvREFCNT_inc(oldpad[ix]) );
1948                         }
1949                         else {                          /* our own lexical */
1950                             if (*name == '@')
1951                                 av_store(newpad, ix, sv = (SV*)newAV());
1952                             else if (*name == '%')
1953                                 av_store(newpad, ix, sv = (SV*)newHV());
1954                             else
1955                                 av_store(newpad, ix, sv = NEWSV(0,0));
1956                             SvPADMY_on(sv);
1957                         }
1958                     }
1959                     else {
1960                         av_store(newpad, ix, sv = NEWSV(0,0));
1961                         SvPADTMP_on(sv);
1962                     }
1963                 }
1964                 av = newAV();           /* will be @_ */
1965                 av_extend(av, 0);
1966                 av_store(newpad, 0, (SV*)av);
1967                 AvFLAGS(av) = AVf_REIFY;
1968                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1969                 AvFILL(padlist) = CvDEPTH(cv);
1970                 svp = AvARRAY(padlist);
1971             }
1972         }
1973         SAVESPTR(curpad);
1974         curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1975         if (hasargs) {
1976             AV* av = (AV*)curpad[0];
1977             SV** ary;
1978
1979             if (AvREAL(av)) {
1980                 av_clear(av);
1981                 AvREAL_off(av);
1982             }
1983             cx->blk_sub.savearray = GvAV(defgv);
1984             cx->blk_sub.argarray = av;
1985             GvAV(defgv) = cx->blk_sub.argarray;
1986             ++MARK;
1987
1988             if (items > AvMAX(av) + 1) {
1989                 ary = AvALLOC(av);
1990                 if (AvARRAY(av) != ary) {
1991                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1992                     SvPVX(av) = (char*)ary;
1993                 }
1994                 if (items > AvMAX(av) + 1) {
1995                     AvMAX(av) = items - 1;
1996                     Renew(ary,items,SV*);
1997                     AvALLOC(av) = ary;
1998                     SvPVX(av) = (char*)ary;
1999                 }
2000             }
2001             Copy(MARK,AvARRAY(av),items,SV*);
2002             AvFILL(av) = items - 1;
2003
2004             while (items--) {
2005                 if (*MARK)
2006                     SvTEMP_off(*MARK);
2007                 MARK++;
2008             }
2009         }
2010         RETURNOP(CvSTART(cv));
2011     }
2012 }
2013
2014 PP(pp_aelem)
2015 {
2016     dSP;
2017     SV** svp;
2018     I32 elem = POPi;
2019     AV *av = (AV*)POPs;
2020     I32 lval = op->op_flags & OPf_MOD;
2021
2022     if (elem > 0)
2023         elem -= curcop->cop_arybase;
2024     if (SvTYPE(av) != SVt_PVAV)
2025         RETPUSHUNDEF;
2026     svp = av_fetch(av, elem, lval);
2027     if (lval) {
2028         if (!svp || *svp == &sv_undef)
2029             DIE(no_aelem, elem);
2030         if (op->op_private & OPpLVAL_INTRO)
2031             save_svref(svp);
2032         else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
2033             provide_ref(op, *svp);
2034     }
2035     PUSHs(svp ? *svp : &sv_undef);
2036     RETURN;
2037 }
2038
2039 void
2040 provide_ref(o, sv)
2041 OP* o;
2042 SV* sv;
2043 {
2044     if (SvGMAGICAL(sv))
2045         mg_get(sv);
2046     if (!SvOK(sv)) {
2047         if (SvREADONLY(sv))
2048             croak(no_modify);
2049         (void)SvUPGRADE(sv, SVt_RV);
2050         SvRV(sv) = (o->op_private & OPpDEREF_HV ?
2051                     (SV*)newHV() : (SV*)newAV());
2052         SvROK_on(sv);
2053         SvSETMAGIC(sv);
2054     }
2055 }
2056
2057 PP(pp_method)
2058 {
2059     dSP;
2060     SV* sv;
2061     SV* ob;
2062     GV* gv;
2063     SV* nm;
2064
2065     nm = TOPs;
2066     sv = *(stack_base + TOPMARK + 1);
2067
2068     gv = 0;
2069     if (SvGMAGICAL(sv))
2070         mg_get(sv);
2071     if (SvROK(sv))
2072         ob = (SV*)SvRV(sv);
2073     else {
2074         GV* iogv;
2075         char* packname = 0;
2076
2077         if (!SvOK(sv) ||
2078             !(packname = SvPV(sv, na)) ||
2079             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2080             !(ob=(SV*)GvIO(iogv)))
2081         {
2082             char *name = SvPV(nm, na);
2083             HV *stash;
2084             if (!packname || !isALPHA(*packname))
2085 DIE("Can't call method \"%s\" without a package or object reference", name);
2086             if (!(stash = gv_stashpv(packname, FALSE))) {
2087                 if (gv_stashpv("UNIVERSAL", FALSE))
2088                     stash = gv_stashpv(packname, TRUE);
2089                 else
2090                     DIE("Can't call method \"%s\" in empty package \"%s\"",
2091                         name, packname);
2092             }
2093             gv = gv_fetchmethod(stash,name);
2094             if (!gv)
2095                 DIE("Can't locate object method \"%s\" via package \"%s\"",
2096                     name, packname);
2097             SETs(gv);
2098             RETURN;
2099         }
2100         *(stack_base + TOPMARK + 1) = sv_2mortal(newRV(iogv));
2101     }
2102
2103     if (!ob || !SvOBJECT(ob)) {
2104         char *name = SvPV(nm, na);
2105         DIE("Can't call method \"%s\" on unblessed reference", name);
2106     }
2107
2108     if (!gv) {          /* nothing cached */
2109         char *name = SvPV(nm, na);
2110         gv = gv_fetchmethod(SvSTASH(ob),name);
2111         if (!gv)
2112             DIE("Can't locate object method \"%s\" via package \"%s\"",
2113                 name, HvNAME(SvSTASH(ob)));
2114     }
2115
2116     SETs(gv);
2117     RETURN;
2118 }
2119