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