op.c

   1 /*    op.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 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  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  13  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  14  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  15  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  16  * either way, as the saying is, if you follow me."  --the Gaffer
  17  */
  18
  19
  20 #include "EXTERN.h"
  21 #define PERL_IN_OP_C
  22 #include "perl.h"
  23 #include "keywords.h"
  24
  25 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
  26
  27 #if defined(PL_OP_SLAB_ALLOC)
  28
  29 #ifndef PERL_SLAB_SIZE
  30 #define PERL_SLAB_SIZE 2048
  31 #endif
  32
  33 void *
  34 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
  35 {
  36     /*
  37      * To make incrementing use count easy PL_OpSlab is an I32 *
  38      * To make inserting the link to slab PL_OpPtr is I32 **
  39      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
  40      * Add an overhead for pointer to slab and round up as a number of pointers
  41      */
  42     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
  43     if ((PL_OpSpace -= sz) < 0) {
  44         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
  45         if (!PL_OpPtr) {
  46             return NULL;
  47         }
  48         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
  49         /* We reserve the 0'th I32 sized chunk as a use count */
  50         PL_OpSlab = (I32 *) PL_OpPtr;
  51         /* Reduce size by the use count word, and by the size we need.
  52          * Latter is to mimic the '-=' in the if() above
  53          */
  54         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
  55         /* Allocation pointer starts at the top.
  56            Theory: because we build leaves before trunk allocating at end
  57            means that at run time access is cache friendly upward
  58          */
  59         PL_OpPtr += PERL_SLAB_SIZE;
  60     }
  61     assert( PL_OpSpace >= 0 );
  62     /* Move the allocation pointer down */
  63     PL_OpPtr   -= sz;
  64     assert( PL_OpPtr > (I32 **) PL_OpSlab );
  65     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
  66     (*PL_OpSlab)++;             /* Increment use count of slab */
  67     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
  68     assert( *PL_OpSlab > 0 );
  69     return (void *)(PL_OpPtr + 1);
  70 }
  71
  72 void
  73 Perl_Slab_Free(pTHX_ void *op)
  74 {
  75     I32 **ptr = (I32 **) op;
  76     I32 *slab = ptr[-1];
  77     assert( ptr-1 > (I32 **) slab );
  78     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
  79     assert( *slab > 0 );
  80     if (--(*slab) == 0) {
  81 #  ifdef NETWARE
  82 #    define PerlMemShared PerlMem
  83 #  endif
  84
  85     PerlMemShared_free(slab);
  86         if (slab == PL_OpSlab) {
  87             PL_OpSpace = 0;
  88         }
  89     }
  90 }
  91 #endif
  92 /*
  93  * In the following definition, the ", Nullop" is just to make the compiler
  94  * think the expression is of the right type: croak actually does a Siglongjmp.
  95  */
  96 #define CHECKOP(type,o) \
  97     ((PL_op_mask && PL_op_mask[type])                                   \
  98      ? ( op_free((OP*)o),                                       \
  99          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 100          Nullop )                                               \
 101      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 102
 103 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 104
 105 STATIC char*
 106 S_gv_ename(pTHX_ GV *gv)
 107 {
 108     STRLEN n_a;
 109     SV* tmpsv = sv_newmortal();
 110     gv_efullname3(tmpsv, gv, Nullch);
 111     return SvPV(tmpsv,n_a);
 112 }
 113
 114 STATIC OP *
 115 S_no_fh_allowed(pTHX_ OP *o)
 116 {
 117     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 118                  OP_DESC(o)));
 119     return o;
 120 }
 121
 122 STATIC OP *
 123 S_too_few_arguments(pTHX_ OP *o, char *name)
 124 {
 125     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 126     return o;
 127 }
 128
 129 STATIC OP *
 130 S_too_many_arguments(pTHX_ OP *o, char *name)
 131 {
 132     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 133     return o;
 134 }
 135
 136 STATIC void
 137 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
 138 {
 139     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 140                  (int)n, name, t, OP_DESC(kid)));
 141 }
 142
 143 STATIC void
 144 S_no_bareword_allowed(pTHX_ OP *o)
 145 {
 146     qerror(Perl_mess(aTHX_
 147                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 148                      cSVOPo_sv));
 149 }
 150
 151 /* "register" allocation */
 152
 153 PADOFFSET
 154 Perl_allocmy(pTHX_ char *name)
 155 {
 156     PADOFFSET off;
 157
 158     /* complain about "my $<special_var>" etc etc */
 159     if (!(PL_in_my == KEY_our ||
 160           isALPHA(name[1]) ||
 161           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 162           (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
 163     {
 164         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 165             /* 1999-02-27 mjd@plover.com */
 166             char *p;
 167             p = strchr(name, '\0');
 168             /* The next block assumes the buffer is at least 205 chars
 169                long.  At present, it's always at least 256 chars. */
 170             if (p-name > 200) {
 171                 strcpy(name+200, "...");
 172                 p = name+199;
 173             }
 174             else {
 175                 p[1] = '\0';
 176             }
 177             /* Move everything else down one character */
 178             for (; p-name > 2; p--)
 179                 *p = *(p-1);
 180             name[2] = toCTRL(name[1]);
 181             name[1] = '^';
 182         }
 183         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 184     }
 185
 186     /* check for duplicate declaration */
 187     pad_check_dup(name,
 188                 (bool)(PL_in_my == KEY_our),
 189                 (PL_curstash ? PL_curstash : PL_defstash)
 190     );
 191
 192     if (PL_in_my_stash && *name != '$') {
 193         yyerror(Perl_form(aTHX_
 194                     "Can't declare class for non-scalar %s in \"%s\"",
 195                      name, PL_in_my == KEY_our ? "our" : "my"));
 196     }
 197
 198     /* allocate a spare slot and store the name in that slot */
 199
 200     off = pad_add_name(name,
 201                     PL_in_my_stash,
 202                     (PL_in_my == KEY_our
 203                         ? (PL_curstash ? PL_curstash : PL_defstash)
 204                         : Nullhv
 205                     ),
 206                     0 /*  not fake */
 207     );
 208     return off;
 209 }
 210
 211 /* Destructor */
 212
 213 void
 214 Perl_op_free(pTHX_ OP *o)
 215 {
 216     register OP *kid, *nextkid;
 217     OPCODE type;
 218
 219     if (!o || o->op_seq == (U16)-1)
 220         return;
 221
 222     if (o->op_private & OPpREFCOUNTED) {
 223         switch (o->op_type) {
 224         case OP_LEAVESUB:
 225         case OP_LEAVESUBLV:
 226         case OP_LEAVEEVAL:
 227         case OP_LEAVE:
 228         case OP_SCOPE:
 229         case OP_LEAVEWRITE:
 230             OP_REFCNT_LOCK;
 231             if (OpREFCNT_dec(o)) {
 232                 OP_REFCNT_UNLOCK;
 233                 return;
 234             }
 235             OP_REFCNT_UNLOCK;
 236             break;
 237         default:
 238             break;
 239         }
 240     }
 241
 242     if (o->op_flags & OPf_KIDS) {
 243         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 244             nextkid = kid->op_sibling; /* Get before next freeing kid */
 245             op_free(kid);
 246         }
 247     }
 248     type = o->op_type;
 249     if (type == OP_NULL)
 250         type = (OPCODE)o->op_targ;
 251
 252     /* COP* is not cleared by op_clear() so that we may track line
 253      * numbers etc even after null() */
 254     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 255         cop_free((COP*)o);
 256
 257     op_clear(o);
 258     FreeOp(o);
 259 }
 260
 261 void
 262 Perl_op_clear(pTHX_ OP *o)
 263 {
 264
 265     switch (o->op_type) {
 266     case OP_NULL:       /* Was holding old type, if any. */
 267     case OP_ENTEREVAL:  /* Was holding hints. */
 268         o->op_targ = 0;
 269         break;
 270     default:
 271         if (!(o->op_flags & OPf_REF)
 272             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 273             break;
 274         /* FALL THROUGH */
 275     case OP_GVSV:
 276     case OP_GV:
 277     case OP_AELEMFAST:
 278 #ifdef USE_ITHREADS
 279         if (cPADOPo->op_padix > 0) {
 280             /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 281              * may still exist on the pad */
 282             pad_swipe(cPADOPo->op_padix, TRUE);
 283             cPADOPo->op_padix = 0;
 284         }
 285 #else
 286         SvREFCNT_dec(cSVOPo->op_sv);
 287         cSVOPo->op_sv = Nullsv;
 288 #endif
 289         break;
 290     case OP_METHOD_NAMED:
 291     case OP_CONST:
 292         SvREFCNT_dec(cSVOPo->op_sv);
 293         cSVOPo->op_sv = Nullsv;
 294 #ifdef USE_ITHREADS
 295         /** Bug #15654
 296           Even if op_clear does a pad_free for the target of the op,
 297           pad_free doesn't actually remove the sv that exists in the bad
 298           instead it lives on. This results in that it could be reused as
 299           a target later on when the pad was reallocated.
 300         **/
 301         if(o->op_targ) {
 302           pad_swipe(o->op_targ,1);
 303           o->op_targ = 0;
 304         }
 305 #endif
 306         break;
 307     case OP_GOTO:
 308     case OP_NEXT:
 309     case OP_LAST:
 310     case OP_REDO:
 311         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 312             break;
 313         /* FALL THROUGH */
 314     case OP_TRANS:
 315         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 316             SvREFCNT_dec(cSVOPo->op_sv);
 317             cSVOPo->op_sv = Nullsv;
 318         }
 319         else {
 320             Safefree(cPVOPo->op_pv);
 321             cPVOPo->op_pv = Nullch;
 322         }
 323         break;
 324     case OP_SUBST:
 325         op_free(cPMOPo->op_pmreplroot);
 326         goto clear_pmop;
 327     case OP_PUSHRE:
 328 #ifdef USE_ITHREADS
 329         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 330             /* No GvIN_PAD_off here, because other references may still
 331              * exist on the pad */
 332             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
 333         }
 334 #else
 335         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 336 #endif
 337         /* FALL THROUGH */
 338     case OP_MATCH:
 339     case OP_QR:
 340 clear_pmop:
 341         {
 342             HV *pmstash = PmopSTASH(cPMOPo);
 343             if (pmstash && SvREFCNT(pmstash)) {
 344                 PMOP *pmop = HvPMROOT(pmstash);
 345                 PMOP *lastpmop = NULL;
 346                 while (pmop) {
 347                     if (cPMOPo == pmop) {
 348                         if (lastpmop)
 349                             lastpmop->op_pmnext = pmop->op_pmnext;
 350                         else
 351                             HvPMROOT(pmstash) = pmop->op_pmnext;
 352                         break;
 353                     }
 354                     lastpmop = pmop;
 355                     pmop = pmop->op_pmnext;
 356                 }
 357             }
 358             PmopSTASH_free(cPMOPo);
 359         }
 360         cPMOPo->op_pmreplroot = Nullop;
 361         /* we use the "SAFE" version of the PM_ macros here
 362          * since sv_clean_all might release some PMOPs
 363          * after PL_regex_padav has been cleared
 364          * and the clearing of PL_regex_padav needs to
 365          * happen before sv_clean_all
 366          */
 367         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
 368         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
 369 #ifdef USE_ITHREADS
 370         if(PL_regex_pad) {        /* We could be in destruction */
 371             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
 372             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 373             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
 374         }
 375 #endif
 376
 377         break;
 378     }
 379
 380     if (o->op_targ > 0) {
 381         pad_free(o->op_targ);
 382         o->op_targ = 0;
 383     }
 384 }
 385
 386 STATIC void
 387 S_cop_free(pTHX_ COP* cop)
 388 {
 389     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
 390     CopFILE_free(cop);
 391     CopSTASH_free(cop);
 392     if (! specialWARN(cop->cop_warnings))
 393         SvREFCNT_dec(cop->cop_warnings);
 394     if (! specialCopIO(cop->cop_io)) {
 395 #ifdef USE_ITHREADS
 396 #if 0
 397         STRLEN len;
 398         char *s = SvPV(cop->cop_io,len);
 399         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
 400 #endif
 401 #else
 402         SvREFCNT_dec(cop->cop_io);
 403 #endif
 404     }
 405 }
 406
 407 void
 408 Perl_op_null(pTHX_ OP *o)
 409 {
 410     if (o->op_type == OP_NULL)
 411         return;
 412     op_clear(o);
 413     o->op_targ = o->op_type;
 414     o->op_type = OP_NULL;
 415     o->op_ppaddr = PL_ppaddr[OP_NULL];
 416 }
 417
 418 /* Contextualizers */
 419
 420 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 421
 422 OP *
 423 Perl_linklist(pTHX_ OP *o)
 424 {
 425     register OP *kid;
 426
 427     if (o->op_next)
 428         return o->op_next;
 429
 430     /* establish postfix order */
 431     if (cUNOPo->op_first) {
 432         o->op_next = LINKLIST(cUNOPo->op_first);
 433         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 434             if (kid->op_sibling)
 435                 kid->op_next = LINKLIST(kid->op_sibling);
 436             else
 437                 kid->op_next = o;
 438         }
 439     }
 440     else
 441         o->op_next = o;
 442
 443     return o->op_next;
 444 }
 445
 446 OP *
 447 Perl_scalarkids(pTHX_ OP *o)
 448 {
 449     OP *kid;
 450     if (o && o->op_flags & OPf_KIDS) {
 451         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 452             scalar(kid);
 453     }
 454     return o;
 455 }
 456
 457 STATIC OP *
 458 S_scalarboolean(pTHX_ OP *o)
 459 {
 460     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 461         if (ckWARN(WARN_SYNTAX)) {
 462             line_t oldline = CopLINE(PL_curcop);
 463
 464             if (PL_copline != NOLINE)
 465                 CopLINE_set(PL_curcop, PL_copline);
 466             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 467             CopLINE_set(PL_curcop, oldline);
 468         }
 469     }
 470     return scalar(o);
 471 }
 472
 473 OP *
 474 Perl_scalar(pTHX_ OP *o)
 475 {
 476     OP *kid;
 477
 478     /* assumes no premature commitment */
 479     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 480          || o->op_type == OP_RETURN)
 481     {
 482         return o;
 483     }
 484
 485     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 486
 487     switch (o->op_type) {
 488     case OP_REPEAT:
 489         scalar(cBINOPo->op_first);
 490         break;
 491     case OP_OR:
 492     case OP_AND:
 493     case OP_COND_EXPR:
 494         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 495             scalar(kid);
 496         break;
 497     case OP_SPLIT:
 498         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 499             if (!kPMOP->op_pmreplroot)
 500                 deprecate_old("implicit split to @_");
 501         }
 502         /* FALL THROUGH */
 503     case OP_MATCH:
 504     case OP_QR:
 505     case OP_SUBST:
 506     case OP_NULL:
 507     default:
 508         if (o->op_flags & OPf_KIDS) {
 509             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 510                 scalar(kid);
 511         }
 512         break;
 513     case OP_LEAVE:
 514     case OP_LEAVETRY:
 515         kid = cLISTOPo->op_first;
 516         scalar(kid);
 517         while ((kid = kid->op_sibling)) {
 518             if (kid->op_sibling)
 519                 scalarvoid(kid);
 520             else
 521                 scalar(kid);
 522         }
 523         WITH_THR(PL_curcop = &PL_compiling);
 524         break;
 525     case OP_SCOPE:
 526     case OP_LINESEQ:
 527     case OP_LIST:
 528         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 529             if (kid->op_sibling)
 530                 scalarvoid(kid);
 531             else
 532                 scalar(kid);
 533         }
 534         WITH_THR(PL_curcop = &PL_compiling);
 535         break;
 536     case OP_SORT:
 537         if (ckWARN(WARN_VOID))
 538             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 539     }
 540     return o;
 541 }
 542
 543 OP *
 544 Perl_scalarvoid(pTHX_ OP *o)
 545 {
 546     OP *kid;
 547     char* useless = 0;
 548     SV* sv;
 549     U8 want;
 550
 551     if (o->op_type == OP_NEXTSTATE
 552         || o->op_type == OP_SETSTATE
 553         || o->op_type == OP_DBSTATE
 554         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 555                                       || o->op_targ == OP_SETSTATE
 556                                       || o->op_targ == OP_DBSTATE)))
 557         PL_curcop = (COP*)o;            /* for warning below */
 558
 559     /* assumes no premature commitment */
 560     want = o->op_flags & OPf_WANT;
 561     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
 562          || o->op_type == OP_RETURN)
 563     {
 564         return o;
 565     }
 566
 567     if ((o->op_private & OPpTARGET_MY)
 568         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 569     {
 570         return scalar(o);                       /* As if inside SASSIGN */
 571     }
 572
 573     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 574
 575     switch (o->op_type) {
 576     default:
 577         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 578             break;
 579         /* FALL THROUGH */
 580     case OP_REPEAT:
 581         if (o->op_flags & OPf_STACKED)
 582             break;
 583         goto func_ops;
 584     case OP_SUBSTR:
 585         if (o->op_private == 4)
 586             break;
 587         /* FALL THROUGH */
 588     case OP_GVSV:
 589     case OP_WANTARRAY:
 590     case OP_GV:
 591     case OP_PADSV:
 592     case OP_PADAV:
 593     case OP_PADHV:
 594     case OP_PADANY:
 595     case OP_AV2ARYLEN:
 596     case OP_REF:
 597     case OP_REFGEN:
 598     case OP_SREFGEN:
 599     case OP_DEFINED:
 600     case OP_HEX:
 601     case OP_OCT:
 602     case OP_LENGTH:
 603     case OP_VEC:
 604     case OP_INDEX:
 605     case OP_RINDEX:
 606     case OP_SPRINTF:
 607     case OP_AELEM:
 608     case OP_AELEMFAST:
 609     case OP_ASLICE:
 610     case OP_HELEM:
 611     case OP_HSLICE:
 612     case OP_UNPACK:
 613     case OP_PACK:
 614     case OP_JOIN:
 615     case OP_LSLICE:
 616     case OP_ANONLIST:
 617     case OP_ANONHASH:
 618     case OP_SORT:
 619     case OP_REVERSE:
 620     case OP_RANGE:
 621     case OP_FLIP:
 622     case OP_FLOP:
 623     case OP_CALLER:
 624     case OP_FILENO:
 625     case OP_EOF:
 626     case OP_TELL:
 627     case OP_GETSOCKNAME:
 628     case OP_GETPEERNAME:
 629     case OP_READLINK:
 630     case OP_TELLDIR:
 631     case OP_GETPPID:
 632     case OP_GETPGRP:
 633     case OP_GETPRIORITY:
 634     case OP_TIME:
 635     case OP_TMS:
 636     case OP_LOCALTIME:
 637     case OP_GMTIME:
 638     case OP_GHBYNAME:
 639     case OP_GHBYADDR:
 640     case OP_GHOSTENT:
 641     case OP_GNBYNAME:
 642     case OP_GNBYADDR:
 643     case OP_GNETENT:
 644     case OP_GPBYNAME:
 645     case OP_GPBYNUMBER:
 646     case OP_GPROTOENT:
 647     case OP_GSBYNAME:
 648     case OP_GSBYPORT:
 649     case OP_GSERVENT:
 650     case OP_GPWNAM:
 651     case OP_GPWUID:
 652     case OP_GGRNAM:
 653     case OP_GGRGID:
 654     case OP_GETLOGIN:
 655     case OP_PROTOTYPE:
 656       func_ops:
 657         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 658             useless = OP_DESC(o);
 659         break;
 660
 661     case OP_RV2GV:
 662     case OP_RV2SV:
 663     case OP_RV2AV:
 664     case OP_RV2HV:
 665         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 666                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 667             useless = "a variable";
 668         break;
 669
 670     case OP_CONST:
 671         sv = cSVOPo_sv;
 672         if (cSVOPo->op_private & OPpCONST_STRICT)
 673             no_bareword_allowed(o);
 674         else {
 675             if (ckWARN(WARN_VOID)) {
 676                 useless = "a constant";
 677                 /* the constants 0 and 1 are permitted as they are
 678                    conventionally used as dummies in constructs like
 679                         1 while some_condition_with_side_effects;  */
 680                 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 681                     useless = 0;
 682                 else if (SvPOK(sv)) {
 683                   /* perl4's way of mixing documentation and code
 684                      (before the invention of POD) was based on a
 685                      trick to mix nroff and perl code. The trick was
 686                      built upon these three nroff macros being used in
 687                      void context. The pink camel has the details in
 688                      the script wrapman near page 319. */
 689                     if (strnEQ(SvPVX(sv), "di", 2) ||
 690                         strnEQ(SvPVX(sv), "ds", 2) ||
 691                         strnEQ(SvPVX(sv), "ig", 2))
 692                             useless = 0;
 693                 }
 694             }
 695         }
 696         op_null(o);             /* don't execute or even remember it */
 697         break;
 698
 699     case OP_POSTINC:
 700         o->op_type = OP_PREINC;         /* pre-increment is faster */
 701         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 702         break;
 703
 704     case OP_POSTDEC:
 705         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 706         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 707         break;
 708
 709     case OP_OR:
 710     case OP_AND:
 711     case OP_DOR:
 712     case OP_COND_EXPR:
 713         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 714             scalarvoid(kid);
 715         break;
 716
 717     case OP_NULL:
 718         if (o->op_flags & OPf_STACKED)
 719             break;
 720         /* FALL THROUGH */
 721     case OP_NEXTSTATE:
 722     case OP_DBSTATE:
 723     case OP_ENTERTRY:
 724     case OP_ENTER:
 725         if (!(o->op_flags & OPf_KIDS))
 726             break;
 727         /* FALL THROUGH */
 728     case OP_SCOPE:
 729     case OP_LEAVE:
 730     case OP_LEAVETRY:
 731     case OP_LEAVELOOP:
 732     case OP_LINESEQ:
 733     case OP_LIST:
 734         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 735             scalarvoid(kid);
 736         break;
 737     case OP_ENTEREVAL:
 738         scalarkids(o);
 739         break;
 740     case OP_REQUIRE:
 741         /* all requires must return a boolean value */
 742         o->op_flags &= ~OPf_WANT;
 743         /* FALL THROUGH */
 744     case OP_SCALAR:
 745         return scalar(o);
 746     case OP_SPLIT:
 747         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 748             if (!kPMOP->op_pmreplroot)
 749                 deprecate_old("implicit split to @_");
 750         }
 751         break;
 752     }
 753     if (useless && ckWARN(WARN_VOID))
 754         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
 755     return o;
 756 }
 757
 758 OP *
 759 Perl_listkids(pTHX_ OP *o)
 760 {
 761     OP *kid;
 762     if (o && o->op_flags & OPf_KIDS) {
 763         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 764             list(kid);
 765     }
 766     return o;
 767 }
 768
 769 OP *
 770 Perl_list(pTHX_ OP *o)
 771 {
 772     OP *kid;
 773
 774     /* assumes no premature commitment */
 775     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 776          || o->op_type == OP_RETURN)
 777     {
 778         return o;
 779     }
 780
 781     if ((o->op_private & OPpTARGET_MY)
 782         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 783     {
 784         return o;                               /* As if inside SASSIGN */
 785     }
 786
 787     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
 788
 789     switch (o->op_type) {
 790     case OP_FLOP:
 791     case OP_REPEAT:
 792         list(cBINOPo->op_first);
 793         break;
 794     case OP_OR:
 795     case OP_AND:
 796     case OP_COND_EXPR:
 797         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 798             list(kid);
 799         break;
 800     default:
 801     case OP_MATCH:
 802     case OP_QR:
 803     case OP_SUBST:
 804     case OP_NULL:
 805         if (!(o->op_flags & OPf_KIDS))
 806             break;
 807         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
 808             list(cBINOPo->op_first);
 809             return gen_constant_list(o);
 810         }
 811     case OP_LIST:
 812         listkids(o);
 813         break;
 814     case OP_LEAVE:
 815     case OP_LEAVETRY:
 816         kid = cLISTOPo->op_first;
 817         list(kid);
 818         while ((kid = kid->op_sibling)) {
 819             if (kid->op_sibling)
 820                 scalarvoid(kid);
 821             else
 822                 list(kid);
 823         }
 824         WITH_THR(PL_curcop = &PL_compiling);
 825         break;
 826     case OP_SCOPE:
 827     case OP_LINESEQ:
 828         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 829             if (kid->op_sibling)
 830                 scalarvoid(kid);
 831             else
 832                 list(kid);
 833         }
 834         WITH_THR(PL_curcop = &PL_compiling);
 835         break;
 836     case OP_REQUIRE:
 837         /* all requires must return a boolean value */
 838         o->op_flags &= ~OPf_WANT;
 839         return scalar(o);
 840     }
 841     return o;
 842 }
 843
 844 OP *
 845 Perl_scalarseq(pTHX_ OP *o)
 846 {
 847     OP *kid;
 848
 849     if (o) {
 850         if (o->op_type == OP_LINESEQ ||
 851              o->op_type == OP_SCOPE ||
 852              o->op_type == OP_LEAVE ||
 853              o->op_type == OP_LEAVETRY)
 854         {
 855             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 856                 if (kid->op_sibling) {
 857                     scalarvoid(kid);
 858                 }
 859             }
 860             PL_curcop = &PL_compiling;
 861         }
 862         o->op_flags &= ~OPf_PARENS;
 863         if (PL_hints & HINT_BLOCK_SCOPE)
 864             o->op_flags |= OPf_PARENS;
 865     }
 866     else
 867         o = newOP(OP_STUB, 0);
 868     return o;
 869 }
 870
 871 STATIC OP *
 872 S_modkids(pTHX_ OP *o, I32 type)
 873 {
 874     OP *kid;
 875     if (o && o->op_flags & OPf_KIDS) {
 876         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 877             mod(kid, type);
 878     }
 879     return o;
 880 }
 881
 882 /* Propagate lvalue ("modifiable") context to an op and it's children.
 883  * 'type' represents the context type, roughly based on the type of op that
 884  * would do the modifying, although local() is represented by OP_NULL.
 885  * It's responsible for detecting things that can't be modified,  flag
 886  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
 887  * might have to vivify a reference in $x), and so on.
 888  *
 889  * For example, "$a+1 = 2" would cause mod() to be called with o being
 890  * OP_ADD and type being OP_SASSIGN, and would output an error.
 891  */
 892
 893 OP *
 894 Perl_mod(pTHX_ OP *o, I32 type)
 895 {
 896     OP *kid;
 897     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
 898     int localize = -1;
 899
 900     if (!o || PL_error_count)
 901         return o;
 902
 903     if ((o->op_private & OPpTARGET_MY)
 904         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 905     {
 906         return o;
 907     }
 908
 909     switch (o->op_type) {
 910     case OP_UNDEF:
 911         localize = 0;
 912         PL_modcount++;
 913         return o;
 914     case OP_CONST:
 915         if (!(o->op_private & (OPpCONST_ARYBASE)))
 916             goto nomod;
 917         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
 918             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
 919             PL_eval_start = 0;
 920         }
 921         else if (!type) {
 922             SAVEI32(PL_compiling.cop_arybase);
 923             PL_compiling.cop_arybase = 0;
 924         }
 925         else if (type == OP_REFGEN)
 926             goto nomod;
 927         else
 928             Perl_croak(aTHX_ "That use of $[ is unsupported");
 929         break;
 930     case OP_STUB:
 931         if (o->op_flags & OPf_PARENS)
 932             break;
 933         goto nomod;
 934     case OP_ENTERSUB:
 935         if ((type == OP_UNDEF || type == OP_REFGEN) &&
 936             !(o->op_flags & OPf_STACKED)) {
 937             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
 938             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
 939             assert(cUNOPo->op_first->op_type == OP_NULL);
 940             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
 941             break;
 942         }
 943         else if (o->op_private & OPpENTERSUB_NOMOD)
 944             return o;
 945         else {                          /* lvalue subroutine call */
 946             o->op_private |= OPpLVAL_INTRO;
 947             PL_modcount = RETURN_UNLIMITED_NUMBER;
 948             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
 949                 /* Backward compatibility mode: */
 950                 o->op_private |= OPpENTERSUB_INARGS;
 951                 break;
 952             }
 953             else {                      /* Compile-time error message: */
 954                 OP *kid = cUNOPo->op_first;
 955                 CV *cv;
 956                 OP *okid;
 957
 958                 if (kid->op_type == OP_PUSHMARK)
 959                     goto skip_kids;
 960                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
 961                     Perl_croak(aTHX_
 962                                "panic: unexpected lvalue entersub "
 963                                "args: type/targ %ld:%"UVuf,
 964                                (long)kid->op_type, (UV)kid->op_targ);
 965                 kid = kLISTOP->op_first;
 966               skip_kids:
 967                 while (kid->op_sibling)
 968                     kid = kid->op_sibling;
 969                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
 970                     /* Indirect call */
 971                     if (kid->op_type == OP_METHOD_NAMED
 972                         || kid->op_type == OP_METHOD)
 973                     {
 974                         UNOP *newop;
 975
 976                         NewOp(1101, newop, 1, UNOP);
 977                         newop->op_type = OP_RV2CV;
 978                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
 979                         newop->op_first = Nullop;
 980                         newop->op_next = (OP*)newop;
 981                         kid->op_sibling = (OP*)newop;
 982                         newop->op_private |= OPpLVAL_INTRO;
 983                         break;
 984                     }
 985
 986                     if (kid->op_type != OP_RV2CV)
 987                         Perl_croak(aTHX_
 988                                    "panic: unexpected lvalue entersub "
 989                                    "entry via type/targ %ld:%"UVuf,
 990                                    (long)kid->op_type, (UV)kid->op_targ);
 991                     kid->op_private |= OPpLVAL_INTRO;
 992                     break;      /* Postpone until runtime */
 993                 }
 994
 995                 okid = kid;
 996                 kid = kUNOP->op_first;
 997                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
 998                     kid = kUNOP->op_first;
 999                 if (kid->op_type == OP_NULL)
1000                     Perl_croak(aTHX_
1001                                "Unexpected constant lvalue entersub "
1002                                "entry via type/targ %ld:%"UVuf,
1003                                (long)kid->op_type, (UV)kid->op_targ);
1004                 if (kid->op_type != OP_GV) {
1005                     /* Restore RV2CV to check lvalueness */
1006                   restore_2cv:
1007                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1008                         okid->op_next = kid->op_next;
1009                         kid->op_next = okid;
1010                     }
1011                     else
1012                         okid->op_next = Nullop;
1013                     okid->op_type = OP_RV2CV;
1014                     okid->op_targ = 0;
1015                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1016                     okid->op_private |= OPpLVAL_INTRO;
1017                     break;
1018                 }
1019
1020                 cv = GvCV(kGVOP_gv);
1021                 if (!cv)
1022                     goto restore_2cv;
1023                 if (CvLVALUE(cv))
1024                     break;
1025             }
1026         }
1027         /* FALL THROUGH */
1028     default:
1029       nomod:
1030         /* grep, foreach, subcalls, refgen */
1031         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1032             break;
1033         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1034                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1035                       ? "do block"
1036                       : (o->op_type == OP_ENTERSUB
1037                         ? "non-lvalue subroutine call"
1038                         : OP_DESC(o))),
1039                      type ? PL_op_desc[type] : "local"));
1040         return o;
1041
1042     case OP_PREINC:
1043     case OP_PREDEC:
1044     case OP_POW:
1045     case OP_MULTIPLY:
1046     case OP_DIVIDE:
1047     case OP_MODULO:
1048     case OP_REPEAT:
1049     case OP_ADD:
1050     case OP_SUBTRACT:
1051     case OP_CONCAT:
1052     case OP_LEFT_SHIFT:
1053     case OP_RIGHT_SHIFT:
1054     case OP_BIT_AND:
1055     case OP_BIT_XOR:
1056     case OP_BIT_OR:
1057     case OP_I_MULTIPLY:
1058     case OP_I_DIVIDE:
1059     case OP_I_MODULO:
1060     case OP_I_ADD:
1061     case OP_I_SUBTRACT:
1062         if (!(o->op_flags & OPf_STACKED))
1063             goto nomod;
1064         PL_modcount++;
1065         break;
1066
1067     case OP_COND_EXPR:
1068         localize = 1;
1069         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1070             mod(kid, type);
1071         break;
1072
1073     case OP_RV2AV:
1074     case OP_RV2HV:
1075         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1076            PL_modcount = RETURN_UNLIMITED_NUMBER;
1077             return o;           /* Treat \(@foo) like ordinary list. */
1078         }
1079         /* FALL THROUGH */
1080     case OP_RV2GV:
1081         if (scalar_mod_type(o, type))
1082             goto nomod;
1083         ref(cUNOPo->op_first, o->op_type);
1084         /* FALL THROUGH */
1085     case OP_ASLICE:
1086     case OP_HSLICE:
1087         if (type == OP_LEAVESUBLV)
1088             o->op_private |= OPpMAYBE_LVSUB;
1089         localize = 1;
1090         /* FALL THROUGH */
1091     case OP_AASSIGN:
1092     case OP_NEXTSTATE:
1093     case OP_DBSTATE:
1094        PL_modcount = RETURN_UNLIMITED_NUMBER;
1095         break;
1096     case OP_RV2SV:
1097         ref(cUNOPo->op_first, o->op_type);
1098         localize = 1;
1099         /* FALL THROUGH */
1100     case OP_GV:
1101     case OP_AV2ARYLEN:
1102         PL_hints |= HINT_BLOCK_SCOPE;
1103     case OP_SASSIGN:
1104     case OP_ANDASSIGN:
1105     case OP_ORASSIGN:
1106     case OP_DORASSIGN:
1107         PL_modcount++;
1108         break;
1109
1110     case OP_AELEMFAST:
1111         localize = 1;
1112         PL_modcount++;
1113         break;
1114
1115     case OP_PADAV:
1116     case OP_PADHV:
1117        PL_modcount = RETURN_UNLIMITED_NUMBER;
1118         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1119             return o;           /* Treat \(@foo) like ordinary list. */
1120         if (scalar_mod_type(o, type))
1121             goto nomod;
1122         if (type == OP_LEAVESUBLV)
1123             o->op_private |= OPpMAYBE_LVSUB;
1124         /* FALL THROUGH */
1125     case OP_PADSV:
1126         PL_modcount++;
1127         if (!type) /* local() */
1128             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1129                  PAD_COMPNAME_PV(o->op_targ));
1130         break;
1131
1132     case OP_PUSHMARK:
1133         localize = 0;
1134         break;
1135
1136     case OP_KEYS:
1137         if (type != OP_SASSIGN)
1138             goto nomod;
1139         goto lvalue_func;
1140     case OP_SUBSTR:
1141         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1142             goto nomod;
1143         /* FALL THROUGH */
1144     case OP_POS:
1145     case OP_VEC:
1146         if (type == OP_LEAVESUBLV)
1147             o->op_private |= OPpMAYBE_LVSUB;
1148       lvalue_func:
1149         pad_free(o->op_targ);
1150         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1151         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1152         if (o->op_flags & OPf_KIDS)
1153             mod(cBINOPo->op_first->op_sibling, type);
1154         break;
1155
1156     case OP_AELEM:
1157     case OP_HELEM:
1158         ref(cBINOPo->op_first, o->op_type);
1159         if (type == OP_ENTERSUB &&
1160              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1161             o->op_private |= OPpLVAL_DEFER;
1162         if (type == OP_LEAVESUBLV)
1163             o->op_private |= OPpMAYBE_LVSUB;
1164         localize = 1;
1165         PL_modcount++;
1166         break;
1167
1168     case OP_SCOPE:
1169     case OP_LEAVE:
1170     case OP_ENTER:
1171     case OP_LINESEQ:
1172         localize = 0;
1173         if (o->op_flags & OPf_KIDS)
1174             mod(cLISTOPo->op_last, type);
1175         break;
1176
1177     case OP_NULL:
1178         localize = 0;
1179         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1180             goto nomod;
1181         else if (!(o->op_flags & OPf_KIDS))
1182             break;
1183         if (o->op_targ != OP_LIST) {
1184             mod(cBINOPo->op_first, type);
1185             break;
1186         }
1187         /* FALL THROUGH */
1188     case OP_LIST:
1189         localize = 0;
1190         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1191             mod(kid, type);
1192         break;
1193
1194     case OP_RETURN:
1195         if (type != OP_LEAVESUBLV)
1196             goto nomod;
1197         break; /* mod()ing was handled by ck_return() */
1198     }
1199
1200     /* [20011101.069] File test operators interpret OPf_REF to mean that
1201        their argument is a filehandle; thus \stat(".") should not set
1202        it. AMS 20011102 */
1203     if (type == OP_REFGEN &&
1204         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1205         return o;
1206
1207     if (type != OP_LEAVESUBLV)
1208         o->op_flags |= OPf_MOD;
1209
1210     if (type == OP_AASSIGN || type == OP_SASSIGN)
1211         o->op_flags |= OPf_SPECIAL|OPf_REF;
1212     else if (!type) { /* local() */
1213         switch (localize) {
1214         case 1:
1215             o->op_private |= OPpLVAL_INTRO;
1216             o->op_flags &= ~OPf_SPECIAL;
1217             PL_hints |= HINT_BLOCK_SCOPE;
1218             break;
1219         case 0:
1220             break;
1221         case -1:
1222             if (ckWARN(WARN_SYNTAX)) {
1223                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1224                     "Useless localization of %s", OP_DESC(o));
1225             }
1226         }
1227     }
1228     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1229              && type != OP_LEAVESUBLV)
1230         o->op_flags |= OPf_REF;
1231     return o;
1232 }
1233
1234 STATIC bool
1235 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1236 {
1237     switch (type) {
1238     case OP_SASSIGN:
1239         if (o->op_type == OP_RV2GV)
1240             return FALSE;
1241         /* FALL THROUGH */
1242     case OP_PREINC:
1243     case OP_PREDEC:
1244     case OP_POSTINC:
1245     case OP_POSTDEC:
1246     case OP_I_PREINC:
1247     case OP_I_PREDEC:
1248     case OP_I_POSTINC:
1249     case OP_I_POSTDEC:
1250     case OP_POW:
1251     case OP_MULTIPLY:
1252     case OP_DIVIDE:
1253     case OP_MODULO:
1254     case OP_REPEAT:
1255     case OP_ADD:
1256     case OP_SUBTRACT:
1257     case OP_I_MULTIPLY:
1258     case OP_I_DIVIDE:
1259     case OP_I_MODULO:
1260     case OP_I_ADD:
1261     case OP_I_SUBTRACT:
1262     case OP_LEFT_SHIFT:
1263     case OP_RIGHT_SHIFT:
1264     case OP_BIT_AND:
1265     case OP_BIT_XOR:
1266     case OP_BIT_OR:
1267     case OP_CONCAT:
1268     case OP_SUBST:
1269     case OP_TRANS:
1270     case OP_READ:
1271     case OP_SYSREAD:
1272     case OP_RECV:
1273     case OP_ANDASSIGN:
1274     case OP_ORASSIGN:
1275         return TRUE;
1276     default:
1277         return FALSE;
1278     }
1279 }
1280
1281 STATIC bool
1282 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1283 {
1284     switch (o->op_type) {
1285     case OP_PIPE_OP:
1286     case OP_SOCKPAIR:
1287         if (argnum == 2)
1288             return TRUE;
1289         /* FALL THROUGH */
1290     case OP_SYSOPEN:
1291     case OP_OPEN:
1292     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1293     case OP_SOCKET:
1294     case OP_OPEN_DIR:
1295     case OP_ACCEPT:
1296         if (argnum == 1)
1297             return TRUE;
1298         /* FALL THROUGH */
1299     default:
1300         return FALSE;
1301     }
1302 }
1303
1304 OP *
1305 Perl_refkids(pTHX_ OP *o, I32 type)
1306 {
1307     OP *kid;
1308     if (o && o->op_flags & OPf_KIDS) {
1309         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1310             ref(kid, type);
1311     }
1312     return o;
1313 }
1314
1315 OP *
1316 Perl_ref(pTHX_ OP *o, I32 type)
1317 {
1318     OP *kid;
1319
1320     if (!o || PL_error_count)
1321         return o;
1322
1323     switch (o->op_type) {
1324     case OP_ENTERSUB:
1325         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1326             !(o->op_flags & OPf_STACKED)) {
1327             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1328             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1329             assert(cUNOPo->op_first->op_type == OP_NULL);
1330             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1331             o->op_flags |= OPf_SPECIAL;
1332         }
1333         break;
1334
1335     case OP_COND_EXPR:
1336         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1337             ref(kid, type);
1338         break;
1339     case OP_RV2SV:
1340         if (type == OP_DEFINED)
1341             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1342         ref(cUNOPo->op_first, o->op_type);
1343         /* FALL THROUGH */
1344     case OP_PADSV:
1345         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1346             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1347                               : type == OP_RV2HV ? OPpDEREF_HV
1348                               : OPpDEREF_SV);
1349             o->op_flags |= OPf_MOD;
1350         }
1351         break;
1352
1353     case OP_THREADSV:
1354         o->op_flags |= OPf_MOD;         /* XXX ??? */
1355         break;
1356
1357     case OP_RV2AV:
1358     case OP_RV2HV:
1359         o->op_flags |= OPf_REF;
1360         /* FALL THROUGH */
1361     case OP_RV2GV:
1362         if (type == OP_DEFINED)
1363             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1364         ref(cUNOPo->op_first, o->op_type);
1365         break;
1366
1367     case OP_PADAV:
1368     case OP_PADHV:
1369         o->op_flags |= OPf_REF;
1370         break;
1371
1372     case OP_SCALAR:
1373     case OP_NULL:
1374         if (!(o->op_flags & OPf_KIDS))
1375             break;
1376         ref(cBINOPo->op_first, type);
1377         break;
1378     case OP_AELEM:
1379     case OP_HELEM:
1380         ref(cBINOPo->op_first, o->op_type);
1381         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1382             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1383                               : type == OP_RV2HV ? OPpDEREF_HV
1384                               : OPpDEREF_SV);
1385             o->op_flags |= OPf_MOD;
1386         }
1387         break;
1388
1389     case OP_SCOPE:
1390     case OP_LEAVE:
1391     case OP_ENTER:
1392     case OP_LIST:
1393         if (!(o->op_flags & OPf_KIDS))
1394             break;
1395         ref(cLISTOPo->op_last, type);
1396         break;
1397     default:
1398         break;
1399     }
1400     return scalar(o);
1401
1402 }
1403
1404 STATIC OP *
1405 S_dup_attrlist(pTHX_ OP *o)
1406 {
1407     OP *rop = Nullop;
1408
1409     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1410      * where the first kid is OP_PUSHMARK and the remaining ones
1411      * are OP_CONST.  We need to push the OP_CONST values.
1412      */
1413     if (o->op_type == OP_CONST)
1414         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1415     else {
1416         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1417         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1418             if (o->op_type == OP_CONST)
1419                 rop = append_elem(OP_LIST, rop,
1420                                   newSVOP(OP_CONST, o->op_flags,
1421                                           SvREFCNT_inc(cSVOPo->op_sv)));
1422         }
1423     }
1424     return rop;
1425 }
1426
1427 STATIC void
1428 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1429 {
1430     SV *stashsv;
1431
1432     /* fake up C<use attributes $pkg,$rv,@attrs> */
1433     ENTER;              /* need to protect against side-effects of 'use' */
1434     SAVEINT(PL_expect);
1435     if (stash)
1436         stashsv = newSVpv(HvNAME(stash), 0);
1437     else
1438         stashsv = &PL_sv_no;
1439
1440 #define ATTRSMODULE "attributes"
1441 #define ATTRSMODULE_PM "attributes.pm"
1442
1443     if (for_my) {
1444         SV **svp;
1445         /* Don't force the C<use> if we don't need it. */
1446         svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1447                        sizeof(ATTRSMODULE_PM)-1, 0);
1448         if (svp && *svp != &PL_sv_undef)
1449             ;           /* already in %INC */
1450         else
1451             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1452                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1453                              Nullsv);
1454     }
1455     else {
1456         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1457                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1458                          Nullsv,
1459                          prepend_elem(OP_LIST,
1460                                       newSVOP(OP_CONST, 0, stashsv),
1461                                       prepend_elem(OP_LIST,
1462                                                    newSVOP(OP_CONST, 0,
1463                                                            newRV(target)),
1464                                                    dup_attrlist(attrs))));
1465     }
1466     LEAVE;
1467 }
1468
1469 STATIC void
1470 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1471 {
1472     OP *pack, *imop, *arg;
1473     SV *meth, *stashsv;
1474
1475     if (!attrs)
1476         return;
1477
1478     assert(target->op_type == OP_PADSV ||
1479            target->op_type == OP_PADHV ||
1480            target->op_type == OP_PADAV);
1481
1482     /* Ensure that attributes.pm is loaded. */
1483     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1484
1485     /* Need package name for method call. */
1486     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1487
1488     /* Build up the real arg-list. */
1489     if (stash)
1490         stashsv = newSVpv(HvNAME(stash), 0);
1491     else
1492         stashsv = &PL_sv_no;
1493     arg = newOP(OP_PADSV, 0);
1494     arg->op_targ = target->op_targ;
1495     arg = prepend_elem(OP_LIST,
1496                        newSVOP(OP_CONST, 0, stashsv),
1497                        prepend_elem(OP_LIST,
1498                                     newUNOP(OP_REFGEN, 0,
1499                                             mod(arg, OP_REFGEN)),
1500                                     dup_attrlist(attrs)));
1501
1502     /* Fake up a method call to import */
1503     meth = newSVpvn("import", 6);
1504     (void)SvUPGRADE(meth, SVt_PVIV);
1505     (void)SvIOK_on(meth);
1506     PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1507     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1508                    append_elem(OP_LIST,
1509                                prepend_elem(OP_LIST, pack, list(arg)),
1510                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1511     imop->op_private |= OPpENTERSUB_NOMOD;
1512
1513     /* Combine the ops. */
1514     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1515 }
1516
1517 /*
1518 =notfor apidoc apply_attrs_string
1519
1520 Attempts to apply a list of attributes specified by the C<attrstr> and
1521 C<len> arguments to the subroutine identified by the C<cv> argument which
1522 is expected to be associated with the package identified by the C<stashpv>
1523 argument (see L<attributes>).  It gets this wrong, though, in that it
1524 does not correctly identify the boundaries of the individual attribute
1525 specifications within C<attrstr>.  This is not really intended for the
1526 public API, but has to be listed here for systems such as AIX which
1527 need an explicit export list for symbols.  (It's called from XS code
1528 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1529 to respect attribute syntax properly would be welcome.
1530
1531 =cut
1532 */
1533
1534 void
1535 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1536                         char *attrstr, STRLEN len)
1537 {
1538     OP *attrs = Nullop;
1539
1540     if (!len) {
1541         len = strlen(attrstr);
1542     }
1543
1544     while (len) {
1545         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1546         if (len) {
1547             char *sstr = attrstr;
1548             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1549             attrs = append_elem(OP_LIST, attrs,
1550                                 newSVOP(OP_CONST, 0,
1551                                         newSVpvn(sstr, attrstr-sstr)));
1552         }
1553     }
1554
1555     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1556                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557                      Nullsv, prepend_elem(OP_LIST,
1558                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1559                                   prepend_elem(OP_LIST,
1560                                                newSVOP(OP_CONST, 0,
1561                                                        newRV((SV*)cv)),
1562                                                attrs)));
1563 }
1564
1565 STATIC OP *
1566 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1567 {
1568     OP *kid;
1569     I32 type;
1570
1571     if (!o || PL_error_count)
1572         return o;
1573
1574     type = o->op_type;
1575     if (type == OP_LIST) {
1576         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1577             my_kid(kid, attrs, imopsp);
1578     } else if (type == OP_UNDEF) {
1579         return o;
1580     } else if (type == OP_RV2SV ||      /* "our" declaration */
1581                type == OP_RV2AV ||
1582                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1583         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1584             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1585                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1586         } else if (attrs) {
1587             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1588             PL_in_my = FALSE;
1589             PL_in_my_stash = Nullhv;
1590             apply_attrs(GvSTASH(gv),
1591                         (type == OP_RV2SV ? GvSV(gv) :
1592                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1593                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1594                         attrs, FALSE);
1595         }
1596         o->op_private |= OPpOUR_INTRO;
1597         return o;
1598     }
1599     else if (type != OP_PADSV &&
1600              type != OP_PADAV &&
1601              type != OP_PADHV &&
1602              type != OP_PUSHMARK)
1603     {
1604         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1605                           OP_DESC(o),
1606                           PL_in_my == KEY_our ? "our" : "my"));
1607         return o;
1608     }
1609     else if (attrs && type != OP_PUSHMARK) {
1610         HV *stash;
1611
1612         PL_in_my = FALSE;
1613         PL_in_my_stash = Nullhv;
1614
1615         /* check for C<my Dog $spot> when deciding package */
1616         stash = PAD_COMPNAME_TYPE(o->op_targ);
1617         if (!stash)
1618             stash = PL_curstash;
1619         apply_attrs_my(stash, o, attrs, imopsp);
1620     }
1621     o->op_flags |= OPf_MOD;
1622     o->op_private |= OPpLVAL_INTRO;
1623     return o;
1624 }
1625
1626 OP *
1627 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1628 {
1629     OP *rops = Nullop;
1630     int maybe_scalar = 0;
1631
1632 /* [perl #17376]: this appears to be premature, and results in code such as
1633    C< our(%x); > executing in list mode rather than void mode */
1634 #if 0
1635     if (o->op_flags & OPf_PARENS)
1636         list(o);
1637     else
1638         maybe_scalar = 1;
1639 #else
1640     maybe_scalar = 1;
1641 #endif
1642     if (attrs)
1643         SAVEFREEOP(attrs);
1644     o = my_kid(o, attrs, &rops);
1645     if (rops) {
1646         if (maybe_scalar && o->op_type == OP_PADSV) {
1647             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1648             o->op_private |= OPpLVAL_INTRO;
1649         }
1650         else
1651             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1652     }
1653     PL_in_my = FALSE;
1654     PL_in_my_stash = Nullhv;
1655     return o;
1656 }
1657
1658 OP *
1659 Perl_my(pTHX_ OP *o)
1660 {
1661     return my_attrs(o, Nullop);
1662 }
1663
1664 OP *
1665 Perl_sawparens(pTHX_ OP *o)
1666 {
1667     if (o)
1668         o->op_flags |= OPf_PARENS;
1669     return o;
1670 }
1671
1672 OP *
1673 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1674 {
1675     OP *o;
1676     bool ismatchop = 0;
1677
1678     if (ckWARN(WARN_MISC) &&
1679       (left->op_type == OP_RV2AV ||
1680        left->op_type == OP_RV2HV ||
1681        left->op_type == OP_PADAV ||
1682        left->op_type == OP_PADHV)) {
1683       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1684                             right->op_type == OP_TRANS)
1685                            ? right->op_type : OP_MATCH];
1686       const char *sample = ((left->op_type == OP_RV2AV ||
1687                              left->op_type == OP_PADAV)
1688                             ? "@array" : "%hash");
1689       Perl_warner(aTHX_ packWARN(WARN_MISC),
1690              "Applying %s to %s will act on scalar(%s)",
1691              desc, sample, sample);
1692     }
1693
1694     if (right->op_type == OP_CONST &&
1695         cSVOPx(right)->op_private & OPpCONST_BARE &&
1696         cSVOPx(right)->op_private & OPpCONST_STRICT)
1697     {
1698         no_bareword_allowed(right);
1699     }
1700
1701     ismatchop = right->op_type == OP_MATCH ||
1702                 right->op_type == OP_SUBST ||
1703                 right->op_type == OP_TRANS;
1704     if (ismatchop && right->op_private & OPpTARGET_MY) {
1705         right->op_targ = 0;
1706         right->op_private &= ~OPpTARGET_MY;
1707     }
1708     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1709         right->op_flags |= OPf_STACKED;
1710         if (right->op_type != OP_MATCH &&
1711             ! (right->op_type == OP_TRANS &&
1712                right->op_private & OPpTRANS_IDENTICAL))
1713             left = mod(left, right->op_type);
1714         if (right->op_type == OP_TRANS)
1715             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1716         else
1717             o = prepend_elem(right->op_type, scalar(left), right);
1718         if (type == OP_NOT)
1719             return newUNOP(OP_NOT, 0, scalar(o));
1720         return o;
1721     }
1722     else
1723         return bind_match(type, left,
1724                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1725 }
1726
1727 OP *
1728 Perl_invert(pTHX_ OP *o)
1729 {
1730     if (!o)
1731         return o;
1732     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1733     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1734 }
1735
1736 OP *
1737 Perl_scope(pTHX_ OP *o)
1738 {
1739     if (o) {
1740         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1741             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1742             o->op_type = OP_LEAVE;
1743             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1744         }
1745         else if (o->op_type == OP_LINESEQ) {
1746             OP *kid;
1747             o->op_type = OP_SCOPE;
1748             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1749             kid = ((LISTOP*)o)->op_first;
1750             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1751                 op_null(kid);
1752         }
1753         else
1754             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1755     }
1756     return o;
1757 }
1758
1759 void
1760 Perl_save_hints(pTHX)
1761 {
1762     SAVEI32(PL_hints);
1763     SAVESPTR(GvHV(PL_hintgv));
1764     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1765     SAVEFREESV(GvHV(PL_hintgv));
1766 }
1767
1768 int
1769 Perl_block_start(pTHX_ int full)
1770 {
1771     int retval = PL_savestack_ix;
1772     /* If there were syntax errors, don't try to start a block */
1773     /* XXX DAPM 13-Feb-04. This symbol no longer gloabl. Think of a better
1774      * way
1775      * if (PL_yynerrs) return retval;
1776      */
1777
1778     pad_block_start(full);
1779     SAVEHINTS();
1780     PL_hints &= ~HINT_BLOCK_SCOPE;
1781     SAVESPTR(PL_compiling.cop_warnings);
1782     if (! specialWARN(PL_compiling.cop_warnings)) {
1783         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1784         SAVEFREESV(PL_compiling.cop_warnings) ;
1785     }
1786     SAVESPTR(PL_compiling.cop_io);
1787     if (! specialCopIO(PL_compiling.cop_io)) {
1788         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1789         SAVEFREESV(PL_compiling.cop_io) ;
1790     }
1791     return retval;
1792 }
1793
1794 OP*
1795 Perl_block_end(pTHX_ I32 floor, OP *seq)
1796 {
1797     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1798     OP* retval = scalarseq(seq);
1799     /* If there were syntax errors, don't try to close a block */
1800     /* XXX DAPM 13-Feb-04. This symbol no longer gloabl. Think of a better
1801      * way
1802      * if (PL_yynerrs) return retval;
1803      */
1804     LEAVE_SCOPE(floor);
1805     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1806     if (needblockscope)
1807         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1808     pad_leavemy();
1809     return retval;
1810 }
1811
1812 STATIC OP *
1813 S_newDEFSVOP(pTHX)
1814 {
1815     I32 offset = pad_findmy("$_");
1816     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1817         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1818     }
1819     else {
1820         OP *o = newOP(OP_PADSV, 0);
1821         o->op_targ = offset;
1822         return o;
1823     }
1824 }
1825
1826 void
1827 Perl_newPROG(pTHX_ OP *o)
1828 {
1829     if (PL_in_eval) {
1830         if (PL_eval_root)
1831                 return;
1832         PL_eval_root = newUNOP(OP_LEAVEEVAL,
1833                                ((PL_in_eval & EVAL_KEEPERR)
1834                                 ? OPf_SPECIAL : 0), o);
1835         PL_eval_start = linklist(PL_eval_root);
1836         PL_eval_root->op_private |= OPpREFCOUNTED;
1837         OpREFCNT_set(PL_eval_root, 1);
1838         PL_eval_root->op_next = 0;
1839         CALL_PEEP(PL_eval_start);
1840     }
1841     else {
1842         if (o->op_type == OP_STUB) {
1843             PL_comppad_name = 0;
1844             PL_compcv = 0;
1845             FreeOp(o);
1846             return;
1847         }
1848         PL_main_root = scope(sawparens(scalarvoid(o)));
1849         PL_curcop = &PL_compiling;
1850         PL_main_start = LINKLIST(PL_main_root);
1851         PL_main_root->op_private |= OPpREFCOUNTED;
1852         OpREFCNT_set(PL_main_root, 1);
1853         PL_main_root->op_next = 0;
1854         CALL_PEEP(PL_main_start);
1855         PL_compcv = 0;
1856
1857         /* Register with debugger */
1858         if (PERLDB_INTER) {
1859             CV *cv = get_cv("DB::postponed", FALSE);
1860             if (cv) {
1861                 dSP;
1862                 PUSHMARK(SP);
1863                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1864                 PUTBACK;
1865                 call_sv((SV*)cv, G_DISCARD);
1866             }
1867         }
1868     }
1869 }
1870
1871 OP *
1872 Perl_localize(pTHX_ OP *o, I32 lex)
1873 {
1874     if (o->op_flags & OPf_PARENS)
1875 /* [perl #17376]: this appears to be premature, and results in code such as
1876    C< our(%x); > executing in list mode rather than void mode */
1877 #if 0
1878         list(o);
1879 #else
1880         ;
1881 #endif
1882     else {
1883         if (ckWARN(WARN_PARENTHESIS)
1884             && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1885         {
1886             char *s = PL_bufptr;
1887             bool sigil = FALSE;
1888
1889             /* some heuristics to detect a potential error */
1890             while (*s && (strchr(", \t\n", *s)))
1891                 s++;
1892
1893             while (1) {
1894                 if (*s && strchr("@$%*", *s) && *++s
1895                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1896                     s++;
1897                     sigil = TRUE;
1898                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1899                         s++;
1900                     while (*s && (strchr(", \t\n", *s)))
1901                         s++;
1902                 }
1903                 else
1904                     break;
1905             }
1906             if (sigil && (*s == ';' || *s == '=')) {
1907                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1908                                 "Parentheses missing around \"%s\" list",
1909                                 lex ? (PL_in_my == KEY_our ? "our" : "my")
1910                                 : "local");
1911             }
1912         }
1913     }
1914     if (lex)
1915         o = my(o);
1916     else
1917         o = mod(o, OP_NULL);            /* a bit kludgey */
1918     PL_in_my = FALSE;
1919     PL_in_my_stash = Nullhv;
1920     return o;
1921 }
1922
1923 OP *
1924 Perl_jmaybe(pTHX_ OP *o)
1925 {
1926     if (o->op_type == OP_LIST) {
1927         OP *o2;
1928         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1929         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1930     }
1931     return o;
1932 }
1933
1934 OP *
1935 Perl_fold_constants(pTHX_ register OP *o)
1936 {
1937     register OP *curop;
1938     I32 type = o->op_type;
1939     SV *sv;
1940
1941     if (PL_opargs[type] & OA_RETSCALAR)
1942         scalar(o);
1943     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1944         o->op_targ = pad_alloc(type, SVs_PADTMP);
1945
1946     /* integerize op, unless it happens to be C<-foo>.
1947      * XXX should pp_i_negate() do magic string negation instead? */
1948     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1949         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1950              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1951     {
1952         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1953     }
1954
1955     if (!(PL_opargs[type] & OA_FOLDCONST))
1956         goto nope;
1957
1958     switch (type) {
1959     case OP_NEGATE:
1960         /* XXX might want a ck_negate() for this */
1961         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1962         break;
1963     case OP_SPRINTF:
1964     case OP_UCFIRST:
1965     case OP_LCFIRST:
1966     case OP_UC:
1967     case OP_LC:
1968     case OP_SLT:
1969     case OP_SGT:
1970     case OP_SLE:
1971     case OP_SGE:
1972     case OP_SCMP:
1973         /* XXX what about the numeric ops? */
1974         if (PL_hints & HINT_LOCALE)
1975             goto nope;
1976     }
1977
1978     if (PL_error_count)
1979         goto nope;              /* Don't try to run w/ errors */
1980
1981     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1982         if ((curop->op_type != OP_CONST ||
1983              (curop->op_private & OPpCONST_BARE)) &&
1984             curop->op_type != OP_LIST &&
1985             curop->op_type != OP_SCALAR &&
1986             curop->op_type != OP_NULL &&
1987             curop->op_type != OP_PUSHMARK)
1988         {
1989             goto nope;
1990         }
1991     }
1992
1993     curop = LINKLIST(o);
1994     o->op_next = 0;
1995     PL_op = curop;
1996     CALLRUNOPS(aTHX);
1997     sv = *(PL_stack_sp--);
1998     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1999         pad_swipe(o->op_targ,  FALSE);
2000     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2001         (void)SvREFCNT_inc(sv);
2002         SvTEMP_off(sv);
2003     }
2004     op_free(o);
2005     if (type == OP_RV2GV)
2006         return newGVOP(OP_GV, 0, (GV*)sv);
2007     return newSVOP(OP_CONST, 0, sv);
2008
2009   nope:
2010     return o;
2011 }
2012
2013 OP *
2014 Perl_gen_constant_list(pTHX_ register OP *o)
2015 {
2016     register OP *curop;
2017     I32 oldtmps_floor = PL_tmps_floor;
2018
2019     list(o);
2020     if (PL_error_count)
2021         return o;               /* Don't attempt to run with errors */
2022
2023     PL_op = curop = LINKLIST(o);
2024     o->op_next = 0;
2025     CALL_PEEP(curop);
2026     pp_pushmark();
2027     CALLRUNOPS(aTHX);
2028     PL_op = curop;
2029     pp_anonlist();
2030     PL_tmps_floor = oldtmps_floor;
2031
2032     o->op_type = OP_RV2AV;
2033     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2034     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2035     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2036     o->op_seq = 0;              /* needs to be revisited in peep() */
2037     curop = ((UNOP*)o)->op_first;
2038     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2039     op_free(curop);
2040     linklist(o);
2041     return list(o);
2042 }
2043
2044 OP *
2045 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2046 {
2047     if (!o || o->op_type != OP_LIST)
2048         o = newLISTOP(OP_LIST, 0, o, Nullop);
2049     else
2050         o->op_flags &= ~OPf_WANT;
2051
2052     if (!(PL_opargs[type] & OA_MARK))
2053         op_null(cLISTOPo->op_first);
2054
2055     o->op_type = (OPCODE)type;
2056     o->op_ppaddr = PL_ppaddr[type];
2057     o->op_flags |= flags;
2058
2059     o = CHECKOP(type, o);
2060     if (o->op_type != type)
2061         return o;
2062
2063     return fold_constants(o);
2064 }
2065
2066 /* List constructors */
2067
2068 OP *
2069 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2070 {
2071     if (!first)
2072         return last;
2073
2074     if (!last)
2075         return first;
2076
2077     if (first->op_type != type
2078         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2079     {
2080         return newLISTOP(type, 0, first, last);
2081     }
2082
2083     if (first->op_flags & OPf_KIDS)
2084         ((LISTOP*)first)->op_last->op_sibling = last;
2085     else {
2086         first->op_flags |= OPf_KIDS;
2087         ((LISTOP*)first)->op_first = last;
2088     }
2089     ((LISTOP*)first)->op_last = last;
2090     return first;
2091 }
2092
2093 OP *
2094 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2095 {
2096     if (!first)
2097         return (OP*)last;
2098
2099     if (!last)
2100         return (OP*)first;
2101
2102     if (first->op_type != type)
2103         return prepend_elem(type, (OP*)first, (OP*)last);
2104
2105     if (last->op_type != type)
2106         return append_elem(type, (OP*)first, (OP*)last);
2107
2108     first->op_last->op_sibling = last->op_first;
2109     first->op_last = last->op_last;
2110     first->op_flags |= (last->op_flags & OPf_KIDS);
2111
2112     FreeOp(last);
2113
2114     return (OP*)first;
2115 }
2116
2117 OP *
2118 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2119 {
2120     if (!first)
2121         return last;
2122
2123     if (!last)
2124         return first;
2125
2126     if (last->op_type == type) {
2127         if (type == OP_LIST) {  /* already a PUSHMARK there */
2128             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2129             ((LISTOP*)last)->op_first->op_sibling = first;
2130             if (!(first->op_flags & OPf_PARENS))
2131                 last->op_flags &= ~OPf_PARENS;
2132         }
2133         else {
2134             if (!(last->op_flags & OPf_KIDS)) {
2135                 ((LISTOP*)last)->op_last = first;
2136                 last->op_flags |= OPf_KIDS;
2137             }
2138             first->op_sibling = ((LISTOP*)last)->op_first;
2139             ((LISTOP*)last)->op_first = first;
2140         }
2141         last->op_flags |= OPf_KIDS;
2142         return last;
2143     }
2144
2145     return newLISTOP(type, 0, first, last);
2146 }
2147
2148 /* Constructors */
2149
2150 OP *
2151 Perl_newNULLLIST(pTHX)
2152 {
2153     return newOP(OP_STUB, 0);
2154 }
2155
2156 OP *
2157 Perl_force_list(pTHX_ OP *o)
2158 {
2159     if (!o || o->op_type != OP_LIST)
2160         o = newLISTOP(OP_LIST, 0, o, Nullop);
2161     op_null(o);
2162     return o;
2163 }
2164
2165 OP *
2166 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2167 {
2168     LISTOP *listop;
2169
2170     NewOp(1101, listop, 1, LISTOP);
2171
2172     listop->op_type = (OPCODE)type;
2173     listop->op_ppaddr = PL_ppaddr[type];
2174     if (first || last)
2175         flags |= OPf_KIDS;
2176     listop->op_flags = (U8)flags;
2177
2178     if (!last && first)
2179         last = first;
2180     else if (!first && last)
2181         first = last;
2182     else if (first)
2183         first->op_sibling = last;
2184     listop->op_first = first;
2185     listop->op_last = last;
2186     if (type == OP_LIST) {
2187         OP* pushop;
2188         pushop = newOP(OP_PUSHMARK, 0);
2189         pushop->op_sibling = first;
2190         listop->op_first = pushop;
2191         listop->op_flags |= OPf_KIDS;
2192         if (!last)
2193             listop->op_last = pushop;
2194     }
2195
2196     return CHECKOP(type, listop);
2197 }
2198
2199 OP *
2200 Perl_newOP(pTHX_ I32 type, I32 flags)
2201 {
2202     OP *o;
2203     NewOp(1101, o, 1, OP);
2204     o->op_type = (OPCODE)type;
2205     o->op_ppaddr = PL_ppaddr[type];
2206     o->op_flags = (U8)flags;
2207
2208     o->op_next = o;
2209     o->op_private = (U8)(0 | (flags >> 8));
2210     if (PL_opargs[type] & OA_RETSCALAR)
2211         scalar(o);
2212     if (PL_opargs[type] & OA_TARGET)
2213         o->op_targ = pad_alloc(type, SVs_PADTMP);
2214     return CHECKOP(type, o);
2215 }
2216
2217 OP *
2218 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2219 {
2220     UNOP *unop;
2221
2222     if (!first)
2223         first = newOP(OP_STUB, 0);
2224     if (PL_opargs[type] & OA_MARK)
2225         first = force_list(first);
2226
2227     NewOp(1101, unop, 1, UNOP);
2228     unop->op_type = (OPCODE)type;
2229     unop->op_ppaddr = PL_ppaddr[type];
2230     unop->op_first = first;
2231     unop->op_flags = flags | OPf_KIDS;
2232     unop->op_private = (U8)(1 | (flags >> 8));
2233     unop = (UNOP*) CHECKOP(type, unop);
2234     if (unop->op_next)
2235         return (OP*)unop;
2236
2237     return fold_constants((OP *) unop);
2238 }
2239
2240 OP *
2241 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2242 {
2243     BINOP *binop;
2244     NewOp(1101, binop, 1, BINOP);
2245
2246     if (!first)
2247         first = newOP(OP_NULL, 0);
2248
2249     binop->op_type = (OPCODE)type;
2250     binop->op_ppaddr = PL_ppaddr[type];
2251     binop->op_first = first;
2252     binop->op_flags = flags | OPf_KIDS;
2253     if (!last) {
2254         last = first;
2255         binop->op_private = (U8)(1 | (flags >> 8));
2256     }
2257     else {
2258         binop->op_private = (U8)(2 | (flags >> 8));
2259         first->op_sibling = last;
2260     }
2261
2262     binop = (BINOP*)CHECKOP(type, binop);
2263     if (binop->op_next || binop->op_type != (OPCODE)type)
2264         return (OP*)binop;
2265
2266     binop->op_last = binop->op_first->op_sibling;
2267
2268     return fold_constants((OP *)binop);
2269 }
2270
2271 static int
2272 uvcompare(const void *a, const void *b)
2273 {
2274     if (*((UV *)a) < (*(UV *)b))
2275         return -1;
2276     if (*((UV *)a) > (*(UV *)b))
2277         return 1;
2278     if (*((UV *)a+1) < (*(UV *)b+1))
2279         return -1;
2280     if (*((UV *)a+1) > (*(UV *)b+1))
2281         return 1;
2282     return 0;
2283 }
2284
2285 OP *
2286 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2287 {
2288     SV *tstr = ((SVOP*)expr)->op_sv;
2289     SV *rstr = ((SVOP*)repl)->op_sv;
2290     STRLEN tlen;
2291     STRLEN rlen;
2292     U8 *t = (U8*)SvPV(tstr, tlen);
2293     U8 *r = (U8*)SvPV(rstr, rlen);
2294     register I32 i;
2295     register I32 j;
2296     I32 del;
2297     I32 complement;
2298     I32 squash;
2299     I32 grows = 0;
2300     register short *tbl;
2301
2302     PL_hints |= HINT_BLOCK_SCOPE;
2303     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2304     del         = o->op_private & OPpTRANS_DELETE;
2305     squash      = o->op_private & OPpTRANS_SQUASH;
2306
2307     if (SvUTF8(tstr))
2308         o->op_private |= OPpTRANS_FROM_UTF;
2309
2310     if (SvUTF8(rstr))
2311         o->op_private |= OPpTRANS_TO_UTF;
2312
2313     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2314         SV* listsv = newSVpvn("# comment\n",10);
2315         SV* transv = 0;
2316         U8* tend = t + tlen;
2317         U8* rend = r + rlen;
2318         STRLEN ulen;
2319         UV tfirst = 1;
2320         UV tlast = 0;
2321         IV tdiff;
2322         UV rfirst = 1;
2323         UV rlast = 0;
2324         IV rdiff;
2325         IV diff;
2326         I32 none = 0;
2327         U32 max = 0;
2328         I32 bits;
2329         I32 havefinal = 0;
2330         U32 final = 0;
2331         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2332         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2333         U8* tsave = NULL;
2334         U8* rsave = NULL;
2335
2336         if (!from_utf) {
2337             STRLEN len = tlen;
2338             tsave = t = bytes_to_utf8(t, &len);
2339             tend = t + len;
2340         }
2341         if (!to_utf && rlen) {
2342             STRLEN len = rlen;
2343             rsave = r = bytes_to_utf8(r, &len);
2344             rend = r + len;
2345         }
2346
2347 /* There are several snags with this code on EBCDIC:
2348    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2349    2. scan_const() in toke.c has encoded chars in native encoding which makes
2350       ranges at least in EBCDIC 0..255 range the bottom odd.
2351 */
2352
2353         if (complement) {
2354             U8 tmpbuf[UTF8_MAXLEN+1];
2355             UV *cp;
2356             UV nextmin = 0;
2357             New(1109, cp, 2*tlen, UV);
2358             i = 0;
2359             transv = newSVpvn("",0);
2360             while (t < tend) {
2361                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2362                 t += ulen;
2363                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2364                     t++;
2365                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2366                     t += ulen;
2367                 }
2368                 else {
2369                  cp[2*i+1] = cp[2*i];
2370                 }
2371                 i++;
2372             }
2373             qsort(cp, i, 2*sizeof(UV), uvcompare);
2374             for (j = 0; j < i; j++) {
2375                 UV  val = cp[2*j];
2376                 diff = val - nextmin;
2377                 if (diff > 0) {
2378                     t = uvuni_to_utf8(tmpbuf,nextmin);
2379                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2380                     if (diff > 1) {
2381                         U8  range_mark = UTF_TO_NATIVE(0xff);
2382                         t = uvuni_to_utf8(tmpbuf, val - 1);
2383                         sv_catpvn(transv, (char *)&range_mark, 1);
2384                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2385                     }
2386                 }
2387                 val = cp[2*j+1];
2388                 if (val >= nextmin)
2389                     nextmin = val + 1;
2390             }
2391             t = uvuni_to_utf8(tmpbuf,nextmin);
2392             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2393             {
2394                 U8 range_mark = UTF_TO_NATIVE(0xff);
2395                 sv_catpvn(transv, (char *)&range_mark, 1);
2396             }
2397             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2398                                     UNICODE_ALLOW_SUPER);
2399             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2400             t = (U8*)SvPVX(transv);
2401             tlen = SvCUR(transv);
2402             tend = t + tlen;
2403             Safefree(cp);
2404         }
2405         else if (!rlen && !del) {
2406             r = t; rlen = tlen; rend = tend;
2407         }
2408         if (!squash) {
2409                 if ((!rlen && !del) || t == r ||
2410                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2411                 {
2412                     o->op_private |= OPpTRANS_IDENTICAL;
2413                 }
2414         }
2415
2416         while (t < tend || tfirst <= tlast) {
2417             /* see if we need more "t" chars */
2418             if (tfirst > tlast) {
2419                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2420                 t += ulen;
2421                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2422                     t++;
2423                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2424                     t += ulen;
2425                 }
2426                 else
2427                     tlast = tfirst;
2428             }
2429
2430             /* now see if we need more "r" chars */
2431             if (rfirst > rlast) {
2432                 if (r < rend) {
2433                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2434                     r += ulen;
2435                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2436                         r++;
2437                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2438                         r += ulen;
2439                     }
2440                     else
2441                         rlast = rfirst;
2442                 }
2443                 else {
2444                     if (!havefinal++)
2445                         final = rlast;
2446                     rfirst = rlast = 0xffffffff;
2447                 }
2448             }
2449
2450             /* now see which range will peter our first, if either. */
2451             tdiff = tlast - tfirst;
2452             rdiff = rlast - rfirst;
2453
2454             if (tdiff <= rdiff)
2455                 diff = tdiff;
2456             else
2457                 diff = rdiff;
2458
2459             if (rfirst == 0xffffffff) {
2460                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2461                 if (diff > 0)
2462                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2463                                    (long)tfirst, (long)tlast);
2464                 else
2465                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2466             }
2467             else {
2468                 if (diff > 0)
2469                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2470                                    (long)tfirst, (long)(tfirst + diff),
2471                                    (long)rfirst);
2472                 else
2473                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2474                                    (long)tfirst, (long)rfirst);
2475
2476                 if (rfirst + diff > max)
2477                     max = rfirst + diff;
2478                 if (!grows)
2479                     grows = (tfirst < rfirst &&
2480                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2481                 rfirst += diff + 1;
2482             }
2483             tfirst += diff + 1;
2484         }
2485
2486         none = ++max;
2487         if (del)
2488             del = ++max;
2489
2490         if (max > 0xffff)
2491             bits = 32;
2492         else if (max > 0xff)
2493             bits = 16;
2494         else
2495             bits = 8;
2496
2497         Safefree(cPVOPo->op_pv);
2498         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2499         SvREFCNT_dec(listsv);
2500         if (transv)
2501             SvREFCNT_dec(transv);
2502
2503         if (!del && havefinal && rlen)
2504             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2505                            newSVuv((UV)final), 0);
2506
2507         if (grows)
2508             o->op_private |= OPpTRANS_GROWS;
2509
2510         if (tsave)
2511             Safefree(tsave);
2512         if (rsave)
2513             Safefree(rsave);
2514
2515         op_free(expr);
2516         op_free(repl);
2517         return o;
2518     }
2519
2520     tbl = (short*)cPVOPo->op_pv;
2521     if (complement) {
2522         Zero(tbl, 256, short);
2523         for (i = 0; i < (I32)tlen; i++)
2524             tbl[t[i]] = -1;
2525         for (i = 0, j = 0; i < 256; i++) {
2526             if (!tbl[i]) {
2527                 if (j >= (I32)rlen) {
2528                     if (del)
2529                         tbl[i] = -2;
2530                     else if (rlen)
2531                         tbl[i] = r[j-1];
2532                     else
2533                         tbl[i] = (short)i;
2534                 }
2535                 else {
2536                     if (i < 128 && r[j] >= 128)
2537                         grows = 1;
2538                     tbl[i] = r[j++];
2539                 }
2540             }
2541         }
2542         if (!del) {
2543             if (!rlen) {
2544                 j = rlen;
2545                 if (!squash)
2546                     o->op_private |= OPpTRANS_IDENTICAL;
2547             }
2548             else if (j >= (I32)rlen)
2549                 j = rlen - 1;
2550             else
2551                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2552             tbl[0x100] = rlen - j;
2553             for (i=0; i < (I32)rlen - j; i++)
2554                 tbl[0x101+i] = r[j+i];
2555         }
2556     }
2557     else {
2558         if (!rlen && !del) {
2559             r = t; rlen = tlen;
2560             if (!squash)
2561                 o->op_private |= OPpTRANS_IDENTICAL;
2562         }
2563         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2564             o->op_private |= OPpTRANS_IDENTICAL;
2565         }
2566         for (i = 0; i < 256; i++)
2567             tbl[i] = -1;
2568         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2569             if (j >= (I32)rlen) {
2570                 if (del) {
2571                     if (tbl[t[i]] == -1)
2572                         tbl[t[i]] = -2;
2573                     continue;
2574                 }
2575                 --j;
2576             }
2577             if (tbl[t[i]] == -1) {
2578                 if (t[i] < 128 && r[j] >= 128)
2579                     grows = 1;
2580                 tbl[t[i]] = r[j];
2581             }
2582         }
2583     }
2584     if (grows)
2585         o->op_private |= OPpTRANS_GROWS;
2586     op_free(expr);
2587     op_free(repl);
2588
2589     return o;
2590 }
2591
2592 OP *
2593 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2594 {
2595     PMOP *pmop;
2596
2597     NewOp(1101, pmop, 1, PMOP);
2598     pmop->op_type = (OPCODE)type;
2599     pmop->op_ppaddr = PL_ppaddr[type];
2600     pmop->op_flags = (U8)flags;
2601     pmop->op_private = (U8)(0 | (flags >> 8));
2602
2603     if (PL_hints & HINT_RE_TAINT)
2604         pmop->op_pmpermflags |= PMf_RETAINT;
2605     if (PL_hints & HINT_LOCALE)
2606         pmop->op_pmpermflags |= PMf_LOCALE;
2607     pmop->op_pmflags = pmop->op_pmpermflags;
2608
2609 #ifdef USE_ITHREADS
2610     {
2611         SV* repointer;
2612         if(av_len((AV*) PL_regex_pad[0]) > -1) {
2613             repointer = av_pop((AV*)PL_regex_pad[0]);
2614             pmop->op_pmoffset = SvIV(repointer);
2615             SvREPADTMP_off(repointer);
2616             sv_setiv(repointer,0);
2617         } else {
2618             repointer = newSViv(0);
2619             av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2620             pmop->op_pmoffset = av_len(PL_regex_padav);
2621             PL_regex_pad = AvARRAY(PL_regex_padav);
2622         }
2623     }
2624 #endif
2625
2626         /* link into pm list */
2627     if (type != OP_TRANS && PL_curstash) {
2628         pmop->op_pmnext = HvPMROOT(PL_curstash);
2629         HvPMROOT(PL_curstash) = pmop;
2630         PmopSTASH_set(pmop,PL_curstash);
2631     }
2632
2633     return CHECKOP(type, pmop);
2634 }
2635
2636 OP *
2637 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2638 {
2639     PMOP *pm;
2640     LOGOP *rcop;
2641     I32 repl_has_vars = 0;
2642
2643     if (o->op_type == OP_TRANS)
2644         return pmtrans(o, expr, repl);
2645
2646     PL_hints |= HINT_BLOCK_SCOPE;
2647     pm = (PMOP*)o;
2648
2649     if (expr->op_type == OP_CONST) {
2650         STRLEN plen;
2651         SV *pat = ((SVOP*)expr)->op_sv;
2652         char *p = SvPV(pat, plen);
2653         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2654             sv_setpvn(pat, "\\s+", 3);
2655             p = SvPV(pat, plen);
2656             pm->op_pmflags |= PMf_SKIPWHITE;
2657         }
2658         if (DO_UTF8(pat))
2659             pm->op_pmdynflags |= PMdf_UTF8;
2660         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2661         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2662             pm->op_pmflags |= PMf_WHITE;
2663         op_free(expr);
2664     }
2665     else {
2666         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2667             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2668                             ? OP_REGCRESET
2669                             : OP_REGCMAYBE),0,expr);
2670
2671         NewOp(1101, rcop, 1, LOGOP);
2672         rcop->op_type = OP_REGCOMP;
2673         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2674         rcop->op_first = scalar(expr);
2675         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2676                            ? (OPf_SPECIAL | OPf_KIDS)
2677                            : OPf_KIDS);
2678         rcop->op_private = 1;
2679         rcop->op_other = o;
2680         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
2681         PL_cv_has_eval = 1;
2682
2683         /* establish postfix order */
2684         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2685             LINKLIST(expr);
2686             rcop->op_next = expr;
2687             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2688         }
2689         else {
2690             rcop->op_next = LINKLIST(expr);
2691             expr->op_next = (OP*)rcop;
2692         }
2693
2694         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2695     }
2696
2697     if (repl) {
2698         OP *curop;
2699         if (pm->op_pmflags & PMf_EVAL) {
2700             curop = 0;
2701             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2702                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2703         }
2704         else if (repl->op_type == OP_CONST)
2705             curop = repl;
2706         else {
2707             OP *lastop = 0;
2708             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2709                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2710                     if (curop->op_type == OP_GV) {
2711                         GV *gv = cGVOPx_gv(curop);
2712                         repl_has_vars = 1;
2713                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2714                             break;
2715                     }
2716                     else if (curop->op_type == OP_RV2CV)
2717                         break;
2718                     else if (curop->op_type == OP_RV2SV ||
2719                              curop->op_type == OP_RV2AV ||
2720                              curop->op_type == OP_RV2HV ||
2721                              curop->op_type == OP_RV2GV) {
2722                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2723                             break;
2724                     }
2725                     else if (curop->op_type == OP_PADSV ||
2726                              curop->op_type == OP_PADAV ||
2727                              curop->op_type == OP_PADHV ||
2728                              curop->op_type == OP_PADANY) {
2729                         repl_has_vars = 1;
2730                     }
2731                     else if (curop->op_type == OP_PUSHRE)
2732                         ; /* Okay here, dangerous in newASSIGNOP */
2733                     else
2734                         break;
2735                 }
2736                 lastop = curop;
2737             }
2738         }
2739         if (curop == repl
2740             && !(repl_has_vars
2741                  && (!PM_GETRE(pm)
2742                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2743             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2744             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2745             prepend_elem(o->op_type, scalar(repl), o);
2746         }
2747         else {
2748             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2749                 pm->op_pmflags |= PMf_MAYBE_CONST;
2750                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2751             }
2752             NewOp(1101, rcop, 1, LOGOP);
2753             rcop->op_type = OP_SUBSTCONT;
2754             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2755             rcop->op_first = scalar(repl);
2756             rcop->op_flags |= OPf_KIDS;
2757             rcop->op_private = 1;
2758             rcop->op_other = o;
2759
2760             /* establish postfix order */
2761             rcop->op_next = LINKLIST(repl);
2762             repl->op_next = (OP*)rcop;
2763
2764             pm->op_pmreplroot = scalar((OP*)rcop);
2765             pm->op_pmreplstart = LINKLIST(rcop);
2766             rcop->op_next = 0;
2767         }
2768     }
2769
2770     return (OP*)pm;
2771 }
2772
2773 OP *
2774 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2775 {
2776     SVOP *svop;
2777     NewOp(1101, svop, 1, SVOP);
2778     svop->op_type = (OPCODE)type;
2779     svop->op_ppaddr = PL_ppaddr[type];
2780     svop->op_sv = sv;
2781     svop->op_next = (OP*)svop;
2782     svop->op_flags = (U8)flags;
2783     if (PL_opargs[type] & OA_RETSCALAR)
2784         scalar((OP*)svop);
2785     if (PL_opargs[type] & OA_TARGET)
2786         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2787     return CHECKOP(type, svop);
2788 }
2789
2790 OP *
2791 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2792 {
2793     PADOP *padop;
2794     NewOp(1101, padop, 1, PADOP);
2795     padop->op_type = (OPCODE)type;
2796     padop->op_ppaddr = PL_ppaddr[type];
2797     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2798     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2799     PAD_SETSV(padop->op_padix, sv);
2800     if (sv)
2801         SvPADTMP_on(sv);
2802     padop->op_next = (OP*)padop;
2803     padop->op_flags = (U8)flags;
2804     if (PL_opargs[type] & OA_RETSCALAR)
2805         scalar((OP*)padop);
2806     if (PL_opargs[type] & OA_TARGET)
2807         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2808     return CHECKOP(type, padop);
2809 }
2810
2811 OP *
2812 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2813 {
2814 #ifdef USE_ITHREADS
2815     if (gv)
2816         GvIN_PAD_on(gv);
2817     return newPADOP(type, flags, SvREFCNT_inc(gv));
2818 #else
2819     return newSVOP(type, flags, SvREFCNT_inc(gv));
2820 #endif
2821 }
2822
2823 OP *
2824 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2825 {
2826     PVOP *pvop;
2827     NewOp(1101, pvop, 1, PVOP);
2828     pvop->op_type = (OPCODE)type;
2829     pvop->op_ppaddr = PL_ppaddr[type];
2830     pvop->op_pv = pv;
2831     pvop->op_next = (OP*)pvop;
2832     pvop->op_flags = (U8)flags;
2833     if (PL_opargs[type] & OA_RETSCALAR)
2834         scalar((OP*)pvop);
2835     if (PL_opargs[type] & OA_TARGET)
2836         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2837     return CHECKOP(type, pvop);
2838 }
2839
2840 void
2841 Perl_package(pTHX_ OP *o)
2842 {
2843     char *name;
2844     STRLEN len;
2845
2846     save_hptr(&PL_curstash);
2847     save_item(PL_curstname);
2848
2849     name = SvPV(cSVOPo->op_sv, len);
2850     PL_curstash = gv_stashpvn(name, len, TRUE);
2851     sv_setpvn(PL_curstname, name, len);
2852     op_free(o);
2853
2854     PL_hints |= HINT_BLOCK_SCOPE;
2855     PL_copline = NOLINE;
2856     PL_expect = XSTATE;
2857 }
2858
2859 void
2860 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2861 {
2862     OP *pack;
2863     OP *imop;
2864     OP *veop;
2865
2866     if (idop->op_type != OP_CONST)
2867         Perl_croak(aTHX_ "Module name must be constant");
2868
2869     veop = Nullop;
2870
2871     if (version != Nullop) {
2872         SV *vesv = ((SVOP*)version)->op_sv;
2873
2874         if (arg == Nullop && !SvNIOKp(vesv)) {
2875             arg = version;
2876         }
2877         else {
2878             OP *pack;
2879             SV *meth;
2880
2881             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2882                 Perl_croak(aTHX_ "Version number must be constant number");
2883
2884             /* Make copy of idop so we don't free it twice */
2885             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2886
2887             /* Fake up a method call to VERSION */
2888             meth = newSVpvn("VERSION",7);
2889             sv_upgrade(meth, SVt_PVIV);
2890             (void)SvIOK_on(meth);
2891             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2892             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2893                             append_elem(OP_LIST,
2894                                         prepend_elem(OP_LIST, pack, list(version)),
2895                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
2896         }
2897     }
2898
2899     /* Fake up an import/unimport */
2900     if (arg && arg->op_type == OP_STUB)
2901         imop = arg;             /* no import on explicit () */
2902     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2903         imop = Nullop;          /* use 5.0; */
2904     }
2905     else {
2906         SV *meth;
2907
2908         /* Make copy of idop so we don't free it twice */
2909         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2910
2911         /* Fake up a method call to import/unimport */
2912         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2913         (void)SvUPGRADE(meth, SVt_PVIV);
2914         (void)SvIOK_on(meth);
2915         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2916         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2917                        append_elem(OP_LIST,
2918                                    prepend_elem(OP_LIST, pack, list(arg)),
2919                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
2920     }
2921
2922     /* Fake up the BEGIN {}, which does its thing immediately. */
2923     newATTRSUB(floor,
2924         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2925         Nullop,
2926         Nullop,
2927         append_elem(OP_LINESEQ,
2928             append_elem(OP_LINESEQ,
2929                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2930                 newSTATEOP(0, Nullch, veop)),
2931             newSTATEOP(0, Nullch, imop) ));
2932
2933     /* The "did you use incorrect case?" warning used to be here.
2934      * The problem is that on case-insensitive filesystems one
2935      * might get false positives for "use" (and "require"):
2936      * "use Strict" or "require CARP" will work.  This causes
2937      * portability problems for the script: in case-strict
2938      * filesystems the script will stop working.
2939      *
2940      * The "incorrect case" warning checked whether "use Foo"
2941      * imported "Foo" to your namespace, but that is wrong, too:
2942      * there is no requirement nor promise in the language that
2943      * a Foo.pm should or would contain anything in package "Foo".
2944      *
2945      * There is very little Configure-wise that can be done, either:
2946      * the case-sensitivity of the build filesystem of Perl does not
2947      * help in guessing the case-sensitivity of the runtime environment.
2948      */
2949
2950     PL_hints |= HINT_BLOCK_SCOPE;
2951     PL_copline = NOLINE;
2952     PL_expect = XSTATE;
2953     PL_cop_seqmax++; /* Purely for B::*'s benefit */
2954 }
2955
2956 /*
2957 =head1 Embedding Functions
2958
2959 =for apidoc load_module
2960
2961 Loads the module whose name is pointed to by the string part of name.
2962 Note that the actual module name, not its filename, should be given.
2963 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
2964 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2965 (or 0 for no flags). ver, if specified, provides version semantics
2966 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
2967 arguments can be used to specify arguments to the module's import()
2968 method, similar to C<use Foo::Bar VERSION LIST>.
2969
2970 =cut */
2971
2972 void
2973 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2974 {
2975     va_list args;
2976     va_start(args, ver);
2977     vload_module(flags, name, ver, &args);
2978     va_end(args);
2979 }
2980
2981 #ifdef PERL_IMPLICIT_CONTEXT
2982 void
2983 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2984 {
2985     dTHX;
2986     va_list args;
2987     va_start(args, ver);
2988     vload_module(flags, name, ver, &args);
2989     va_end(args);
2990 }
2991 #endif
2992
2993 void
2994 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2995 {
2996     OP *modname, *veop, *imop;
2997
2998     modname = newSVOP(OP_CONST, 0, name);
2999     modname->op_private |= OPpCONST_BARE;
3000     if (ver) {
3001         veop = newSVOP(OP_CONST, 0, ver);
3002     }
3003     else
3004         veop = Nullop;
3005     if (flags & PERL_LOADMOD_NOIMPORT) {
3006         imop = sawparens(newNULLLIST());
3007     }
3008     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3009         imop = va_arg(*args, OP*);
3010     }
3011     else {
3012         SV *sv;
3013         imop = Nullop;
3014         sv = va_arg(*args, SV*);
3015         while (sv) {
3016             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3017             sv = va_arg(*args, SV*);
3018         }
3019     }
3020     {
3021         line_t ocopline = PL_copline;
3022         COP *ocurcop = PL_curcop;
3023         int oexpect = PL_expect;
3024
3025         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3026                 veop, modname, imop);
3027         PL_expect = oexpect;
3028         PL_copline = ocopline;
3029         PL_curcop = ocurcop;
3030     }
3031 }
3032
3033 OP *
3034 Perl_dofile(pTHX_ OP *term)
3035 {
3036     OP *doop;
3037     GV *gv;
3038
3039     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3040     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3041         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3042
3043     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3044         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3045                                append_elem(OP_LIST, term,
3046                                            scalar(newUNOP(OP_RV2CV, 0,
3047                                                           newGVOP(OP_GV, 0,
3048                                                                   gv))))));
3049     }
3050     else {
3051         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3052     }
3053     return doop;
3054 }
3055
3056 OP *
3057 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3058 {
3059     return newBINOP(OP_LSLICE, flags,
3060             list(force_list(subscript)),
3061             list(force_list(listval)) );
3062 }
3063
3064 STATIC I32
3065 S_list_assignment(pTHX_ register OP *o)
3066 {
3067     if (!o)
3068         return TRUE;
3069
3070     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3071         o = cUNOPo->op_first;
3072
3073     if (o->op_type == OP_COND_EXPR) {
3074         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3075         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3076
3077         if (t && f)
3078             return TRUE;
3079         if (t || f)
3080             yyerror("Assignment to both a list and a scalar");
3081         return FALSE;
3082     }
3083
3084     if (o->op_type == OP_LIST &&
3085         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3086         o->op_private & OPpLVAL_INTRO)
3087         return FALSE;
3088
3089     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3090         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3091         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3092         return TRUE;
3093
3094     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3095         return TRUE;
3096
3097     if (o->op_type == OP_RV2SV)
3098         return FALSE;
3099
3100     return FALSE;
3101 }
3102
3103 OP *
3104 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3105 {
3106     OP *o;
3107
3108     if (optype) {
3109         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3110             return newLOGOP(optype, 0,
3111                 mod(scalar(left), optype),
3112                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3113         }
3114         else {
3115             return newBINOP(optype, OPf_STACKED,
3116                 mod(scalar(left), optype), scalar(right));
3117         }
3118     }
3119
3120     if (list_assignment(left)) {
3121         OP *curop;
3122
3123         PL_modcount = 0;
3124         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3125         left = mod(left, OP_AASSIGN);
3126         if (PL_eval_start)
3127             PL_eval_start = 0;
3128         else {
3129             op_free(left);
3130             op_free(right);
3131             return Nullop;
3132         }
3133         curop = list(force_list(left));
3134         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3135         o->op_private = (U8)(0 | (flags >> 8));
3136
3137         /* PL_generation sorcery:
3138          * an assignment like ($a,$b) = ($c,$d) is easier than
3139          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3140          * To detect whether there are common vars, the global var
3141          * PL_generation is incremented for each assign op we compile.
3142          * Then, while compiling the assign op, we run through all the
3143          * variables on both sides of the assignment, setting a spare slot
3144          * in each of them to PL_generation. If any of them already have
3145          * that value, we know we've got commonality.  We could use a
3146          * single bit marker, but then we'd have to make 2 passes, first
3147          * to clear the flag, then to test and set it.  To find somewhere
3148          * to store these values, evil chicanery is done with SvCUR().
3149          */
3150
3151         if (!(left->op_private & OPpLVAL_INTRO)) {
3152             OP *lastop = o;
3153             PL_generation++;
3154             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3155                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3156                     if (curop->op_type == OP_GV) {
3157                         GV *gv = cGVOPx_gv(curop);
3158                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3159                             break;
3160                         SvCUR(gv) = PL_generation;
3161                     }
3162                     else if (curop->op_type == OP_PADSV ||
3163                              curop->op_type == OP_PADAV ||
3164                              curop->op_type == OP_PADHV ||
3165                              curop->op_type == OP_PADANY)
3166                     {
3167                         if (PAD_COMPNAME_GEN(curop->op_targ)
3168                                                     == (STRLEN)PL_generation)
3169                             break;
3170                         PAD_COMPNAME_GEN(curop->op_targ)
3171                                                         = PL_generation;
3172
3173                     }
3174                     else if (curop->op_type == OP_RV2CV)
3175                         break;
3176                     else if (curop->op_type == OP_RV2SV ||
3177                              curop->op_type == OP_RV2AV ||
3178                              curop->op_type == OP_RV2HV ||
3179                              curop->op_type == OP_RV2GV) {
3180                         if (lastop->op_type != OP_GV)   /* funny deref? */
3181                             break;
3182                     }
3183                     else if (curop->op_type == OP_PUSHRE) {
3184                         if (((PMOP*)curop)->op_pmreplroot) {
3185 #ifdef USE_ITHREADS
3186                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3187                                         ((PMOP*)curop)->op_pmreplroot));
3188 #else
3189                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3190 #endif
3191                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3192                                 break;
3193                             SvCUR(gv) = PL_generation;
3194                         }
3195                     }
3196                     else
3197                         break;
3198                 }
3199                 lastop = curop;
3200             }
3201             if (curop != o)
3202                 o->op_private |= OPpASSIGN_COMMON;
3203         }
3204         if (right && right->op_type == OP_SPLIT) {
3205             OP* tmpop;
3206             if ((tmpop = ((LISTOP*)right)->op_first) &&
3207                 tmpop->op_type == OP_PUSHRE)
3208             {
3209                 PMOP *pm = (PMOP*)tmpop;
3210                 if (left->op_type == OP_RV2AV &&
3211                     !(left->op_private & OPpLVAL_INTRO) &&
3212                     !(o->op_private & OPpASSIGN_COMMON) )
3213                 {
3214                     tmpop = ((UNOP*)left)->op_first;
3215                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3216 #ifdef USE_ITHREADS
3217                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3218                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3219 #else
3220                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3221                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3222 #endif
3223                         pm->op_pmflags |= PMf_ONCE;
3224                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3225                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3226                         tmpop->op_sibling = Nullop;     /* don't free split */
3227                         right->op_next = tmpop->op_next;  /* fix starting loc */
3228                         op_free(o);                     /* blow off assign */
3229                         right->op_flags &= ~OPf_WANT;
3230                                 /* "I don't know and I don't care." */
3231                         return right;
3232                     }
3233                 }
3234                 else {
3235                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3236                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3237                     {
3238                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3239                         if (SvIVX(sv) == 0)
3240                             sv_setiv(sv, PL_modcount+1);
3241                     }
3242                 }
3243             }
3244         }
3245         return o;
3246     }
3247     if (!right)
3248         right = newOP(OP_UNDEF, 0);
3249     if (right->op_type == OP_READLINE) {
3250         right->op_flags |= OPf_STACKED;
3251         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3252     }
3253     else {
3254         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3255         o = newBINOP(OP_SASSIGN, flags,
3256             scalar(right), mod(scalar(left), OP_SASSIGN) );
3257         if (PL_eval_start)
3258             PL_eval_start = 0;
3259         else {
3260             op_free(o);
3261             return Nullop;
3262         }
3263     }
3264     return o;
3265 }
3266
3267 OP *
3268 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3269 {
3270     U32 seq = intro_my();
3271     register COP *cop;
3272
3273     NewOp(1101, cop, 1, COP);
3274     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3275         cop->op_type = OP_DBSTATE;
3276         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3277     }
3278     else {
3279         cop->op_type = OP_NEXTSTATE;
3280         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3281     }
3282     cop->op_flags = (U8)flags;
3283     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3284 #ifdef NATIVE_HINTS
3285     cop->op_private |= NATIVE_HINTS;
3286 #endif
3287     PL_compiling.op_private = cop->op_private;
3288     cop->op_next = (OP*)cop;
3289
3290     if (label) {
3291         cop->cop_label = label;
3292         PL_hints |= HINT_BLOCK_SCOPE;
3293     }
3294     cop->cop_seq = seq;
3295     cop->cop_arybase = PL_curcop->cop_arybase;
3296     if (specialWARN(PL_curcop->cop_warnings))
3297         cop->cop_warnings = PL_curcop->cop_warnings ;
3298     else
3299         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3300     if (specialCopIO(PL_curcop->cop_io))
3301         cop->cop_io = PL_curcop->cop_io;
3302     else
3303         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3304
3305
3306     if (PL_copline == NOLINE)
3307         CopLINE_set(cop, CopLINE(PL_curcop));
3308     else {
3309         CopLINE_set(cop, PL_copline);
3310         PL_copline = NOLINE;
3311     }
3312 #ifdef USE_ITHREADS
3313     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3314 #else
3315     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3316 #endif
3317     CopSTASH_set(cop, PL_curstash);
3318
3319     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3320         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3321         if (svp && *svp != &PL_sv_undef ) {
3322            (void)SvIOK_on(*svp);
3323             SvIVX(*svp) = PTR2IV(cop);
3324         }
3325     }
3326
3327     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3328 }
3329
3330
3331 OP *
3332 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3333 {
3334     return new_logop(type, flags, &first, &other);
3335 }
3336
3337 STATIC OP *
3338 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3339 {
3340     LOGOP *logop;
3341     OP *o;
3342     OP *first = *firstp;
3343     OP *other = *otherp;
3344
3345     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3346         return newBINOP(type, flags, scalar(first), scalar(other));
3347
3348     scalarboolean(first);
3349     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3350     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3351         if (type == OP_AND || type == OP_OR) {
3352             if (type == OP_AND)
3353                 type = OP_OR;
3354             else
3355                 type = OP_AND;
3356             o = first;
3357             first = *firstp = cUNOPo->op_first;
3358             if (o->op_next)
3359                 first->op_next = o->op_next;
3360             cUNOPo->op_first = Nullop;
3361             op_free(o);
3362         }
3363     }
3364     if (first->op_type == OP_CONST) {
3365         if (first->op_private & OPpCONST_STRICT)
3366             no_bareword_allowed(first);
3367         else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3368                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3369         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3370             op_free(first);
3371             *firstp = Nullop;
3372             return other;
3373         }
3374         else {
3375             op_free(other);
3376             *otherp = Nullop;
3377             return first;
3378         }
3379     }
3380     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3381              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3382     {
3383         OP *k1 = ((UNOP*)first)->op_first;
3384         OP *k2 = k1->op_sibling;
3385         OPCODE warnop = 0;
3386         switch (first->op_type)
3387         {
3388         case OP_NULL:
3389             if (k2 && k2->op_type == OP_READLINE
3390                   && (k2->op_flags & OPf_STACKED)
3391                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3392             {
3393                 warnop = k2->op_type;
3394             }
3395             break;
3396
3397         case OP_SASSIGN:
3398             if (k1->op_type == OP_READDIR
3399                   || k1->op_type == OP_GLOB
3400                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3401                   || k1->op_type == OP_EACH)
3402             {
3403                 warnop = ((k1->op_type == OP_NULL)
3404                           ? (OPCODE)k1->op_targ : k1->op_type);
3405             }
3406             break;
3407         }
3408         if (warnop) {
3409             line_t oldline = CopLINE(PL_curcop);
3410             CopLINE_set(PL_curcop, PL_copline);
3411             Perl_warner(aTHX_ packWARN(WARN_MISC),
3412                  "Value of %s%s can be \"0\"; test with defined()",
3413                  PL_op_desc[warnop],
3414                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3415                   ? " construct" : "() operator"));
3416             CopLINE_set(PL_curcop, oldline);
3417         }
3418     }
3419
3420     if (!other)
3421         return first;
3422
3423     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3424         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3425
3426     NewOp(1101, logop, 1, LOGOP);
3427
3428     logop->op_type = (OPCODE)type;
3429     logop->op_ppaddr = PL_ppaddr[type];
3430     logop->op_first = first;
3431     logop->op_flags = flags | OPf_KIDS;
3432     logop->op_other = LINKLIST(other);
3433     logop->op_private = (U8)(1 | (flags >> 8));
3434
3435     /* establish postfix order */
3436     logop->op_next = LINKLIST(first);
3437     first->op_next = (OP*)logop;
3438     first->op_sibling = other;
3439
3440     CHECKOP(type,logop);
3441
3442     o = newUNOP(OP_NULL, 0, (OP*)logop);
3443     other->op_next = o;
3444
3445     return o;
3446 }
3447
3448 OP *
3449 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3450 {
3451     LOGOP *logop;
3452     OP *start;
3453     OP *o;
3454
3455     if (!falseop)
3456         return newLOGOP(OP_AND, 0, first, trueop);
3457     if (!trueop)
3458         return newLOGOP(OP_OR, 0, first, falseop);
3459
3460     scalarboolean(first);
3461     if (first->op_type == OP_CONST) {
3462         if (first->op_private & OPpCONST_BARE &&
3463            first->op_private & OPpCONST_STRICT) {
3464            no_bareword_allowed(first);
3465        }
3466         if (SvTRUE(((SVOP*)first)->op_sv)) {
3467             op_free(first);
3468             op_free(falseop);
3469             return trueop;
3470         }
3471         else {
3472             op_free(first);
3473             op_free(trueop);
3474             return falseop;
3475         }
3476     }
3477     NewOp(1101, logop, 1, LOGOP);
3478     logop->op_type = OP_COND_EXPR;
3479     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3480     logop->op_first = first;
3481     logop->op_flags = flags | OPf_KIDS;
3482     logop->op_private = (U8)(1 | (flags >> 8));
3483     logop->op_other = LINKLIST(trueop);
3484     logop->op_next = LINKLIST(falseop);
3485
3486     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3487             logop);
3488
3489     /* establish postfix order */
3490     start = LINKLIST(first);
3491     first->op_next = (OP*)logop;
3492
3493     first->op_sibling = trueop;
3494     trueop->op_sibling = falseop;
3495     o = newUNOP(OP_NULL, 0, (OP*)logop);
3496
3497     trueop->op_next = falseop->op_next = o;
3498
3499     o->op_next = start;
3500     return o;
3501 }
3502
3503 OP *
3504 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3505 {
3506     LOGOP *range;
3507     OP *flip;
3508     OP *flop;
3509     OP *leftstart;
3510     OP *o;
3511
3512     NewOp(1101, range, 1, LOGOP);
3513
3514     range->op_type = OP_RANGE;
3515     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3516     range->op_first = left;
3517     range->op_flags = OPf_KIDS;
3518     leftstart = LINKLIST(left);
3519     range->op_other = LINKLIST(right);
3520     range->op_private = (U8)(1 | (flags >> 8));
3521
3522     left->op_sibling = right;
3523
3524     range->op_next = (OP*)range;
3525     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3526     flop = newUNOP(OP_FLOP, 0, flip);
3527     o = newUNOP(OP_NULL, 0, flop);
3528     linklist(flop);
3529     range->op_next = leftstart;
3530
3531     left->op_next = flip;
3532     right->op_next = flop;
3533
3534     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3535     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3536     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3537     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3538
3539     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3540     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3541
3542     flip->op_next = o;
3543     if (!flip->op_private || !flop->op_private)
3544         linklist(o);            /* blow off optimizer unless constant */
3545
3546     return o;
3547 }
3548
3549 OP *
3550 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3551 {
3552     OP* listop;
3553     OP* o;
3554     int once = block && block->op_flags & OPf_SPECIAL &&
3555       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3556
3557     if (expr) {
3558         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3559             return block;       /* do {} while 0 does once */
3560         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3561             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3562             expr = newUNOP(OP_DEFINED, 0,
3563                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3564         } else if (expr->op_flags & OPf_KIDS) {
3565             OP *k1 = ((UNOP*)expr)->op_first;
3566             OP *k2 = (k1) ? k1->op_sibling : NULL;
3567             switch (expr->op_type) {
3568               case OP_NULL:
3569                 if (k2 && k2->op_type == OP_READLINE
3570                       && (k2->op_flags & OPf_STACKED)
3571                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3572                     expr = newUNOP(OP_DEFINED, 0, expr);
3573                 break;
3574
3575               case OP_SASSIGN:
3576                 if (k1->op_type == OP_READDIR
3577                       || k1->op_type == OP_GLOB
3578                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3579                       || k1->op_type == OP_EACH)
3580                     expr = newUNOP(OP_DEFINED, 0, expr);
3581                 break;
3582             }
3583         }
3584     }
3585
3586     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3587     o = new_logop(OP_AND, 0, &expr, &listop);
3588
3589     if (listop)
3590         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3591
3592     if (once && o != listop)
3593         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3594
3595     if (o == listop)
3596         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3597
3598     o->op_flags |= flags;
3599     o = scope(o);
3600     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3601     return o;
3602 }
3603
3604 OP *
3605 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3606 {
3607     OP *redo;
3608     OP *next = 0;
3609     OP *listop;
3610     OP *o;
3611     U8 loopflags = 0;
3612
3613     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3614                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3615         expr = newUNOP(OP_DEFINED, 0,
3616             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3617     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3618         OP *k1 = ((UNOP*)expr)->op_first;
3619         OP *k2 = (k1) ? k1->op_sibling : NULL;
3620         switch (expr->op_type) {
3621           case OP_NULL:
3622             if (k2 && k2->op_type == OP_READLINE
3623                   && (k2->op_flags & OPf_STACKED)
3624                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3625                 expr = newUNOP(OP_DEFINED, 0, expr);
3626             break;
3627
3628           case OP_SASSIGN:
3629             if (k1->op_type == OP_READDIR
3630                   || k1->op_type == OP_GLOB
3631                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3632                   || k1->op_type == OP_EACH)
3633                 expr = newUNOP(OP_DEFINED, 0, expr);
3634             break;
3635         }
3636     }
3637
3638     if (!block)
3639         block = newOP(OP_NULL, 0);
3640     else if (cont) {
3641         block = scope(block);
3642     }
3643
3644     if (cont) {
3645         next = LINKLIST(cont);
3646     }
3647     if (expr) {
3648         OP *unstack = newOP(OP_UNSTACK, 0);
3649         if (!next)
3650             next = unstack;
3651         cont = append_elem(OP_LINESEQ, cont, unstack);
3652     }
3653
3654     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3655     redo = LINKLIST(listop);
3656
3657     if (expr) {
3658         PL_copline = (line_t)whileline;
3659         scalar(listop);
3660         o = new_logop(OP_AND, 0, &expr, &listop);
3661         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3662             op_free(expr);              /* oops, it's a while (0) */
3663             op_free((OP*)loop);
3664             return Nullop;              /* listop already freed by new_logop */
3665         }
3666         if (listop)
3667             ((LISTOP*)listop)->op_last->op_next =
3668                 (o == listop ? redo : LINKLIST(o));
3669     }
3670     else
3671         o = listop;
3672
3673     if (!loop) {
3674         NewOp(1101,loop,1,LOOP);
3675         loop->op_type = OP_ENTERLOOP;
3676         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3677         loop->op_private = 0;
3678         loop->op_next = (OP*)loop;
3679     }
3680
3681     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3682
3683     loop->op_redoop = redo;
3684     loop->op_lastop = o;
3685     o->op_private |= loopflags;
3686
3687     if (next)
3688         loop->op_nextop = next;
3689     else
3690         loop->op_nextop = o;
3691
3692     o->op_flags |= flags;
3693     o->op_private |= (flags >> 8);
3694     return o;
3695 }
3696
3697 OP *
3698 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3699 {
3700     LOOP *loop;
3701     OP *wop;
3702     PADOFFSET padoff = 0;
3703     I32 iterflags = 0;
3704     I32 iterpflags = 0;
3705
3706     if (sv) {
3707         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3708             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3709             sv->op_type = OP_RV2GV;
3710             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3711         }
3712         else if (sv->op_type == OP_PADSV) { /* private variable */
3713             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3714             padoff = sv->op_targ;
3715             sv->op_targ = 0;
3716             op_free(sv);
3717             sv = Nullop;
3718         }
3719         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3720             padoff = sv->op_targ;
3721             sv->op_targ = 0;
3722             iterflags |= OPf_SPECIAL;
3723             op_free(sv);
3724             sv = Nullop;
3725         }
3726         else
3727             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3728     }
3729     else {
3730         I32 offset = pad_findmy("$_");
3731         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3732             sv = newGVOP(OP_GV, 0, PL_defgv);
3733         }
3734         else {
3735             padoff = offset;
3736             iterpflags = OPpLVAL_INTRO; /* my $_; for () */
3737         }
3738     }
3739     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3740         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3741         iterflags |= OPf_STACKED;
3742     }
3743     else if (expr->op_type == OP_NULL &&
3744              (expr->op_flags & OPf_KIDS) &&
3745              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3746     {
3747         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3748          * set the STACKED flag to indicate that these values are to be
3749          * treated as min/max values by 'pp_iterinit'.
3750          */
3751         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3752         LOGOP* range = (LOGOP*) flip->op_first;
3753         OP* left  = range->op_first;
3754         OP* right = left->op_sibling;
3755         LISTOP* listop;
3756
3757         range->op_flags &= ~OPf_KIDS;
3758         range->op_first = Nullop;
3759
3760         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3761         listop->op_first->op_next = range->op_next;
3762         left->op_next = range->op_other;
3763         right->op_next = (OP*)listop;
3764         listop->op_next = listop->op_first;
3765
3766         op_free(expr);
3767         expr = (OP*)(listop);
3768         op_null(expr);
3769         iterflags |= OPf_STACKED;
3770     }
3771     else {
3772         expr = mod(force_list(expr), OP_GREPSTART);
3773     }
3774
3775
3776     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3777                                append_elem(OP_LIST, expr, scalar(sv))));
3778     assert(!loop->op_next);
3779     /* for my  $x () sets OPpLVAL_INTRO;
3780      * for our $x () sets OPpOUR_INTRO */
3781     loop->op_private = (U8)iterpflags;
3782 #ifdef PL_OP_SLAB_ALLOC
3783     {
3784         LOOP *tmp;
3785         NewOp(1234,tmp,1,LOOP);
3786         Copy(loop,tmp,1,LOOP);
3787         FreeOp(loop);
3788         loop = tmp;
3789     }
3790 #else
3791     Renew(loop, 1, LOOP);
3792 #endif
3793     loop->op_targ = padoff;
3794     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3795     PL_copline = forline;
3796     return newSTATEOP(0, label, wop);
3797 }
3798
3799 OP*
3800 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3801 {
3802     OP *o;
3803     STRLEN n_a;
3804
3805     if (type != OP_GOTO || label->op_type == OP_CONST) {
3806         /* "last()" means "last" */
3807         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3808             o = newOP(type, OPf_SPECIAL);
3809         else {
3810             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3811                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3812                                         : ""));
3813         }
3814         op_free(label);
3815     }
3816     else {
3817         /* Check whether it's going to be a goto &function */
3818         if (label->op_type == OP_ENTERSUB
3819                 && !(label->op_flags & OPf_STACKED))
3820             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3821         o = newUNOP(type, OPf_STACKED, label);
3822     }
3823     PL_hints |= HINT_BLOCK_SCOPE;
3824     return o;
3825 }
3826
3827 /*
3828 =for apidoc cv_undef
3829
3830 Clear out all the active components of a CV. This can happen either
3831 by an explicit C<undef &foo>, or by the reference count going to zero.
3832 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3833 children can still follow the full lexical scope chain.
3834
3835 =cut
3836 */
3837
3838 void
3839 Perl_cv_undef(pTHX_ CV *cv)
3840 {
3841 #ifdef USE_ITHREADS
3842     if (CvFILE(cv) && !CvXSUB(cv)) {
3843         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3844         Safefree(CvFILE(cv));
3845     }
3846     CvFILE(cv) = 0;
3847 #endif
3848
3849     if (!CvXSUB(cv) && CvROOT(cv)) {
3850         if (CvDEPTH(cv))
3851             Perl_croak(aTHX_ "Can't undef active subroutine");
3852         ENTER;
3853
3854         PAD_SAVE_SETNULLPAD();
3855
3856         op_free(CvROOT(cv));
3857         CvROOT(cv) = Nullop;
3858         LEAVE;
3859     }
3860     SvPOK_off((SV*)cv);         /* forget prototype */
3861     CvGV(cv) = Nullgv;
3862
3863     pad_undef(cv);
3864
3865     /* remove CvOUTSIDE unless this is an undef rather than a free */
3866     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3867         if (!CvWEAKOUTSIDE(cv))
3868             SvREFCNT_dec(CvOUTSIDE(cv));
3869         CvOUTSIDE(cv) = Nullcv;
3870     }
3871     if (CvCONST(cv)) {
3872         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3873         CvCONST_off(cv);
3874     }
3875     if (CvXSUB(cv)) {
3876         CvXSUB(cv) = 0;
3877     }
3878     /* delete all flags except WEAKOUTSIDE */
3879     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3880 }
3881
3882 void
3883 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3884 {
3885     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3886         SV* msg = sv_newmortal();
3887         SV* name = Nullsv;
3888
3889         if (gv)
3890             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3891         sv_setpv(msg, "Prototype mismatch:");
3892         if (name)
3893             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3894         if (SvPOK(cv))
3895             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3896         sv_catpv(msg, " vs ");
3897         if (p)
3898             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3899         else
3900             sv_catpv(msg, "none");
3901         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3902     }
3903 }
3904
3905 static void const_sv_xsub(pTHX_ CV* cv);
3906
3907 /*
3908
3909 =head1 Optree Manipulation Functions
3910
3911 =for apidoc cv_const_sv
3912
3913 If C<cv> is a constant sub eligible for inlining. returns the constant
3914 value returned by the sub.  Otherwise, returns NULL.
3915
3916 Constant subs can be created with C<newCONSTSUB> or as described in
3917 L<perlsub/"Constant Functions">.
3918
3919 =cut
3920 */
3921 SV *
3922 Perl_cv_const_sv(pTHX_ CV *cv)
3923 {
3924     if (!cv || !CvCONST(cv))
3925         return Nullsv;
3926     return (SV*)CvXSUBANY(cv).any_ptr;
3927 }
3928
3929 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
3930  * Can be called in 3 ways:
3931  *
3932  * !cv
3933  *      look for a single OP_CONST with attached value: return the value
3934  *
3935  * cv && CvCLONE(cv) && !CvCONST(cv)
3936  *
3937  *      examine the clone prototype, and if contains only a single
3938  *      OP_CONST referencing a pad const, or a single PADSV referencing
3939  *      an outer lexical, return a non-zero value to indicate the CV is
3940  *      a candidate for "constizing" at clone time
3941  *
3942  * cv && CvCONST(cv)
3943  *
3944  *      We have just cloned an anon prototype that was marked as a const
3945  *      candidiate. Try to grab the current value, and in the case of
3946  *      PADSV, ignore it if it has multiple references. Return the value.
3947  */
3948
3949 SV *
3950 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3951 {
3952     SV *sv = Nullsv;
3953
3954     if (!o)
3955         return Nullsv;
3956
3957     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3958         o = cLISTOPo->op_first->op_sibling;
3959
3960     for (; o; o = o->op_next) {
3961         OPCODE type = o->op_type;
3962
3963         if (sv && o->op_next == o)
3964             return sv;
3965         if (o->op_next != o) {
3966             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3967                 continue;
3968             if (type == OP_DBSTATE)
3969                 continue;
3970         }
3971         if (type == OP_LEAVESUB || type == OP_RETURN)
3972             break;
3973         if (sv)
3974             return Nullsv;
3975         if (type == OP_CONST && cSVOPo->op_sv)
3976             sv = cSVOPo->op_sv;
3977         else if (cv && type == OP_CONST) {
3978             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3979             if (!sv)
3980                 return Nullsv;
3981         }
3982         else if (cv && type == OP_PADSV) {
3983             if (CvCONST(cv)) { /* newly cloned anon */
3984                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3985                 /* the candidate should have 1 ref from this pad and 1 ref
3986                  * from the parent */
3987                 if (!sv || SvREFCNT(sv) != 2)
3988                     return Nullsv;
3989                 sv = newSVsv(sv);
3990                 SvREADONLY_on(sv);
3991                 return sv;
3992             }
3993             else {
3994                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3995                     sv = &PL_sv_undef; /* an arbitrary non-null value */
3996             }
3997         }
3998         else {
3999             return Nullsv;
4000         }
4001     }
4002     return sv;
4003 }
4004
4005 void
4006 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4007 {
4008     if (o)
4009         SAVEFREEOP(o);
4010     if (proto)
4011         SAVEFREEOP(proto);
4012     if (attrs)
4013         SAVEFREEOP(attrs);
4014     if (block)
4015         SAVEFREEOP(block);
4016     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4017 }
4018
4019 CV *
4020 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4021 {
4022     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4023 }
4024
4025 CV *
4026 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4027 {
4028     STRLEN n_a;
4029     char *name;
4030     char *aname;
4031     GV *gv;
4032     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4033     register CV *cv=0;
4034     SV *const_sv;
4035
4036     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4037     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4038         SV *sv = sv_newmortal();
4039         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4040                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4041                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4042         aname = SvPVX(sv);
4043     }
4044     else
4045         aname = Nullch;
4046     gv = gv_fetchpv(name ? name : (aname ? aname :
4047                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4048                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4049                     SVt_PVCV);
4050
4051     if (o)
4052         SAVEFREEOP(o);
4053     if (proto)
4054         SAVEFREEOP(proto);
4055     if (attrs)
4056         SAVEFREEOP(attrs);
4057
4058     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4059                                            maximum a prototype before. */
4060         if (SvTYPE(gv) > SVt_NULL) {
4061             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4062                 && ckWARN_d(WARN_PROTOTYPE))
4063             {
4064                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4065             }
4066             cv_ckproto((CV*)gv, NULL, ps);
4067         }
4068         if (ps)
4069             sv_setpv((SV*)gv, ps);
4070         else
4071             sv_setiv((SV*)gv, -1);
4072         SvREFCNT_dec(PL_compcv);
4073         cv = PL_compcv = NULL;
4074         PL_sub_generation++;
4075         goto done;
4076     }
4077
4078     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4079
4080 #ifdef GV_UNIQUE_CHECK
4081     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4082         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4083     }
4084 #endif
4085
4086     if (!block || !ps || *ps || attrs)
4087         const_sv = Nullsv;
4088     else
4089         const_sv = op_const_sv(block, Nullcv);
4090
4091     if (cv) {
4092         bool exists = CvROOT(cv) || CvXSUB(cv);
4093
4094 #ifdef GV_UNIQUE_CHECK
4095         if (exists && GvUNIQUE(gv)) {
4096             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4097         }
4098 #endif
4099
4100         /* if the subroutine doesn't exist and wasn't pre-declared
4101          * with a prototype, assume it will be AUTOLOADed,
4102          * skipping the prototype check
4103          */
4104         if (exists || SvPOK(cv))
4105             cv_ckproto(cv, gv, ps);
4106         /* already defined (or promised)? */
4107         if (exists || GvASSUMECV(gv)) {
4108             if (!block && !attrs) {
4109                 if (CvFLAGS(PL_compcv)) {
4110                     /* might have had built-in attrs applied */
4111                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4112                 }
4113                 /* just a "sub foo;" when &foo is already defined */
4114                 SAVEFREESV(PL_compcv);
4115                 goto done;
4116             }
4117             /* ahem, death to those who redefine active sort subs */
4118             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4119                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4120             if (block) {
4121                 if (ckWARN(WARN_REDEFINE)
4122                     || (CvCONST(cv)
4123                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4124                 {
4125                     line_t oldline = CopLINE(PL_curcop);
4126                     if (PL_copline != NOLINE)
4127                         CopLINE_set(PL_curcop, PL_copline);
4128                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4129                         CvCONST(cv) ? "Constant subroutine %s redefined"
4130                                     : "Subroutine %s redefined", name);
4131                     CopLINE_set(PL_curcop, oldline);
4132                 }
4133                 SvREFCNT_dec(cv);
4134                 cv = Nullcv;
4135             }
4136         }
4137     }
4138     if (const_sv) {
4139         SvREFCNT_inc(const_sv);
4140         if (cv) {
4141             assert(!CvROOT(cv) && !CvCONST(cv));
4142             sv_setpv((SV*)cv, "");  /* prototype is "" */
4143             CvXSUBANY(cv).any_ptr = const_sv;
4144             CvXSUB(cv) = const_sv_xsub;
4145             CvCONST_on(cv);
4146         }
4147         else {
4148             GvCV(gv) = Nullcv;
4149             cv = newCONSTSUB(NULL, name, const_sv);
4150         }
4151         op_free(block);
4152         SvREFCNT_dec(PL_compcv);
4153         PL_compcv = NULL;
4154         PL_sub_generation++;
4155         goto done;
4156     }
4157     if (attrs) {
4158         HV *stash;
4159         SV *rcv;
4160
4161         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4162          * before we clobber PL_compcv.
4163          */
4164         if (cv && !block) {
4165             rcv = (SV*)cv;
4166             /* Might have had built-in attributes applied -- propagate them. */
4167             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4168             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4169                 stash = GvSTASH(CvGV(cv));
4170             else if (CvSTASH(cv))
4171                 stash = CvSTASH(cv);
4172             else
4173                 stash = PL_curstash;
4174         }
4175         else {
4176             /* possibly about to re-define existing subr -- ignore old cv */
4177             rcv = (SV*)PL_compcv;
4178             if (name && GvSTASH(gv))
4179                 stash = GvSTASH(gv);
4180             else
4181                 stash = PL_curstash;
4182         }
4183         apply_attrs(stash, rcv, attrs, FALSE);
4184     }
4185     if (cv) {                           /* must reuse cv if autoloaded */
4186         if (!block) {
4187             /* got here with just attrs -- work done, so bug out */
4188             SAVEFREESV(PL_compcv);
4189             goto done;
4190         }
4191         /* transfer PL_compcv to cv */
4192         cv_undef(cv);
4193         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4194         if (!CvWEAKOUTSIDE(cv))
4195             SvREFCNT_dec(CvOUTSIDE(cv));
4196         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4197         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4198         CvOUTSIDE(PL_compcv) = 0;
4199         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4200         CvPADLIST(PL_compcv) = 0;
4201         /* inner references to PL_compcv must be fixed up ... */
4202         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4203         /* ... before we throw it away */
4204         SvREFCNT_dec(PL_compcv);
4205         PL_compcv = cv;
4206         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4207           ++PL_sub_generation;
4208     }
4209     else {
4210         cv = PL_compcv;
4211         if (name) {
4212             GvCV(gv) = cv;
4213             GvCVGEN(gv) = 0;
4214             PL_sub_generation++;
4215         }
4216     }
4217     CvGV(cv) = gv;
4218     CvFILE_set_from_cop(cv, PL_curcop);
4219     CvSTASH(cv) = PL_curstash;
4220
4221     if (ps)
4222         sv_setpv((SV*)cv, ps);
4223
4224     if (PL_error_count) {
4225         op_free(block);
4226         block = Nullop;
4227         if (name) {
4228             char *s = strrchr(name, ':');
4229             s = s ? s+1 : name;
4230             if (strEQ(s, "BEGIN")) {
4231                 char *not_safe =
4232                     "BEGIN not safe after errors--compilation aborted";
4233                 if (PL_in_eval & EVAL_KEEPERR)
4234                     Perl_croak(aTHX_ not_safe);
4235                 else {
4236                     /* force display of errors found but not reported */
4237                     sv_catpv(ERRSV, not_safe);
4238                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4239                 }
4240             }
4241         }
4242     }
4243     if (!block)
4244         goto done;
4245
4246     if (CvLVALUE(cv)) {
4247         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4248                              mod(scalarseq(block), OP_LEAVESUBLV));
4249     }
4250     else {
4251         /* This makes sub {}; work as expected.  */
4252         if (block->op_type == OP_STUB) {
4253             op_free(block);
4254             block = newSTATEOP(0, Nullch, 0);
4255         }
4256         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4257     }
4258     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4259     OpREFCNT_set(CvROOT(cv), 1);
4260     CvSTART(cv) = LINKLIST(CvROOT(cv));
4261     CvROOT(cv)->op_next = 0;
4262     CALL_PEEP(CvSTART(cv));
4263
4264     /* now that optimizer has done its work, adjust pad values */
4265
4266     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4267
4268     if (CvCLONE(cv)) {
4269         assert(!CvCONST(cv));
4270         if (ps && !*ps && op_const_sv(block, cv))
4271             CvCONST_on(cv);
4272     }
4273
4274     if (name || aname) {
4275         char *s;
4276         char *tname = (name ? name : aname);
4277
4278         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4279             SV *sv = NEWSV(0,0);
4280             SV *tmpstr = sv_newmortal();
4281             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4282             CV *pcv;
4283             HV *hv;
4284
4285             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4286                            CopFILE(PL_curcop),
4287                            (long)PL_subline, (long)CopLINE(PL_curcop));
4288             gv_efullname3(tmpstr, gv, Nullch);
4289             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4290             hv = GvHVn(db_postponed);
4291             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4292                 && (pcv = GvCV(db_postponed)))
4293             {
4294                 dSP;
4295                 PUSHMARK(SP);
4296                 XPUSHs(tmpstr);
4297                 PUTBACK;
4298                 call_sv((SV*)pcv, G_DISCARD);
4299             }
4300         }
4301
4302         if ((s = strrchr(tname,':')))
4303             s++;
4304         else
4305             s = tname;
4306
4307         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4308             goto done;
4309
4310         if (strEQ(s, "BEGIN") && !PL_error_count) {
4311             I32 oldscope = PL_scopestack_ix;
4312             ENTER;
4313             SAVECOPFILE(&PL_compiling);
4314             SAVECOPLINE(&PL_compiling);
4315
4316             if (!PL_beginav)
4317                 PL_beginav = newAV();
4318             DEBUG_x( dump_sub(gv) );
4319             av_push(PL_beginav, (SV*)cv);
4320             GvCV(gv) = 0;               /* cv has been hijacked */
4321             call_list(oldscope, PL_beginav);
4322
4323             PL_curcop = &PL_compiling;
4324             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4325             LEAVE;
4326         }
4327         else if (strEQ(s, "END") && !PL_error_count) {
4328             if (!PL_endav)
4329                 PL_endav = newAV();
4330             DEBUG_x( dump_sub(gv) );
4331             av_unshift(PL_endav, 1);
4332             av_store(PL_endav, 0, (SV*)cv);
4333             GvCV(gv) = 0;               /* cv has been hijacked */
4334         }
4335         else if (strEQ(s, "CHECK") && !PL_error_count) {
4336             if (!PL_checkav)
4337                 PL_checkav = newAV();
4338             DEBUG_x( dump_sub(gv) );
4339             if (PL_main_start && ckWARN(WARN_VOID))
4340                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4341             av_unshift(PL_checkav, 1);
4342             av_store(PL_checkav, 0, (SV*)cv);
4343             GvCV(gv) = 0;               /* cv has been hijacked */
4344         }
4345         else if (strEQ(s, "INIT") && !PL_error_count) {
4346             if (!PL_initav)
4347                 PL_initav = newAV();
4348             DEBUG_x( dump_sub(gv) );
4349             if (PL_main_start && ckWARN(WARN_VOID))
4350                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4351             av_push(PL_initav, (SV*)cv);
4352             GvCV(gv) = 0;               /* cv has been hijacked */
4353         }
4354     }
4355
4356   done:
4357     PL_copline = NOLINE;
4358     LEAVE_SCOPE(floor);
4359     return cv;
4360 }
4361
4362 /* XXX unsafe for threads if eval_owner isn't held */
4363 /*
4364 =for apidoc newCONSTSUB
4365
4366 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4367 eligible for inlining at compile-time.
4368
4369 =cut
4370 */
4371
4372 CV *
4373 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4374 {
4375     CV* cv;
4376
4377     ENTER;
4378
4379     SAVECOPLINE(PL_curcop);
4380     CopLINE_set(PL_curcop, PL_copline);
4381
4382     SAVEHINTS();
4383     PL_hints &= ~HINT_BLOCK_SCOPE;
4384
4385     if (stash) {
4386         SAVESPTR(PL_curstash);
4387         SAVECOPSTASH(PL_curcop);
4388         PL_curstash = stash;
4389         CopSTASH_set(PL_curcop,stash);
4390     }
4391
4392     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4393     CvXSUBANY(cv).any_ptr = sv;
4394     CvCONST_on(cv);
4395     sv_setpv((SV*)cv, "");  /* prototype is "" */
4396
4397     if (stash)
4398         CopSTASH_free(PL_curcop);
4399
4400     LEAVE;
4401
4402     return cv;
4403 }
4404
4405 /*
4406 =for apidoc U||newXS
4407
4408 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4409
4410 =cut
4411 */
4412
4413 CV *
4414 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4415 {
4416     GV *gv = gv_fetchpv(name ? name :
4417                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4418                         GV_ADDMULTI, SVt_PVCV);
4419     register CV *cv;
4420
4421     if (!subaddr)
4422         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4423
4424     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4425         if (GvCVGEN(gv)) {
4426             /* just a cached method */
4427             SvREFCNT_dec(cv);
4428             cv = 0;
4429         }
4430         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4431             /* already defined (or promised) */
4432             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4433                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4434                 line_t oldline = CopLINE(PL_curcop);
4435                 if (PL_copline != NOLINE)
4436                     CopLINE_set(PL_curcop, PL_copline);
4437                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4438                             CvCONST(cv) ? "Constant subroutine %s redefined"
4439                                         : "Subroutine %s redefined"
4440                             ,name);
4441                 CopLINE_set(PL_curcop, oldline);
4442             }
4443             SvREFCNT_dec(cv);
4444             cv = 0;
4445         }
4446     }
4447
4448     if (cv)                             /* must reuse cv if autoloaded */
4449         cv_undef(cv);
4450     else {
4451         cv = (CV*)NEWSV(1105,0);
4452         sv_upgrade((SV *)cv, SVt_PVCV);
4453         if (name) {
4454             GvCV(gv) = cv;
4455             GvCVGEN(gv) = 0;
4456             PL_sub_generation++;
4457         }
4458     }
4459     CvGV(cv) = gv;
4460     (void)gv_fetchfile(filename);
4461     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4462                                    an external constant string */
4463     CvXSUB(cv) = subaddr;
4464
4465     if (name) {
4466         char *s = strrchr(name,':');
4467         if (s)
4468             s++;
4469         else
4470             s = name;
4471
4472         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4473             goto done;
4474
4475         if (strEQ(s, "BEGIN")) {
4476             if (!PL_beginav)
4477                 PL_beginav = newAV();
4478             av_push(PL_beginav, (SV*)cv);
4479             GvCV(gv) = 0;               /* cv has been hijacked */
4480         }
4481         else if (strEQ(s, "END")) {
4482             if (!PL_endav)
4483                 PL_endav = newAV();
4484             av_unshift(PL_endav, 1);
4485             av_store(PL_endav, 0, (SV*)cv);
4486             GvCV(gv) = 0;               /* cv has been hijacked */
4487         }
4488         else if (strEQ(s, "CHECK")) {
4489             if (!PL_checkav)
4490                 PL_checkav = newAV();
4491             if (PL_main_start && ckWARN(WARN_VOID))
4492                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4493             av_unshift(PL_checkav, 1);
4494             av_store(PL_checkav, 0, (SV*)cv);
4495             GvCV(gv) = 0;               /* cv has been hijacked */
4496         }
4497         else if (strEQ(s, "INIT")) {
4498             if (!PL_initav)
4499                 PL_initav = newAV();
4500             if (PL_main_start && ckWARN(WARN_VOID))
4501                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4502             av_push(PL_initav, (SV*)cv);
4503             GvCV(gv) = 0;               /* cv has been hijacked */
4504         }
4505     }
4506     else
4507         CvANON_on(cv);
4508
4509 done:
4510     return cv;
4511 }
4512
4513 void
4514 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4515 {
4516     register CV *cv;
4517     char *name;
4518     GV *gv;
4519     STRLEN n_a;
4520
4521     if (o)
4522         name = SvPVx(cSVOPo->op_sv, n_a);
4523     else
4524         name = "STDOUT";
4525     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4526 #ifdef GV_UNIQUE_CHECK
4527     if (GvUNIQUE(gv)) {
4528         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4529     }
4530 #endif
4531     GvMULTI_on(gv);
4532     if ((cv = GvFORM(gv))) {
4533         if (ckWARN(WARN_REDEFINE)) {
4534             line_t oldline = CopLINE(PL_curcop);
4535             if (PL_copline != NOLINE)
4536                 CopLINE_set(PL_curcop, PL_copline);
4537             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4538             CopLINE_set(PL_curcop, oldline);
4539         }
4540         SvREFCNT_dec(cv);
4541     }
4542     cv = PL_compcv;
4543     GvFORM(gv) = cv;
4544     CvGV(cv) = gv;
4545     CvFILE_set_from_cop(cv, PL_curcop);
4546
4547
4548     pad_tidy(padtidy_FORMAT);
4549     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4550     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4551     OpREFCNT_set(CvROOT(cv), 1);
4552     CvSTART(cv) = LINKLIST(CvROOT(cv));
4553     CvROOT(cv)->op_next = 0;
4554     CALL_PEEP(CvSTART(cv));
4555     op_free(o);
4556     PL_copline = NOLINE;
4557     LEAVE_SCOPE(floor);
4558 }
4559
4560 OP *
4561 Perl_newANONLIST(pTHX_ OP *o)
4562 {
4563     return newUNOP(OP_REFGEN, 0,
4564         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4565 }
4566
4567 OP *
4568 Perl_newANONHASH(pTHX_ OP *o)
4569 {
4570     return newUNOP(OP_REFGEN, 0,
4571         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4572 }
4573
4574 OP *
4575 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4576 {
4577     return newANONATTRSUB(floor, proto, Nullop, block);
4578 }
4579
4580 OP *
4581 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4582 {
4583     return newUNOP(OP_REFGEN, 0,
4584         newSVOP(OP_ANONCODE, 0,
4585                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4586 }
4587
4588 OP *
4589 Perl_oopsAV(pTHX_ OP *o)
4590 {
4591     switch (o->op_type) {
4592     case OP_PADSV:
4593         o->op_type = OP_PADAV;
4594         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4595         return ref(o, OP_RV2AV);
4596
4597     case OP_RV2SV:
4598         o->op_type = OP_RV2AV;
4599         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4600         ref(o, OP_RV2AV);
4601         break;
4602
4603     default:
4604         if (ckWARN_d(WARN_INTERNAL))
4605             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4606         break;
4607     }
4608     return o;
4609 }
4610
4611 OP *
4612 Perl_oopsHV(pTHX_ OP *o)
4613 {
4614     switch (o->op_type) {
4615     case OP_PADSV:
4616     case OP_PADAV:
4617         o->op_type = OP_PADHV;
4618         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4619         return ref(o, OP_RV2HV);
4620
4621     case OP_RV2SV:
4622     case OP_RV2AV:
4623         o->op_type = OP_RV2HV;
4624         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4625         ref(o, OP_RV2HV);
4626         break;
4627
4628     default:
4629         if (ckWARN_d(WARN_INTERNAL))
4630             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4631         break;
4632     }
4633     return o;
4634 }
4635
4636 OP *
4637 Perl_newAVREF(pTHX_ OP *o)
4638 {
4639     if (o->op_type == OP_PADANY) {
4640         o->op_type = OP_PADAV;
4641         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4642         return o;
4643     }
4644     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4645                 && ckWARN(WARN_DEPRECATED)) {
4646         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4647                 "Using an array as a reference is deprecated");
4648     }
4649     return newUNOP(OP_RV2AV, 0, scalar(o));
4650 }
4651
4652 OP *
4653 Perl_newGVREF(pTHX_ I32 type, OP *o)
4654 {
4655     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4656         return newUNOP(OP_NULL, 0, o);
4657     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4658 }
4659
4660 OP *
4661 Perl_newHVREF(pTHX_ OP *o)
4662 {
4663     if (o->op_type == OP_PADANY) {
4664         o->op_type = OP_PADHV;
4665         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4666         return o;
4667     }
4668     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4669                 && ckWARN(WARN_DEPRECATED)) {
4670         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4671                 "Using a hash as a reference is deprecated");
4672     }
4673     return newUNOP(OP_RV2HV, 0, scalar(o));
4674 }
4675
4676 OP *
4677 Perl_oopsCV(pTHX_ OP *o)
4678 {
4679     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4680     /* STUB */
4681     return o;
4682 }
4683
4684 OP *
4685 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4686 {
4687     return newUNOP(OP_RV2CV, flags, scalar(o));
4688 }
4689
4690 OP *
4691 Perl_newSVREF(pTHX_ OP *o)
4692 {
4693     if (o->op_type == OP_PADANY) {
4694         o->op_type = OP_PADSV;
4695         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4696         return o;
4697     }
4698     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4699         o->op_flags |= OPpDONE_SVREF;
4700         return o;
4701     }
4702     return newUNOP(OP_RV2SV, 0, scalar(o));
4703 }
4704
4705 /* Check routines. */
4706
4707 OP *
4708 Perl_ck_anoncode(pTHX_ OP *o)
4709 {
4710     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4711     cSVOPo->op_sv = Nullsv;
4712     return o;
4713 }
4714
4715 OP *
4716 Perl_ck_bitop(pTHX_ OP *o)
4717 {
4718 #define OP_IS_NUMCOMPARE(op) \
4719         ((op) == OP_LT   || (op) == OP_I_LT || \
4720          (op) == OP_GT   || (op) == OP_I_GT || \
4721          (op) == OP_LE   || (op) == OP_I_LE || \
4722          (op) == OP_GE   || (op) == OP_I_GE || \
4723          (op) == OP_EQ   || (op) == OP_I_EQ || \
4724          (op) == OP_NE   || (op) == OP_I_NE || \
4725          (op) == OP_NCMP || (op) == OP_I_NCMP)
4726     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4727     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4728             && (o->op_type == OP_BIT_OR
4729              || o->op_type == OP_BIT_AND
4730              || o->op_type == OP_BIT_XOR))
4731     {
4732         OP * left = cBINOPo->op_first;
4733         OP * right = left->op_sibling;
4734         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4735                 (left->op_flags & OPf_PARENS) == 0) ||
4736             (OP_IS_NUMCOMPARE(right->op_type) &&
4737                 (right->op_flags & OPf_PARENS) == 0))
4738             if (ckWARN(WARN_PRECEDENCE))
4739                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4740                         "Possible precedence problem on bitwise %c operator",
4741                         o->op_type == OP_BIT_OR ? '|'
4742                             : o->op_type == OP_BIT_AND ? '&' : '^'
4743                         );
4744     }
4745     return o;
4746 }
4747
4748 OP *
4749 Perl_ck_concat(pTHX_ OP *o)
4750 {
4751     OP *kid = cUNOPo->op_first;
4752     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4753             !(kUNOP->op_first->op_flags & OPf_MOD))
4754         o->op_flags |= OPf_STACKED;
4755     return o;
4756 }
4757
4758 OP *
4759 Perl_ck_spair(pTHX_ OP *o)
4760 {
4761     if (o->op_flags & OPf_KIDS) {
4762         OP* newop;
4763         OP* kid;
4764         OPCODE type = o->op_type;
4765         o = modkids(ck_fun(o), type);
4766         kid = cUNOPo->op_first;
4767         newop = kUNOP->op_first->op_sibling;
4768         if (newop &&
4769             (newop->op_sibling ||
4770              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4771              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4772              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4773
4774             return o;
4775         }
4776         op_free(kUNOP->op_first);
4777         kUNOP->op_first = newop;
4778     }
4779     o->op_ppaddr = PL_ppaddr[++o->op_type];
4780     return ck_fun(o);
4781 }
4782
4783 OP *
4784 Perl_ck_delete(pTHX_ OP *o)
4785 {
4786     o = ck_fun(o);
4787     o->op_private = 0;
4788     if (o->op_flags & OPf_KIDS) {
4789         OP *kid = cUNOPo->op_first;
4790         switch (kid->op_type) {
4791         case OP_ASLICE:
4792             o->op_flags |= OPf_SPECIAL;
4793             /* FALL THROUGH */
4794         case OP_HSLICE:
4795             o->op_private |= OPpSLICE;
4796             break;
4797         case OP_AELEM:
4798             o->op_flags |= OPf_SPECIAL;
4799             /* FALL THROUGH */
4800         case OP_HELEM:
4801             break;
4802         default:
4803             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4804                   OP_DESC(o));
4805         }
4806         op_null(kid);
4807     }
4808     return o;
4809 }
4810
4811 OP *
4812 Perl_ck_die(pTHX_ OP *o)
4813 {
4814 #ifdef VMS
4815     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4816 #endif
4817     return ck_fun(o);
4818 }
4819
4820 OP *
4821 Perl_ck_eof(pTHX_ OP *o)
4822 {
4823     I32 type = o->op_type;
4824
4825     if (o->op_flags & OPf_KIDS) {
4826         if (cLISTOPo->op_first->op_type == OP_STUB) {
4827             op_free(o);
4828             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4829         }
4830         return ck_fun(o);
4831     }
4832     return o;
4833 }
4834
4835 OP *
4836 Perl_ck_eval(pTHX_ OP *o)
4837 {
4838     PL_hints |= HINT_BLOCK_SCOPE;
4839     if (o->op_flags & OPf_KIDS) {
4840         SVOP *kid = (SVOP*)cUNOPo->op_first;
4841
4842         if (!kid) {
4843             o->op_flags &= ~OPf_KIDS;
4844             op_null(o);
4845         }
4846         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4847             LOGOP *enter;
4848
4849             cUNOPo->op_first = 0;
4850             op_free(o);
4851
4852             NewOp(1101, enter, 1, LOGOP);
4853             enter->op_type = OP_ENTERTRY;
4854             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4855             enter->op_private = 0;
4856
4857             /* establish postfix order */
4858             enter->op_next = (OP*)enter;
4859
4860             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4861             o->op_type = OP_LEAVETRY;
4862             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4863             enter->op_other = o;
4864             return o;
4865         }
4866         else {
4867             scalar((OP*)kid);
4868             PL_cv_has_eval = 1;
4869         }
4870     }
4871     else {
4872         op_free(o);
4873         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4874     }
4875     o->op_targ = (PADOFFSET)PL_hints;
4876     return o;
4877 }
4878
4879 OP *
4880 Perl_ck_exit(pTHX_ OP *o)
4881 {
4882 #ifdef VMS
4883     HV *table = GvHV(PL_hintgv);
4884     if (table) {
4885        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4886        if (svp && *svp && SvTRUE(*svp))
4887            o->op_private |= OPpEXIT_VMSISH;
4888     }
4889     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4890 #endif
4891     return ck_fun(o);
4892 }
4893
4894 OP *
4895 Perl_ck_exec(pTHX_ OP *o)
4896 {
4897     OP *kid;
4898     if (o->op_flags & OPf_STACKED) {
4899         o = ck_fun(o);
4900         kid = cUNOPo->op_first->op_sibling;
4901         if (kid->op_type == OP_RV2GV)
4902             op_null(kid);
4903     }
4904     else
4905         o = listkids(o);
4906     return o;
4907 }
4908
4909 OP *
4910 Perl_ck_exists(pTHX_ OP *o)
4911 {
4912     o = ck_fun(o);
4913     if (o->op_flags & OPf_KIDS) {
4914         OP *kid = cUNOPo->op_first;
4915         if (kid->op_type == OP_ENTERSUB) {
4916             (void) ref(kid, o->op_type);
4917             if (kid->op_type != OP_RV2CV && !PL_error_count)
4918                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4919                             OP_DESC(o));
4920             o->op_private |= OPpEXISTS_SUB;
4921         }
4922         else if (kid->op_type == OP_AELEM)
4923             o->op_flags |= OPf_SPECIAL;
4924         else if (kid->op_type != OP_HELEM)
4925             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4926                         OP_DESC(o));
4927         op_null(kid);
4928     }
4929     return o;
4930 }
4931
4932 #if 0
4933 OP *
4934 Perl_ck_gvconst(pTHX_ register OP *o)
4935 {
4936     o = fold_constants(o);
4937     if (o->op_type == OP_CONST)
4938         o->op_type = OP_GV;
4939     return o;
4940 }
4941 #endif
4942
4943 OP *
4944 Perl_ck_rvconst(pTHX_ register OP *o)
4945 {
4946     SVOP *kid = (SVOP*)cUNOPo->op_first;
4947
4948     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4949     if (kid->op_type == OP_CONST) {
4950         char *name;
4951         int iscv;
4952         GV *gv;
4953         SV *kidsv = kid->op_sv;
4954         STRLEN n_a;
4955
4956         /* Is it a constant from cv_const_sv()? */
4957         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4958             SV *rsv = SvRV(kidsv);
4959             int svtype = SvTYPE(rsv);
4960             char *badtype = Nullch;
4961
4962             switch (o->op_type) {
4963             case OP_RV2SV:
4964                 if (svtype > SVt_PVMG)
4965                     badtype = "a SCALAR";
4966                 break;
4967             case OP_RV2AV:
4968                 if (svtype != SVt_PVAV)
4969                     badtype = "an ARRAY";
4970                 break;
4971             case OP_RV2HV:
4972                 if (svtype != SVt_PVHV)
4973                     badtype = "a HASH";
4974                 break;
4975             case OP_RV2CV:
4976                 if (svtype != SVt_PVCV)
4977                     badtype = "a CODE";
4978                 break;
4979             }
4980             if (badtype)
4981                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4982             return o;
4983         }
4984         name = SvPV(kidsv, n_a);
4985         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4986             char *badthing = Nullch;
4987             switch (o->op_type) {
4988             case OP_RV2SV:
4989                 badthing = "a SCALAR";
4990                 break;
4991             case OP_RV2AV:
4992                 badthing = "an ARRAY";
4993                 break;
4994             case OP_RV2HV:
4995                 badthing = "a HASH";
4996                 break;
4997             }
4998             if (badthing)
4999                 Perl_croak(aTHX_
5000           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5001                       name, badthing);
5002         }
5003         /*
5004          * This is a little tricky.  We only want to add the symbol if we
5005          * didn't add it in the lexer.  Otherwise we get duplicate strict
5006          * warnings.  But if we didn't add it in the lexer, we must at
5007          * least pretend like we wanted to add it even if it existed before,
5008          * or we get possible typo warnings.  OPpCONST_ENTERED says
5009          * whether the lexer already added THIS instance of this symbol.
5010          */
5011         iscv = (o->op_type == OP_RV2CV) * 2;
5012         do {
5013             gv = gv_fetchpv(name,
5014                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5015                 iscv
5016                     ? SVt_PVCV
5017                     : o->op_type == OP_RV2SV
5018                         ? SVt_PV
5019                         : o->op_type == OP_RV2AV
5020                             ? SVt_PVAV
5021                             : o->op_type == OP_RV2HV
5022                                 ? SVt_PVHV
5023                                 : SVt_PVGV);
5024         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5025         if (gv) {
5026             kid->op_type = OP_GV;
5027             SvREFCNT_dec(kid->op_sv);
5028 #ifdef USE_ITHREADS
5029             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5030             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5031             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5032             GvIN_PAD_on(gv);
5033             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5034 #else
5035             kid->op_sv = SvREFCNT_inc(gv);
5036 #endif
5037             kid->op_private = 0;
5038             kid->op_ppaddr = PL_ppaddr[OP_GV];
5039         }
5040     }
5041     return o;
5042 }
5043
5044 OP *
5045 Perl_ck_ftst(pTHX_ OP *o)
5046 {
5047     I32 type = o->op_type;
5048
5049     if (o->op_flags & OPf_REF) {
5050         /* nothing */
5051     }
5052     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5053         SVOP *kid = (SVOP*)cUNOPo->op_first;
5054
5055         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5056             STRLEN n_a;
5057             OP *newop = newGVOP(type, OPf_REF,
5058                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5059             op_free(o);
5060             o = newop;
5061         }
5062         else {
5063           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5064               OP_IS_FILETEST_ACCESS(o))
5065             o->op_private |= OPpFT_ACCESS;
5066         }
5067         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5068                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5069             o->op_private |= OPpFT_STACKED;
5070     }
5071     else {
5072         op_free(o);
5073         if (type == OP_FTTTY)
5074             o = newGVOP(type, OPf_REF, PL_stdingv);
5075         else
5076             o = newUNOP(type, 0, newDEFSVOP());
5077     }
5078     return o;
5079 }
5080
5081 OP *
5082 Perl_ck_fun(pTHX_ OP *o)
5083 {
5084     register OP *kid;
5085     OP **tokid;
5086     OP *sibl;
5087     I32 numargs = 0;
5088     int type = o->op_type;
5089     register I32 oa = PL_opargs[type] >> OASHIFT;
5090
5091     if (o->op_flags & OPf_STACKED) {
5092         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5093             oa &= ~OA_OPTIONAL;
5094         else
5095             return no_fh_allowed(o);
5096     }
5097
5098     if (o->op_flags & OPf_KIDS) {
5099         STRLEN n_a;
5100         tokid = &cLISTOPo->op_first;
5101         kid = cLISTOPo->op_first;
5102         if (kid->op_type == OP_PUSHMARK ||
5103             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5104         {
5105             tokid = &kid->op_sibling;
5106             kid = kid->op_sibling;
5107         }
5108         if (!kid && PL_opargs[type] & OA_DEFGV)
5109             *tokid = kid = newDEFSVOP();
5110
5111         while (oa && kid) {
5112             numargs++;
5113             sibl = kid->op_sibling;
5114             switch (oa & 7) {
5115             case OA_SCALAR:
5116                 /* list seen where single (scalar) arg expected? */
5117                 if (numargs == 1 && !(oa >> 4)
5118                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5119                 {
5120                     return too_many_arguments(o,PL_op_desc[type]);
5121                 }
5122                 scalar(kid);
5123                 break;
5124             case OA_LIST:
5125                 if (oa < 16) {
5126                     kid = 0;
5127                     continue;
5128                 }
5129                 else
5130                     list(kid);
5131                 break;
5132             case OA_AVREF:
5133                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5134                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5135                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5136                         "Useless use of %s with no values",
5137                         PL_op_desc[type]);
5138
5139                 if (kid->op_type == OP_CONST &&
5140                     (kid->op_private & OPpCONST_BARE))
5141                 {
5142                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5143                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5144                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5145                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5146                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5147                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5148                             name, (IV)numargs, PL_op_desc[type]);
5149                     op_free(kid);
5150                     kid = newop;
5151                     kid->op_sibling = sibl;
5152                     *tokid = kid;
5153                 }
5154                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5155                     bad_type(numargs, "array", PL_op_desc[type], kid);
5156                 mod(kid, type);
5157                 break;
5158             case OA_HVREF:
5159                 if (kid->op_type == OP_CONST &&
5160                     (kid->op_private & OPpCONST_BARE))
5161                 {
5162                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5163                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5164                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5165                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5166                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5167                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5168                             name, (IV)numargs, PL_op_desc[type]);
5169                     op_free(kid);
5170                     kid = newop;
5171                     kid->op_sibling = sibl;
5172                     *tokid = kid;
5173                 }
5174                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5175                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5176                 mod(kid, type);
5177                 break;
5178             case OA_CVREF:
5179                 {
5180                     OP *newop = newUNOP(OP_NULL, 0, kid);
5181                     kid->op_sibling = 0;
5182                     linklist(kid);
5183                     newop->op_next = newop;
5184                     kid = newop;
5185                     kid->op_sibling = sibl;
5186                     *tokid = kid;
5187                 }
5188                 break;
5189             case OA_FILEREF:
5190                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5191                     if (kid->op_type == OP_CONST &&
5192                         (kid->op_private & OPpCONST_BARE))
5193                     {
5194                         OP *newop = newGVOP(OP_GV, 0,
5195                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5196                                         SVt_PVIO) );
5197                         if (!(o->op_private & 1) && /* if not unop */
5198                             kid == cLISTOPo->op_last)
5199                             cLISTOPo->op_last = newop;
5200                         op_free(kid);
5201                         kid = newop;
5202                     }
5203                     else if (kid->op_type == OP_READLINE) {
5204                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5205                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5206                     }
5207                     else {
5208                         I32 flags = OPf_SPECIAL;
5209                         I32 priv = 0;
5210                         PADOFFSET targ = 0;
5211
5212                         /* is this op a FH constructor? */
5213                         if (is_handle_constructor(o,numargs)) {
5214                             char *name = Nullch;
5215                             STRLEN len = 0;
5216
5217                             flags = 0;
5218                             /* Set a flag to tell rv2gv to vivify
5219                              * need to "prove" flag does not mean something
5220                              * else already - NI-S 1999/05/07
5221                              */
5222                             priv = OPpDEREF;
5223                             if (kid->op_type == OP_PADSV) {
5224                                 name = PAD_COMPNAME_PV(kid->op_targ);
5225                                 /* SvCUR of a pad namesv can't be trusted
5226                                  * (see PL_generation), so calc its length
5227                                  * manually */
5228                                 if (name)
5229                                     len = strlen(name);
5230
5231                             }
5232                             else if (kid->op_type == OP_RV2SV
5233                                      && kUNOP->op_first->op_type == OP_GV)
5234                             {
5235                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5236                                 name = GvNAME(gv);
5237                                 len = GvNAMELEN(gv);
5238                             }
5239                             else if (kid->op_type == OP_AELEM
5240                                      || kid->op_type == OP_HELEM)
5241                             {
5242                                  OP *op;
5243
5244                                  name = 0;
5245                                  if ((op = ((BINOP*)kid)->op_first)) {
5246                                       SV *tmpstr = Nullsv;
5247                                       char *a =
5248                                            kid->op_type == OP_AELEM ?
5249                                            "[]" : "{}";
5250                                       if (((op->op_type == OP_RV2AV) ||
5251                                            (op->op_type == OP_RV2HV)) &&
5252                                           (op = ((UNOP*)op)->op_first) &&
5253                                           (op->op_type == OP_GV)) {
5254                                            /* packagevar $a[] or $h{} */
5255                                            GV *gv = cGVOPx_gv(op);
5256                                            if (gv)
5257                                                 tmpstr =
5258                                                      Perl_newSVpvf(aTHX_
5259                                                                    "%s%c...%c",
5260                                                                    GvNAME(gv),
5261                                                                    a[0], a[1]);
5262                                       }
5263                                       else if (op->op_type == OP_PADAV
5264                                                || op->op_type == OP_PADHV) {
5265                                            /* lexicalvar $a[] or $h{} */
5266                                            char *padname =
5267                                                 PAD_COMPNAME_PV(op->op_targ);
5268                                            if (padname)
5269                                                 tmpstr =
5270                                                      Perl_newSVpvf(aTHX_
5271                                                                    "%s%c...%c",
5272                                                                    padname + 1,
5273                                                                    a[0], a[1]);
5274
5275                                       }
5276                                       if (tmpstr) {
5277                                            name = SvPV(tmpstr, len);
5278                                            sv_2mortal(tmpstr);
5279                                       }
5280                                  }
5281                                  if (!name) {
5282                                       name = "__ANONIO__";
5283                                       len = 10;
5284                                  }
5285                                  mod(kid, type);
5286                             }
5287                             if (name) {
5288                                 SV *namesv;
5289                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5290                                 namesv = PAD_SVl(targ);
5291                                 (void)SvUPGRADE(namesv, SVt_PV);
5292                                 if (*name != '$')
5293                                     sv_setpvn(namesv, "$", 1);
5294                                 sv_catpvn(namesv, name, len);
5295                             }
5296                         }
5297                         kid->op_sibling = 0;
5298                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5299                         kid->op_targ = targ;
5300                         kid->op_private |= priv;
5301                     }
5302                     kid->op_sibling = sibl;
5303                     *tokid = kid;
5304                 }
5305                 scalar(kid);
5306                 break;
5307             case OA_SCALARREF:
5308                 mod(scalar(kid), type);
5309                 break;
5310             }
5311             oa >>= 4;
5312             tokid = &kid->op_sibling;
5313             kid = kid->op_sibling;
5314         }
5315         o->op_private |= numargs;
5316         if (kid)
5317             return too_many_arguments(o,OP_DESC(o));
5318         listkids(o);
5319     }
5320     else if (PL_opargs[type] & OA_DEFGV) {
5321         op_free(o);
5322         return newUNOP(type, 0, newDEFSVOP());
5323     }
5324
5325     if (oa) {
5326         while (oa & OA_OPTIONAL)
5327             oa >>= 4;
5328         if (oa && oa != OA_LIST)
5329             return too_few_arguments(o,OP_DESC(o));
5330     }
5331     return o;
5332 }
5333
5334 OP *
5335 Perl_ck_glob(pTHX_ OP *o)
5336 {
5337     GV *gv;
5338
5339     o = ck_fun(o);
5340     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5341         append_elem(OP_GLOB, o, newDEFSVOP());
5342
5343     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5344           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5345     {
5346         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5347     }
5348
5349 #if !defined(PERL_EXTERNAL_GLOB)
5350     /* XXX this can be tightened up and made more failsafe. */
5351     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5352         GV *glob_gv;
5353         ENTER;
5354         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5355                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5356         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5357         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5358         GvCV(gv) = GvCV(glob_gv);
5359         SvREFCNT_inc((SV*)GvCV(gv));
5360         GvIMPORTED_CV_on(gv);
5361         LEAVE;
5362     }
5363 #endif /* PERL_EXTERNAL_GLOB */
5364
5365     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5366         append_elem(OP_GLOB, o,
5367                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5368         o->op_type = OP_LIST;
5369         o->op_ppaddr = PL_ppaddr[OP_LIST];
5370         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5371         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5372         cLISTOPo->op_first->op_targ = 0;
5373         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5374                     append_elem(OP_LIST, o,
5375                                 scalar(newUNOP(OP_RV2CV, 0,
5376                                                newGVOP(OP_GV, 0, gv)))));
5377         o = newUNOP(OP_NULL, 0, ck_subr(o));
5378         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5379         return o;
5380     }
5381     gv = newGVgen("main");
5382     gv_IOadd(gv);
5383     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5384     scalarkids(o);
5385     return o;
5386 }
5387
5388 OP *
5389 Perl_ck_grep(pTHX_ OP *o)
5390 {
5391     LOGOP *gwop;
5392     OP *kid;
5393     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5394     I32 offset;
5395
5396     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5397     NewOp(1101, gwop, 1, LOGOP);
5398
5399     if (o->op_flags & OPf_STACKED) {
5400         OP* k;
5401         o = ck_sort(o);
5402         kid = cLISTOPo->op_first->op_sibling;
5403         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5404             kid = k;
5405         }
5406         kid->op_next = (OP*)gwop;
5407         o->op_flags &= ~OPf_STACKED;
5408     }
5409     kid = cLISTOPo->op_first->op_sibling;
5410     if (type == OP_MAPWHILE)
5411         list(kid);
5412     else
5413         scalar(kid);
5414     o = ck_fun(o);
5415     if (PL_error_count)
5416         return o;
5417     kid = cLISTOPo->op_first->op_sibling;
5418     if (kid->op_type != OP_NULL)
5419         Perl_croak(aTHX_ "panic: ck_grep");
5420     kid = kUNOP->op_first;
5421
5422     gwop->op_type = type;
5423     gwop->op_ppaddr = PL_ppaddr[type];
5424     gwop->op_first = listkids(o);
5425     gwop->op_flags |= OPf_KIDS;
5426     gwop->op_other = LINKLIST(kid);
5427     kid->op_next = (OP*)gwop;
5428     offset = pad_findmy("$_");
5429     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5430         o->op_private = gwop->op_private = 0;
5431         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5432     }
5433     else {
5434         o->op_private = gwop->op_private = OPpGREP_LEX;
5435         gwop->op_targ = o->op_targ = offset;
5436     }
5437
5438     kid = cLISTOPo->op_first->op_sibling;
5439     if (!kid || !kid->op_sibling)
5440         return too_few_arguments(o,OP_DESC(o));
5441     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5442         mod(kid, OP_GREPSTART);
5443
5444     return (OP*)gwop;
5445 }
5446
5447 OP *
5448 Perl_ck_index(pTHX_ OP *o)
5449 {
5450     if (o->op_flags & OPf_KIDS) {
5451         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5452         if (kid)
5453             kid = kid->op_sibling;                      /* get past "big" */
5454         if (kid && kid->op_type == OP_CONST)
5455             fbm_compile(((SVOP*)kid)->op_sv, 0);
5456     }
5457     return ck_fun(o);
5458 }
5459
5460 OP *
5461 Perl_ck_lengthconst(pTHX_ OP *o)
5462 {
5463     /* XXX length optimization goes here */
5464     return ck_fun(o);
5465 }
5466
5467 OP *
5468 Perl_ck_lfun(pTHX_ OP *o)
5469 {
5470     OPCODE type = o->op_type;
5471     return modkids(ck_fun(o), type);
5472 }
5473
5474 OP *
5475 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5476 {
5477     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5478         switch (cUNOPo->op_first->op_type) {
5479         case OP_RV2AV:
5480             /* This is needed for
5481                if (defined %stash::)
5482                to work.   Do not break Tk.
5483                */
5484             break;                      /* Globals via GV can be undef */
5485         case OP_PADAV:
5486         case OP_AASSIGN:                /* Is this a good idea? */
5487             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5488                         "defined(@array) is deprecated");
5489             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5490                         "\t(Maybe you should just omit the defined()?)\n");
5491         break;
5492         case OP_RV2HV:
5493             /* This is needed for
5494                if (defined %stash::)
5495                to work.   Do not break Tk.
5496                */
5497             break;                      /* Globals via GV can be undef */
5498         case OP_PADHV:
5499             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5500                         "defined(%%hash) is deprecated");
5501             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5502                         "\t(Maybe you should just omit the defined()?)\n");
5503             break;
5504         default:
5505             /* no warning */
5506             break;
5507         }
5508     }
5509     return ck_rfun(o);
5510 }
5511
5512 OP *
5513 Perl_ck_rfun(pTHX_ OP *o)
5514 {
5515     OPCODE type = o->op_type;
5516     return refkids(ck_fun(o), type);
5517 }
5518
5519 OP *
5520 Perl_ck_listiob(pTHX_ OP *o)
5521 {
5522     register OP *kid;
5523
5524     kid = cLISTOPo->op_first;
5525     if (!kid) {
5526         o = force_list(o);
5527         kid = cLISTOPo->op_first;
5528     }
5529     if (kid->op_type == OP_PUSHMARK)
5530         kid = kid->op_sibling;
5531     if (kid && o->op_flags & OPf_STACKED)
5532         kid = kid->op_sibling;
5533     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5534         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5535             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5536             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5537             cLISTOPo->op_first->op_sibling = kid;
5538             cLISTOPo->op_last = kid;
5539             kid = kid->op_sibling;
5540         }
5541     }
5542
5543     if (!kid)
5544         append_elem(o->op_type, o, newDEFSVOP());
5545
5546     return listkids(o);
5547 }
5548
5549 OP *
5550 Perl_ck_sassign(pTHX_ OP *o)
5551 {
5552     OP *kid = cLISTOPo->op_first;
5553     /* has a disposable target? */
5554     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5555         && !(kid->op_flags & OPf_STACKED)
5556         /* Cannot steal the second time! */
5557         && !(kid->op_private & OPpTARGET_MY))
5558     {
5559         OP *kkid = kid->op_sibling;
5560
5561         /* Can just relocate the target. */
5562         if (kkid && kkid->op_type == OP_PADSV
5563             && !(kkid->op_private & OPpLVAL_INTRO))
5564         {
5565             kid->op_targ = kkid->op_targ;
5566             kkid->op_targ = 0;
5567             /* Now we do not need PADSV and SASSIGN. */
5568             kid->op_sibling = o->op_sibling;    /* NULL */
5569             cLISTOPo->op_first = NULL;
5570             op_free(o);
5571             op_free(kkid);
5572             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5573             return kid;
5574         }
5575     }
5576     return o;
5577 }
5578
5579 OP *
5580 Perl_ck_match(pTHX_ OP *o)
5581 {
5582     if (o->op_type != OP_QR) {
5583         I32 offset = pad_findmy("$_");
5584         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5585             o->op_targ = offset;
5586             o->op_private |= OPpTARGET_MY;
5587         }
5588     }
5589     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5590         o->op_private |= OPpRUNTIME;
5591     return o;
5592 }
5593
5594 OP *
5595 Perl_ck_method(pTHX_ OP *o)
5596 {
5597     OP *kid = cUNOPo->op_first;
5598     if (kid->op_type == OP_CONST) {
5599         SV* sv = kSVOP->op_sv;
5600         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5601             OP *cmop;
5602             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5603                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5604             }
5605             else {
5606                 kSVOP->op_sv = Nullsv;
5607             }
5608             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5609             op_free(o);
5610             return cmop;
5611         }
5612     }
5613     return o;
5614 }
5615
5616 OP *
5617 Perl_ck_null(pTHX_ OP *o)
5618 {
5619     return o;
5620 }
5621
5622 OP *
5623 Perl_ck_open(pTHX_ OP *o)
5624 {
5625     HV *table = GvHV(PL_hintgv);
5626     if (table) {
5627         SV **svp;
5628         I32 mode;
5629         svp = hv_fetch(table, "open_IN", 7, FALSE);
5630         if (svp && *svp) {
5631             mode = mode_from_discipline(*svp);
5632             if (mode & O_BINARY)
5633                 o->op_private |= OPpOPEN_IN_RAW;
5634             else if (mode & O_TEXT)
5635                 o->op_private |= OPpOPEN_IN_CRLF;
5636         }
5637
5638         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5639         if (svp && *svp) {
5640             mode = mode_from_discipline(*svp);
5641             if (mode & O_BINARY)
5642                 o->op_private |= OPpOPEN_OUT_RAW;
5643             else if (mode & O_TEXT)
5644                 o->op_private |= OPpOPEN_OUT_CRLF;
5645         }
5646     }
5647     if (o->op_type == OP_BACKTICK)
5648         return o;
5649     {
5650          /* In case of three-arg dup open remove strictness
5651           * from the last arg if it is a bareword. */
5652          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5653          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5654          OP *oa;
5655          char *mode;
5656
5657          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5658              (last->op_private & OPpCONST_BARE) &&
5659              (last->op_private & OPpCONST_STRICT) &&
5660              (oa = first->op_sibling) &&                /* The fh. */
5661              (oa = oa->op_sibling) &&                   /* The mode. */
5662              SvPOK(((SVOP*)oa)->op_sv) &&
5663              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5664              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5665              (last == oa->op_sibling))                  /* The bareword. */
5666               last->op_private &= ~OPpCONST_STRICT;
5667     }
5668     return ck_fun(o);
5669 }
5670
5671 OP *
5672 Perl_ck_repeat(pTHX_ OP *o)
5673 {
5674     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5675         o->op_private |= OPpREPEAT_DOLIST;
5676         cBINOPo->op_first = force_list(cBINOPo->op_first);
5677     }
5678     else
5679         scalar(o);
5680     return o;
5681 }
5682
5683 OP *
5684 Perl_ck_require(pTHX_ OP *o)
5685 {
5686     GV* gv;
5687
5688     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5689         SVOP *kid = (SVOP*)cUNOPo->op_first;
5690
5691         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5692             char *s;
5693             for (s = SvPVX(kid->op_sv); *s; s++) {
5694                 if (*s == ':' && s[1] == ':') {
5695                     *s = '/';
5696                     Move(s+2, s+1, strlen(s+2)+1, char);
5697                     --SvCUR(kid->op_sv);
5698                 }
5699             }
5700             if (SvREADONLY(kid->op_sv)) {
5701                 SvREADONLY_off(kid->op_sv);
5702                 sv_catpvn(kid->op_sv, ".pm", 3);
5703                 SvREADONLY_on(kid->op_sv);
5704             }
5705             else
5706                 sv_catpvn(kid->op_sv, ".pm", 3);
5707         }
5708     }
5709
5710     /* handle override, if any */
5711     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5712     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5713         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5714
5715     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5716         OP *kid = cUNOPo->op_first;
5717         cUNOPo->op_first = 0;
5718         op_free(o);
5719         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5720                                append_elem(OP_LIST, kid,
5721                                            scalar(newUNOP(OP_RV2CV, 0,
5722                                                           newGVOP(OP_GV, 0,
5723                                                                   gv))))));
5724     }
5725
5726     return ck_fun(o);
5727 }
5728
5729 OP *
5730 Perl_ck_return(pTHX_ OP *o)
5731 {
5732     OP *kid;
5733     if (CvLVALUE(PL_compcv)) {
5734         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5735             mod(kid, OP_LEAVESUBLV);
5736     }
5737     return o;
5738 }
5739
5740 #if 0
5741 OP *
5742 Perl_ck_retarget(pTHX_ OP *o)
5743 {
5744     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5745     /* STUB */
5746     return o;
5747 }
5748 #endif
5749
5750 OP *
5751 Perl_ck_select(pTHX_ OP *o)
5752 {
5753     OP* kid;
5754     if (o->op_flags & OPf_KIDS) {
5755         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5756         if (kid && kid->op_sibling) {
5757             o->op_type = OP_SSELECT;
5758             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5759             o = ck_fun(o);
5760             return fold_constants(o);
5761         }
5762     }
5763     o = ck_fun(o);
5764     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5765     if (kid && kid->op_type == OP_RV2GV)
5766         kid->op_private &= ~HINT_STRICT_REFS;
5767     return o;
5768 }
5769
5770 OP *
5771 Perl_ck_shift(pTHX_ OP *o)
5772 {
5773     I32 type = o->op_type;
5774
5775     if (!(o->op_flags & OPf_KIDS)) {
5776         OP *argop;
5777
5778         op_free(o);
5779         argop = newUNOP(OP_RV2AV, 0,
5780             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5781         return newUNOP(type, 0, scalar(argop));
5782     }
5783     return scalar(modkids(ck_fun(o), type));
5784 }
5785
5786 OP *
5787 Perl_ck_sort(pTHX_ OP *o)
5788 {
5789     OP *firstkid;
5790
5791     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5792         simplify_sort(o);
5793     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5794     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5795         OP *k = NULL;
5796         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5797
5798         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5799             linklist(kid);
5800             if (kid->op_type == OP_SCOPE) {
5801                 k = kid->op_next;
5802                 kid->op_next = 0;
5803             }
5804             else if (kid->op_type == OP_LEAVE) {
5805                 if (o->op_type == OP_SORT) {
5806                     op_null(kid);                       /* wipe out leave */
5807                     kid->op_next = kid;
5808
5809                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5810                         if (k->op_next == kid)
5811                             k->op_next = 0;
5812                         /* don't descend into loops */
5813                         else if (k->op_type == OP_ENTERLOOP
5814                                  || k->op_type == OP_ENTERITER)
5815                         {
5816                             k = cLOOPx(k)->op_lastop;
5817                         }
5818                     }
5819                 }
5820                 else
5821                     kid->op_next = 0;           /* just disconnect the leave */
5822                 k = kLISTOP->op_first;
5823             }
5824             CALL_PEEP(k);
5825
5826             kid = firstkid;
5827             if (o->op_type == OP_SORT) {
5828                 /* provide scalar context for comparison function/block */
5829                 kid = scalar(kid);
5830                 kid->op_next = kid;
5831             }
5832             else
5833                 kid->op_next = k;
5834             o->op_flags |= OPf_SPECIAL;
5835         }
5836         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5837             op_null(firstkid);
5838
5839         firstkid = firstkid->op_sibling;
5840     }
5841
5842     /* provide list context for arguments */
5843     if (o->op_type == OP_SORT)
5844         list(firstkid);
5845
5846     return o;
5847 }
5848
5849 STATIC void
5850 S_simplify_sort(pTHX_ OP *o)
5851 {
5852     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5853     OP *k;
5854     int reversed;
5855     GV *gv;
5856     if (!(o->op_flags & OPf_STACKED))
5857         return;
5858     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5859     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5860     kid = kUNOP->op_first;                              /* get past null */
5861     if (kid->op_type != OP_SCOPE)
5862         return;
5863     kid = kLISTOP->op_last;                             /* get past scope */
5864     switch(kid->op_type) {
5865         case OP_NCMP:
5866         case OP_I_NCMP:
5867         case OP_SCMP:
5868             break;
5869         default:
5870             return;
5871     }
5872     k = kid;                                            /* remember this node*/
5873     if (kBINOP->op_first->op_type != OP_RV2SV)
5874         return;
5875     kid = kBINOP->op_first;                             /* get past cmp */
5876     if (kUNOP->op_first->op_type != OP_GV)
5877         return;
5878     kid = kUNOP->op_first;                              /* get past rv2sv */
5879     gv = kGVOP_gv;
5880     if (GvSTASH(gv) != PL_curstash)
5881         return;
5882     if (strEQ(GvNAME(gv), "a"))
5883         reversed = 0;
5884     else if (strEQ(GvNAME(gv), "b"))
5885         reversed = 1;
5886     else
5887         return;
5888     kid = k;                                            /* back to cmp */
5889     if (kBINOP->op_last->op_type != OP_RV2SV)
5890         return;
5891     kid = kBINOP->op_last;                              /* down to 2nd arg */
5892     if (kUNOP->op_first->op_type != OP_GV)
5893         return;
5894     kid = kUNOP->op_first;                              /* get past rv2sv */
5895     gv = kGVOP_gv;
5896     if (GvSTASH(gv) != PL_curstash
5897         || ( reversed
5898             ? strNE(GvNAME(gv), "a")
5899             : strNE(GvNAME(gv), "b")))
5900         return;
5901     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5902     if (reversed)
5903         o->op_private |= OPpSORT_REVERSE;
5904     if (k->op_type == OP_NCMP)
5905         o->op_private |= OPpSORT_NUMERIC;
5906     if (k->op_type == OP_I_NCMP)
5907         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5908     kid = cLISTOPo->op_first->op_sibling;
5909     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5910     op_free(kid);                                     /* then delete it */
5911 }
5912
5913 OP *
5914 Perl_ck_split(pTHX_ OP *o)
5915 {
5916     register OP *kid;
5917
5918     if (o->op_flags & OPf_STACKED)
5919         return no_fh_allowed(o);
5920
5921     kid = cLISTOPo->op_first;
5922     if (kid->op_type != OP_NULL)
5923         Perl_croak(aTHX_ "panic: ck_split");
5924     kid = kid->op_sibling;
5925     op_free(cLISTOPo->op_first);
5926     cLISTOPo->op_first = kid;
5927     if (!kid) {
5928         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5929         cLISTOPo->op_last = kid; /* There was only one element previously */
5930     }
5931
5932     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5933         OP *sibl = kid->op_sibling;
5934         kid->op_sibling = 0;
5935         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5936         if (cLISTOPo->op_first == cLISTOPo->op_last)
5937             cLISTOPo->op_last = kid;
5938         cLISTOPo->op_first = kid;
5939         kid->op_sibling = sibl;
5940     }
5941
5942     kid->op_type = OP_PUSHRE;
5943     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5944     scalar(kid);
5945     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5946       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5947                   "Use of /g modifier is meaningless in split");
5948     }
5949
5950     if (!kid->op_sibling)
5951         append_elem(OP_SPLIT, o, newDEFSVOP());
5952
5953     kid = kid->op_sibling;
5954     scalar(kid);
5955
5956     if (!kid->op_sibling)
5957         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5958
5959     kid = kid->op_sibling;
5960     scalar(kid);
5961
5962     if (kid->op_sibling)
5963         return too_many_arguments(o,OP_DESC(o));
5964
5965     return o;
5966 }
5967
5968 OP *
5969 Perl_ck_join(pTHX_ OP *o)
5970 {
5971     if (ckWARN(WARN_SYNTAX)) {
5972         OP *kid = cLISTOPo->op_first->op_sibling;
5973         if (kid && kid->op_type == OP_MATCH) {
5974             char *pmstr = "STRING";
5975             if (PM_GETRE(kPMOP))
5976                 pmstr = PM_GETRE(kPMOP)->precomp;
5977             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5978                         "/%s/ should probably be written as \"%s\"",
5979                         pmstr, pmstr);
5980         }
5981     }
5982     return ck_fun(o);
5983 }
5984
5985 OP *
5986 Perl_ck_subr(pTHX_ OP *o)
5987 {
5988     OP *prev = ((cUNOPo->op_first->op_sibling)
5989              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5990     OP *o2 = prev->op_sibling;
5991     OP *cvop;
5992     char *proto = 0;
5993     CV *cv = 0;
5994     GV *namegv = 0;
5995     int optional = 0;
5996     I32 arg = 0;
5997     I32 contextclass = 0;
5998     char *e = 0;
5999     STRLEN n_a;
6000     bool delete=0;
6001
6002     o->op_private |= OPpENTERSUB_HASTARG;
6003     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6004     if (cvop->op_type == OP_RV2CV) {
6005         SVOP* tmpop;
6006         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6007         op_null(cvop);          /* disable rv2cv */
6008         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6009         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6010             GV *gv = cGVOPx_gv(tmpop);
6011             cv = GvCVu(gv);
6012             if (!cv)
6013                 tmpop->op_private |= OPpEARLY_CV;
6014             else {
6015                 if (SvPOK(cv)) {
6016                     namegv = CvANON(cv) ? gv : CvGV(cv);
6017                     proto = SvPV((SV*)cv, n_a);
6018                 }
6019                 if (CvASSERTION(cv)) {
6020                     if (PL_hints & HINT_ASSERTING) {
6021                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6022                             o->op_private |= OPpENTERSUB_DB;
6023                     }
6024                     else {
6025                         delete=1;
6026                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6027                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6028                                         "Impossible to activate assertion call");
6029                         }
6030                     }
6031                 }
6032             }
6033         }
6034     }
6035     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6036         if (o2->op_type == OP_CONST)
6037             o2->op_private &= ~OPpCONST_STRICT;
6038         else if (o2->op_type == OP_LIST) {
6039             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6040             if (o && o->op_type == OP_CONST)
6041                 o->op_private &= ~OPpCONST_STRICT;
6042         }
6043     }
6044     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6045     if (PERLDB_SUB && PL_curstash != PL_debstash)
6046         o->op_private |= OPpENTERSUB_DB;
6047     while (o2 != cvop) {
6048         if (proto) {
6049             switch (*proto) {
6050             case '\0':
6051                 return too_many_arguments(o, gv_ename(namegv));
6052             case ';':
6053                 optional = 1;
6054                 proto++;
6055                 continue;
6056             case '$':
6057                 proto++;
6058                 arg++;
6059                 scalar(o2);
6060                 break;
6061             case '%':
6062             case '@':
6063                 list(o2);
6064                 arg++;
6065                 break;
6066             case '&':
6067                 proto++;
6068                 arg++;
6069                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6070                     bad_type(arg,
6071                         arg == 1 ? "block or sub {}" : "sub {}",
6072                         gv_ename(namegv), o2);
6073                 break;
6074             case '*':
6075                 /* '*' allows any scalar type, including bareword */
6076                 proto++;
6077                 arg++;
6078                 if (o2->op_type == OP_RV2GV)
6079                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6080                 else if (o2->op_type == OP_CONST)
6081                     o2->op_private &= ~OPpCONST_STRICT;
6082                 else if (o2->op_type == OP_ENTERSUB) {
6083                     /* accidental subroutine, revert to bareword */
6084                     OP *gvop = ((UNOP*)o2)->op_first;
6085                     if (gvop && gvop->op_type == OP_NULL) {
6086                         gvop = ((UNOP*)gvop)->op_first;
6087                         if (gvop) {
6088                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6089                                 ;
6090                             if (gvop &&
6091                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6092                                 (gvop = ((UNOP*)gvop)->op_first) &&
6093                                 gvop->op_type == OP_GV)
6094                             {
6095                                 GV *gv = cGVOPx_gv(gvop);
6096                                 OP *sibling = o2->op_sibling;
6097                                 SV *n = newSVpvn("",0);
6098                                 op_free(o2);
6099                                 gv_fullname3(n, gv, "");
6100                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6101                                     sv_chop(n, SvPVX(n)+6);
6102                                 o2 = newSVOP(OP_CONST, 0, n);
6103                                 prev->op_sibling = o2;
6104                                 o2->op_sibling = sibling;
6105                             }
6106                         }
6107                     }
6108                 }
6109                 scalar(o2);
6110                 break;
6111             case '[': case ']':
6112                  goto oops;
6113                  break;
6114             case '\\':
6115                 proto++;
6116                 arg++;
6117             again:
6118                 switch (*proto++) {
6119                 case '[':
6120                      if (contextclass++ == 0) {
6121                           e = strchr(proto, ']');
6122                           if (!e || e == proto)
6123                                goto oops;
6124                      }
6125                      else
6126                           goto oops;
6127                      goto again;
6128                      break;
6129                 case ']':
6130                      if (contextclass) {
6131                          char *p = proto;
6132                          char s = *p;
6133                          contextclass = 0;
6134                          *p = '\0';
6135                          while (*--p != '[');
6136                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6137                                  gv_ename(namegv), o2);
6138                          *proto = s;
6139                      } else
6140                           goto oops;
6141                      break;
6142                 case '*':
6143                      if (o2->op_type == OP_RV2GV)
6144                           goto wrapref;
6145                      if (!contextclass)
6146                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6147                      break;
6148                 case '&':
6149                      if (o2->op_type == OP_ENTERSUB)
6150                           goto wrapref;
6151                      if (!contextclass)
6152                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6153                      break;
6154                 case '$':
6155                     if (o2->op_type == OP_RV2SV ||
6156                         o2->op_type == OP_PADSV ||
6157                         o2->op_type == OP_HELEM ||
6158                         o2->op_type == OP_AELEM ||
6159                         o2->op_type == OP_THREADSV)
6160                          goto wrapref;
6161                     if (!contextclass)
6162                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6163                      break;
6164                 case '@':
6165                     if (o2->op_type == OP_RV2AV ||
6166                         o2->op_type == OP_PADAV)
6167                          goto wrapref;
6168                     if (!contextclass)
6169                         bad_type(arg, "array", gv_ename(namegv), o2);
6170                     break;
6171                 case '%':
6172                     if (o2->op_type == OP_RV2HV ||
6173                         o2->op_type == OP_PADHV)
6174                          goto wrapref;
6175                     if (!contextclass)
6176                          bad_type(arg, "hash", gv_ename(namegv), o2);
6177                     break;
6178                 wrapref:
6179                     {
6180                         OP* kid = o2;
6181                         OP* sib = kid->op_sibling;
6182                         kid->op_sibling = 0;
6183                         o2 = newUNOP(OP_REFGEN, 0, kid);
6184                         o2->op_sibling = sib;
6185                         prev->op_sibling = o2;
6186                     }
6187                     if (contextclass && e) {
6188                          proto = e + 1;
6189                          contextclass = 0;
6190                     }
6191                     break;
6192                 default: goto oops;
6193                 }
6194                 if (contextclass)
6195                      goto again;
6196                 break;
6197             case ' ':
6198                 proto++;
6199                 continue;
6200             default:
6201               oops:
6202                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6203                            gv_ename(namegv), cv);
6204             }
6205         }
6206         else
6207             list(o2);
6208         mod(o2, OP_ENTERSUB);
6209         prev = o2;
6210         o2 = o2->op_sibling;
6211     }
6212     if (proto && !optional &&
6213           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6214         return too_few_arguments(o, gv_ename(namegv));
6215     if(delete) {
6216         op_free(o);
6217         o=newSVOP(OP_CONST, 0, newSViv(0));
6218     }
6219     return o;
6220 }
6221
6222 OP *
6223 Perl_ck_svconst(pTHX_ OP *o)
6224 {
6225     SvREADONLY_on(cSVOPo->op_sv);
6226     return o;
6227 }
6228
6229 OP *
6230 Perl_ck_trunc(pTHX_ OP *o)
6231 {
6232     if (o->op_flags & OPf_KIDS) {
6233         SVOP *kid = (SVOP*)cUNOPo->op_first;
6234
6235         if (kid->op_type == OP_NULL)
6236             kid = (SVOP*)kid->op_sibling;
6237         if (kid && kid->op_type == OP_CONST &&
6238             (kid->op_private & OPpCONST_BARE))
6239         {
6240             o->op_flags |= OPf_SPECIAL;
6241             kid->op_private &= ~OPpCONST_STRICT;
6242         }
6243     }
6244     return ck_fun(o);
6245 }
6246
6247 OP *
6248 Perl_ck_unpack(pTHX_ OP *o)
6249 {
6250     OP *kid = cLISTOPo->op_first;
6251     if (kid->op_sibling) {
6252         kid = kid->op_sibling;
6253         if (!kid->op_sibling)
6254             kid->op_sibling = newDEFSVOP();
6255     }
6256     return ck_fun(o);
6257 }
6258
6259 OP *
6260 Perl_ck_substr(pTHX_ OP *o)
6261 {
6262     o = ck_fun(o);
6263     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6264         OP *kid = cLISTOPo->op_first;
6265
6266         if (kid->op_type == OP_NULL)
6267             kid = kid->op_sibling;
6268         if (kid)
6269             kid->op_flags |= OPf_MOD;
6270
6271     }
6272     return o;
6273 }
6274
6275 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6276
6277 void
6278 Perl_peep(pTHX_ register OP *o)
6279 {
6280     register OP* oldop = 0;
6281
6282     if (!o || o->op_seq)
6283         return;
6284     ENTER;
6285     SAVEOP();
6286     SAVEVPTR(PL_curcop);
6287     for (; o; o = o->op_next) {
6288         if (o->op_seq)
6289             break;
6290         /* The special value -1 is used by the B::C compiler backend to indicate
6291          * that an op is statically defined and should not be freed */
6292         if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6293             PL_op_seqmax = 1;
6294         PL_op = o;
6295         switch (o->op_type) {
6296         case OP_SETSTATE:
6297         case OP_NEXTSTATE:
6298         case OP_DBSTATE:
6299             PL_curcop = ((COP*)o);              /* for warnings */
6300             o->op_seq = PL_op_seqmax++;
6301             break;
6302
6303         case OP_CONST:
6304             if (cSVOPo->op_private & OPpCONST_STRICT)
6305                 no_bareword_allowed(o);
6306 #ifdef USE_ITHREADS
6307         case OP_METHOD_NAMED:
6308             /* Relocate sv to the pad for thread safety.
6309              * Despite being a "constant", the SV is written to,
6310              * for reference counts, sv_upgrade() etc. */
6311             if (cSVOP->op_sv) {
6312                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6313                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6314                     /* If op_sv is already a PADTMP then it is being used by
6315                      * some pad, so make a copy. */
6316                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6317                     SvREADONLY_on(PAD_SVl(ix));
6318                     SvREFCNT_dec(cSVOPo->op_sv);
6319                 }
6320                 else {
6321                     SvREFCNT_dec(PAD_SVl(ix));
6322                     SvPADTMP_on(cSVOPo->op_sv);
6323                     PAD_SETSV(ix, cSVOPo->op_sv);
6324                     /* XXX I don't know how this isn't readonly already. */
6325                     SvREADONLY_on(PAD_SVl(ix));
6326                 }
6327                 cSVOPo->op_sv = Nullsv;
6328                 o->op_targ = ix;
6329             }
6330 #endif
6331             o->op_seq = PL_op_seqmax++;
6332             break;
6333
6334         case OP_CONCAT:
6335             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6336                 if (o->op_next->op_private & OPpTARGET_MY) {
6337                     if (o->op_flags & OPf_STACKED) /* chained concats */
6338                         goto ignore_optimization;
6339                     else {
6340                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6341                         o->op_targ = o->op_next->op_targ;
6342                         o->op_next->op_targ = 0;
6343                         o->op_private |= OPpTARGET_MY;
6344                     }
6345                 }
6346                 op_null(o->op_next);
6347             }
6348           ignore_optimization:
6349             o->op_seq = PL_op_seqmax++;
6350             break;
6351         case OP_STUB:
6352             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6353                 o->op_seq = PL_op_seqmax++;
6354                 break; /* Scalar stub must produce undef.  List stub is noop */
6355             }
6356             goto nothin;
6357         case OP_NULL:
6358             if (o->op_targ == OP_NEXTSTATE
6359                 || o->op_targ == OP_DBSTATE
6360                 || o->op_targ == OP_SETSTATE)
6361             {
6362                 PL_curcop = ((COP*)o);
6363             }
6364             /* XXX: We avoid setting op_seq here to prevent later calls
6365                to peep() from mistakenly concluding that optimisation
6366                has already occurred. This doesn't fix the real problem,
6367                though (See 20010220.007). AMS 20010719 */
6368             if (oldop && o->op_next) {
6369                 oldop->op_next = o->op_next;
6370                 continue;
6371             }
6372             break;
6373         case OP_SCALAR:
6374         case OP_LINESEQ:
6375         case OP_SCOPE:
6376           nothin:
6377             if (oldop && o->op_next) {
6378                 oldop->op_next = o->op_next;
6379                 continue;
6380             }
6381             o->op_seq = PL_op_seqmax++;
6382             break;
6383
6384         case OP_GV:
6385             if (o->op_next->op_type == OP_RV2SV) {
6386                 if (!(o->op_next->op_private & OPpDEREF)) {
6387                     op_null(o->op_next);
6388                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6389                                                                | OPpOUR_INTRO);
6390                     o->op_next = o->op_next->op_next;
6391                     o->op_type = OP_GVSV;
6392                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6393                 }
6394             }
6395             else if (o->op_next->op_type == OP_RV2AV) {
6396                 OP* pop = o->op_next->op_next;
6397                 IV i;
6398                 if (pop && pop->op_type == OP_CONST &&
6399                     (PL_op = pop->op_next) &&
6400                     pop->op_next->op_type == OP_AELEM &&
6401                     !(pop->op_next->op_private &
6402                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6403                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6404                                 <= 255 &&
6405                     i >= 0)
6406                 {
6407                     GV *gv;
6408                     op_null(o->op_next);
6409                     op_null(pop->op_next);
6410                     op_null(pop);
6411                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6412                     o->op_next = pop->op_next->op_next;
6413                     o->op_type = OP_AELEMFAST;
6414                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6415                     o->op_private = (U8)i;
6416                     gv = cGVOPo_gv;
6417                     GvAVn(gv);
6418                 }
6419             }
6420             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6421                 GV *gv = cGVOPo_gv;
6422                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6423                     /* XXX could check prototype here instead of just carping */
6424                     SV *sv = sv_newmortal();
6425                     gv_efullname3(sv, gv, Nullch);
6426                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6427                                 "%"SVf"() called too early to check prototype",
6428                                 sv);
6429                 }
6430             }
6431             else if (o->op_next->op_type == OP_READLINE
6432                     && o->op_next->op_next->op_type == OP_CONCAT
6433                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6434             {
6435                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6436                 o->op_type   = OP_RCATLINE;
6437                 o->op_flags |= OPf_STACKED;
6438                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6439                 op_null(o->op_next->op_next);
6440                 op_null(o->op_next);
6441             }
6442
6443             o->op_seq = PL_op_seqmax++;
6444             break;
6445
6446         case OP_MAPWHILE:
6447         case OP_GREPWHILE:
6448         case OP_AND:
6449         case OP_OR:
6450         case OP_DOR:
6451         case OP_ANDASSIGN:
6452         case OP_ORASSIGN:
6453         case OP_DORASSIGN:
6454         case OP_COND_EXPR:
6455         case OP_RANGE:
6456             o->op_seq = PL_op_seqmax++;
6457             while (cLOGOP->op_other->op_type == OP_NULL)
6458                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6459             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6460             break;
6461
6462         case OP_ENTERLOOP:
6463         case OP_ENTERITER:
6464             o->op_seq = PL_op_seqmax++;
6465             while (cLOOP->op_redoop->op_type == OP_NULL)
6466                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6467             peep(cLOOP->op_redoop);
6468             while (cLOOP->op_nextop->op_type == OP_NULL)
6469                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6470             peep(cLOOP->op_nextop);
6471             while (cLOOP->op_lastop->op_type == OP_NULL)
6472                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6473             peep(cLOOP->op_lastop);
6474             break;
6475
6476         case OP_QR:
6477         case OP_MATCH:
6478         case OP_SUBST:
6479             o->op_seq = PL_op_seqmax++;
6480             while (cPMOP->op_pmreplstart &&
6481                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6482                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6483             peep(cPMOP->op_pmreplstart);
6484             break;
6485
6486         case OP_EXEC:
6487             o->op_seq = PL_op_seqmax++;
6488             if (ckWARN(WARN_SYNTAX) && o->op_next
6489                 && o->op_next->op_type == OP_NEXTSTATE) {
6490                 if (o->op_next->op_sibling &&
6491                         o->op_next->op_sibling->op_type != OP_EXIT &&
6492                         o->op_next->op_sibling->op_type != OP_WARN &&
6493                         o->op_next->op_sibling->op_type != OP_DIE) {
6494                     line_t oldline = CopLINE(PL_curcop);
6495
6496                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6497                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6498                                 "Statement unlikely to be reached");
6499                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6500                                 "\t(Maybe you meant system() when you said exec()?)\n");
6501                     CopLINE_set(PL_curcop, oldline);
6502                 }
6503             }
6504             break;
6505
6506         case OP_HELEM: {
6507             SV *lexname;
6508             SV **svp, *sv;
6509             char *key = NULL;
6510             STRLEN keylen;
6511
6512             o->op_seq = PL_op_seqmax++;
6513
6514             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6515                 break;
6516
6517             /* Make the CONST have a shared SV */
6518             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6519             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6520                 key = SvPV(sv, keylen);
6521                 lexname = newSVpvn_share(key,
6522                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6523                                          0);
6524                 SvREFCNT_dec(sv);
6525                 *svp = lexname;
6526             }
6527             break;
6528         }
6529
6530         default:
6531             o->op_seq = PL_op_seqmax++;
6532             break;
6533         }
6534         oldop = o;
6535     }
6536     LEAVE;
6537 }
6538
6539
6540
6541 char* Perl_custom_op_name(pTHX_ OP* o)
6542 {
6543     IV  index = PTR2IV(o->op_ppaddr);
6544     SV* keysv;
6545     HE* he;
6546
6547     if (!PL_custom_op_names) /* This probably shouldn't happen */
6548         return PL_op_name[OP_CUSTOM];
6549
6550     keysv = sv_2mortal(newSViv(index));
6551
6552     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6553     if (!he)
6554         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6555
6556     return SvPV_nolen(HeVAL(he));
6557 }
6558
6559 char* Perl_custom_op_desc(pTHX_ OP* o)
6560 {
6561     IV  index = PTR2IV(o->op_ppaddr);
6562     SV* keysv;
6563     HE* he;
6564
6565     if (!PL_custom_op_descs)
6566         return PL_op_desc[OP_CUSTOM];
6567
6568     keysv = sv_2mortal(newSViv(index));
6569
6570     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6571     if (!he)
6572         return PL_op_desc[OP_CUSTOM];
6573
6574     return SvPV_nolen(HeVAL(he));
6575 }
6576
6577
6578 #include "XSUB.h"
6579
6580 /* Efficient sub that returns a constant scalar value. */
6581 static void
6582 const_sv_xsub(pTHX_ CV* cv)
6583 {
6584     dXSARGS;
6585     if (items != 0) {
6586 #if 0
6587         Perl_croak(aTHX_ "usage: %s::%s()",
6588                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6589 #endif
6590     }
6591     EXTEND(sp, 1);
6592     ST(0) = (SV*)XSANY.any_ptr;
6593     XSRETURN(1);
6594 }