op.c

   1 /*    op.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 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 /* This file contains the functions that create, manipulate and optimize
  20  * the OP structures that hold a compiled perl program.
  21  *
  22  * A Perl program is compiled into a tree of OPs. Each op contains
  23  * structural pointers (eg to its siblings and the next op in the
  24  * execution sequence), a pointer to the function that would execute the
  25  * op, plus any data specific to that op. For example, an OP_CONST op
  26  * points to the pp_const() function and to an SV containing the constant
  27  * value. When pp_const() is executed, its job is to push that SV onto the
  28  * stack.
  29  *
  30  * OPs are mainly created by the newFOO() functions, which are mainly
  31  * called from the parser (in perly.y) as the code is parsed. For example
  32  * the Perl code $a + $b * $c would cause the equivalent of the following
  33  * to be called (oversimplifying a bit):
  34  *
  35  *  newBINOP(OP_ADD, flags,
  36  *      newSVREF($a),
  37  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  38  *  )
  39  *
  40  * Note that during the build of miniperl, a temporary copy of this file
  41  * is made, called opmini.c.
  42  */
  43
  44 /*
  45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  46
  47     A bottom-up pass
  48     A top-down pass
  49     An execution-order pass
  50
  51 The bottom-up pass is represented by all the "newOP" routines and
  52 the ck_ routines.  The bottom-upness is actually driven by yacc.
  53 So at the point that a ck_ routine fires, we have no idea what the
  54 context is, either upward in the syntax tree, or either forward or
  55 backward in the execution order.  (The bottom-up parser builds that
  56 part of the execution order it knows about, but if you follow the "next"
  57 links around, you'll find it's actually a closed loop through the
  58 top level node.
  59
  60 Whenever the bottom-up parser gets to a node that supplies context to
  61 its components, it invokes that portion of the top-down pass that applies
  62 to that part of the subtree (and marks the top node as processed, so
  63 if a node further up supplies context, it doesn't have to take the
  64 plunge again).  As a particular subcase of this, as the new node is
  65 built, it takes all the closed execution loops of its subcomponents
  66 and links them into a new closed loop for the higher level node.  But
  67 it's still not the real execution order.
  68
  69 The actual execution order is not known till we get a grammar reduction
  70 to a top-level unit like a subroutine or file that will be called by
  71 "name" rather than via a "next" pointer.  At that point, we can call
  72 into peep() to do that code's portion of the 3rd pass.  It has to be
  73 recursive, but it's recursive on basic blocks, not on tree nodes.
  74 */
  75
  76 #include "EXTERN.h"
  77 #define PERL_IN_OP_C
  78 #include "perl.h"
  79 #include "keywords.h"
  80
  81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
  82
  83 #if defined(PL_OP_SLAB_ALLOC)
  84
  85 #ifndef PERL_SLAB_SIZE
  86 #define PERL_SLAB_SIZE 2048
  87 #endif
  88
  89 void *
  90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
  91 {
  92     /*
  93      * To make incrementing use count easy PL_OpSlab is an I32 *
  94      * To make inserting the link to slab PL_OpPtr is I32 **
  95      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
  96      * Add an overhead for pointer to slab and round up as a number of pointers
  97      */
  98     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
  99     if ((PL_OpSpace -= sz) < 0) {
 100         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
 101         if (!PL_OpPtr) {
 102             return NULL;
 103         }
 104         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
 105         /* We reserve the 0'th I32 sized chunk as a use count */
 106         PL_OpSlab = (I32 *) PL_OpPtr;
 107         /* Reduce size by the use count word, and by the size we need.
 108          * Latter is to mimic the '-=' in the if() above
 109          */
 110         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 111         /* Allocation pointer starts at the top.
 112            Theory: because we build leaves before trunk allocating at end
 113            means that at run time access is cache friendly upward
 114          */
 115         PL_OpPtr += PERL_SLAB_SIZE;
 116     }
 117     assert( PL_OpSpace >= 0 );
 118     /* Move the allocation pointer down */
 119     PL_OpPtr   -= sz;
 120     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 121     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 122     (*PL_OpSlab)++;             /* Increment use count of slab */
 123     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 124     assert( *PL_OpSlab > 0 );
 125     return (void *)(PL_OpPtr + 1);
 126 }
 127
 128 void
 129 Perl_Slab_Free(pTHX_ void *op)
 130 {
 131     I32 **ptr = (I32 **) op;
 132     I32 *slab = ptr[-1];
 133     assert( ptr-1 > (I32 **) slab );
 134     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 135     assert( *slab > 0 );
 136     if (--(*slab) == 0) {
 137 #  ifdef NETWARE
 138 #    define PerlMemShared PerlMem
 139 #  endif
 140
 141     PerlMemShared_free(slab);
 142         if (slab == PL_OpSlab) {
 143             PL_OpSpace = 0;
 144         }
 145     }
 146 }
 147 #endif
 148 /*
 149  * In the following definition, the ", Nullop" is just to make the compiler
 150  * think the expression is of the right type: croak actually does a Siglongjmp.
 151  */
 152 #define CHECKOP(type,o) \
 153     ((PL_op_mask && PL_op_mask[type])                                   \
 154      ? ( op_free((OP*)o),                                       \
 155          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 156          Nullop )                                               \
 157      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 158
 159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 160
 161 STATIC char*
 162 S_gv_ename(pTHX_ GV *gv)
 163 {
 164     STRLEN n_a;
 165     SV* tmpsv = sv_newmortal();
 166     gv_efullname3(tmpsv, gv, Nullch);
 167     return SvPV(tmpsv,n_a);
 168 }
 169
 170 STATIC OP *
 171 S_no_fh_allowed(pTHX_ OP *o)
 172 {
 173     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 174                  OP_DESC(o)));
 175     return o;
 176 }
 177
 178 STATIC OP *
 179 S_too_few_arguments(pTHX_ OP *o, const char *name)
 180 {
 181     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 182     return o;
 183 }
 184
 185 STATIC OP *
 186 S_too_many_arguments(pTHX_ OP *o, const char *name)
 187 {
 188     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 189     return o;
 190 }
 191
 192 STATIC void
 193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 194 {
 195     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 196                  (int)n, name, t, OP_DESC(kid)));
 197 }
 198
 199 STATIC void
 200 S_no_bareword_allowed(pTHX_ const OP *o)
 201 {
 202     qerror(Perl_mess(aTHX_
 203                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 204                      cSVOPo_sv));
 205 }
 206
 207 /* "register" allocation */
 208
 209 PADOFFSET
 210 Perl_allocmy(pTHX_ char *name)
 211 {
 212     PADOFFSET off;
 213
 214     /* complain about "my $<special_var>" etc etc */
 215     if (!(PL_in_my == KEY_our ||
 216           isALPHA(name[1]) ||
 217           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 218           (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
 219     {
 220         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 221             /* 1999-02-27 mjd@plover.com */
 222             char *p;
 223             p = strchr(name, '\0');
 224             /* The next block assumes the buffer is at least 205 chars
 225                long.  At present, it's always at least 256 chars. */
 226             if (p-name > 200) {
 227                 strcpy(name+200, "...");
 228                 p = name+199;
 229             }
 230             else {
 231                 p[1] = '\0';
 232             }
 233             /* Move everything else down one character */
 234             for (; p-name > 2; p--)
 235                 *p = *(p-1);
 236             name[2] = toCTRL(name[1]);
 237             name[1] = '^';
 238         }
 239         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 240     }
 241
 242     /* check for duplicate declaration */
 243     pad_check_dup(name,
 244                 (bool)(PL_in_my == KEY_our),
 245                 (PL_curstash ? PL_curstash : PL_defstash)
 246     );
 247
 248     if (PL_in_my_stash && *name != '$') {
 249         yyerror(Perl_form(aTHX_
 250                     "Can't declare class for non-scalar %s in \"%s\"",
 251                      name, PL_in_my == KEY_our ? "our" : "my"));
 252     }
 253
 254     /* allocate a spare slot and store the name in that slot */
 255
 256     off = pad_add_name(name,
 257                     PL_in_my_stash,
 258                     (PL_in_my == KEY_our
 259                         /* $_ is always in main::, even with our */
 260                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 261                         : Nullhv
 262                     ),
 263                     0 /*  not fake */
 264     );
 265     return off;
 266 }
 267
 268 /* Destructor */
 269
 270 void
 271 Perl_op_free(pTHX_ OP *o)
 272 {
 273     dVAR;
 274     OPCODE type;
 275     PADOFFSET refcnt;
 276
 277     if (!o || o->op_static)
 278         return;
 279
 280     if (o->op_private & OPpREFCOUNTED) {
 281         switch (o->op_type) {
 282         case OP_LEAVESUB:
 283         case OP_LEAVESUBLV:
 284         case OP_LEAVEEVAL:
 285         case OP_LEAVE:
 286         case OP_SCOPE:
 287         case OP_LEAVEWRITE:
 288             OP_REFCNT_LOCK;
 289             refcnt = OpREFCNT_dec(o);
 290             OP_REFCNT_UNLOCK;
 291             if (refcnt)
 292                 return;
 293             break;
 294         default:
 295             break;
 296         }
 297     }
 298
 299     if (o->op_flags & OPf_KIDS) {
 300         register OP *kid, *nextkid;
 301         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 302             nextkid = kid->op_sibling; /* Get before next freeing kid */
 303             op_free(kid);
 304         }
 305     }
 306     type = o->op_type;
 307     if (type == OP_NULL)
 308         type = (OPCODE)o->op_targ;
 309
 310     /* COP* is not cleared by op_clear() so that we may track line
 311      * numbers etc even after null() */
 312     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 313         cop_free((COP*)o);
 314
 315     op_clear(o);
 316     FreeOp(o);
 317 #ifdef DEBUG_LEAKING_SCALARS
 318     if (PL_op == o)
 319         PL_op = Nullop;
 320 #endif
 321 }
 322
 323 void
 324 Perl_op_clear(pTHX_ OP *o)
 325 {
 326
 327     dVAR;
 328     switch (o->op_type) {
 329     case OP_NULL:       /* Was holding old type, if any. */
 330     case OP_ENTEREVAL:  /* Was holding hints. */
 331         o->op_targ = 0;
 332         break;
 333     default:
 334         if (!(o->op_flags & OPf_REF)
 335             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 336             break;
 337         /* FALL THROUGH */
 338     case OP_GVSV:
 339     case OP_GV:
 340     case OP_AELEMFAST:
 341         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 342             /* not an OP_PADAV replacement */
 343 #ifdef USE_ITHREADS
 344             if (cPADOPo->op_padix > 0) {
 345                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 346                  * may still exist on the pad */
 347                 pad_swipe(cPADOPo->op_padix, TRUE);
 348                 cPADOPo->op_padix = 0;
 349             }
 350 #else
 351             SvREFCNT_dec(cSVOPo->op_sv);
 352             cSVOPo->op_sv = Nullsv;
 353 #endif
 354         }
 355         break;
 356     case OP_METHOD_NAMED:
 357     case OP_CONST:
 358         SvREFCNT_dec(cSVOPo->op_sv);
 359         cSVOPo->op_sv = Nullsv;
 360 #ifdef USE_ITHREADS
 361         /** Bug #15654
 362           Even if op_clear does a pad_free for the target of the op,
 363           pad_free doesn't actually remove the sv that exists in the pad;
 364           instead it lives on. This results in that it could be reused as
 365           a target later on when the pad was reallocated.
 366         **/
 367         if(o->op_targ) {
 368           pad_swipe(o->op_targ,1);
 369           o->op_targ = 0;
 370         }
 371 #endif
 372         break;
 373     case OP_GOTO:
 374     case OP_NEXT:
 375     case OP_LAST:
 376     case OP_REDO:
 377         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 378             break;
 379         /* FALL THROUGH */
 380     case OP_TRANS:
 381         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 382             SvREFCNT_dec(cSVOPo->op_sv);
 383             cSVOPo->op_sv = Nullsv;
 384         }
 385         else {
 386             Safefree(cPVOPo->op_pv);
 387             cPVOPo->op_pv = Nullch;
 388         }
 389         break;
 390     case OP_SUBST:
 391         op_free(cPMOPo->op_pmreplroot);
 392         goto clear_pmop;
 393     case OP_PUSHRE:
 394 #ifdef USE_ITHREADS
 395         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 396             /* No GvIN_PAD_off here, because other references may still
 397              * exist on the pad */
 398             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
 399         }
 400 #else
 401         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 402 #endif
 403         /* FALL THROUGH */
 404     case OP_MATCH:
 405     case OP_QR:
 406 clear_pmop:
 407         {
 408             HV *pmstash = PmopSTASH(cPMOPo);
 409             if (pmstash && SvREFCNT(pmstash)) {
 410                 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
 411                 if (mg) {
 412                     PMOP *pmop = (PMOP*) mg->mg_obj;
 413                     PMOP *lastpmop = NULL;
 414                     while (pmop) {
 415                         if (cPMOPo == pmop) {
 416                             if (lastpmop)
 417                                 lastpmop->op_pmnext = pmop->op_pmnext;
 418                             else
 419                                 mg->mg_obj = (SV*) pmop->op_pmnext;
 420                             break;
 421                         }
 422                         lastpmop = pmop;
 423                         pmop = pmop->op_pmnext;
 424                     }
 425                 }
 426             }
 427             PmopSTASH_free(cPMOPo);
 428         }
 429         cPMOPo->op_pmreplroot = Nullop;
 430         /* we use the "SAFE" version of the PM_ macros here
 431          * since sv_clean_all might release some PMOPs
 432          * after PL_regex_padav has been cleared
 433          * and the clearing of PL_regex_padav needs to
 434          * happen before sv_clean_all
 435          */
 436         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
 437         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
 438 #ifdef USE_ITHREADS
 439         if(PL_regex_pad) {        /* We could be in destruction */
 440             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
 441             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 442             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
 443         }
 444 #endif
 445
 446         break;
 447     }
 448
 449     if (o->op_targ > 0) {
 450         pad_free(o->op_targ);
 451         o->op_targ = 0;
 452     }
 453 }
 454
 455 STATIC void
 456 S_cop_free(pTHX_ COP* cop)
 457 {
 458     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
 459     CopFILE_free(cop);
 460     CopSTASH_free(cop);
 461     if (! specialWARN(cop->cop_warnings))
 462         SvREFCNT_dec(cop->cop_warnings);
 463     if (! specialCopIO(cop->cop_io)) {
 464 #ifdef USE_ITHREADS
 465 #if 0
 466         STRLEN len;
 467         char *s = SvPV(cop->cop_io,len);
 468         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
 469 #endif
 470 #else
 471         SvREFCNT_dec(cop->cop_io);
 472 #endif
 473     }
 474 }
 475
 476 void
 477 Perl_op_null(pTHX_ OP *o)
 478 {
 479     dVAR;
 480     if (o->op_type == OP_NULL)
 481         return;
 482     op_clear(o);
 483     o->op_targ = o->op_type;
 484     o->op_type = OP_NULL;
 485     o->op_ppaddr = PL_ppaddr[OP_NULL];
 486 }
 487
 488 void
 489 Perl_op_refcnt_lock(pTHX)
 490 {
 491     dVAR;
 492     OP_REFCNT_LOCK;
 493 }
 494
 495 void
 496 Perl_op_refcnt_unlock(pTHX)
 497 {
 498     dVAR;
 499     OP_REFCNT_UNLOCK;
 500 }
 501
 502 /* Contextualizers */
 503
 504 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 505
 506 OP *
 507 Perl_linklist(pTHX_ OP *o)
 508 {
 509
 510     if (o->op_next)
 511         return o->op_next;
 512
 513     /* establish postfix order */
 514     if (cUNOPo->op_first) {
 515         register OP *kid;
 516         o->op_next = LINKLIST(cUNOPo->op_first);
 517         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 518             if (kid->op_sibling)
 519                 kid->op_next = LINKLIST(kid->op_sibling);
 520             else
 521                 kid->op_next = o;
 522         }
 523     }
 524     else
 525         o->op_next = o;
 526
 527     return o->op_next;
 528 }
 529
 530 OP *
 531 Perl_scalarkids(pTHX_ OP *o)
 532 {
 533     if (o && o->op_flags & OPf_KIDS) {
 534         OP *kid;
 535         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 536             scalar(kid);
 537     }
 538     return o;
 539 }
 540
 541 STATIC OP *
 542 S_scalarboolean(pTHX_ OP *o)
 543 {
 544     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 545         if (ckWARN(WARN_SYNTAX)) {
 546             const line_t oldline = CopLINE(PL_curcop);
 547
 548             if (PL_copline != NOLINE)
 549                 CopLINE_set(PL_curcop, PL_copline);
 550             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 551             CopLINE_set(PL_curcop, oldline);
 552         }
 553     }
 554     return scalar(o);
 555 }
 556
 557 OP *
 558 Perl_scalar(pTHX_ OP *o)
 559 {
 560     dVAR;
 561     OP *kid;
 562
 563     /* assumes no premature commitment */
 564     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 565          || o->op_type == OP_RETURN)
 566     {
 567         return o;
 568     }
 569
 570     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 571
 572     switch (o->op_type) {
 573     case OP_REPEAT:
 574         scalar(cBINOPo->op_first);
 575         break;
 576     case OP_OR:
 577     case OP_AND:
 578     case OP_COND_EXPR:
 579         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 580             scalar(kid);
 581         break;
 582     case OP_SPLIT:
 583         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 584             if (!kPMOP->op_pmreplroot)
 585                 deprecate_old("implicit split to @_");
 586         }
 587         /* FALL THROUGH */
 588     case OP_MATCH:
 589     case OP_QR:
 590     case OP_SUBST:
 591     case OP_NULL:
 592     default:
 593         if (o->op_flags & OPf_KIDS) {
 594             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 595                 scalar(kid);
 596         }
 597         break;
 598     case OP_LEAVE:
 599     case OP_LEAVETRY:
 600         kid = cLISTOPo->op_first;
 601         scalar(kid);
 602         while ((kid = kid->op_sibling)) {
 603             if (kid->op_sibling)
 604                 scalarvoid(kid);
 605             else
 606                 scalar(kid);
 607         }
 608         WITH_THR(PL_curcop = &PL_compiling);
 609         break;
 610     case OP_SCOPE:
 611     case OP_LINESEQ:
 612     case OP_LIST:
 613         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 614             if (kid->op_sibling)
 615                 scalarvoid(kid);
 616             else
 617                 scalar(kid);
 618         }
 619         WITH_THR(PL_curcop = &PL_compiling);
 620         break;
 621     case OP_SORT:
 622         if (ckWARN(WARN_VOID))
 623             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 624     }
 625     return o;
 626 }
 627
 628 OP *
 629 Perl_scalarvoid(pTHX_ OP *o)
 630 {
 631     dVAR;
 632     OP *kid;
 633     const char* useless = 0;
 634     SV* sv;
 635     U8 want;
 636
 637     if (o->op_type == OP_NEXTSTATE
 638         || o->op_type == OP_SETSTATE
 639         || o->op_type == OP_DBSTATE
 640         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 641                                       || o->op_targ == OP_SETSTATE
 642                                       || o->op_targ == OP_DBSTATE)))
 643         PL_curcop = (COP*)o;            /* for warning below */
 644
 645     /* assumes no premature commitment */
 646     want = o->op_flags & OPf_WANT;
 647     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
 648          || o->op_type == OP_RETURN)
 649     {
 650         return o;
 651     }
 652
 653     if ((o->op_private & OPpTARGET_MY)
 654         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 655     {
 656         return scalar(o);                       /* As if inside SASSIGN */
 657     }
 658
 659     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 660
 661     switch (o->op_type) {
 662     default:
 663         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 664             break;
 665         /* FALL THROUGH */
 666     case OP_REPEAT:
 667         if (o->op_flags & OPf_STACKED)
 668             break;
 669         goto func_ops;
 670     case OP_SUBSTR:
 671         if (o->op_private == 4)
 672             break;
 673         /* FALL THROUGH */
 674     case OP_GVSV:
 675     case OP_WANTARRAY:
 676     case OP_GV:
 677     case OP_PADSV:
 678     case OP_PADAV:
 679     case OP_PADHV:
 680     case OP_PADANY:
 681     case OP_AV2ARYLEN:
 682     case OP_REF:
 683     case OP_REFGEN:
 684     case OP_SREFGEN:
 685     case OP_DEFINED:
 686     case OP_HEX:
 687     case OP_OCT:
 688     case OP_LENGTH:
 689     case OP_VEC:
 690     case OP_INDEX:
 691     case OP_RINDEX:
 692     case OP_SPRINTF:
 693     case OP_AELEM:
 694     case OP_AELEMFAST:
 695     case OP_ASLICE:
 696     case OP_HELEM:
 697     case OP_HSLICE:
 698     case OP_UNPACK:
 699     case OP_PACK:
 700     case OP_JOIN:
 701     case OP_LSLICE:
 702     case OP_ANONLIST:
 703     case OP_ANONHASH:
 704     case OP_SORT:
 705     case OP_REVERSE:
 706     case OP_RANGE:
 707     case OP_FLIP:
 708     case OP_FLOP:
 709     case OP_CALLER:
 710     case OP_FILENO:
 711     case OP_EOF:
 712     case OP_TELL:
 713     case OP_GETSOCKNAME:
 714     case OP_GETPEERNAME:
 715     case OP_READLINK:
 716     case OP_TELLDIR:
 717     case OP_GETPPID:
 718     case OP_GETPGRP:
 719     case OP_GETPRIORITY:
 720     case OP_TIME:
 721     case OP_TMS:
 722     case OP_LOCALTIME:
 723     case OP_GMTIME:
 724     case OP_GHBYNAME:
 725     case OP_GHBYADDR:
 726     case OP_GHOSTENT:
 727     case OP_GNBYNAME:
 728     case OP_GNBYADDR:
 729     case OP_GNETENT:
 730     case OP_GPBYNAME:
 731     case OP_GPBYNUMBER:
 732     case OP_GPROTOENT:
 733     case OP_GSBYNAME:
 734     case OP_GSBYPORT:
 735     case OP_GSERVENT:
 736     case OP_GPWNAM:
 737     case OP_GPWUID:
 738     case OP_GGRNAM:
 739     case OP_GGRGID:
 740     case OP_GETLOGIN:
 741     case OP_PROTOTYPE:
 742       func_ops:
 743         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 744             useless = OP_DESC(o);
 745         break;
 746
 747     case OP_NOT:
 748        kid = cUNOPo->op_first;
 749        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
 750            kid->op_type != OP_TRANS) {
 751                 goto func_ops;
 752        }
 753        useless = "negative pattern binding (!~)";
 754        break;
 755
 756     case OP_RV2GV:
 757     case OP_RV2SV:
 758     case OP_RV2AV:
 759     case OP_RV2HV:
 760         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 761                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 762             useless = "a variable";
 763         break;
 764
 765     case OP_CONST:
 766         sv = cSVOPo_sv;
 767         if (cSVOPo->op_private & OPpCONST_STRICT)
 768             no_bareword_allowed(o);
 769         else {
 770             if (ckWARN(WARN_VOID)) {
 771                 useless = "a constant";
 772                 /* don't warn on optimised away booleans, eg
 773                  * use constant Foo, 5; Foo || print; */
 774                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
 775                     useless = 0;
 776                 /* the constants 0 and 1 are permitted as they are
 777                    conventionally used as dummies in constructs like
 778                         1 while some_condition_with_side_effects;  */
 779                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 780                     useless = 0;
 781                 else if (SvPOK(sv)) {
 782                   /* perl4's way of mixing documentation and code
 783                      (before the invention of POD) was based on a
 784                      trick to mix nroff and perl code. The trick was
 785                      built upon these three nroff macros being used in
 786                      void context. The pink camel has the details in
 787                      the script wrapman near page 319. */
 788                     if (strnEQ(SvPVX(sv), "di", 2) ||
 789                         strnEQ(SvPVX(sv), "ds", 2) ||
 790                         strnEQ(SvPVX(sv), "ig", 2))
 791                             useless = 0;
 792                 }
 793             }
 794         }
 795         op_null(o);             /* don't execute or even remember it */
 796         break;
 797
 798     case OP_POSTINC:
 799         o->op_type = OP_PREINC;         /* pre-increment is faster */
 800         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 801         break;
 802
 803     case OP_POSTDEC:
 804         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 805         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 806         break;
 807
 808     case OP_OR:
 809     case OP_AND:
 810     case OP_DOR:
 811     case OP_COND_EXPR:
 812         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 813             scalarvoid(kid);
 814         break;
 815
 816     case OP_NULL:
 817         if (o->op_flags & OPf_STACKED)
 818             break;
 819         /* FALL THROUGH */
 820     case OP_NEXTSTATE:
 821     case OP_DBSTATE:
 822     case OP_ENTERTRY:
 823     case OP_ENTER:
 824         if (!(o->op_flags & OPf_KIDS))
 825             break;
 826         /* FALL THROUGH */
 827     case OP_SCOPE:
 828     case OP_LEAVE:
 829     case OP_LEAVETRY:
 830     case OP_LEAVELOOP:
 831     case OP_LINESEQ:
 832     case OP_LIST:
 833         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 834             scalarvoid(kid);
 835         break;
 836     case OP_ENTEREVAL:
 837         scalarkids(o);
 838         break;
 839     case OP_REQUIRE:
 840         /* all requires must return a boolean value */
 841         o->op_flags &= ~OPf_WANT;
 842         /* FALL THROUGH */
 843     case OP_SCALAR:
 844         return scalar(o);
 845     case OP_SPLIT:
 846         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 847             if (!kPMOP->op_pmreplroot)
 848                 deprecate_old("implicit split to @_");
 849         }
 850         break;
 851     }
 852     if (useless && ckWARN(WARN_VOID))
 853         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
 854     return o;
 855 }
 856
 857 OP *
 858 Perl_listkids(pTHX_ OP *o)
 859 {
 860     if (o && o->op_flags & OPf_KIDS) {
 861         OP *kid;
 862         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 863             list(kid);
 864     }
 865     return o;
 866 }
 867
 868 OP *
 869 Perl_list(pTHX_ OP *o)
 870 {
 871     dVAR;
 872     OP *kid;
 873
 874     /* assumes no premature commitment */
 875     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 876          || o->op_type == OP_RETURN)
 877     {
 878         return o;
 879     }
 880
 881     if ((o->op_private & OPpTARGET_MY)
 882         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 883     {
 884         return o;                               /* As if inside SASSIGN */
 885     }
 886
 887     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
 888
 889     switch (o->op_type) {
 890     case OP_FLOP:
 891     case OP_REPEAT:
 892         list(cBINOPo->op_first);
 893         break;
 894     case OP_OR:
 895     case OP_AND:
 896     case OP_COND_EXPR:
 897         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 898             list(kid);
 899         break;
 900     default:
 901     case OP_MATCH:
 902     case OP_QR:
 903     case OP_SUBST:
 904     case OP_NULL:
 905         if (!(o->op_flags & OPf_KIDS))
 906             break;
 907         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
 908             list(cBINOPo->op_first);
 909             return gen_constant_list(o);
 910         }
 911     case OP_LIST:
 912         listkids(o);
 913         break;
 914     case OP_LEAVE:
 915     case OP_LEAVETRY:
 916         kid = cLISTOPo->op_first;
 917         list(kid);
 918         while ((kid = kid->op_sibling)) {
 919             if (kid->op_sibling)
 920                 scalarvoid(kid);
 921             else
 922                 list(kid);
 923         }
 924         WITH_THR(PL_curcop = &PL_compiling);
 925         break;
 926     case OP_SCOPE:
 927     case OP_LINESEQ:
 928         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 929             if (kid->op_sibling)
 930                 scalarvoid(kid);
 931             else
 932                 list(kid);
 933         }
 934         WITH_THR(PL_curcop = &PL_compiling);
 935         break;
 936     case OP_REQUIRE:
 937         /* all requires must return a boolean value */
 938         o->op_flags &= ~OPf_WANT;
 939         return scalar(o);
 940     }
 941     return o;
 942 }
 943
 944 OP *
 945 Perl_scalarseq(pTHX_ OP *o)
 946 {
 947     if (o) {
 948         if (o->op_type == OP_LINESEQ ||
 949              o->op_type == OP_SCOPE ||
 950              o->op_type == OP_LEAVE ||
 951              o->op_type == OP_LEAVETRY)
 952         {
 953             OP *kid;
 954             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 955                 if (kid->op_sibling) {
 956                     scalarvoid(kid);
 957                 }
 958             }
 959             PL_curcop = &PL_compiling;
 960         }
 961         o->op_flags &= ~OPf_PARENS;
 962         if (PL_hints & HINT_BLOCK_SCOPE)
 963             o->op_flags |= OPf_PARENS;
 964     }
 965     else
 966         o = newOP(OP_STUB, 0);
 967     return o;
 968 }
 969
 970 STATIC OP *
 971 S_modkids(pTHX_ OP *o, I32 type)
 972 {
 973     if (o && o->op_flags & OPf_KIDS) {
 974         OP *kid;
 975         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 976             mod(kid, type);
 977     }
 978     return o;
 979 }
 980
 981 /* Propagate lvalue ("modifiable") context to an op and it's children.
 982  * 'type' represents the context type, roughly based on the type of op that
 983  * would do the modifying, although local() is represented by OP_NULL.
 984  * It's responsible for detecting things that can't be modified,  flag
 985  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
 986  * might have to vivify a reference in $x), and so on.
 987  *
 988  * For example, "$a+1 = 2" would cause mod() to be called with o being
 989  * OP_ADD and type being OP_SASSIGN, and would output an error.
 990  */
 991
 992 OP *
 993 Perl_mod(pTHX_ OP *o, I32 type)
 994 {
 995     dVAR;
 996     OP *kid;
 997     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
 998     int localize = -1;
 999
1000     if (!o || PL_error_count)
1001         return o;
1002
1003     if ((o->op_private & OPpTARGET_MY)
1004         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1005     {
1006         return o;
1007     }
1008
1009     switch (o->op_type) {
1010     case OP_UNDEF:
1011         localize = 0;
1012         PL_modcount++;
1013         return o;
1014     case OP_CONST:
1015         if (!(o->op_private & (OPpCONST_ARYBASE)))
1016             goto nomod;
1017         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1018             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1019             PL_eval_start = 0;
1020         }
1021         else if (!type) {
1022             SAVEI32(PL_compiling.cop_arybase);
1023             PL_compiling.cop_arybase = 0;
1024         }
1025         else if (type == OP_REFGEN)
1026             goto nomod;
1027         else
1028             Perl_croak(aTHX_ "That use of $[ is unsupported");
1029         break;
1030     case OP_STUB:
1031         if (o->op_flags & OPf_PARENS)
1032             break;
1033         goto nomod;
1034     case OP_ENTERSUB:
1035         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1036             !(o->op_flags & OPf_STACKED)) {
1037             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1038             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1039             assert(cUNOPo->op_first->op_type == OP_NULL);
1040             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1041             break;
1042         }
1043         else if (o->op_private & OPpENTERSUB_NOMOD)
1044             return o;
1045         else {                          /* lvalue subroutine call */
1046             o->op_private |= OPpLVAL_INTRO;
1047             PL_modcount = RETURN_UNLIMITED_NUMBER;
1048             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1049                 /* Backward compatibility mode: */
1050                 o->op_private |= OPpENTERSUB_INARGS;
1051                 break;
1052             }
1053             else {                      /* Compile-time error message: */
1054                 OP *kid = cUNOPo->op_first;
1055                 CV *cv;
1056                 OP *okid;
1057
1058                 if (kid->op_type == OP_PUSHMARK)
1059                     goto skip_kids;
1060                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1061                     Perl_croak(aTHX_
1062                                "panic: unexpected lvalue entersub "
1063                                "args: type/targ %ld:%"UVuf,
1064                                (long)kid->op_type, (UV)kid->op_targ);
1065                 kid = kLISTOP->op_first;
1066               skip_kids:
1067                 while (kid->op_sibling)
1068                     kid = kid->op_sibling;
1069                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1070                     /* Indirect call */
1071                     if (kid->op_type == OP_METHOD_NAMED
1072                         || kid->op_type == OP_METHOD)
1073                     {
1074                         UNOP *newop;
1075
1076                         NewOp(1101, newop, 1, UNOP);
1077                         newop->op_type = OP_RV2CV;
1078                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1079                         newop->op_first = Nullop;
1080                         newop->op_next = (OP*)newop;
1081                         kid->op_sibling = (OP*)newop;
1082                         newop->op_private |= OPpLVAL_INTRO;
1083                         break;
1084                     }
1085
1086                     if (kid->op_type != OP_RV2CV)
1087                         Perl_croak(aTHX_
1088                                    "panic: unexpected lvalue entersub "
1089                                    "entry via type/targ %ld:%"UVuf,
1090                                    (long)kid->op_type, (UV)kid->op_targ);
1091                     kid->op_private |= OPpLVAL_INTRO;
1092                     break;      /* Postpone until runtime */
1093                 }
1094
1095                 okid = kid;
1096                 kid = kUNOP->op_first;
1097                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1098                     kid = kUNOP->op_first;
1099                 if (kid->op_type == OP_NULL)
1100                     Perl_croak(aTHX_
1101                                "Unexpected constant lvalue entersub "
1102                                "entry via type/targ %ld:%"UVuf,
1103                                (long)kid->op_type, (UV)kid->op_targ);
1104                 if (kid->op_type != OP_GV) {
1105                     /* Restore RV2CV to check lvalueness */
1106                   restore_2cv:
1107                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1108                         okid->op_next = kid->op_next;
1109                         kid->op_next = okid;
1110                     }
1111                     else
1112                         okid->op_next = Nullop;
1113                     okid->op_type = OP_RV2CV;
1114                     okid->op_targ = 0;
1115                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1116                     okid->op_private |= OPpLVAL_INTRO;
1117                     break;
1118                 }
1119
1120                 cv = GvCV(kGVOP_gv);
1121                 if (!cv)
1122                     goto restore_2cv;
1123                 if (CvLVALUE(cv))
1124                     break;
1125             }
1126         }
1127         /* FALL THROUGH */
1128     default:
1129       nomod:
1130         /* grep, foreach, subcalls, refgen */
1131         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1132             break;
1133         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1134                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1135                       ? "do block"
1136                       : (o->op_type == OP_ENTERSUB
1137                         ? "non-lvalue subroutine call"
1138                         : OP_DESC(o))),
1139                      type ? PL_op_desc[type] : "local"));
1140         return o;
1141
1142     case OP_PREINC:
1143     case OP_PREDEC:
1144     case OP_POW:
1145     case OP_MULTIPLY:
1146     case OP_DIVIDE:
1147     case OP_MODULO:
1148     case OP_REPEAT:
1149     case OP_ADD:
1150     case OP_SUBTRACT:
1151     case OP_CONCAT:
1152     case OP_LEFT_SHIFT:
1153     case OP_RIGHT_SHIFT:
1154     case OP_BIT_AND:
1155     case OP_BIT_XOR:
1156     case OP_BIT_OR:
1157     case OP_I_MULTIPLY:
1158     case OP_I_DIVIDE:
1159     case OP_I_MODULO:
1160     case OP_I_ADD:
1161     case OP_I_SUBTRACT:
1162         if (!(o->op_flags & OPf_STACKED))
1163             goto nomod;
1164         PL_modcount++;
1165         break;
1166
1167     case OP_COND_EXPR:
1168         localize = 1;
1169         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1170             mod(kid, type);
1171         break;
1172
1173     case OP_RV2AV:
1174     case OP_RV2HV:
1175         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1176            PL_modcount = RETURN_UNLIMITED_NUMBER;
1177             return o;           /* Treat \(@foo) like ordinary list. */
1178         }
1179         /* FALL THROUGH */
1180     case OP_RV2GV:
1181         if (scalar_mod_type(o, type))
1182             goto nomod;
1183         ref(cUNOPo->op_first, o->op_type);
1184         /* FALL THROUGH */
1185     case OP_ASLICE:
1186     case OP_HSLICE:
1187         if (type == OP_LEAVESUBLV)
1188             o->op_private |= OPpMAYBE_LVSUB;
1189         localize = 1;
1190         /* FALL THROUGH */
1191     case OP_AASSIGN:
1192     case OP_NEXTSTATE:
1193     case OP_DBSTATE:
1194        PL_modcount = RETURN_UNLIMITED_NUMBER;
1195         break;
1196     case OP_RV2SV:
1197         ref(cUNOPo->op_first, o->op_type);
1198         localize = 1;
1199         /* FALL THROUGH */
1200     case OP_GV:
1201     case OP_AV2ARYLEN:
1202         PL_hints |= HINT_BLOCK_SCOPE;
1203     case OP_SASSIGN:
1204     case OP_ANDASSIGN:
1205     case OP_ORASSIGN:
1206     case OP_DORASSIGN:
1207         PL_modcount++;
1208         break;
1209
1210     case OP_AELEMFAST:
1211         localize = -1;
1212         PL_modcount++;
1213         break;
1214
1215     case OP_PADAV:
1216     case OP_PADHV:
1217        PL_modcount = RETURN_UNLIMITED_NUMBER;
1218         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1219             return o;           /* Treat \(@foo) like ordinary list. */
1220         if (scalar_mod_type(o, type))
1221             goto nomod;
1222         if (type == OP_LEAVESUBLV)
1223             o->op_private |= OPpMAYBE_LVSUB;
1224         /* FALL THROUGH */
1225     case OP_PADSV:
1226         PL_modcount++;
1227         if (!type) /* local() */
1228             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1229                  PAD_COMPNAME_PV(o->op_targ));
1230         break;
1231
1232     case OP_PUSHMARK:
1233         localize = 0;
1234         break;
1235
1236     case OP_KEYS:
1237         if (type != OP_SASSIGN)
1238             goto nomod;
1239         goto lvalue_func;
1240     case OP_SUBSTR:
1241         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1242             goto nomod;
1243         /* FALL THROUGH */
1244     case OP_POS:
1245     case OP_VEC:
1246         if (type == OP_LEAVESUBLV)
1247             o->op_private |= OPpMAYBE_LVSUB;
1248       lvalue_func:
1249         pad_free(o->op_targ);
1250         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1251         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1252         if (o->op_flags & OPf_KIDS)
1253             mod(cBINOPo->op_first->op_sibling, type);
1254         break;
1255
1256     case OP_AELEM:
1257     case OP_HELEM:
1258         ref(cBINOPo->op_first, o->op_type);
1259         if (type == OP_ENTERSUB &&
1260              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1261             o->op_private |= OPpLVAL_DEFER;
1262         if (type == OP_LEAVESUBLV)
1263             o->op_private |= OPpMAYBE_LVSUB;
1264         localize = 1;
1265         PL_modcount++;
1266         break;
1267
1268     case OP_SCOPE:
1269     case OP_LEAVE:
1270     case OP_ENTER:
1271     case OP_LINESEQ:
1272         localize = 0;
1273         if (o->op_flags & OPf_KIDS)
1274             mod(cLISTOPo->op_last, type);
1275         break;
1276
1277     case OP_NULL:
1278         localize = 0;
1279         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1280             goto nomod;
1281         else if (!(o->op_flags & OPf_KIDS))
1282             break;
1283         if (o->op_targ != OP_LIST) {
1284             mod(cBINOPo->op_first, type);
1285             break;
1286         }
1287         /* FALL THROUGH */
1288     case OP_LIST:
1289         localize = 0;
1290         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1291             mod(kid, type);
1292         break;
1293
1294     case OP_RETURN:
1295         if (type != OP_LEAVESUBLV)
1296             goto nomod;
1297         break; /* mod()ing was handled by ck_return() */
1298     }
1299
1300     /* [20011101.069] File test operators interpret OPf_REF to mean that
1301        their argument is a filehandle; thus \stat(".") should not set
1302        it. AMS 20011102 */
1303     if (type == OP_REFGEN &&
1304         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1305         return o;
1306
1307     if (type != OP_LEAVESUBLV)
1308         o->op_flags |= OPf_MOD;
1309
1310     if (type == OP_AASSIGN || type == OP_SASSIGN)
1311         o->op_flags |= OPf_SPECIAL|OPf_REF;
1312     else if (!type) { /* local() */
1313         switch (localize) {
1314         case 1:
1315             o->op_private |= OPpLVAL_INTRO;
1316             o->op_flags &= ~OPf_SPECIAL;
1317             PL_hints |= HINT_BLOCK_SCOPE;
1318             break;
1319         case 0:
1320             break;
1321         case -1:
1322             if (ckWARN(WARN_SYNTAX)) {
1323                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1324                     "Useless localization of %s", OP_DESC(o));
1325             }
1326         }
1327     }
1328     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1329              && type != OP_LEAVESUBLV)
1330         o->op_flags |= OPf_REF;
1331     return o;
1332 }
1333
1334 STATIC bool
1335 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1336 {
1337     switch (type) {
1338     case OP_SASSIGN:
1339         if (o->op_type == OP_RV2GV)
1340             return FALSE;
1341         /* FALL THROUGH */
1342     case OP_PREINC:
1343     case OP_PREDEC:
1344     case OP_POSTINC:
1345     case OP_POSTDEC:
1346     case OP_I_PREINC:
1347     case OP_I_PREDEC:
1348     case OP_I_POSTINC:
1349     case OP_I_POSTDEC:
1350     case OP_POW:
1351     case OP_MULTIPLY:
1352     case OP_DIVIDE:
1353     case OP_MODULO:
1354     case OP_REPEAT:
1355     case OP_ADD:
1356     case OP_SUBTRACT:
1357     case OP_I_MULTIPLY:
1358     case OP_I_DIVIDE:
1359     case OP_I_MODULO:
1360     case OP_I_ADD:
1361     case OP_I_SUBTRACT:
1362     case OP_LEFT_SHIFT:
1363     case OP_RIGHT_SHIFT:
1364     case OP_BIT_AND:
1365     case OP_BIT_XOR:
1366     case OP_BIT_OR:
1367     case OP_CONCAT:
1368     case OP_SUBST:
1369     case OP_TRANS:
1370     case OP_READ:
1371     case OP_SYSREAD:
1372     case OP_RECV:
1373     case OP_ANDASSIGN:
1374     case OP_ORASSIGN:
1375         return TRUE;
1376     default:
1377         return FALSE;
1378     }
1379 }
1380
1381 STATIC bool
1382 S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
1383 {
1384     switch (o->op_type) {
1385     case OP_PIPE_OP:
1386     case OP_SOCKPAIR:
1387         if (argnum == 2)
1388             return TRUE;
1389         /* FALL THROUGH */
1390     case OP_SYSOPEN:
1391     case OP_OPEN:
1392     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1393     case OP_SOCKET:
1394     case OP_OPEN_DIR:
1395     case OP_ACCEPT:
1396         if (argnum == 1)
1397             return TRUE;
1398         /* FALL THROUGH */
1399     default:
1400         return FALSE;
1401     }
1402 }
1403
1404 OP *
1405 Perl_refkids(pTHX_ OP *o, I32 type)
1406 {
1407     if (o && o->op_flags & OPf_KIDS) {
1408         OP *kid;
1409         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1410             ref(kid, type);
1411     }
1412     return o;
1413 }
1414
1415 OP *
1416 Perl_ref(pTHX_ OP *o, I32 type)
1417 {
1418     dVAR;
1419     OP *kid;
1420
1421     if (!o || PL_error_count)
1422         return o;
1423
1424     switch (o->op_type) {
1425     case OP_ENTERSUB:
1426         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1427             !(o->op_flags & OPf_STACKED)) {
1428             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1429             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1430             assert(cUNOPo->op_first->op_type == OP_NULL);
1431             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1432             o->op_flags |= OPf_SPECIAL;
1433         }
1434         break;
1435
1436     case OP_COND_EXPR:
1437         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1438             ref(kid, type);
1439         break;
1440     case OP_RV2SV:
1441         if (type == OP_DEFINED)
1442             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1443         ref(cUNOPo->op_first, o->op_type);
1444         /* FALL THROUGH */
1445     case OP_PADSV:
1446         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1447             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1448                               : type == OP_RV2HV ? OPpDEREF_HV
1449                               : OPpDEREF_SV);
1450             o->op_flags |= OPf_MOD;
1451         }
1452         break;
1453
1454     case OP_THREADSV:
1455         o->op_flags |= OPf_MOD;         /* XXX ??? */
1456         break;
1457
1458     case OP_RV2AV:
1459     case OP_RV2HV:
1460         o->op_flags |= OPf_REF;
1461         /* FALL THROUGH */
1462     case OP_RV2GV:
1463         if (type == OP_DEFINED)
1464             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1465         ref(cUNOPo->op_first, o->op_type);
1466         break;
1467
1468     case OP_PADAV:
1469     case OP_PADHV:
1470         o->op_flags |= OPf_REF;
1471         break;
1472
1473     case OP_SCALAR:
1474     case OP_NULL:
1475         if (!(o->op_flags & OPf_KIDS))
1476             break;
1477         ref(cBINOPo->op_first, type);
1478         break;
1479     case OP_AELEM:
1480     case OP_HELEM:
1481         ref(cBINOPo->op_first, o->op_type);
1482         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1483             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1484                               : type == OP_RV2HV ? OPpDEREF_HV
1485                               : OPpDEREF_SV);
1486             o->op_flags |= OPf_MOD;
1487         }
1488         break;
1489
1490     case OP_SCOPE:
1491     case OP_LEAVE:
1492     case OP_ENTER:
1493     case OP_LIST:
1494         if (!(o->op_flags & OPf_KIDS))
1495             break;
1496         ref(cLISTOPo->op_last, type);
1497         break;
1498     default:
1499         break;
1500     }
1501     return scalar(o);
1502
1503 }
1504
1505 STATIC OP *
1506 S_dup_attrlist(pTHX_ OP *o)
1507 {
1508     OP *rop = Nullop;
1509
1510     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1511      * where the first kid is OP_PUSHMARK and the remaining ones
1512      * are OP_CONST.  We need to push the OP_CONST values.
1513      */
1514     if (o->op_type == OP_CONST)
1515         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1516     else {
1517         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1518         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1519             if (o->op_type == OP_CONST)
1520                 rop = append_elem(OP_LIST, rop,
1521                                   newSVOP(OP_CONST, o->op_flags,
1522                                           SvREFCNT_inc(cSVOPo->op_sv)));
1523         }
1524     }
1525     return rop;
1526 }
1527
1528 STATIC void
1529 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1530 {
1531     dVAR;
1532     SV *stashsv;
1533
1534     /* fake up C<use attributes $pkg,$rv,@attrs> */
1535     ENTER;              /* need to protect against side-effects of 'use' */
1536     SAVEINT(PL_expect);
1537     if (stash)
1538         stashsv = newSVpv(HvNAME(stash), 0);
1539     else
1540         stashsv = &PL_sv_no;
1541
1542 #define ATTRSMODULE "attributes"
1543 #define ATTRSMODULE_PM "attributes.pm"
1544
1545     if (for_my) {
1546         SV **svp;
1547         /* Don't force the C<use> if we don't need it. */
1548         svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1549                        sizeof(ATTRSMODULE_PM)-1, 0);
1550         if (svp && *svp != &PL_sv_undef)
1551             ;           /* already in %INC */
1552         else
1553             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1554                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1555                              Nullsv);
1556     }
1557     else {
1558         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1559                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1560                          Nullsv,
1561                          prepend_elem(OP_LIST,
1562                                       newSVOP(OP_CONST, 0, stashsv),
1563                                       prepend_elem(OP_LIST,
1564                                                    newSVOP(OP_CONST, 0,
1565                                                            newRV(target)),
1566                                                    dup_attrlist(attrs))));
1567     }
1568     LEAVE;
1569 }
1570
1571 STATIC void
1572 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1573 {
1574     OP *pack, *imop, *arg;
1575     SV *meth, *stashsv;
1576
1577     if (!attrs)
1578         return;
1579
1580     assert(target->op_type == OP_PADSV ||
1581            target->op_type == OP_PADHV ||
1582            target->op_type == OP_PADAV);
1583
1584     /* Ensure that attributes.pm is loaded. */
1585     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1586
1587     /* Need package name for method call. */
1588     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1589
1590     /* Build up the real arg-list. */
1591     if (stash)
1592         stashsv = newSVpv(HvNAME(stash), 0);
1593     else
1594         stashsv = &PL_sv_no;
1595     arg = newOP(OP_PADSV, 0);
1596     arg->op_targ = target->op_targ;
1597     arg = prepend_elem(OP_LIST,
1598                        newSVOP(OP_CONST, 0, stashsv),
1599                        prepend_elem(OP_LIST,
1600                                     newUNOP(OP_REFGEN, 0,
1601                                             mod(arg, OP_REFGEN)),
1602                                     dup_attrlist(attrs)));
1603
1604     /* Fake up a method call to import */
1605     meth = newSVpvn("import", 6);
1606     (void)SvUPGRADE(meth, SVt_PVIV);
1607     (void)SvIOK_on(meth);
1608     {
1609         U32 hash;
1610         PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
1611         SvUV_set(meth, hash);
1612     }
1613     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1614                    append_elem(OP_LIST,
1615                                prepend_elem(OP_LIST, pack, list(arg)),
1616                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1617     imop->op_private |= OPpENTERSUB_NOMOD;
1618
1619     /* Combine the ops. */
1620     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1621 }
1622
1623 /*
1624 =notfor apidoc apply_attrs_string
1625
1626 Attempts to apply a list of attributes specified by the C<attrstr> and
1627 C<len> arguments to the subroutine identified by the C<cv> argument which
1628 is expected to be associated with the package identified by the C<stashpv>
1629 argument (see L<attributes>).  It gets this wrong, though, in that it
1630 does not correctly identify the boundaries of the individual attribute
1631 specifications within C<attrstr>.  This is not really intended for the
1632 public API, but has to be listed here for systems such as AIX which
1633 need an explicit export list for symbols.  (It's called from XS code
1634 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1635 to respect attribute syntax properly would be welcome.
1636
1637 =cut
1638 */
1639
1640 void
1641 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1642                         const char *attrstr, STRLEN len)
1643 {
1644     OP *attrs = Nullop;
1645
1646     if (!len) {
1647         len = strlen(attrstr);
1648     }
1649
1650     while (len) {
1651         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1652         if (len) {
1653             const char *sstr = attrstr;
1654             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1655             attrs = append_elem(OP_LIST, attrs,
1656                                 newSVOP(OP_CONST, 0,
1657                                         newSVpvn(sstr, attrstr-sstr)));
1658         }
1659     }
1660
1661     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1662                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1663                      Nullsv, prepend_elem(OP_LIST,
1664                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1665                                   prepend_elem(OP_LIST,
1666                                                newSVOP(OP_CONST, 0,
1667                                                        newRV((SV*)cv)),
1668                                                attrs)));
1669 }
1670
1671 STATIC OP *
1672 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1673 {
1674     I32 type;
1675
1676     if (!o || PL_error_count)
1677         return o;
1678
1679     type = o->op_type;
1680     if (type == OP_LIST) {
1681         OP *kid;
1682         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1683             my_kid(kid, attrs, imopsp);
1684     } else if (type == OP_UNDEF) {
1685         return o;
1686     } else if (type == OP_RV2SV ||      /* "our" declaration */
1687                type == OP_RV2AV ||
1688                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1689         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1690             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1691                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1692         } else if (attrs) {
1693             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1694             PL_in_my = FALSE;
1695             PL_in_my_stash = Nullhv;
1696             apply_attrs(GvSTASH(gv),
1697                         (type == OP_RV2SV ? GvSV(gv) :
1698                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1699                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1700                         attrs, FALSE);
1701         }
1702         o->op_private |= OPpOUR_INTRO;
1703         return o;
1704     }
1705     else if (type != OP_PADSV &&
1706              type != OP_PADAV &&
1707              type != OP_PADHV &&
1708              type != OP_PUSHMARK)
1709     {
1710         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1711                           OP_DESC(o),
1712                           PL_in_my == KEY_our ? "our" : "my"));
1713         return o;
1714     }
1715     else if (attrs && type != OP_PUSHMARK) {
1716         HV *stash;
1717
1718         PL_in_my = FALSE;
1719         PL_in_my_stash = Nullhv;
1720
1721         /* check for C<my Dog $spot> when deciding package */
1722         stash = PAD_COMPNAME_TYPE(o->op_targ);
1723         if (!stash)
1724             stash = PL_curstash;
1725         apply_attrs_my(stash, o, attrs, imopsp);
1726     }
1727     o->op_flags |= OPf_MOD;
1728     o->op_private |= OPpLVAL_INTRO;
1729     return o;
1730 }
1731
1732 OP *
1733 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1734 {
1735     OP *rops = Nullop;
1736     int maybe_scalar = 0;
1737
1738 /* [perl #17376]: this appears to be premature, and results in code such as
1739    C< our(%x); > executing in list mode rather than void mode */
1740 #if 0
1741     if (o->op_flags & OPf_PARENS)
1742         list(o);
1743     else
1744         maybe_scalar = 1;
1745 #else
1746     maybe_scalar = 1;
1747 #endif
1748     if (attrs)
1749         SAVEFREEOP(attrs);
1750     o = my_kid(o, attrs, &rops);
1751     if (rops) {
1752         if (maybe_scalar && o->op_type == OP_PADSV) {
1753             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1754             o->op_private |= OPpLVAL_INTRO;
1755         }
1756         else
1757             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1758     }
1759     PL_in_my = FALSE;
1760     PL_in_my_stash = Nullhv;
1761     return o;
1762 }
1763
1764 OP *
1765 Perl_my(pTHX_ OP *o)
1766 {
1767     return my_attrs(o, Nullop);
1768 }
1769
1770 OP *
1771 Perl_sawparens(pTHX_ OP *o)
1772 {
1773     if (o)
1774         o->op_flags |= OPf_PARENS;
1775     return o;
1776 }
1777
1778 OP *
1779 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1780 {
1781     OP *o;
1782     bool ismatchop = 0;
1783
1784     if (ckWARN(WARN_MISC) &&
1785       (left->op_type == OP_RV2AV ||
1786        left->op_type == OP_RV2HV ||
1787        left->op_type == OP_PADAV ||
1788        left->op_type == OP_PADHV)) {
1789       const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1790                             right->op_type == OP_TRANS)
1791                            ? right->op_type : OP_MATCH];
1792       const char *sample = ((left->op_type == OP_RV2AV ||
1793                              left->op_type == OP_PADAV)
1794                             ? "@array" : "%hash");
1795       Perl_warner(aTHX_ packWARN(WARN_MISC),
1796              "Applying %s to %s will act on scalar(%s)",
1797              desc, sample, sample);
1798     }
1799
1800     if (right->op_type == OP_CONST &&
1801         cSVOPx(right)->op_private & OPpCONST_BARE &&
1802         cSVOPx(right)->op_private & OPpCONST_STRICT)
1803     {
1804         no_bareword_allowed(right);
1805     }
1806
1807     ismatchop = right->op_type == OP_MATCH ||
1808                 right->op_type == OP_SUBST ||
1809                 right->op_type == OP_TRANS;
1810     if (ismatchop && right->op_private & OPpTARGET_MY) {
1811         right->op_targ = 0;
1812         right->op_private &= ~OPpTARGET_MY;
1813     }
1814     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1815         right->op_flags |= OPf_STACKED;
1816         if (right->op_type != OP_MATCH &&
1817             ! (right->op_type == OP_TRANS &&
1818                right->op_private & OPpTRANS_IDENTICAL))
1819             left = mod(left, right->op_type);
1820         if (right->op_type == OP_TRANS)
1821             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1822         else
1823             o = prepend_elem(right->op_type, scalar(left), right);
1824         if (type == OP_NOT)
1825             return newUNOP(OP_NOT, 0, scalar(o));
1826         return o;
1827     }
1828     else
1829         return bind_match(type, left,
1830                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1831 }
1832
1833 OP *
1834 Perl_invert(pTHX_ OP *o)
1835 {
1836     if (!o)
1837         return o;
1838     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1839     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1840 }
1841
1842 OP *
1843 Perl_scope(pTHX_ OP *o)
1844 {
1845     dVAR;
1846     if (o) {
1847         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1848             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1849             o->op_type = OP_LEAVE;
1850             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1851         }
1852         else if (o->op_type == OP_LINESEQ) {
1853             OP *kid;
1854             o->op_type = OP_SCOPE;
1855             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1856             kid = ((LISTOP*)o)->op_first;
1857             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1858                 op_null(kid);
1859         }
1860         else
1861             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1862     }
1863     return o;
1864 }
1865
1866 /* XXX kept for BINCOMPAT only */
1867 void
1868 Perl_save_hints(pTHX)
1869 {
1870     Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1871 }
1872
1873 int
1874 Perl_block_start(pTHX_ int full)
1875 {
1876     const int retval = PL_savestack_ix;
1877     pad_block_start(full);
1878     SAVEHINTS();
1879     PL_hints &= ~HINT_BLOCK_SCOPE;
1880     SAVESPTR(PL_compiling.cop_warnings);
1881     if (! specialWARN(PL_compiling.cop_warnings)) {
1882         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1883         SAVEFREESV(PL_compiling.cop_warnings) ;
1884     }
1885     SAVESPTR(PL_compiling.cop_io);
1886     if (! specialCopIO(PL_compiling.cop_io)) {
1887         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1888         SAVEFREESV(PL_compiling.cop_io) ;
1889     }
1890     return retval;
1891 }
1892
1893 OP*
1894 Perl_block_end(pTHX_ I32 floor, OP *seq)
1895 {
1896     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1897     OP* retval = scalarseq(seq);
1898     LEAVE_SCOPE(floor);
1899     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1900     if (needblockscope)
1901         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1902     pad_leavemy();
1903     return retval;
1904 }
1905
1906 STATIC OP *
1907 S_newDEFSVOP(pTHX)
1908 {
1909     const I32 offset = pad_findmy("$_");
1910     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1911         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1912     }
1913     else {
1914         OP *o = newOP(OP_PADSV, 0);
1915         o->op_targ = offset;
1916         return o;
1917     }
1918 }
1919
1920 void
1921 Perl_newPROG(pTHX_ OP *o)
1922 {
1923     if (PL_in_eval) {
1924         if (PL_eval_root)
1925                 return;
1926         PL_eval_root = newUNOP(OP_LEAVEEVAL,
1927                                ((PL_in_eval & EVAL_KEEPERR)
1928                                 ? OPf_SPECIAL : 0), o);
1929         PL_eval_start = linklist(PL_eval_root);
1930         PL_eval_root->op_private |= OPpREFCOUNTED;
1931         OpREFCNT_set(PL_eval_root, 1);
1932         PL_eval_root->op_next = 0;
1933         CALL_PEEP(PL_eval_start);
1934     }
1935     else {
1936         if (o->op_type == OP_STUB) {
1937             PL_comppad_name = 0;
1938             PL_compcv = 0;
1939             FreeOp(o);
1940             return;
1941         }
1942         PL_main_root = scope(sawparens(scalarvoid(o)));
1943         PL_curcop = &PL_compiling;
1944         PL_main_start = LINKLIST(PL_main_root);
1945         PL_main_root->op_private |= OPpREFCOUNTED;
1946         OpREFCNT_set(PL_main_root, 1);
1947         PL_main_root->op_next = 0;
1948         CALL_PEEP(PL_main_start);
1949         PL_compcv = 0;
1950
1951         /* Register with debugger */
1952         if (PERLDB_INTER) {
1953             CV *cv = get_cv("DB::postponed", FALSE);
1954             if (cv) {
1955                 dSP;
1956                 PUSHMARK(SP);
1957                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1958                 PUTBACK;
1959                 call_sv((SV*)cv, G_DISCARD);
1960             }
1961         }
1962     }
1963 }
1964
1965 OP *
1966 Perl_localize(pTHX_ OP *o, I32 lex)
1967 {
1968     if (o->op_flags & OPf_PARENS)
1969 /* [perl #17376]: this appears to be premature, and results in code such as
1970    C< our(%x); > executing in list mode rather than void mode */
1971 #if 0
1972         list(o);
1973 #else
1974         ;
1975 #endif
1976     else {
1977         if (ckWARN(WARN_PARENTHESIS)
1978             && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1979         {
1980             char *s = PL_bufptr;
1981             bool sigil = FALSE;
1982
1983             /* some heuristics to detect a potential error */
1984             while (*s && (strchr(", \t\n", *s)))
1985                 s++;
1986
1987             while (1) {
1988                 if (*s && strchr("@$%*", *s) && *++s
1989                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1990                     s++;
1991                     sigil = TRUE;
1992                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1993                         s++;
1994                     while (*s && (strchr(", \t\n", *s)))
1995                         s++;
1996                 }
1997                 else
1998                     break;
1999             }
2000             if (sigil && (*s == ';' || *s == '=')) {
2001                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2002                                 "Parentheses missing around \"%s\" list",
2003                                 lex ? (PL_in_my == KEY_our ? "our" : "my")
2004                                 : "local");
2005             }
2006         }
2007     }
2008     if (lex)
2009         o = my(o);
2010     else
2011         o = mod(o, OP_NULL);            /* a bit kludgey */
2012     PL_in_my = FALSE;
2013     PL_in_my_stash = Nullhv;
2014     return o;
2015 }
2016
2017 OP *
2018 Perl_jmaybe(pTHX_ OP *o)
2019 {
2020     if (o->op_type == OP_LIST) {
2021         OP *o2;
2022         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2023         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2024     }
2025     return o;
2026 }
2027
2028 OP *
2029 Perl_fold_constants(pTHX_ register OP *o)
2030 {
2031     dVAR;
2032     register OP *curop;
2033     I32 type = o->op_type;
2034     SV *sv;
2035
2036     if (PL_opargs[type] & OA_RETSCALAR)
2037         scalar(o);
2038     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2039         o->op_targ = pad_alloc(type, SVs_PADTMP);
2040
2041     /* integerize op, unless it happens to be C<-foo>.
2042      * XXX should pp_i_negate() do magic string negation instead? */
2043     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2044         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2045              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2046     {
2047         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2048     }
2049
2050     if (!(PL_opargs[type] & OA_FOLDCONST))
2051         goto nope;
2052
2053     switch (type) {
2054     case OP_NEGATE:
2055         /* XXX might want a ck_negate() for this */
2056         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2057         break;
2058     case OP_SPRINTF:
2059     case OP_UCFIRST:
2060     case OP_LCFIRST:
2061     case OP_UC:
2062     case OP_LC:
2063     case OP_SLT:
2064     case OP_SGT:
2065     case OP_SLE:
2066     case OP_SGE:
2067     case OP_SCMP:
2068         /* XXX what about the numeric ops? */
2069         if (PL_hints & HINT_LOCALE)
2070             goto nope;
2071     }
2072
2073     if (PL_error_count)
2074         goto nope;              /* Don't try to run w/ errors */
2075
2076     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2077         if ((curop->op_type != OP_CONST ||
2078              (curop->op_private & OPpCONST_BARE)) &&
2079             curop->op_type != OP_LIST &&
2080             curop->op_type != OP_SCALAR &&
2081             curop->op_type != OP_NULL &&
2082             curop->op_type != OP_PUSHMARK)
2083         {
2084             goto nope;
2085         }
2086     }
2087
2088     curop = LINKLIST(o);
2089     o->op_next = 0;
2090     PL_op = curop;
2091     CALLRUNOPS(aTHX);
2092     sv = *(PL_stack_sp--);
2093     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2094         pad_swipe(o->op_targ,  FALSE);
2095     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2096         (void)SvREFCNT_inc(sv);
2097         SvTEMP_off(sv);
2098     }
2099     op_free(o);
2100     if (type == OP_RV2GV)
2101         return newGVOP(OP_GV, 0, (GV*)sv);
2102     return newSVOP(OP_CONST, 0, sv);
2103
2104   nope:
2105     return o;
2106 }
2107
2108 OP *
2109 Perl_gen_constant_list(pTHX_ register OP *o)
2110 {
2111     dVAR;
2112     register OP *curop;
2113     const I32 oldtmps_floor = PL_tmps_floor;
2114
2115     list(o);
2116     if (PL_error_count)
2117         return o;               /* Don't attempt to run with errors */
2118
2119     PL_op = curop = LINKLIST(o);
2120     o->op_next = 0;
2121     CALL_PEEP(curop);
2122     pp_pushmark();
2123     CALLRUNOPS(aTHX);
2124     PL_op = curop;
2125     pp_anonlist();
2126     PL_tmps_floor = oldtmps_floor;
2127
2128     o->op_type = OP_RV2AV;
2129     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2130     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2131     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2132     o->op_opt = 0;              /* needs to be revisited in peep() */
2133     curop = ((UNOP*)o)->op_first;
2134     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2135     op_free(curop);
2136     linklist(o);
2137     return list(o);
2138 }
2139
2140 OP *
2141 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2142 {
2143     dVAR;
2144     if (!o || o->op_type != OP_LIST)
2145         o = newLISTOP(OP_LIST, 0, o, Nullop);
2146     else
2147         o->op_flags &= ~OPf_WANT;
2148
2149     if (!(PL_opargs[type] & OA_MARK))
2150         op_null(cLISTOPo->op_first);
2151
2152     o->op_type = (OPCODE)type;
2153     o->op_ppaddr = PL_ppaddr[type];
2154     o->op_flags |= flags;
2155
2156     o = CHECKOP(type, o);
2157     if (o->op_type != (unsigned)type)
2158         return o;
2159
2160     return fold_constants(o);
2161 }
2162
2163 /* List constructors */
2164
2165 OP *
2166 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2167 {
2168     if (!first)
2169         return last;
2170
2171     if (!last)
2172         return first;
2173
2174     if (first->op_type != (unsigned)type
2175         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2176     {
2177         return newLISTOP(type, 0, first, last);
2178     }
2179
2180     if (first->op_flags & OPf_KIDS)
2181         ((LISTOP*)first)->op_last->op_sibling = last;
2182     else {
2183         first->op_flags |= OPf_KIDS;
2184         ((LISTOP*)first)->op_first = last;
2185     }
2186     ((LISTOP*)first)->op_last = last;
2187     return first;
2188 }
2189
2190 OP *
2191 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2192 {
2193     if (!first)
2194         return (OP*)last;
2195
2196     if (!last)
2197         return (OP*)first;
2198
2199     if (first->op_type != (unsigned)type)
2200         return prepend_elem(type, (OP*)first, (OP*)last);
2201
2202     if (last->op_type != (unsigned)type)
2203         return append_elem(type, (OP*)first, (OP*)last);
2204
2205     first->op_last->op_sibling = last->op_first;
2206     first->op_last = last->op_last;
2207     first->op_flags |= (last->op_flags & OPf_KIDS);
2208
2209     FreeOp(last);
2210
2211     return (OP*)first;
2212 }
2213
2214 OP *
2215 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2216 {
2217     if (!first)
2218         return last;
2219
2220     if (!last)
2221         return first;
2222
2223     if (last->op_type == (unsigned)type) {
2224         if (type == OP_LIST) {  /* already a PUSHMARK there */
2225             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2226             ((LISTOP*)last)->op_first->op_sibling = first;
2227             if (!(first->op_flags & OPf_PARENS))
2228                 last->op_flags &= ~OPf_PARENS;
2229         }
2230         else {
2231             if (!(last->op_flags & OPf_KIDS)) {
2232                 ((LISTOP*)last)->op_last = first;
2233                 last->op_flags |= OPf_KIDS;
2234             }
2235             first->op_sibling = ((LISTOP*)last)->op_first;
2236             ((LISTOP*)last)->op_first = first;
2237         }
2238         last->op_flags |= OPf_KIDS;
2239         return last;
2240     }
2241
2242     return newLISTOP(type, 0, first, last);
2243 }
2244
2245 /* Constructors */
2246
2247 OP *
2248 Perl_newNULLLIST(pTHX)
2249 {
2250     return newOP(OP_STUB, 0);
2251 }
2252
2253 OP *
2254 Perl_force_list(pTHX_ OP *o)
2255 {
2256     if (!o || o->op_type != OP_LIST)
2257         o = newLISTOP(OP_LIST, 0, o, Nullop);
2258     op_null(o);
2259     return o;
2260 }
2261
2262 OP *
2263 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2264 {
2265     dVAR;
2266     LISTOP *listop;
2267
2268     NewOp(1101, listop, 1, LISTOP);
2269
2270     listop->op_type = (OPCODE)type;
2271     listop->op_ppaddr = PL_ppaddr[type];
2272     if (first || last)
2273         flags |= OPf_KIDS;
2274     listop->op_flags = (U8)flags;
2275
2276     if (!last && first)
2277         last = first;
2278     else if (!first && last)
2279         first = last;
2280     else if (first)
2281         first->op_sibling = last;
2282     listop->op_first = first;
2283     listop->op_last = last;
2284     if (type == OP_LIST) {
2285         OP* pushop;
2286         pushop = newOP(OP_PUSHMARK, 0);
2287         pushop->op_sibling = first;
2288         listop->op_first = pushop;
2289         listop->op_flags |= OPf_KIDS;
2290         if (!last)
2291             listop->op_last = pushop;
2292     }
2293
2294     return CHECKOP(type, listop);
2295 }
2296
2297 OP *
2298 Perl_newOP(pTHX_ I32 type, I32 flags)
2299 {
2300     dVAR;
2301     OP *o;
2302     NewOp(1101, o, 1, OP);
2303     o->op_type = (OPCODE)type;
2304     o->op_ppaddr = PL_ppaddr[type];
2305     o->op_flags = (U8)flags;
2306
2307     o->op_next = o;
2308     o->op_private = (U8)(0 | (flags >> 8));
2309     if (PL_opargs[type] & OA_RETSCALAR)
2310         scalar(o);
2311     if (PL_opargs[type] & OA_TARGET)
2312         o->op_targ = pad_alloc(type, SVs_PADTMP);
2313     return CHECKOP(type, o);
2314 }
2315
2316 OP *
2317 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2318 {
2319     dVAR;
2320     UNOP *unop;
2321
2322     if (!first)
2323         first = newOP(OP_STUB, 0);
2324     if (PL_opargs[type] & OA_MARK)
2325         first = force_list(first);
2326
2327     NewOp(1101, unop, 1, UNOP);
2328     unop->op_type = (OPCODE)type;
2329     unop->op_ppaddr = PL_ppaddr[type];
2330     unop->op_first = first;
2331     unop->op_flags = flags | OPf_KIDS;
2332     unop->op_private = (U8)(1 | (flags >> 8));
2333     unop = (UNOP*) CHECKOP(type, unop);
2334     if (unop->op_next)
2335         return (OP*)unop;
2336
2337     return fold_constants((OP *) unop);
2338 }
2339
2340 OP *
2341 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2342 {
2343     dVAR;
2344     BINOP *binop;
2345     NewOp(1101, binop, 1, BINOP);
2346
2347     if (!first)
2348         first = newOP(OP_NULL, 0);
2349
2350     binop->op_type = (OPCODE)type;
2351     binop->op_ppaddr = PL_ppaddr[type];
2352     binop->op_first = first;
2353     binop->op_flags = flags | OPf_KIDS;
2354     if (!last) {
2355         last = first;
2356         binop->op_private = (U8)(1 | (flags >> 8));
2357     }
2358     else {
2359         binop->op_private = (U8)(2 | (flags >> 8));
2360         first->op_sibling = last;
2361     }
2362
2363     binop = (BINOP*)CHECKOP(type, binop);
2364     if (binop->op_next || binop->op_type != (OPCODE)type)
2365         return (OP*)binop;
2366
2367     binop->op_last = binop->op_first->op_sibling;
2368
2369     return fold_constants((OP *)binop);
2370 }
2371
2372 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2373 static int uvcompare(const void *a, const void *b)
2374 {
2375     if (*((const UV *)a) < (*(const UV *)b))
2376         return -1;
2377     if (*((const UV *)a) > (*(const UV *)b))
2378         return 1;
2379     if (*((const UV *)a+1) < (*(const UV *)b+1))
2380         return -1;
2381     if (*((const UV *)a+1) > (*(const UV *)b+1))
2382         return 1;
2383     return 0;
2384 }
2385
2386 OP *
2387 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2388 {
2389     SV *tstr = ((SVOP*)expr)->op_sv;
2390     SV *rstr = ((SVOP*)repl)->op_sv;
2391     STRLEN tlen;
2392     STRLEN rlen;
2393     U8 *t = (U8*)SvPV(tstr, tlen);
2394     U8 *r = (U8*)SvPV(rstr, rlen);
2395     register I32 i;
2396     register I32 j;
2397     I32 del;
2398     I32 complement;
2399     I32 squash;
2400     I32 grows = 0;
2401     register short *tbl;
2402
2403     PL_hints |= HINT_BLOCK_SCOPE;
2404     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2405     del         = o->op_private & OPpTRANS_DELETE;
2406     squash      = o->op_private & OPpTRANS_SQUASH;
2407
2408     if (SvUTF8(tstr))
2409         o->op_private |= OPpTRANS_FROM_UTF;
2410
2411     if (SvUTF8(rstr))
2412         o->op_private |= OPpTRANS_TO_UTF;
2413
2414     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2415         SV* listsv = newSVpvn("# comment\n",10);
2416         SV* transv = 0;
2417         U8* tend = t + tlen;
2418         U8* rend = r + rlen;
2419         STRLEN ulen;
2420         UV tfirst = 1;
2421         UV tlast = 0;
2422         IV tdiff;
2423         UV rfirst = 1;
2424         UV rlast = 0;
2425         IV rdiff;
2426         IV diff;
2427         I32 none = 0;
2428         U32 max = 0;
2429         I32 bits;
2430         I32 havefinal = 0;
2431         U32 final = 0;
2432         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2433         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2434         U8* tsave = NULL;
2435         U8* rsave = NULL;
2436
2437         if (!from_utf) {
2438             STRLEN len = tlen;
2439             tsave = t = bytes_to_utf8(t, &len);
2440             tend = t + len;
2441         }
2442         if (!to_utf && rlen) {
2443             STRLEN len = rlen;
2444             rsave = r = bytes_to_utf8(r, &len);
2445             rend = r + len;
2446         }
2447
2448 /* There are several snags with this code on EBCDIC:
2449    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2450    2. scan_const() in toke.c has encoded chars in native encoding which makes
2451       ranges at least in EBCDIC 0..255 range the bottom odd.
2452 */
2453
2454         if (complement) {
2455             U8 tmpbuf[UTF8_MAXBYTES+1];
2456             UV *cp;
2457             UV nextmin = 0;
2458             New(1109, cp, 2*tlen, UV);
2459             i = 0;
2460             transv = newSVpvn("",0);
2461             while (t < tend) {
2462                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2463                 t += ulen;
2464                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2465                     t++;
2466                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2467                     t += ulen;
2468                 }
2469                 else {
2470                  cp[2*i+1] = cp[2*i];
2471                 }
2472                 i++;
2473             }
2474             qsort(cp, i, 2*sizeof(UV), uvcompare);
2475             for (j = 0; j < i; j++) {
2476                 UV  val = cp[2*j];
2477                 diff = val - nextmin;
2478                 if (diff > 0) {
2479                     t = uvuni_to_utf8(tmpbuf,nextmin);
2480                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2481                     if (diff > 1) {
2482                         U8  range_mark = UTF_TO_NATIVE(0xff);
2483                         t = uvuni_to_utf8(tmpbuf, val - 1);
2484                         sv_catpvn(transv, (char *)&range_mark, 1);
2485                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2486                     }
2487                 }
2488                 val = cp[2*j+1];
2489                 if (val >= nextmin)
2490                     nextmin = val + 1;
2491             }
2492             t = uvuni_to_utf8(tmpbuf,nextmin);
2493             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2494             {
2495                 U8 range_mark = UTF_TO_NATIVE(0xff);
2496                 sv_catpvn(transv, (char *)&range_mark, 1);
2497             }
2498             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2499                                     UNICODE_ALLOW_SUPER);
2500             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2501             t = (U8*)SvPVX(transv);
2502             tlen = SvCUR(transv);
2503             tend = t + tlen;
2504             Safefree(cp);
2505         }
2506         else if (!rlen && !del) {
2507             r = t; rlen = tlen; rend = tend;
2508         }
2509         if (!squash) {
2510                 if ((!rlen && !del) || t == r ||
2511                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2512                 {
2513                     o->op_private |= OPpTRANS_IDENTICAL;
2514                 }
2515         }
2516
2517         while (t < tend || tfirst <= tlast) {
2518             /* see if we need more "t" chars */
2519             if (tfirst > tlast) {
2520                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2521                 t += ulen;
2522                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2523                     t++;
2524                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2525                     t += ulen;
2526                 }
2527                 else
2528                     tlast = tfirst;
2529             }
2530
2531             /* now see if we need more "r" chars */
2532             if (rfirst > rlast) {
2533                 if (r < rend) {
2534                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2535                     r += ulen;
2536                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2537                         r++;
2538                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2539                         r += ulen;
2540                     }
2541                     else
2542                         rlast = rfirst;
2543                 }
2544                 else {
2545                     if (!havefinal++)
2546                         final = rlast;
2547                     rfirst = rlast = 0xffffffff;
2548                 }
2549             }
2550
2551             /* now see which range will peter our first, if either. */
2552             tdiff = tlast - tfirst;
2553             rdiff = rlast - rfirst;
2554
2555             if (tdiff <= rdiff)
2556                 diff = tdiff;
2557             else
2558                 diff = rdiff;
2559
2560             if (rfirst == 0xffffffff) {
2561                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2562                 if (diff > 0)
2563                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2564                                    (long)tfirst, (long)tlast);
2565                 else
2566                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2567             }
2568             else {
2569                 if (diff > 0)
2570                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2571                                    (long)tfirst, (long)(tfirst + diff),
2572                                    (long)rfirst);
2573                 else
2574                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2575                                    (long)tfirst, (long)rfirst);
2576
2577                 if (rfirst + diff > max)
2578                     max = rfirst + diff;
2579                 if (!grows)
2580                     grows = (tfirst < rfirst &&
2581                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2582                 rfirst += diff + 1;
2583             }
2584             tfirst += diff + 1;
2585         }
2586
2587         none = ++max;
2588         if (del)
2589             del = ++max;
2590
2591         if (max > 0xffff)
2592             bits = 32;
2593         else if (max > 0xff)
2594             bits = 16;
2595         else
2596             bits = 8;
2597
2598         Safefree(cPVOPo->op_pv);
2599         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2600         SvREFCNT_dec(listsv);
2601         if (transv)
2602             SvREFCNT_dec(transv);
2603
2604         if (!del && havefinal && rlen)
2605             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2606                            newSVuv((UV)final), 0);
2607
2608         if (grows)
2609             o->op_private |= OPpTRANS_GROWS;
2610
2611         if (tsave)
2612             Safefree(tsave);
2613         if (rsave)
2614             Safefree(rsave);
2615
2616         op_free(expr);
2617         op_free(repl);
2618         return o;
2619     }
2620
2621     tbl = (short*)cPVOPo->op_pv;
2622     if (complement) {
2623         Zero(tbl, 256, short);
2624         for (i = 0; i < (I32)tlen; i++)
2625             tbl[t[i]] = -1;
2626         for (i = 0, j = 0; i < 256; i++) {
2627             if (!tbl[i]) {
2628                 if (j >= (I32)rlen) {
2629                     if (del)
2630                         tbl[i] = -2;
2631                     else if (rlen)
2632                         tbl[i] = r[j-1];
2633                     else
2634                         tbl[i] = (short)i;
2635                 }
2636                 else {
2637                     if (i < 128 && r[j] >= 128)
2638                         grows = 1;
2639                     tbl[i] = r[j++];
2640                 }
2641             }
2642         }
2643         if (!del) {
2644             if (!rlen) {
2645                 j = rlen;
2646                 if (!squash)
2647                     o->op_private |= OPpTRANS_IDENTICAL;
2648             }
2649             else if (j >= (I32)rlen)
2650                 j = rlen - 1;
2651             else
2652                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2653             tbl[0x100] = rlen - j;
2654             for (i=0; i < (I32)rlen - j; i++)
2655                 tbl[0x101+i] = r[j+i];
2656         }
2657     }
2658     else {
2659         if (!rlen && !del) {
2660             r = t; rlen = tlen;
2661             if (!squash)
2662                 o->op_private |= OPpTRANS_IDENTICAL;
2663         }
2664         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2665             o->op_private |= OPpTRANS_IDENTICAL;
2666         }
2667         for (i = 0; i < 256; i++)
2668             tbl[i] = -1;
2669         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2670             if (j >= (I32)rlen) {
2671                 if (del) {
2672                     if (tbl[t[i]] == -1)
2673                         tbl[t[i]] = -2;
2674                     continue;
2675                 }
2676                 --j;
2677             }
2678             if (tbl[t[i]] == -1) {
2679                 if (t[i] < 128 && r[j] >= 128)
2680                     grows = 1;
2681                 tbl[t[i]] = r[j];
2682             }
2683         }
2684     }
2685     if (grows)
2686         o->op_private |= OPpTRANS_GROWS;
2687     op_free(expr);
2688     op_free(repl);
2689
2690     return o;
2691 }
2692
2693 OP *
2694 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2695 {
2696     dVAR;
2697     PMOP *pmop;
2698
2699     NewOp(1101, pmop, 1, PMOP);
2700     pmop->op_type = (OPCODE)type;
2701     pmop->op_ppaddr = PL_ppaddr[type];
2702     pmop->op_flags = (U8)flags;
2703     pmop->op_private = (U8)(0 | (flags >> 8));
2704
2705     if (PL_hints & HINT_RE_TAINT)
2706         pmop->op_pmpermflags |= PMf_RETAINT;
2707     if (PL_hints & HINT_LOCALE)
2708         pmop->op_pmpermflags |= PMf_LOCALE;
2709     pmop->op_pmflags = pmop->op_pmpermflags;
2710
2711 #ifdef USE_ITHREADS
2712     {
2713         SV* repointer;
2714         if(av_len((AV*) PL_regex_pad[0]) > -1) {
2715             repointer = av_pop((AV*)PL_regex_pad[0]);
2716             pmop->op_pmoffset = SvIV(repointer);
2717             SvREPADTMP_off(repointer);
2718             sv_setiv(repointer,0);
2719         } else {
2720             repointer = newSViv(0);
2721             av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2722             pmop->op_pmoffset = av_len(PL_regex_padav);
2723             PL_regex_pad = AvARRAY(PL_regex_padav);
2724         }
2725     }
2726 #endif
2727
2728         /* link into pm list */
2729     if (type != OP_TRANS && PL_curstash) {
2730         MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2731
2732         if (!mg) {
2733             mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2734         }
2735         pmop->op_pmnext = (PMOP*)mg->mg_obj;
2736         mg->mg_obj = (SV*)pmop;
2737         PmopSTASH_set(pmop,PL_curstash);
2738     }
2739
2740     return CHECKOP(type, pmop);
2741 }
2742
2743 /* Given some sort of match op o, and an expression expr containing a
2744  * pattern, either compile expr into a regex and attach it to o (if it's
2745  * constant), or convert expr into a runtime regcomp op sequence (if it's
2746  * not)
2747  *
2748  * isreg indicates that the pattern is part of a regex construct, eg
2749  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2750  * split "pattern", which aren't. In the former case, expr will be a list
2751  * if the pattern contains more than one term (eg /a$b/) or if it contains
2752  * a replacement, ie s/// or tr///.
2753  */
2754
2755 OP *
2756 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2757 {
2758     dVAR;
2759     PMOP *pm;
2760     LOGOP *rcop;
2761     I32 repl_has_vars = 0;
2762     OP* repl  = Nullop;
2763     bool reglist;
2764
2765     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2766         /* last element in list is the replacement; pop it */
2767         OP* kid;
2768         repl = cLISTOPx(expr)->op_last;
2769         kid = cLISTOPx(expr)->op_first;
2770         while (kid->op_sibling != repl)
2771             kid = kid->op_sibling;
2772         kid->op_sibling = Nullop;
2773         cLISTOPx(expr)->op_last = kid;
2774     }
2775
2776     if (isreg && expr->op_type == OP_LIST &&
2777         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2778     {
2779         /* convert single element list to element */
2780         OP* oe = expr;
2781         expr = cLISTOPx(oe)->op_first->op_sibling;
2782         cLISTOPx(oe)->op_first->op_sibling = Nullop;
2783         cLISTOPx(oe)->op_last = Nullop;
2784         op_free(oe);
2785     }
2786
2787     if (o->op_type == OP_TRANS) {
2788         return pmtrans(o, expr, repl);
2789     }
2790
2791     reglist = isreg && expr->op_type == OP_LIST;
2792     if (reglist)
2793         op_null(expr);
2794
2795     PL_hints |= HINT_BLOCK_SCOPE;
2796     pm = (PMOP*)o;
2797
2798     if (expr->op_type == OP_CONST) {
2799         STRLEN plen;
2800         SV *pat = ((SVOP*)expr)->op_sv;
2801         char *p = SvPV(pat, plen);
2802         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2803             sv_setpvn(pat, "\\s+", 3);
2804             p = SvPV(pat, plen);
2805             pm->op_pmflags |= PMf_SKIPWHITE;
2806         }
2807         if (DO_UTF8(pat))
2808             pm->op_pmdynflags |= PMdf_UTF8;
2809         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2810         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2811             pm->op_pmflags |= PMf_WHITE;
2812         op_free(expr);
2813     }
2814     else {
2815         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2816             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2817                             ? OP_REGCRESET
2818                             : OP_REGCMAYBE),0,expr);
2819
2820         NewOp(1101, rcop, 1, LOGOP);
2821         rcop->op_type = OP_REGCOMP;
2822         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2823         rcop->op_first = scalar(expr);
2824         rcop->op_flags |= OPf_KIDS
2825                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2826                             | (reglist ? OPf_STACKED : 0);
2827         rcop->op_private = 1;
2828         rcop->op_other = o;
2829         if (reglist)
2830             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2831
2832         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
2833         PL_cv_has_eval = 1;
2834
2835         /* establish postfix order */
2836         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2837             LINKLIST(expr);
2838             rcop->op_next = expr;
2839             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2840         }
2841         else {
2842             rcop->op_next = LINKLIST(expr);
2843             expr->op_next = (OP*)rcop;
2844         }
2845
2846         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2847     }
2848
2849     if (repl) {
2850         OP *curop;
2851         if (pm->op_pmflags & PMf_EVAL) {
2852             curop = 0;
2853             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2854                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2855         }
2856         else if (repl->op_type == OP_CONST)
2857             curop = repl;
2858         else {
2859             OP *lastop = 0;
2860             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2861                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2862                     if (curop->op_type == OP_GV) {
2863                         GV *gv = cGVOPx_gv(curop);
2864                         repl_has_vars = 1;
2865                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2866                             break;
2867                     }
2868                     else if (curop->op_type == OP_RV2CV)
2869                         break;
2870                     else if (curop->op_type == OP_RV2SV ||
2871                              curop->op_type == OP_RV2AV ||
2872                              curop->op_type == OP_RV2HV ||
2873                              curop->op_type == OP_RV2GV) {
2874                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2875                             break;
2876                     }
2877                     else if (curop->op_type == OP_PADSV ||
2878                              curop->op_type == OP_PADAV ||
2879                              curop->op_type == OP_PADHV ||
2880                              curop->op_type == OP_PADANY) {
2881                         repl_has_vars = 1;
2882                     }
2883                     else if (curop->op_type == OP_PUSHRE)
2884                         ; /* Okay here, dangerous in newASSIGNOP */
2885                     else
2886                         break;
2887                 }
2888                 lastop = curop;
2889             }
2890         }
2891         if (curop == repl
2892             && !(repl_has_vars
2893                  && (!PM_GETRE(pm)
2894                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2895             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2896             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2897             prepend_elem(o->op_type, scalar(repl), o);
2898         }
2899         else {
2900             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2901                 pm->op_pmflags |= PMf_MAYBE_CONST;
2902                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2903             }
2904             NewOp(1101, rcop, 1, LOGOP);
2905             rcop->op_type = OP_SUBSTCONT;
2906             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2907             rcop->op_first = scalar(repl);
2908             rcop->op_flags |= OPf_KIDS;
2909             rcop->op_private = 1;
2910             rcop->op_other = o;
2911
2912             /* establish postfix order */
2913             rcop->op_next = LINKLIST(repl);
2914             repl->op_next = (OP*)rcop;
2915
2916             pm->op_pmreplroot = scalar((OP*)rcop);
2917             pm->op_pmreplstart = LINKLIST(rcop);
2918             rcop->op_next = 0;
2919         }
2920     }
2921
2922     return (OP*)pm;
2923 }
2924
2925 OP *
2926 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2927 {
2928     dVAR;
2929     SVOP *svop;
2930     NewOp(1101, svop, 1, SVOP);
2931     svop->op_type = (OPCODE)type;
2932     svop->op_ppaddr = PL_ppaddr[type];
2933     svop->op_sv = sv;
2934     svop->op_next = (OP*)svop;
2935     svop->op_flags = (U8)flags;
2936     if (PL_opargs[type] & OA_RETSCALAR)
2937         scalar((OP*)svop);
2938     if (PL_opargs[type] & OA_TARGET)
2939         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2940     return CHECKOP(type, svop);
2941 }
2942
2943 OP *
2944 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2945 {
2946     dVAR;
2947     PADOP *padop;
2948     NewOp(1101, padop, 1, PADOP);
2949     padop->op_type = (OPCODE)type;
2950     padop->op_ppaddr = PL_ppaddr[type];
2951     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2952     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2953     PAD_SETSV(padop->op_padix, sv);
2954     if (sv)
2955         SvPADTMP_on(sv);
2956     padop->op_next = (OP*)padop;
2957     padop->op_flags = (U8)flags;
2958     if (PL_opargs[type] & OA_RETSCALAR)
2959         scalar((OP*)padop);
2960     if (PL_opargs[type] & OA_TARGET)
2961         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2962     return CHECKOP(type, padop);
2963 }
2964
2965 OP *
2966 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2967 {
2968     dVAR;
2969 #ifdef USE_ITHREADS
2970     if (gv)
2971         GvIN_PAD_on(gv);
2972     return newPADOP(type, flags, SvREFCNT_inc(gv));
2973 #else
2974     return newSVOP(type, flags, SvREFCNT_inc(gv));
2975 #endif
2976 }
2977
2978 OP *
2979 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2980 {
2981     dVAR;
2982     PVOP *pvop;
2983     NewOp(1101, pvop, 1, PVOP);
2984     pvop->op_type = (OPCODE)type;
2985     pvop->op_ppaddr = PL_ppaddr[type];
2986     pvop->op_pv = pv;
2987     pvop->op_next = (OP*)pvop;
2988     pvop->op_flags = (U8)flags;
2989     if (PL_opargs[type] & OA_RETSCALAR)
2990         scalar((OP*)pvop);
2991     if (PL_opargs[type] & OA_TARGET)
2992         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2993     return CHECKOP(type, pvop);
2994 }
2995
2996 void
2997 Perl_package(pTHX_ OP *o)
2998 {
2999     const char *name;
3000     STRLEN len;
3001
3002     save_hptr(&PL_curstash);
3003     save_item(PL_curstname);
3004
3005     name = SvPV(cSVOPo->op_sv, len);
3006     PL_curstash = gv_stashpvn(name, len, TRUE);
3007     sv_setpvn(PL_curstname, name, len);
3008     op_free(o);
3009
3010     PL_hints |= HINT_BLOCK_SCOPE;
3011     PL_copline = NOLINE;
3012     PL_expect = XSTATE;
3013 }
3014
3015 void
3016 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3017 {
3018     OP *pack;
3019     OP *imop;
3020     OP *veop;
3021
3022     if (idop->op_type != OP_CONST)
3023         Perl_croak(aTHX_ "Module name must be constant");
3024
3025     veop = Nullop;
3026
3027     if (version != Nullop) {
3028         SV *vesv = ((SVOP*)version)->op_sv;
3029
3030         if (arg == Nullop && !SvNIOKp(vesv)) {
3031             arg = version;
3032         }
3033         else {
3034             OP *pack;
3035             SV *meth;
3036
3037             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3038                 Perl_croak(aTHX_ "Version number must be constant number");
3039
3040             /* Make copy of idop so we don't free it twice */
3041             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3042
3043             /* Fake up a method call to VERSION */
3044             meth = newSVpvn("VERSION",7);
3045             sv_upgrade(meth, SVt_PVIV);
3046             (void)SvIOK_on(meth);
3047             {
3048                 U32 hash;
3049                 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3050                 SvUV_set(meth, hash);
3051             }
3052             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3053                             append_elem(OP_LIST,
3054                                         prepend_elem(OP_LIST, pack, list(version)),
3055                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3056         }
3057     }
3058
3059     /* Fake up an import/unimport */
3060     if (arg && arg->op_type == OP_STUB)
3061         imop = arg;             /* no import on explicit () */
3062     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3063         imop = Nullop;          /* use 5.0; */
3064     }
3065     else {
3066         SV *meth;
3067
3068         /* Make copy of idop so we don't free it twice */
3069         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3070
3071         /* Fake up a method call to import/unimport */
3072         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3073         (void)SvUPGRADE(meth, SVt_PVIV);
3074         (void)SvIOK_on(meth);
3075         {
3076             U32 hash;
3077             PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3078             SvUV_set(meth, hash);
3079         }
3080         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3081                        append_elem(OP_LIST,
3082                                    prepend_elem(OP_LIST, pack, list(arg)),
3083                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3084     }
3085
3086     /* Fake up the BEGIN {}, which does its thing immediately. */
3087     newATTRSUB(floor,
3088         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3089         Nullop,
3090         Nullop,
3091         append_elem(OP_LINESEQ,
3092             append_elem(OP_LINESEQ,
3093                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3094                 newSTATEOP(0, Nullch, veop)),
3095             newSTATEOP(0, Nullch, imop) ));
3096
3097     /* The "did you use incorrect case?" warning used to be here.
3098      * The problem is that on case-insensitive filesystems one
3099      * might get false positives for "use" (and "require"):
3100      * "use Strict" or "require CARP" will work.  This causes
3101      * portability problems for the script: in case-strict
3102      * filesystems the script will stop working.
3103      *
3104      * The "incorrect case" warning checked whether "use Foo"
3105      * imported "Foo" to your namespace, but that is wrong, too:
3106      * there is no requirement nor promise in the language that
3107      * a Foo.pm should or would contain anything in package "Foo".
3108      *
3109      * There is very little Configure-wise that can be done, either:
3110      * the case-sensitivity of the build filesystem of Perl does not
3111      * help in guessing the case-sensitivity of the runtime environment.
3112      */
3113
3114     PL_hints |= HINT_BLOCK_SCOPE;
3115     PL_copline = NOLINE;
3116     PL_expect = XSTATE;
3117     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3118 }
3119
3120 /*
3121 =head1 Embedding Functions
3122
3123 =for apidoc load_module
3124
3125 Loads the module whose name is pointed to by the string part of name.
3126 Note that the actual module name, not its filename, should be given.
3127 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3128 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3129 (or 0 for no flags). ver, if specified, provides version semantics
3130 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3131 arguments can be used to specify arguments to the module's import()
3132 method, similar to C<use Foo::Bar VERSION LIST>.
3133
3134 =cut */
3135
3136 void
3137 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3138 {
3139     va_list args;
3140     va_start(args, ver);
3141     vload_module(flags, name, ver, &args);
3142     va_end(args);
3143 }
3144
3145 #ifdef PERL_IMPLICIT_CONTEXT
3146 void
3147 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3148 {
3149     dTHX;
3150     va_list args;
3151     va_start(args, ver);
3152     vload_module(flags, name, ver, &args);
3153     va_end(args);
3154 }
3155 #endif
3156
3157 void
3158 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3159 {
3160     OP *modname, *veop, *imop;
3161
3162     modname = newSVOP(OP_CONST, 0, name);
3163     modname->op_private |= OPpCONST_BARE;
3164     if (ver) {
3165         veop = newSVOP(OP_CONST, 0, ver);
3166     }
3167     else
3168         veop = Nullop;
3169     if (flags & PERL_LOADMOD_NOIMPORT) {
3170         imop = sawparens(newNULLLIST());
3171     }
3172     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3173         imop = va_arg(*args, OP*);
3174     }
3175     else {
3176         SV *sv;
3177         imop = Nullop;
3178         sv = va_arg(*args, SV*);
3179         while (sv) {
3180             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3181             sv = va_arg(*args, SV*);
3182         }
3183     }
3184     {
3185         const line_t ocopline = PL_copline;
3186         COP * const ocurcop = PL_curcop;
3187         const int oexpect = PL_expect;
3188
3189         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3190                 veop, modname, imop);
3191         PL_expect = oexpect;
3192         PL_copline = ocopline;
3193         PL_curcop = ocurcop;
3194     }
3195 }
3196
3197 OP *
3198 Perl_dofile(pTHX_ OP *term)
3199 {
3200     OP *doop;
3201     GV *gv;
3202
3203     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3204     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3205         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3206
3207     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3208         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3209                                append_elem(OP_LIST, term,
3210                                            scalar(newUNOP(OP_RV2CV, 0,
3211                                                           newGVOP(OP_GV, 0,
3212                                                                   gv))))));
3213     }
3214     else {
3215         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3216     }
3217     return doop;
3218 }
3219
3220 OP *
3221 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3222 {
3223     return newBINOP(OP_LSLICE, flags,
3224             list(force_list(subscript)),
3225             list(force_list(listval)) );
3226 }
3227
3228 STATIC I32
3229 S_list_assignment(pTHX_ register const OP *o)
3230 {
3231     if (!o)
3232         return TRUE;
3233
3234     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3235         o = cUNOPo->op_first;
3236
3237     if (o->op_type == OP_COND_EXPR) {
3238         const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3239         const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3240
3241         if (t && f)
3242             return TRUE;
3243         if (t || f)
3244             yyerror("Assignment to both a list and a scalar");
3245         return FALSE;
3246     }
3247
3248     if (o->op_type == OP_LIST &&
3249         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3250         o->op_private & OPpLVAL_INTRO)
3251         return FALSE;
3252
3253     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3254         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3255         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3256         return TRUE;
3257
3258     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3259         return TRUE;
3260
3261     if (o->op_type == OP_RV2SV)
3262         return FALSE;
3263
3264     return FALSE;
3265 }
3266
3267 OP *
3268 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3269 {
3270     OP *o;
3271
3272     if (optype) {
3273         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3274             return newLOGOP(optype, 0,
3275                 mod(scalar(left), optype),
3276                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3277         }
3278         else {
3279             return newBINOP(optype, OPf_STACKED,
3280                 mod(scalar(left), optype), scalar(right));
3281         }
3282     }
3283
3284     if (list_assignment(left)) {
3285         OP *curop;
3286
3287         PL_modcount = 0;
3288         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3289         left = mod(left, OP_AASSIGN);
3290         if (PL_eval_start)
3291             PL_eval_start = 0;
3292         else {
3293             op_free(left);
3294             op_free(right);
3295             return Nullop;
3296         }
3297         /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3298         if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3299                 && right->op_type == OP_STUB
3300                 && (left->op_private & OPpLVAL_INTRO))
3301         {
3302             op_free(right);
3303             left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3304             return left;
3305         }
3306         curop = list(force_list(left));
3307         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3308         o->op_private = (U8)(0 | (flags >> 8));
3309
3310         /* PL_generation sorcery:
3311          * an assignment like ($a,$b) = ($c,$d) is easier than
3312          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3313          * To detect whether there are common vars, the global var
3314          * PL_generation is incremented for each assign op we compile.
3315          * Then, while compiling the assign op, we run through all the
3316          * variables on both sides of the assignment, setting a spare slot
3317          * in each of them to PL_generation. If any of them already have
3318          * that value, we know we've got commonality.  We could use a
3319          * single bit marker, but then we'd have to make 2 passes, first
3320          * to clear the flag, then to test and set it.  To find somewhere
3321          * to store these values, evil chicanery is done with SvCUR().
3322          */
3323
3324         if (!(left->op_private & OPpLVAL_INTRO)) {
3325             OP *lastop = o;
3326             PL_generation++;
3327             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3328                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3329                     if (curop->op_type == OP_GV) {
3330                         GV *gv = cGVOPx_gv(curop);
3331                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3332                             break;
3333                         SvCUR_set(gv, PL_generation);
3334                     }
3335                     else if (curop->op_type == OP_PADSV ||
3336                              curop->op_type == OP_PADAV ||
3337                              curop->op_type == OP_PADHV ||
3338                              curop->op_type == OP_PADANY)
3339                     {
3340                         if (PAD_COMPNAME_GEN(curop->op_targ)
3341                                                     == (STRLEN)PL_generation)
3342                             break;
3343                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3344
3345                     }
3346                     else if (curop->op_type == OP_RV2CV)
3347                         break;
3348                     else if (curop->op_type == OP_RV2SV ||
3349                              curop->op_type == OP_RV2AV ||
3350                              curop->op_type == OP_RV2HV ||
3351                              curop->op_type == OP_RV2GV) {
3352                         if (lastop->op_type != OP_GV)   /* funny deref? */
3353                             break;
3354                     }
3355                     else if (curop->op_type == OP_PUSHRE) {
3356                         if (((PMOP*)curop)->op_pmreplroot) {
3357 #ifdef USE_ITHREADS
3358                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3359                                         ((PMOP*)curop)->op_pmreplroot));
3360 #else
3361                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3362 #endif
3363                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3364                                 break;
3365                             SvCUR_set(gv, PL_generation);
3366                         }
3367                     }
3368                     else
3369                         break;
3370                 }
3371                 lastop = curop;
3372             }
3373             if (curop != o)
3374                 o->op_private |= OPpASSIGN_COMMON;
3375         }
3376         if (right && right->op_type == OP_SPLIT) {
3377             OP* tmpop;
3378             if ((tmpop = ((LISTOP*)right)->op_first) &&
3379                 tmpop->op_type == OP_PUSHRE)
3380             {
3381                 PMOP *pm = (PMOP*)tmpop;
3382                 if (left->op_type == OP_RV2AV &&
3383                     !(left->op_private & OPpLVAL_INTRO) &&
3384                     !(o->op_private & OPpASSIGN_COMMON) )
3385                 {
3386                     tmpop = ((UNOP*)left)->op_first;
3387                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3388 #ifdef USE_ITHREADS
3389                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3390                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3391 #else
3392                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3393                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3394 #endif
3395                         pm->op_pmflags |= PMf_ONCE;
3396                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3397                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3398                         tmpop->op_sibling = Nullop;     /* don't free split */
3399                         right->op_next = tmpop->op_next;  /* fix starting loc */
3400                         op_free(o);                     /* blow off assign */
3401                         right->op_flags &= ~OPf_WANT;
3402                                 /* "I don't know and I don't care." */
3403                         return right;
3404                     }
3405                 }
3406                 else {
3407                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3408                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3409                     {
3410                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3411                         if (SvIVX(sv) == 0)
3412                             sv_setiv(sv, PL_modcount+1);
3413                     }
3414                 }
3415             }
3416         }
3417         return o;
3418     }
3419     if (!right)
3420         right = newOP(OP_UNDEF, 0);
3421     if (right->op_type == OP_READLINE) {
3422         right->op_flags |= OPf_STACKED;
3423         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3424     }
3425     else {
3426         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3427         o = newBINOP(OP_SASSIGN, flags,
3428             scalar(right), mod(scalar(left), OP_SASSIGN) );
3429         if (PL_eval_start)
3430             PL_eval_start = 0;
3431         else {
3432             op_free(o);
3433             return Nullop;
3434         }
3435     }
3436     return o;
3437 }
3438
3439 OP *
3440 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3441 {
3442     dVAR;
3443     const U32 seq = intro_my();
3444     register COP *cop;
3445
3446     NewOp(1101, cop, 1, COP);
3447     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3448         cop->op_type = OP_DBSTATE;
3449         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3450     }
3451     else {
3452         cop->op_type = OP_NEXTSTATE;
3453         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3454     }
3455     cop->op_flags = (U8)flags;
3456     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3457 #ifdef NATIVE_HINTS
3458     cop->op_private |= NATIVE_HINTS;
3459 #endif
3460     PL_compiling.op_private = cop->op_private;
3461     cop->op_next = (OP*)cop;
3462
3463     if (label) {
3464         cop->cop_label = label;
3465         PL_hints |= HINT_BLOCK_SCOPE;
3466     }
3467     cop->cop_seq = seq;
3468     cop->cop_arybase = PL_curcop->cop_arybase;
3469     if (specialWARN(PL_curcop->cop_warnings))
3470         cop->cop_warnings = PL_curcop->cop_warnings ;
3471     else
3472         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3473     if (specialCopIO(PL_curcop->cop_io))
3474         cop->cop_io = PL_curcop->cop_io;
3475     else
3476         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3477
3478
3479     if (PL_copline == NOLINE)
3480         CopLINE_set(cop, CopLINE(PL_curcop));
3481     else {
3482         CopLINE_set(cop, PL_copline);
3483         PL_copline = NOLINE;
3484     }
3485 #ifdef USE_ITHREADS
3486     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3487 #else
3488     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3489 #endif
3490     CopSTASH_set(cop, PL_curstash);
3491
3492     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3493         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3494         if (svp && *svp != &PL_sv_undef ) {
3495            (void)SvIOK_on(*svp);
3496             SvIV_set(*svp, PTR2IV(cop));
3497         }
3498     }
3499
3500     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3501 }
3502
3503
3504 OP *
3505 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3506 {
3507     dVAR;
3508     return new_logop(type, flags, &first, &other);
3509 }
3510
3511 STATIC OP *
3512 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3513 {
3514     dVAR;
3515     LOGOP *logop;
3516     OP *o;
3517     OP *first = *firstp;
3518     OP *other = *otherp;
3519
3520     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3521         return newBINOP(type, flags, scalar(first), scalar(other));
3522
3523     scalarboolean(first);
3524     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3525     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3526         if (type == OP_AND || type == OP_OR) {
3527             if (type == OP_AND)
3528                 type = OP_OR;
3529             else
3530                 type = OP_AND;
3531             o = first;
3532             first = *firstp = cUNOPo->op_first;
3533             if (o->op_next)
3534                 first->op_next = o->op_next;
3535             cUNOPo->op_first = Nullop;
3536             op_free(o);
3537         }
3538     }
3539     if (first->op_type == OP_CONST) {
3540         if (first->op_private & OPpCONST_STRICT)
3541             no_bareword_allowed(first);
3542         else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3543                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3544         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3545             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3546             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3547             op_free(first);
3548             *firstp = Nullop;
3549             if (other->op_type == OP_CONST)
3550                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3551             return other;
3552         }
3553         else {
3554             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3555             const OP *o2 = other;
3556             if ( ! (o2->op_type == OP_LIST
3557                     && (( o2 = cUNOPx(o2)->op_first))
3558                     && o2->op_type == OP_PUSHMARK
3559                     && (( o2 = o2->op_sibling)) )
3560             )
3561                 o2 = other;
3562             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3563                         || o2->op_type == OP_PADHV)
3564                 && o2->op_private & OPpLVAL_INTRO
3565                 && ckWARN(WARN_DEPRECATED))
3566             {
3567                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3568                             "Deprecated use of my() in false conditional");
3569             }
3570
3571             op_free(other);
3572             *otherp = Nullop;
3573             if (first->op_type == OP_CONST)
3574                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3575             return first;
3576         }
3577     }
3578     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3579              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3580     {
3581         const OP *k1 = ((UNOP*)first)->op_first;
3582         const OP *k2 = k1->op_sibling;
3583         OPCODE warnop = 0;
3584         switch (first->op_type)
3585         {
3586         case OP_NULL:
3587             if (k2 && k2->op_type == OP_READLINE
3588                   && (k2->op_flags & OPf_STACKED)
3589                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3590             {
3591                 warnop = k2->op_type;
3592             }
3593             break;
3594
3595         case OP_SASSIGN:
3596             if (k1->op_type == OP_READDIR
3597                   || k1->op_type == OP_GLOB
3598                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3599                   || k1->op_type == OP_EACH)
3600             {
3601                 warnop = ((k1->op_type == OP_NULL)
3602                           ? (OPCODE)k1->op_targ : k1->op_type);
3603             }
3604             break;
3605         }
3606         if (warnop) {
3607             const line_t oldline = CopLINE(PL_curcop);
3608             CopLINE_set(PL_curcop, PL_copline);
3609             Perl_warner(aTHX_ packWARN(WARN_MISC),
3610                  "Value of %s%s can be \"0\"; test with defined()",
3611                  PL_op_desc[warnop],
3612                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3613                   ? " construct" : "() operator"));
3614             CopLINE_set(PL_curcop, oldline);
3615         }
3616     }
3617
3618     if (!other)
3619         return first;
3620
3621     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3622         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3623
3624     NewOp(1101, logop, 1, LOGOP);
3625
3626     logop->op_type = (OPCODE)type;
3627     logop->op_ppaddr = PL_ppaddr[type];
3628     logop->op_first = first;
3629     logop->op_flags = flags | OPf_KIDS;
3630     logop->op_other = LINKLIST(other);
3631     logop->op_private = (U8)(1 | (flags >> 8));
3632
3633     /* establish postfix order */
3634     logop->op_next = LINKLIST(first);
3635     first->op_next = (OP*)logop;
3636     first->op_sibling = other;
3637
3638     CHECKOP(type,logop);
3639
3640     o = newUNOP(OP_NULL, 0, (OP*)logop);
3641     other->op_next = o;
3642
3643     return o;
3644 }
3645
3646 OP *
3647 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3648 {
3649     dVAR;
3650     LOGOP *logop;
3651     OP *start;
3652     OP *o;
3653
3654     if (!falseop)
3655         return newLOGOP(OP_AND, 0, first, trueop);
3656     if (!trueop)
3657         return newLOGOP(OP_OR, 0, first, falseop);
3658
3659     scalarboolean(first);
3660     if (first->op_type == OP_CONST) {
3661         if (first->op_private & OPpCONST_BARE &&
3662            first->op_private & OPpCONST_STRICT) {
3663            no_bareword_allowed(first);
3664        }
3665         if (SvTRUE(((SVOP*)first)->op_sv)) {
3666             op_free(first);
3667             op_free(falseop);
3668             return trueop;
3669         }
3670         else {
3671             op_free(first);
3672             op_free(trueop);
3673             return falseop;
3674         }
3675     }
3676     NewOp(1101, logop, 1, LOGOP);
3677     logop->op_type = OP_COND_EXPR;
3678     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3679     logop->op_first = first;
3680     logop->op_flags = flags | OPf_KIDS;
3681     logop->op_private = (U8)(1 | (flags >> 8));
3682     logop->op_other = LINKLIST(trueop);
3683     logop->op_next = LINKLIST(falseop);
3684
3685     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3686             logop);
3687
3688     /* establish postfix order */
3689     start = LINKLIST(first);
3690     first->op_next = (OP*)logop;
3691
3692     first->op_sibling = trueop;
3693     trueop->op_sibling = falseop;
3694     o = newUNOP(OP_NULL, 0, (OP*)logop);
3695
3696     trueop->op_next = falseop->op_next = o;
3697
3698     o->op_next = start;
3699     return o;
3700 }
3701
3702 OP *
3703 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3704 {
3705     dVAR;
3706     LOGOP *range;
3707     OP *flip;
3708     OP *flop;
3709     OP *leftstart;
3710     OP *o;
3711
3712     NewOp(1101, range, 1, LOGOP);
3713
3714     range->op_type = OP_RANGE;
3715     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3716     range->op_first = left;
3717     range->op_flags = OPf_KIDS;
3718     leftstart = LINKLIST(left);
3719     range->op_other = LINKLIST(right);
3720     range->op_private = (U8)(1 | (flags >> 8));
3721
3722     left->op_sibling = right;
3723
3724     range->op_next = (OP*)range;
3725     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3726     flop = newUNOP(OP_FLOP, 0, flip);
3727     o = newUNOP(OP_NULL, 0, flop);
3728     linklist(flop);
3729     range->op_next = leftstart;
3730
3731     left->op_next = flip;
3732     right->op_next = flop;
3733
3734     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3735     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3736     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3737     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3738
3739     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3740     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3741
3742     flip->op_next = o;
3743     if (!flip->op_private || !flop->op_private)
3744         linklist(o);            /* blow off optimizer unless constant */
3745
3746     return o;
3747 }
3748
3749 OP *
3750 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3751 {
3752     OP* listop;
3753     OP* o;
3754     const bool once = block && block->op_flags & OPf_SPECIAL &&
3755       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3756     (void)debuggable;
3757
3758     if (expr) {
3759         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3760             return block;       /* do {} while 0 does once */
3761         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3762             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3763             expr = newUNOP(OP_DEFINED, 0,
3764                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3765         } else if (expr->op_flags & OPf_KIDS) {
3766             const OP *k1 = ((UNOP*)expr)->op_first;
3767             const OP *k2 = (k1) ? k1->op_sibling : NULL;
3768             switch (expr->op_type) {
3769               case OP_NULL:
3770                 if (k2 && k2->op_type == OP_READLINE
3771                       && (k2->op_flags & OPf_STACKED)
3772                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3773                     expr = newUNOP(OP_DEFINED, 0, expr);
3774                 break;
3775
3776               case OP_SASSIGN:
3777                 if (k1->op_type == OP_READDIR
3778                       || k1->op_type == OP_GLOB
3779                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3780                       || k1->op_type == OP_EACH)
3781                     expr = newUNOP(OP_DEFINED, 0, expr);
3782                 break;
3783             }
3784         }
3785     }
3786
3787     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3788      * op, in listop. This is wrong. [perl #27024] */
3789     if (!block)
3790         block = newOP(OP_NULL, 0);
3791     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3792     o = new_logop(OP_AND, 0, &expr, &listop);
3793
3794     if (listop)
3795         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3796
3797     if (once && o != listop)
3798         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3799
3800     if (o == listop)
3801         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3802
3803     o->op_flags |= flags;
3804     o = scope(o);
3805     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3806     return o;
3807 }
3808
3809 OP *
3810 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3811 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3812 {
3813     dVAR;
3814     OP *redo;
3815     OP *next = 0;
3816     OP *listop;
3817     OP *o;
3818     U8 loopflags = 0;
3819     (void)debuggable;
3820
3821     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3822                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3823         expr = newUNOP(OP_DEFINED, 0,
3824             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3825     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3826         const OP *k1 = ((UNOP*)expr)->op_first;
3827         const OP *k2 = (k1) ? k1->op_sibling : NULL;
3828         switch (expr->op_type) {
3829           case OP_NULL:
3830             if (k2 && k2->op_type == OP_READLINE
3831                   && (k2->op_flags & OPf_STACKED)
3832                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3833                 expr = newUNOP(OP_DEFINED, 0, expr);
3834             break;
3835
3836           case OP_SASSIGN:
3837             if (k1->op_type == OP_READDIR
3838                   || k1->op_type == OP_GLOB
3839                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3840                   || k1->op_type == OP_EACH)
3841                 expr = newUNOP(OP_DEFINED, 0, expr);
3842             break;
3843         }
3844     }
3845
3846     if (!block)
3847         block = newOP(OP_NULL, 0);
3848     else if (cont || has_my) {
3849         block = scope(block);
3850     }
3851
3852     if (cont) {
3853         next = LINKLIST(cont);
3854     }
3855     if (expr) {
3856         OP *unstack = newOP(OP_UNSTACK, 0);
3857         if (!next)
3858             next = unstack;
3859         cont = append_elem(OP_LINESEQ, cont, unstack);
3860     }
3861
3862     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3863     redo = LINKLIST(listop);
3864
3865     if (expr) {
3866         PL_copline = (line_t)whileline;
3867         scalar(listop);
3868         o = new_logop(OP_AND, 0, &expr, &listop);
3869         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3870             op_free(expr);              /* oops, it's a while (0) */
3871             op_free((OP*)loop);
3872             return Nullop;              /* listop already freed by new_logop */
3873         }
3874         if (listop)
3875             ((LISTOP*)listop)->op_last->op_next =
3876                 (o == listop ? redo : LINKLIST(o));
3877     }
3878     else
3879         o = listop;
3880
3881     if (!loop) {
3882         NewOp(1101,loop,1,LOOP);
3883         loop->op_type = OP_ENTERLOOP;
3884         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3885         loop->op_private = 0;
3886         loop->op_next = (OP*)loop;
3887     }
3888
3889     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3890
3891     loop->op_redoop = redo;
3892     loop->op_lastop = o;
3893     o->op_private |= loopflags;
3894
3895     if (next)
3896         loop->op_nextop = next;
3897     else
3898         loop->op_nextop = o;
3899
3900     o->op_flags |= flags;
3901     o->op_private |= (flags >> 8);
3902     return o;
3903 }
3904
3905 OP *
3906 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3907 {
3908     dVAR;
3909     LOOP *loop;
3910     OP *wop;
3911     PADOFFSET padoff = 0;
3912     I32 iterflags = 0;
3913     I32 iterpflags = 0;
3914
3915     if (sv) {
3916         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3917             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3918             sv->op_type = OP_RV2GV;
3919             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3920         }
3921         else if (sv->op_type == OP_PADSV) { /* private variable */
3922             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3923             padoff = sv->op_targ;
3924             sv->op_targ = 0;
3925             op_free(sv);
3926             sv = Nullop;
3927         }
3928         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3929             padoff = sv->op_targ;
3930             sv->op_targ = 0;
3931             iterflags |= OPf_SPECIAL;
3932             op_free(sv);
3933             sv = Nullop;
3934         }
3935         else
3936             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3937     }
3938     else {
3939         const I32 offset = pad_findmy("$_");
3940         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3941             sv = newGVOP(OP_GV, 0, PL_defgv);
3942         }
3943         else {
3944             padoff = offset;
3945         }
3946     }
3947     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3948         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3949         iterflags |= OPf_STACKED;
3950     }
3951     else if (expr->op_type == OP_NULL &&
3952              (expr->op_flags & OPf_KIDS) &&
3953              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3954     {
3955         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3956          * set the STACKED flag to indicate that these values are to be
3957          * treated as min/max values by 'pp_iterinit'.
3958          */
3959         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3960         LOGOP* range = (LOGOP*) flip->op_first;
3961         OP* left  = range->op_first;
3962         OP* right = left->op_sibling;
3963         LISTOP* listop;
3964
3965         range->op_flags &= ~OPf_KIDS;
3966         range->op_first = Nullop;
3967
3968         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3969         listop->op_first->op_next = range->op_next;
3970         left->op_next = range->op_other;
3971         right->op_next = (OP*)listop;
3972         listop->op_next = listop->op_first;
3973
3974         op_free(expr);
3975         expr = (OP*)(listop);
3976         op_null(expr);
3977         iterflags |= OPf_STACKED;
3978     }
3979     else {
3980         expr = mod(force_list(expr), OP_GREPSTART);
3981     }
3982
3983     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3984                                append_elem(OP_LIST, expr, scalar(sv))));
3985     assert(!loop->op_next);
3986     /* for my  $x () sets OPpLVAL_INTRO;
3987      * for our $x () sets OPpOUR_INTRO */
3988     loop->op_private = (U8)iterpflags;
3989 #ifdef PL_OP_SLAB_ALLOC
3990     {
3991         LOOP *tmp;
3992         NewOp(1234,tmp,1,LOOP);
3993         Copy(loop,tmp,1,LISTOP);
3994         FreeOp(loop);
3995         loop = tmp;
3996     }
3997 #else
3998     Renew(loop, 1, LOOP);
3999 #endif
4000     loop->op_targ = padoff;
4001     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4002     PL_copline = forline;
4003     return newSTATEOP(0, label, wop);
4004 }
4005
4006 OP*
4007 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4008 {
4009     OP *o;
4010     STRLEN n_a;
4011
4012     if (type != OP_GOTO || label->op_type == OP_CONST) {
4013         /* "last()" means "last" */
4014         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4015             o = newOP(type, OPf_SPECIAL);
4016         else {
4017             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4018                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4019                                         : ""));
4020         }
4021         op_free(label);
4022     }
4023     else {
4024         /* Check whether it's going to be a goto &function */
4025         if (label->op_type == OP_ENTERSUB
4026                 && !(label->op_flags & OPf_STACKED))
4027             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4028         o = newUNOP(type, OPf_STACKED, label);
4029     }
4030     PL_hints |= HINT_BLOCK_SCOPE;
4031     return o;
4032 }
4033
4034 /*
4035 =for apidoc cv_undef
4036
4037 Clear out all the active components of a CV. This can happen either
4038 by an explicit C<undef &foo>, or by the reference count going to zero.
4039 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4040 children can still follow the full lexical scope chain.
4041
4042 =cut
4043 */
4044
4045 void
4046 Perl_cv_undef(pTHX_ CV *cv)
4047 {
4048     dVAR;
4049 #ifdef USE_ITHREADS
4050     if (CvFILE(cv) && !CvXSUB(cv)) {
4051         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4052         Safefree(CvFILE(cv));
4053     }
4054     CvFILE(cv) = 0;
4055 #endif
4056
4057     if (!CvXSUB(cv) && CvROOT(cv)) {
4058         if (CvDEPTH(cv))
4059             Perl_croak(aTHX_ "Can't undef active subroutine");
4060         ENTER;
4061
4062         PAD_SAVE_SETNULLPAD();
4063
4064         op_free(CvROOT(cv));
4065         CvROOT(cv) = Nullop;
4066         LEAVE;
4067     }
4068     SvPOK_off((SV*)cv);         /* forget prototype */
4069     CvGV(cv) = Nullgv;
4070
4071     pad_undef(cv);
4072
4073     /* remove CvOUTSIDE unless this is an undef rather than a free */
4074     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4075         if (!CvWEAKOUTSIDE(cv))
4076             SvREFCNT_dec(CvOUTSIDE(cv));
4077         CvOUTSIDE(cv) = Nullcv;
4078     }
4079     if (CvCONST(cv)) {
4080         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4081         CvCONST_off(cv);
4082     }
4083     if (CvXSUB(cv)) {
4084         CvXSUB(cv) = 0;
4085     }
4086     /* delete all flags except WEAKOUTSIDE */
4087     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4088 }
4089
4090 void
4091 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4092 {
4093     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4094         SV* msg = sv_newmortal();
4095         SV* name = Nullsv;
4096
4097         if (gv)
4098             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4099         sv_setpv(msg, "Prototype mismatch:");
4100         if (name)
4101             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4102         if (SvPOK(cv))
4103             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4104         else
4105             Perl_sv_catpv(aTHX_ msg, ": none");
4106         sv_catpv(msg, " vs ");
4107         if (p)
4108             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4109         else
4110             sv_catpv(msg, "none");
4111         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4112     }
4113 }
4114
4115 static void const_sv_xsub(pTHX_ CV* cv);
4116
4117 /*
4118
4119 =head1 Optree Manipulation Functions
4120
4121 =for apidoc cv_const_sv
4122
4123 If C<cv> is a constant sub eligible for inlining. returns the constant
4124 value returned by the sub.  Otherwise, returns NULL.
4125
4126 Constant subs can be created with C<newCONSTSUB> or as described in
4127 L<perlsub/"Constant Functions">.
4128
4129 =cut
4130 */
4131 SV *
4132 Perl_cv_const_sv(pTHX_ CV *cv)
4133 {
4134     if (!cv || !CvCONST(cv))
4135         return Nullsv;
4136     return (SV*)CvXSUBANY(cv).any_ptr;
4137 }
4138
4139 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4140  * Can be called in 3 ways:
4141  *
4142  * !cv
4143  *      look for a single OP_CONST with attached value: return the value
4144  *
4145  * cv && CvCLONE(cv) && !CvCONST(cv)
4146  *
4147  *      examine the clone prototype, and if contains only a single
4148  *      OP_CONST referencing a pad const, or a single PADSV referencing
4149  *      an outer lexical, return a non-zero value to indicate the CV is
4150  *      a candidate for "constizing" at clone time
4151  *
4152  * cv && CvCONST(cv)
4153  *
4154  *      We have just cloned an anon prototype that was marked as a const
4155  *      candidiate. Try to grab the current value, and in the case of
4156  *      PADSV, ignore it if it has multiple references. Return the value.
4157  */
4158
4159 SV *
4160 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4161 {
4162     SV *sv = Nullsv;
4163
4164     if (!o)
4165         return Nullsv;
4166
4167     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4168         o = cLISTOPo->op_first->op_sibling;
4169
4170     for (; o; o = o->op_next) {
4171         OPCODE type = o->op_type;
4172
4173         if (sv && o->op_next == o)
4174             return sv;
4175         if (o->op_next != o) {
4176             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4177                 continue;
4178             if (type == OP_DBSTATE)
4179                 continue;
4180         }
4181         if (type == OP_LEAVESUB || type == OP_RETURN)
4182             break;
4183         if (sv)
4184             return Nullsv;
4185         if (type == OP_CONST && cSVOPo->op_sv)
4186             sv = cSVOPo->op_sv;
4187         else if (cv && type == OP_CONST) {
4188             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4189             if (!sv)
4190                 return Nullsv;
4191         }
4192         else if (cv && type == OP_PADSV) {
4193             if (CvCONST(cv)) { /* newly cloned anon */
4194                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4195                 /* the candidate should have 1 ref from this pad and 1 ref
4196                  * from the parent */
4197                 if (!sv || SvREFCNT(sv) != 2)
4198                     return Nullsv;
4199                 sv = newSVsv(sv);
4200                 SvREADONLY_on(sv);
4201                 return sv;
4202             }
4203             else {
4204                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4205                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4206             }
4207         }
4208         else {
4209             return Nullsv;
4210         }
4211     }
4212     return sv;
4213 }
4214
4215 void
4216 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4217 {
4218     (void)floor;
4219     if (o)
4220         SAVEFREEOP(o);
4221     if (proto)
4222         SAVEFREEOP(proto);
4223     if (attrs)
4224         SAVEFREEOP(attrs);
4225     if (block)
4226         SAVEFREEOP(block);
4227     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4228 }
4229
4230 CV *
4231 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4232 {
4233     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4234 }
4235
4236 CV *
4237 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4238 {
4239     dVAR;
4240     STRLEN n_a;
4241     const char *aname;
4242     GV *gv;
4243     char *ps;
4244     STRLEN ps_len;
4245     register CV *cv=0;
4246     SV *const_sv;
4247
4248     const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4249
4250     if (proto) {
4251         assert(proto->op_type == OP_CONST);
4252         ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4253     }
4254     else
4255         ps = Nullch;
4256
4257     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4258         SV *sv = sv_newmortal();
4259         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4260                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4261                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4262         aname = SvPVX(sv);
4263     }
4264     else
4265         aname = Nullch;
4266     gv = name ? gv_fetchsv(cSVOPo->op_sv,
4267                            GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4268                            SVt_PVCV)
4269         : gv_fetchpv(aname ? aname
4270                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4271                      GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4272                      SVt_PVCV);
4273
4274     if (o)
4275         SAVEFREEOP(o);
4276     if (proto)
4277         SAVEFREEOP(proto);
4278     if (attrs)
4279         SAVEFREEOP(attrs);
4280
4281     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4282                                            maximum a prototype before. */
4283         if (SvTYPE(gv) > SVt_NULL) {
4284             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4285                 && ckWARN_d(WARN_PROTOTYPE))
4286             {
4287                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4288             }
4289             cv_ckproto((CV*)gv, NULL, ps);
4290         }
4291         if (ps)
4292             sv_setpvn((SV*)gv, ps, ps_len);
4293         else
4294             sv_setiv((SV*)gv, -1);
4295         SvREFCNT_dec(PL_compcv);
4296         cv = PL_compcv = NULL;
4297         PL_sub_generation++;
4298         goto done;
4299     }
4300
4301     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4302
4303 #ifdef GV_UNIQUE_CHECK
4304     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4305         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4306     }
4307 #endif
4308
4309     if (!block || !ps || *ps || attrs)
4310         const_sv = Nullsv;
4311     else
4312         const_sv = op_const_sv(block, Nullcv);
4313
4314     if (cv) {
4315         const bool exists = CvROOT(cv) || CvXSUB(cv);
4316
4317 #ifdef GV_UNIQUE_CHECK
4318         if (exists && GvUNIQUE(gv)) {
4319             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4320         }
4321 #endif
4322
4323         /* if the subroutine doesn't exist and wasn't pre-declared
4324          * with a prototype, assume it will be AUTOLOADed,
4325          * skipping the prototype check
4326          */
4327         if (exists || SvPOK(cv))
4328             cv_ckproto(cv, gv, ps);
4329         /* already defined (or promised)? */
4330         if (exists || GvASSUMECV(gv)) {
4331             if (!block && !attrs) {
4332                 if (CvFLAGS(PL_compcv)) {
4333                     /* might have had built-in attrs applied */
4334                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4335                 }
4336                 /* just a "sub foo;" when &foo is already defined */
4337                 SAVEFREESV(PL_compcv);
4338                 goto done;
4339             }
4340             /* ahem, death to those who redefine active sort subs */
4341             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4342                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4343             if (block) {
4344                 if (ckWARN(WARN_REDEFINE)
4345                     || (CvCONST(cv)
4346                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4347                 {
4348                     const line_t oldline = CopLINE(PL_curcop);
4349                     if (PL_copline != NOLINE)
4350                         CopLINE_set(PL_curcop, PL_copline);
4351                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4352                         CvCONST(cv) ? "Constant subroutine %s redefined"
4353                                     : "Subroutine %s redefined", name);
4354                     CopLINE_set(PL_curcop, oldline);
4355                 }
4356                 SvREFCNT_dec(cv);
4357                 cv = Nullcv;
4358             }
4359         }
4360     }
4361     if (const_sv) {
4362         (void)SvREFCNT_inc(const_sv);
4363         if (cv) {
4364             assert(!CvROOT(cv) && !CvCONST(cv));
4365             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4366             CvXSUBANY(cv).any_ptr = const_sv;
4367             CvXSUB(cv) = const_sv_xsub;
4368             CvCONST_on(cv);
4369         }
4370         else {
4371             GvCV(gv) = Nullcv;
4372             cv = newCONSTSUB(NULL, name, const_sv);
4373         }
4374         op_free(block);
4375         SvREFCNT_dec(PL_compcv);
4376         PL_compcv = NULL;
4377         PL_sub_generation++;
4378         goto done;
4379     }
4380     if (attrs) {
4381         HV *stash;
4382         SV *rcv;
4383
4384         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4385          * before we clobber PL_compcv.
4386          */
4387         if (cv && !block) {
4388             rcv = (SV*)cv;
4389             /* Might have had built-in attributes applied -- propagate them. */
4390             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4391             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4392                 stash = GvSTASH(CvGV(cv));
4393             else if (CvSTASH(cv))
4394                 stash = CvSTASH(cv);
4395             else
4396                 stash = PL_curstash;
4397         }
4398         else {
4399             /* possibly about to re-define existing subr -- ignore old cv */
4400             rcv = (SV*)PL_compcv;
4401             if (name && GvSTASH(gv))
4402                 stash = GvSTASH(gv);
4403             else
4404                 stash = PL_curstash;
4405         }
4406         apply_attrs(stash, rcv, attrs, FALSE);
4407     }
4408     if (cv) {                           /* must reuse cv if autoloaded */
4409         if (!block) {
4410             /* got here with just attrs -- work done, so bug out */
4411             SAVEFREESV(PL_compcv);
4412             goto done;
4413         }
4414         /* transfer PL_compcv to cv */
4415         cv_undef(cv);
4416         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4417         if (!CvWEAKOUTSIDE(cv))
4418             SvREFCNT_dec(CvOUTSIDE(cv));
4419         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4420         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4421         CvOUTSIDE(PL_compcv) = 0;
4422         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4423         CvPADLIST(PL_compcv) = 0;
4424         /* inner references to PL_compcv must be fixed up ... */
4425         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4426         /* ... before we throw it away */
4427         SvREFCNT_dec(PL_compcv);
4428         PL_compcv = cv;
4429         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4430           ++PL_sub_generation;
4431     }
4432     else {
4433         cv = PL_compcv;
4434         if (name) {
4435             GvCV(gv) = cv;
4436             GvCVGEN(gv) = 0;
4437             PL_sub_generation++;
4438         }
4439     }
4440     CvGV(cv) = gv;
4441     CvFILE_set_from_cop(cv, PL_curcop);
4442     CvSTASH(cv) = PL_curstash;
4443
4444     if (ps)
4445         sv_setpvn((SV*)cv, ps, ps_len);
4446
4447     if (PL_error_count) {
4448         op_free(block);
4449         block = Nullop;
4450         if (name) {
4451             const char *s = strrchr(name, ':');
4452             s = s ? s+1 : name;
4453             if (strEQ(s, "BEGIN")) {
4454                 const char not_safe[] =
4455                     "BEGIN not safe after errors--compilation aborted";
4456                 if (PL_in_eval & EVAL_KEEPERR)
4457                     Perl_croak(aTHX_ not_safe);
4458                 else {
4459                     /* force display of errors found but not reported */
4460                     sv_catpv(ERRSV, not_safe);
4461                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4462                 }
4463             }
4464         }
4465     }
4466     if (!block)
4467         goto done;
4468
4469     if (CvLVALUE(cv)) {
4470         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4471                              mod(scalarseq(block), OP_LEAVESUBLV));
4472     }
4473     else {
4474         /* This makes sub {}; work as expected.  */
4475         if (block->op_type == OP_STUB) {
4476             op_free(block);
4477             block = newSTATEOP(0, Nullch, 0);
4478         }
4479         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4480     }
4481     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4482     OpREFCNT_set(CvROOT(cv), 1);
4483     CvSTART(cv) = LINKLIST(CvROOT(cv));
4484     CvROOT(cv)->op_next = 0;
4485     CALL_PEEP(CvSTART(cv));
4486
4487     /* now that optimizer has done its work, adjust pad values */
4488
4489     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4490
4491     if (CvCLONE(cv)) {
4492         assert(!CvCONST(cv));
4493         if (ps && !*ps && op_const_sv(block, cv))
4494             CvCONST_on(cv);
4495     }
4496
4497     if (name || aname) {
4498         const char *s;
4499         const char *tname = (name ? name : aname);
4500
4501         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4502             SV *sv = NEWSV(0,0);
4503             SV *tmpstr = sv_newmortal();
4504             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4505             CV *pcv;
4506             HV *hv;
4507
4508             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4509                            CopFILE(PL_curcop),
4510                            (long)PL_subline, (long)CopLINE(PL_curcop));
4511             gv_efullname3(tmpstr, gv, Nullch);
4512             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4513             hv = GvHVn(db_postponed);
4514             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4515                 && (pcv = GvCV(db_postponed)))
4516             {
4517                 dSP;
4518                 PUSHMARK(SP);
4519                 XPUSHs(tmpstr);
4520                 PUTBACK;
4521                 call_sv((SV*)pcv, G_DISCARD);
4522             }
4523         }
4524
4525         if ((s = strrchr(tname,':')))
4526             s++;
4527         else
4528             s = tname;
4529
4530         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4531             goto done;
4532
4533         if (strEQ(s, "BEGIN") && !PL_error_count) {
4534             const I32 oldscope = PL_scopestack_ix;
4535             ENTER;
4536             SAVECOPFILE(&PL_compiling);
4537             SAVECOPLINE(&PL_compiling);
4538
4539             if (!PL_beginav)
4540                 PL_beginav = newAV();
4541             DEBUG_x( dump_sub(gv) );
4542             av_push(PL_beginav, (SV*)cv);
4543             GvCV(gv) = 0;               /* cv has been hijacked */
4544             call_list(oldscope, PL_beginav);
4545
4546             PL_curcop = &PL_compiling;
4547             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4548             LEAVE;
4549         }
4550         else if (strEQ(s, "END") && !PL_error_count) {
4551             if (!PL_endav)
4552                 PL_endav = newAV();
4553             DEBUG_x( dump_sub(gv) );
4554             av_unshift(PL_endav, 1);
4555             av_store(PL_endav, 0, (SV*)cv);
4556             GvCV(gv) = 0;               /* cv has been hijacked */
4557         }
4558         else if (strEQ(s, "CHECK") && !PL_error_count) {
4559             if (!PL_checkav)
4560                 PL_checkav = newAV();
4561             DEBUG_x( dump_sub(gv) );
4562             if (PL_main_start && ckWARN(WARN_VOID))
4563                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4564             av_unshift(PL_checkav, 1);
4565             av_store(PL_checkav, 0, (SV*)cv);
4566             GvCV(gv) = 0;               /* cv has been hijacked */
4567         }
4568         else if (strEQ(s, "INIT") && !PL_error_count) {
4569             if (!PL_initav)
4570                 PL_initav = newAV();
4571             DEBUG_x( dump_sub(gv) );
4572             if (PL_main_start && ckWARN(WARN_VOID))
4573                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4574             av_push(PL_initav, (SV*)cv);
4575             GvCV(gv) = 0;               /* cv has been hijacked */
4576         }
4577     }
4578
4579   done:
4580     PL_copline = NOLINE;
4581     LEAVE_SCOPE(floor);
4582     return cv;
4583 }
4584
4585 /* XXX unsafe for threads if eval_owner isn't held */
4586 /*
4587 =for apidoc newCONSTSUB
4588
4589 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4590 eligible for inlining at compile-time.
4591
4592 =cut
4593 */
4594
4595 CV *
4596 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4597 {
4598     dVAR;
4599     CV* cv;
4600
4601     ENTER;
4602
4603     SAVECOPLINE(PL_curcop);
4604     CopLINE_set(PL_curcop, PL_copline);
4605
4606     SAVEHINTS();
4607     PL_hints &= ~HINT_BLOCK_SCOPE;
4608
4609     if (stash) {
4610         SAVESPTR(PL_curstash);
4611         SAVECOPSTASH(PL_curcop);
4612         PL_curstash = stash;
4613         CopSTASH_set(PL_curcop,stash);
4614     }
4615
4616     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4617     CvXSUBANY(cv).any_ptr = sv;
4618     CvCONST_on(cv);
4619     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4620
4621     if (stash)
4622         CopSTASH_free(PL_curcop);
4623
4624     LEAVE;
4625
4626     return cv;
4627 }
4628
4629 /*
4630 =for apidoc U||newXS
4631
4632 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4633
4634 =cut
4635 */
4636
4637 CV *
4638 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4639 {
4640     GV *gv = gv_fetchpv(name ? name :
4641                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4642                         GV_ADDMULTI, SVt_PVCV);
4643     register CV *cv;
4644
4645     if (!subaddr)
4646         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4647
4648     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4649         if (GvCVGEN(gv)) {
4650             /* just a cached method */
4651             SvREFCNT_dec(cv);
4652             cv = 0;
4653         }
4654         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4655             /* already defined (or promised) */
4656             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4657                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4658                 const line_t oldline = CopLINE(PL_curcop);
4659                 if (PL_copline != NOLINE)
4660                     CopLINE_set(PL_curcop, PL_copline);
4661                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4662                             CvCONST(cv) ? "Constant subroutine %s redefined"
4663                                         : "Subroutine %s redefined"
4664                             ,name);
4665                 CopLINE_set(PL_curcop, oldline);
4666             }
4667             SvREFCNT_dec(cv);
4668             cv = 0;
4669         }
4670     }
4671
4672     if (cv)                             /* must reuse cv if autoloaded */
4673         cv_undef(cv);
4674     else {
4675         cv = (CV*)NEWSV(1105,0);
4676         sv_upgrade((SV *)cv, SVt_PVCV);
4677         if (name) {
4678             GvCV(gv) = cv;
4679             GvCVGEN(gv) = 0;
4680             PL_sub_generation++;
4681         }
4682     }
4683     CvGV(cv) = gv;
4684     (void)gv_fetchfile(filename);
4685     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4686                                    an external constant string */
4687     CvXSUB(cv) = subaddr;
4688
4689     if (name) {
4690         const char *s = strrchr(name,':');
4691         if (s)
4692             s++;
4693         else
4694             s = name;
4695
4696         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4697             goto done;
4698
4699         if (strEQ(s, "BEGIN")) {
4700             if (!PL_beginav)
4701                 PL_beginav = newAV();
4702             av_push(PL_beginav, (SV*)cv);
4703             GvCV(gv) = 0;               /* cv has been hijacked */
4704         }
4705         else if (strEQ(s, "END")) {
4706             if (!PL_endav)
4707                 PL_endav = newAV();
4708             av_unshift(PL_endav, 1);
4709             av_store(PL_endav, 0, (SV*)cv);
4710             GvCV(gv) = 0;               /* cv has been hijacked */
4711         }
4712         else if (strEQ(s, "CHECK")) {
4713             if (!PL_checkav)
4714                 PL_checkav = newAV();
4715             if (PL_main_start && ckWARN(WARN_VOID))
4716                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4717             av_unshift(PL_checkav, 1);
4718             av_store(PL_checkav, 0, (SV*)cv);
4719             GvCV(gv) = 0;               /* cv has been hijacked */
4720         }
4721         else if (strEQ(s, "INIT")) {
4722             if (!PL_initav)
4723                 PL_initav = newAV();
4724             if (PL_main_start && ckWARN(WARN_VOID))
4725                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4726             av_push(PL_initav, (SV*)cv);
4727             GvCV(gv) = 0;               /* cv has been hijacked */
4728         }
4729     }
4730     else
4731         CvANON_on(cv);
4732
4733 done:
4734     return cv;
4735 }
4736
4737 void
4738 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4739 {
4740     register CV *cv;
4741     GV *gv;
4742
4743     if (o)
4744         gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4745     else
4746         gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4747
4748 #ifdef GV_UNIQUE_CHECK
4749     if (GvUNIQUE(gv)) {
4750         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4751     }
4752 #endif
4753     GvMULTI_on(gv);
4754     if ((cv = GvFORM(gv))) {
4755         if (ckWARN(WARN_REDEFINE)) {
4756             const line_t oldline = CopLINE(PL_curcop);
4757             if (PL_copline != NOLINE)
4758                 CopLINE_set(PL_curcop, PL_copline);
4759             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4760                         o ? "Format %"SVf" redefined"
4761                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4762             CopLINE_set(PL_curcop, oldline);
4763         }
4764         SvREFCNT_dec(cv);
4765     }
4766     cv = PL_compcv;
4767     GvFORM(gv) = cv;
4768     CvGV(cv) = gv;
4769     CvFILE_set_from_cop(cv, PL_curcop);
4770
4771
4772     pad_tidy(padtidy_FORMAT);
4773     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4774     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4775     OpREFCNT_set(CvROOT(cv), 1);
4776     CvSTART(cv) = LINKLIST(CvROOT(cv));
4777     CvROOT(cv)->op_next = 0;
4778     CALL_PEEP(CvSTART(cv));
4779     op_free(o);
4780     PL_copline = NOLINE;
4781     LEAVE_SCOPE(floor);
4782 }
4783
4784 OP *
4785 Perl_newANONLIST(pTHX_ OP *o)
4786 {
4787     return newUNOP(OP_REFGEN, 0,
4788         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4789 }
4790
4791 OP *
4792 Perl_newANONHASH(pTHX_ OP *o)
4793 {
4794     return newUNOP(OP_REFGEN, 0,
4795         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4796 }
4797
4798 OP *
4799 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4800 {
4801     return newANONATTRSUB(floor, proto, Nullop, block);
4802 }
4803
4804 OP *
4805 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4806 {
4807     return newUNOP(OP_REFGEN, 0,
4808         newSVOP(OP_ANONCODE, 0,
4809                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4810 }
4811
<