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, 2006, 2007, 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 /* To implement user lexical pragmas, there needs to be a way at run time to
  77    get the compile time state of %^H for that block.  Storing %^H in every
  78    block (or even COP) would be very expensive, so a different approach is
  79    taken.  The (running) state of %^H is serialised into a tree of HE-like
  80    structs.  Stores into %^H are chained onto the current leaf as a struct
  81    refcounted_he * with the key and the value.  Deletes from %^H are saved
  82    with a value of PL_sv_placeholder.  The state of %^H at any point can be
  83    turned back into a regular HV by walking back up the tree from that point's
  84    leaf, ignoring any key you've already seen (placeholder or not), storing
  85    the rest into the HV structure, then removing the placeholders. Hence
  86    memory is only used to store the %^H deltas from the enclosing COP, rather
  87    than the entire %^H on each COP.
  88
  89    To cause actions on %^H to write out the serialisation records, it has
  90    magic type 'H'. This magic (itself) does nothing, but its presence causes
  91    the values to gain magic type 'h', which has entries for set and clear.
  92    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
  93    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
  94    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
  95    it will be correctly restored when any inner compiling scope is exited.
  96 */
  97
  98 #include "EXTERN.h"
  99 #define PERL_IN_OP_C
 100 #include "perl.h"
 101 #include "keywords.h"
 102
 103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
 104
 105 #if defined(PL_OP_SLAB_ALLOC)
 106
 107 #ifdef PERL_DEBUG_READONLY_OPS
 108 #  define PERL_SLAB_SIZE 4096
 109 #  include <sys/mman.h>
 110 #endif
 111
 112 #ifndef PERL_SLAB_SIZE
 113 #define PERL_SLAB_SIZE 2048
 114 #endif
 115
 116 void *
 117 Perl_Slab_Alloc(pTHX_ size_t sz)
 118 {
 119     dVAR;
 120     /*
 121      * To make incrementing use count easy PL_OpSlab is an I32 *
 122      * To make inserting the link to slab PL_OpPtr is I32 **
 123      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
 124      * Add an overhead for pointer to slab and round up as a number of pointers
 125      */
 126     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
 127     if ((PL_OpSpace -= sz) < 0) {
 128 #ifdef PERL_DEBUG_READONLY_OPS
 129         /* We need to allocate chunk by chunk so that we can control the VM
 130            mapping */
 131         PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
 132                         MAP_ANON|MAP_PRIVATE, -1, 0);
 133
 134         DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 135                               (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
 136                               PL_OpPtr));
 137         if(PL_OpPtr == MAP_FAILED) {
 138             perror("mmap failed");
 139             abort();
 140         }
 141 #else
 142
 143         PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
 144 #endif
 145         if (!PL_OpPtr) {
 146             return NULL;
 147         }
 148         /* We reserve the 0'th I32 sized chunk as a use count */
 149         PL_OpSlab = (I32 *) PL_OpPtr;
 150         /* Reduce size by the use count word, and by the size we need.
 151          * Latter is to mimic the '-=' in the if() above
 152          */
 153         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 154         /* Allocation pointer starts at the top.
 155            Theory: because we build leaves before trunk allocating at end
 156            means that at run time access is cache friendly upward
 157          */
 158         PL_OpPtr += PERL_SLAB_SIZE;
 159
 160 #ifdef PERL_DEBUG_READONLY_OPS
 161         /* We remember this slab.  */
 162         /* This implementation isn't efficient, but it is simple. */
 163         PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
 164         PL_slabs[PL_slab_count++] = PL_OpSlab;
 165         DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
 166 #endif
 167     }
 168     assert( PL_OpSpace >= 0 );
 169     /* Move the allocation pointer down */
 170     PL_OpPtr   -= sz;
 171     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 172     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 173     (*PL_OpSlab)++;             /* Increment use count of slab */
 174     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 175     assert( *PL_OpSlab > 0 );
 176     return (void *)(PL_OpPtr + 1);
 177 }
 178
 179 #ifdef PERL_DEBUG_READONLY_OPS
 180 void
 181 Perl_pending_Slabs_to_ro(pTHX) {
 182     /* Turn all the allocated op slabs read only.  */
 183     U32 count = PL_slab_count;
 184     I32 **const slabs = PL_slabs;
 185
 186     /* Reset the array of pending OP slabs, as we're about to turn this lot
 187        read only. Also, do it ahead of the loop in case the warn triggers,
 188        and a warn handler has an eval */
 189
 190     PL_slabs = NULL;
 191     PL_slab_count = 0;
 192
 193     /* Force a new slab for any further allocation.  */
 194     PL_OpSpace = 0;
 195
 196     while (count--) {
 197         void *const start = slabs[count];
 198         const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
 199         if(mprotect(start, size, PROT_READ)) {
 200             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
 201                       start, (unsigned long) size, errno);
 202         }
 203     }
 204
 205     free(slabs);
 206 }
 207
 208 STATIC void
 209 S_Slab_to_rw(pTHX_ void *op)
 210 {
 211     I32 * const * const ptr = (I32 **) op;
 212     I32 * const slab = ptr[-1];
 213
 214     PERL_ARGS_ASSERT_SLAB_TO_RW;
 215
 216     assert( ptr-1 > (I32 **) slab );
 217     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 218     assert( *slab > 0 );
 219     if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
 220         Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
 221                   slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
 222     }
 223 }
 224
 225 OP *
 226 Perl_op_refcnt_inc(pTHX_ OP *o)
 227 {
 228     if(o) {
 229         Slab_to_rw(o);
 230         ++o->op_targ;
 231     }
 232     return o;
 233
 234 }
 235
 236 PADOFFSET
 237 Perl_op_refcnt_dec(pTHX_ OP *o)
 238 {
 239     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 240     Slab_to_rw(o);
 241     return --o->op_targ;
 242 }
 243 #else
 244 #  define Slab_to_rw(op)
 245 #endif
 246
 247 void
 248 Perl_Slab_Free(pTHX_ void *op)
 249 {
 250     I32 * const * const ptr = (I32 **) op;
 251     I32 * const slab = ptr[-1];
 252     PERL_ARGS_ASSERT_SLAB_FREE;
 253     assert( ptr-1 > (I32 **) slab );
 254     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 255     assert( *slab > 0 );
 256     Slab_to_rw(op);
 257     if (--(*slab) == 0) {
 258 #  ifdef NETWARE
 259 #    define PerlMemShared PerlMem
 260 #  endif
 261
 262 #ifdef PERL_DEBUG_READONLY_OPS
 263         U32 count = PL_slab_count;
 264         /* Need to remove this slab from our list of slabs */
 265         if (count) {
 266             while (count--) {
 267                 if (PL_slabs[count] == slab) {
 268                     dVAR;
 269                     /* Found it. Move the entry at the end to overwrite it.  */
 270                     DEBUG_m(PerlIO_printf(Perl_debug_log,
 271                                           "Deallocate %p by moving %p from %lu to %lu\n",
 272                                           PL_OpSlab,
 273                                           PL_slabs[PL_slab_count - 1],
 274                                           PL_slab_count, count));
 275                     PL_slabs[count] = PL_slabs[--PL_slab_count];
 276                     /* Could realloc smaller at this point, but probably not
 277                        worth it.  */
 278                     if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
 279                         perror("munmap failed");
 280                         abort();
 281                     }
 282                     break;
 283                 }
 284             }
 285         }
 286 #else
 287     PerlMemShared_free(slab);
 288 #endif
 289         if (slab == PL_OpSlab) {
 290             PL_OpSpace = 0;
 291         }
 292     }
 293 }
 294 #endif
 295 /*
 296  * In the following definition, the ", (OP*)0" is just to make the compiler
 297  * think the expression is of the right type: croak actually does a Siglongjmp.
 298  */
 299 #define CHECKOP(type,o) \
 300     ((PL_op_mask && PL_op_mask[type])                           \
 301      ? ( op_free((OP*)o),                                       \
 302          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 303          (OP*)0 )                                               \
 304      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 305
 306 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 307
 308 STATIC const char*
 309 S_gv_ename(pTHX_ GV *gv)
 310 {
 311     SV* const tmpsv = sv_newmortal();
 312
 313     PERL_ARGS_ASSERT_GV_ENAME;
 314
 315     gv_efullname3(tmpsv, gv, NULL);
 316     return SvPV_nolen_const(tmpsv);
 317 }
 318
 319 STATIC OP *
 320 S_no_fh_allowed(pTHX_ OP *o)
 321 {
 322     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 323
 324     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 325                  OP_DESC(o)));
 326     return o;
 327 }
 328
 329 STATIC OP *
 330 S_too_few_arguments(pTHX_ OP *o, const char *name)
 331 {
 332     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
 333
 334     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 335     return o;
 336 }
 337
 338 STATIC OP *
 339 S_too_many_arguments(pTHX_ OP *o, const char *name)
 340 {
 341     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
 342
 343     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 344     return o;
 345 }
 346
 347 STATIC void
 348 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 349 {
 350     PERL_ARGS_ASSERT_BAD_TYPE;
 351
 352     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 353                  (int)n, name, t, OP_DESC(kid)));
 354 }
 355
 356 STATIC void
 357 S_no_bareword_allowed(pTHX_ const OP *o)
 358 {
 359     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 360
 361     if (PL_madskills)
 362         return;         /* various ok barewords are hidden in extra OP_NULL */
 363     qerror(Perl_mess(aTHX_
 364                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 365                      SVfARG(cSVOPo_sv)));
 366 }
 367
 368 /* "register" allocation */
 369
 370 PADOFFSET
 371 Perl_allocmy(pTHX_ const char *const name)
 372 {
 373     dVAR;
 374     PADOFFSET off;
 375     const bool is_our = (PL_parser->in_my == KEY_our);
 376
 377     PERL_ARGS_ASSERT_ALLOCMY;
 378
 379     /* complain about "my $<special_var>" etc etc */
 380     if (*name &&
 381         !(is_our ||
 382           isALPHA(name[1]) ||
 383           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 384           (name[1] == '_' && (*name == '$' || name[2]))))
 385     {
 386         /* name[2] is true if strlen(name) > 2  */
 387         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 388             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
 389                               name[0], toCTRL(name[1]), name + 2,
 390                               PL_parser->in_my == KEY_state ? "state" : "my"));
 391         } else {
 392             yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
 393                               PL_parser->in_my == KEY_state ? "state" : "my"));
 394         }
 395     }
 396
 397     /* check for duplicate declaration */
 398     pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
 399
 400     if (PL_parser->in_my_stash && *name != '$') {
 401         yyerror(Perl_form(aTHX_
 402                     "Can't declare class for non-scalar %s in \"%s\"",
 403                      name,
 404                      is_our ? "our"
 405                             : PL_parser->in_my == KEY_state ? "state" : "my"));
 406     }
 407
 408     /* allocate a spare slot and store the name in that slot */
 409
 410     off = pad_add_name(name,
 411                     PL_parser->in_my_stash,
 412                     (is_our
 413                         /* $_ is always in main::, even with our */
 414                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 415                         : NULL
 416                     ),
 417                     0, /*  not fake */
 418                     PL_parser->in_my == KEY_state
 419     );
 420     /* anon sub prototypes contains state vars should always be cloned,
 421      * otherwise the state var would be shared between anon subs */
 422
 423     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 424         CvCLONE_on(PL_compcv);
 425
 426     return off;
 427 }
 428
 429 /* free the body of an op without examining its contents.
 430  * Always use this rather than FreeOp directly */
 431
 432 static void
 433 S_op_destroy(pTHX_ OP *o)
 434 {
 435     if (o->op_latefree) {
 436         o->op_latefreed = 1;
 437         return;
 438     }
 439     FreeOp(o);
 440 }
 441
 442 #ifdef USE_ITHREADS
 443 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a,b)
 444 #else
 445 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a)
 446 #endif
 447
 448 /* Destructor */
 449
 450 void
 451 Perl_op_free(pTHX_ OP *o)
 452 {
 453     dVAR;
 454     OPCODE type;
 455
 456     if (!o)
 457         return;
 458     if (o->op_latefreed) {
 459         if (o->op_latefree)
 460             return;
 461         goto do_free;
 462     }
 463
 464     type = o->op_type;
 465     if (o->op_private & OPpREFCOUNTED) {
 466         switch (type) {
 467         case OP_LEAVESUB:
 468         case OP_LEAVESUBLV:
 469         case OP_LEAVEEVAL:
 470         case OP_LEAVE:
 471         case OP_SCOPE:
 472         case OP_LEAVEWRITE:
 473             {
 474             PADOFFSET refcnt;
 475             OP_REFCNT_LOCK;
 476             refcnt = OpREFCNT_dec(o);
 477             OP_REFCNT_UNLOCK;
 478             if (refcnt) {
 479                 /* Need to find and remove any pattern match ops from the list
 480                    we maintain for reset().  */
 481                 find_and_forget_pmops(o);
 482                 return;
 483             }
 484             }
 485             break;
 486         default:
 487             break;
 488         }
 489     }
 490
 491     if (o->op_flags & OPf_KIDS) {
 492         register OP *kid, *nextkid;
 493         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 494             nextkid = kid->op_sibling; /* Get before next freeing kid */
 495             op_free(kid);
 496         }
 497     }
 498     if (type == OP_NULL)
 499         type = (OPCODE)o->op_targ;
 500
 501 #ifdef PERL_DEBUG_READONLY_OPS
 502     Slab_to_rw(o);
 503 #endif
 504
 505     /* COP* is not cleared by op_clear() so that we may track line
 506      * numbers etc even after null() */
 507     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 508         cop_free((COP*)o);
 509     }
 510
 511     op_clear(o);
 512     if (o->op_latefree) {
 513         o->op_latefreed = 1;
 514         return;
 515     }
 516   do_free:
 517     FreeOp(o);
 518 #ifdef DEBUG_LEAKING_SCALARS
 519     if (PL_op == o)
 520         PL_op = NULL;
 521 #endif
 522 }
 523
 524 void
 525 Perl_op_clear(pTHX_ OP *o)
 526 {
 527
 528     dVAR;
 529
 530     PERL_ARGS_ASSERT_OP_CLEAR;
 531
 532 #ifdef PERL_MAD
 533     /* if (o->op_madprop && o->op_madprop->mad_next)
 534        abort(); */
 535     /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
 536        "modification of a read only value" for a reason I can't fathom why.
 537        It's the "" stringification of $_, where $_ was set to '' in a foreach
 538        loop, but it defies simplification into a small test case.
 539        However, commenting them out has caused ext/List/Util/t/weak.t to fail
 540        the last test.  */
 541     /*
 542       mad_free(o->op_madprop);
 543       o->op_madprop = 0;
 544     */
 545 #endif
 546
 547  retry:
 548     switch (o->op_type) {
 549     case OP_NULL:       /* Was holding old type, if any. */
 550         if (PL_madskills && o->op_targ != OP_NULL) {
 551             o->op_type = (optype)o->op_targ;
 552             o->op_targ = 0;
 553             goto retry;
 554         }
 555     case OP_ENTEREVAL:  /* Was holding hints. */
 556         o->op_targ = 0;
 557         break;
 558     default:
 559         if (!(o->op_flags & OPf_REF)
 560             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 561             break;
 562         /* FALL THROUGH */
 563     case OP_GVSV:
 564     case OP_GV:
 565     case OP_AELEMFAST:
 566         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 567             /* not an OP_PADAV replacement */
 568 #ifdef USE_ITHREADS
 569             if (cPADOPo->op_padix > 0) {
 570                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 571                  * may still exist on the pad */
 572                 pad_swipe(cPADOPo->op_padix, TRUE);
 573                 cPADOPo->op_padix = 0;
 574             }
 575 #else
 576             SvREFCNT_dec(cSVOPo->op_sv);
 577             cSVOPo->op_sv = NULL;
 578 #endif
 579         }
 580         break;
 581     case OP_METHOD_NAMED:
 582     case OP_CONST:
 583         SvREFCNT_dec(cSVOPo->op_sv);
 584         cSVOPo->op_sv = NULL;
 585 #ifdef USE_ITHREADS
 586         /** Bug #15654
 587           Even if op_clear does a pad_free for the target of the op,
 588           pad_free doesn't actually remove the sv that exists in the pad;
 589           instead it lives on. This results in that it could be reused as
 590           a target later on when the pad was reallocated.
 591         **/
 592         if(o->op_targ) {
 593           pad_swipe(o->op_targ,1);
 594           o->op_targ = 0;
 595         }
 596 #endif
 597         break;
 598     case OP_GOTO:
 599     case OP_NEXT:
 600     case OP_LAST:
 601     case OP_REDO:
 602         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 603             break;
 604         /* FALL THROUGH */
 605     case OP_TRANS:
 606         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 607 #ifdef USE_ITHREADS
 608             if (cPADOPo->op_padix > 0) {
 609                 pad_swipe(cPADOPo->op_padix, TRUE);
 610                 cPADOPo->op_padix = 0;
 611             }
 612 #else
 613             SvREFCNT_dec(cSVOPo->op_sv);
 614             cSVOPo->op_sv = NULL;
 615 #endif
 616         }
 617         else {
 618             PerlMemShared_free(cPVOPo->op_pv);
 619             cPVOPo->op_pv = NULL;
 620         }
 621         break;
 622     case OP_SUBST:
 623         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 624         goto clear_pmop;
 625     case OP_PUSHRE:
 626 #ifdef USE_ITHREADS
 627         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 628             /* No GvIN_PAD_off here, because other references may still
 629              * exist on the pad */
 630             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 631         }
 632 #else
 633         SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
 634 #endif
 635         /* FALL THROUGH */
 636     case OP_MATCH:
 637     case OP_QR:
 638 clear_pmop:
 639         forget_pmop(cPMOPo, 1);
 640         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 641         /* we use the same protection as the "SAFE" version of the PM_ macros
 642          * here since sv_clean_all might release some PMOPs
 643          * after PL_regex_padav has been cleared
 644          * and the clearing of PL_regex_padav needs to
 645          * happen before sv_clean_all
 646          */
 647 #ifdef USE_ITHREADS
 648         if(PL_regex_pad) {        /* We could be in destruction */
 649             const IV offset = (cPMOPo)->op_pmoffset;
 650             ReREFCNT_dec(PM_GETRE(cPMOPo));
 651             PL_regex_pad[offset] = &PL_sv_undef;
 652             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 653                            sizeof(offset));
 654         }
 655 #else
 656         ReREFCNT_dec(PM_GETRE(cPMOPo));
 657         PM_SETRE(cPMOPo, NULL);
 658 #endif
 659
 660         break;
 661     }
 662
 663     if (o->op_targ > 0) {
 664         pad_free(o->op_targ);
 665         o->op_targ = 0;
 666     }
 667 }
 668
 669 STATIC void
 670 S_cop_free(pTHX_ COP* cop)
 671 {
 672     PERL_ARGS_ASSERT_COP_FREE;
 673
 674     CopLABEL_free(cop);
 675     CopFILE_free(cop);
 676     CopSTASH_free(cop);
 677     if (! specialWARN(cop->cop_warnings))
 678         PerlMemShared_free(cop->cop_warnings);
 679     Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
 680 }
 681
 682 STATIC void
 683 S_forget_pmop(pTHX_ PMOP *const o
 684 #ifdef USE_ITHREADS
 685               , U32 flags
 686 #endif
 687               )
 688 {
 689     HV * const pmstash = PmopSTASH(o);
 690
 691     PERL_ARGS_ASSERT_FORGET_PMOP;
 692
 693     if (pmstash && !SvIS_FREED(pmstash)) {
 694         MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
 695         if (mg) {
 696             PMOP **const array = (PMOP**) mg->mg_ptr;
 697             U32 count = mg->mg_len / sizeof(PMOP**);
 698             U32 i = count;
 699
 700             while (i--) {
 701                 if (array[i] == o) {
 702                     /* Found it. Move the entry at the end to overwrite it.  */
 703                     array[i] = array[--count];
 704                     mg->mg_len = count * sizeof(PMOP**);
 705                     /* Could realloc smaller at this point always, but probably
 706                        not worth it. Probably worth free()ing if we're the
 707                        last.  */
 708                     if(!count) {
 709                         Safefree(mg->mg_ptr);
 710                         mg->mg_ptr = NULL;
 711                     }
 712                     break;
 713                 }
 714             }
 715         }
 716     }
 717     if (PL_curpm == o)
 718         PL_curpm = NULL;
 719 #ifdef USE_ITHREADS
 720     if (flags)
 721         PmopSTASH_free(o);
 722 #endif
 723 }
 724
 725 STATIC void
 726 S_find_and_forget_pmops(pTHX_ OP *o)
 727 {
 728     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 729
 730     if (o->op_flags & OPf_KIDS) {
 731         OP *kid = cUNOPo->op_first;
 732         while (kid) {
 733             switch (kid->op_type) {
 734             case OP_SUBST:
 735             case OP_PUSHRE:
 736             case OP_MATCH:
 737             case OP_QR:
 738                 forget_pmop((PMOP*)kid, 0);
 739             }
 740             find_and_forget_pmops(kid);
 741             kid = kid->op_sibling;
 742         }
 743     }
 744 }
 745
 746 void
 747 Perl_op_null(pTHX_ OP *o)
 748 {
 749     dVAR;
 750
 751     PERL_ARGS_ASSERT_OP_NULL;
 752
 753     if (o->op_type == OP_NULL)
 754         return;
 755     if (!PL_madskills)
 756         op_clear(o);
 757     o->op_targ = o->op_type;
 758     o->op_type = OP_NULL;
 759     o->op_ppaddr = PL_ppaddr[OP_NULL];
 760 }
 761
 762 void
 763 Perl_op_refcnt_lock(pTHX)
 764 {
 765     dVAR;
 766     PERL_UNUSED_CONTEXT;
 767     OP_REFCNT_LOCK;
 768 }
 769
 770 void
 771 Perl_op_refcnt_unlock(pTHX)
 772 {
 773     dVAR;
 774     PERL_UNUSED_CONTEXT;
 775     OP_REFCNT_UNLOCK;
 776 }
 777
 778 /* Contextualizers */
 779
 780 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 781
 782 OP *
 783 Perl_linklist(pTHX_ OP *o)
 784 {
 785     OP *first;
 786
 787     PERL_ARGS_ASSERT_LINKLIST;
 788
 789     if (o->op_next)
 790         return o->op_next;
 791
 792     /* establish postfix order */
 793     first = cUNOPo->op_first;
 794     if (first) {
 795         register OP *kid;
 796         o->op_next = LINKLIST(first);
 797         kid = first;
 798         for (;;) {
 799             if (kid->op_sibling) {
 800                 kid->op_next = LINKLIST(kid->op_sibling);
 801                 kid = kid->op_sibling;
 802             } else {
 803                 kid->op_next = o;
 804                 break;
 805             }
 806         }
 807     }
 808     else
 809         o->op_next = o;
 810
 811     return o->op_next;
 812 }
 813
 814 OP *
 815 Perl_scalarkids(pTHX_ OP *o)
 816 {
 817     if (o && o->op_flags & OPf_KIDS) {
 818         OP *kid;
 819         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 820             scalar(kid);
 821     }
 822     return o;
 823 }
 824
 825 STATIC OP *
 826 S_scalarboolean(pTHX_ OP *o)
 827 {
 828     dVAR;
 829
 830     PERL_ARGS_ASSERT_SCALARBOOLEAN;
 831
 832     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 833         if (ckWARN(WARN_SYNTAX)) {
 834             const line_t oldline = CopLINE(PL_curcop);
 835
 836             if (PL_parser && PL_parser->copline != NOLINE)
 837                 CopLINE_set(PL_curcop, PL_parser->copline);
 838             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 839             CopLINE_set(PL_curcop, oldline);
 840         }
 841     }
 842     return scalar(o);
 843 }
 844
 845 OP *
 846 Perl_scalar(pTHX_ OP *o)
 847 {
 848     dVAR;
 849     OP *kid;
 850
 851     /* assumes no premature commitment */
 852     if (!o || (PL_parser && PL_parser->error_count)
 853          || (o->op_flags & OPf_WANT)
 854          || o->op_type == OP_RETURN)
 855     {
 856         return o;
 857     }
 858
 859     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 860
 861     switch (o->op_type) {
 862     case OP_REPEAT:
 863         scalar(cBINOPo->op_first);
 864         break;
 865     case OP_OR:
 866     case OP_AND:
 867     case OP_COND_EXPR:
 868         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 869             scalar(kid);
 870         break;
 871     case OP_SPLIT:
 872         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 873             if (!kPMOP->op_pmreplrootu.op_pmreplroot)
 874                 deprecate_old("implicit split to @_");
 875         }
 876         /* FALL THROUGH */
 877     case OP_MATCH:
 878     case OP_QR:
 879     case OP_SUBST:
 880     case OP_NULL:
 881     default:
 882         if (o->op_flags & OPf_KIDS) {
 883             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 884                 scalar(kid);
 885         }
 886         break;
 887     case OP_LEAVE:
 888     case OP_LEAVETRY:
 889         kid = cLISTOPo->op_first;
 890         scalar(kid);
 891         while ((kid = kid->op_sibling)) {
 892             if (kid->op_sibling)
 893                 scalarvoid(kid);
 894             else
 895                 scalar(kid);
 896         }
 897         PL_curcop = &PL_compiling;
 898         break;
 899     case OP_SCOPE:
 900     case OP_LINESEQ:
 901     case OP_LIST:
 902         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 903             if (kid->op_sibling)
 904                 scalarvoid(kid);
 905             else
 906                 scalar(kid);
 907         }
 908         PL_curcop = &PL_compiling;
 909         break;
 910     case OP_SORT:
 911         if (ckWARN(WARN_VOID))
 912             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 913     }
 914     return o;
 915 }
 916
 917 OP *
 918 Perl_scalarvoid(pTHX_ OP *o)
 919 {
 920     dVAR;
 921     OP *kid;
 922     const char* useless = NULL;
 923     SV* sv;
 924     U8 want;
 925
 926     PERL_ARGS_ASSERT_SCALARVOID;
 927
 928     /* trailing mad null ops don't count as "there" for void processing */
 929     if (PL_madskills &&
 930         o->op_type != OP_NULL &&
 931         o->op_sibling &&
 932         o->op_sibling->op_type == OP_NULL)
 933     {
 934         OP *sib;
 935         for (sib = o->op_sibling;
 936                 sib && sib->op_type == OP_NULL;
 937                 sib = sib->op_sibling) ;
 938
 939         if (!sib)
 940             return o;
 941     }
 942
 943     if (o->op_type == OP_NEXTSTATE
 944         || o->op_type == OP_DBSTATE
 945         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 946                                       || o->op_targ == OP_DBSTATE)))
 947         PL_curcop = (COP*)o;            /* for warning below */
 948
 949     /* assumes no premature commitment */
 950     want = o->op_flags & OPf_WANT;
 951     if ((want && want != OPf_WANT_SCALAR)
 952          || (PL_parser && PL_parser->error_count)
 953          || o->op_type == OP_RETURN)
 954     {
 955         return o;
 956     }
 957
 958     if ((o->op_private & OPpTARGET_MY)
 959         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 960     {
 961         return scalar(o);                       /* As if inside SASSIGN */
 962     }
 963
 964     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 965
 966     switch (o->op_type) {
 967     default:
 968         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 969             break;
 970         /* FALL THROUGH */
 971     case OP_REPEAT:
 972         if (o->op_flags & OPf_STACKED)
 973             break;
 974         goto func_ops;
 975     case OP_SUBSTR:
 976         if (o->op_private == 4)
 977             break;
 978         /* FALL THROUGH */
 979     case OP_GVSV:
 980     case OP_WANTARRAY:
 981     case OP_GV:
 982     case OP_SMARTMATCH:
 983     case OP_PADSV:
 984     case OP_PADAV:
 985     case OP_PADHV:
 986     case OP_PADANY:
 987     case OP_AV2ARYLEN:
 988     case OP_REF:
 989     case OP_REFGEN:
 990     case OP_SREFGEN:
 991     case OP_DEFINED:
 992     case OP_HEX:
 993     case OP_OCT:
 994     case OP_LENGTH:
 995     case OP_VEC:
 996     case OP_INDEX:
 997     case OP_RINDEX:
 998     case OP_SPRINTF:
 999     case OP_AELEM:
1000     case OP_AELEMFAST:
1001     case OP_ASLICE:
1002     case OP_HELEM:
1003     case OP_HSLICE:
1004     case OP_UNPACK:
1005     case OP_PACK:
1006     case OP_JOIN:
1007     case OP_LSLICE:
1008     case OP_ANONLIST:
1009     case OP_ANONHASH:
1010     case OP_SORT:
1011     case OP_REVERSE:
1012     case OP_RANGE:
1013     case OP_FLIP:
1014     case OP_FLOP:
1015     case OP_CALLER:
1016     case OP_FILENO:
1017     case OP_EOF:
1018     case OP_TELL:
1019     case OP_GETSOCKNAME:
1020     case OP_GETPEERNAME:
1021     case OP_READLINK:
1022     case OP_TELLDIR:
1023     case OP_GETPPID:
1024     case OP_GETPGRP:
1025     case OP_GETPRIORITY:
1026     case OP_TIME:
1027     case OP_TMS:
1028     case OP_LOCALTIME:
1029     case OP_GMTIME:
1030     case OP_GHBYNAME:
1031     case OP_GHBYADDR:
1032     case OP_GHOSTENT:
1033     case OP_GNBYNAME:
1034     case OP_GNBYADDR:
1035     case OP_GNETENT:
1036     case OP_GPBYNAME:
1037     case OP_GPBYNUMBER:
1038     case OP_GPROTOENT:
1039     case OP_GSBYNAME:
1040     case OP_GSBYPORT:
1041     case OP_GSERVENT:
1042     case OP_GPWNAM:
1043     case OP_GPWUID:
1044     case OP_GGRNAM:
1045     case OP_GGRGID:
1046     case OP_GETLOGIN:
1047     case OP_PROTOTYPE:
1048       func_ops:
1049         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1050             /* Otherwise it's "Useless use of grep iterator" */
1051             useless = OP_DESC(o);
1052         break;
1053
1054     case OP_NOT:
1055        kid = cUNOPo->op_first;
1056        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1057            kid->op_type != OP_TRANS) {
1058                 goto func_ops;
1059        }
1060        useless = "negative pattern binding (!~)";
1061        break;
1062
1063     case OP_RV2GV:
1064     case OP_RV2SV:
1065     case OP_RV2AV:
1066     case OP_RV2HV:
1067         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1068                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1069             useless = "a variable";
1070         break;
1071
1072     case OP_CONST:
1073         sv = cSVOPo_sv;
1074         if (cSVOPo->op_private & OPpCONST_STRICT)
1075             no_bareword_allowed(o);
1076         else {
1077             if (ckWARN(WARN_VOID)) {
1078                 if (SvOK(sv)) {
1079                     SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1080                                 "a constant (%"SVf")", sv));
1081                     useless = SvPV_nolen(msv);
1082                 }
1083                 else
1084                     useless = "a constant (undef)";
1085                 if (o->op_private & OPpCONST_ARYBASE)
1086                     useless = NULL;
1087                 /* don't warn on optimised away booleans, eg
1088                  * use constant Foo, 5; Foo || print; */
1089                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1090                     useless = NULL;
1091                 /* the constants 0 and 1 are permitted as they are
1092                    conventionally used as dummies in constructs like
1093                         1 while some_condition_with_side_effects;  */
1094                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1095                     useless = NULL;
1096                 else if (SvPOK(sv)) {
1097                   /* perl4's way of mixing documentation and code
1098                      (before the invention of POD) was based on a
1099                      trick to mix nroff and perl code. The trick was
1100                      built upon these three nroff macros being used in
1101                      void context. The pink camel has the details in
1102                      the script wrapman near page 319. */
1103                     const char * const maybe_macro = SvPVX_const(sv);
1104                     if (strnEQ(maybe_macro, "di", 2) ||
1105                         strnEQ(maybe_macro, "ds", 2) ||
1106                         strnEQ(maybe_macro, "ig", 2))
1107                             useless = NULL;
1108                 }
1109             }
1110         }
1111         op_null(o);             /* don't execute or even remember it */
1112         break;
1113
1114     case OP_POSTINC:
1115         o->op_type = OP_PREINC;         /* pre-increment is faster */
1116         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1117         break;
1118
1119     case OP_POSTDEC:
1120         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1121         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1122         break;
1123
1124     case OP_I_POSTINC:
1125         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1126         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1127         break;
1128
1129     case OP_I_POSTDEC:
1130         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1131         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1132         break;
1133
1134     case OP_OR:
1135     case OP_AND:
1136     case OP_DOR:
1137     case OP_COND_EXPR:
1138     case OP_ENTERGIVEN:
1139     case OP_ENTERWHEN:
1140         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1141             scalarvoid(kid);
1142         break;
1143
1144     case OP_NULL:
1145         if (o->op_flags & OPf_STACKED)
1146             break;
1147         /* FALL THROUGH */
1148     case OP_NEXTSTATE:
1149     case OP_DBSTATE:
1150     case OP_ENTERTRY:
1151     case OP_ENTER:
1152         if (!(o->op_flags & OPf_KIDS))
1153             break;
1154         /* FALL THROUGH */
1155     case OP_SCOPE:
1156     case OP_LEAVE:
1157     case OP_LEAVETRY:
1158     case OP_LEAVELOOP:
1159     case OP_LINESEQ:
1160     case OP_LIST:
1161     case OP_LEAVEGIVEN:
1162     case OP_LEAVEWHEN:
1163         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1164             scalarvoid(kid);
1165         break;
1166     case OP_ENTEREVAL:
1167         scalarkids(o);
1168         break;
1169     case OP_REQUIRE:
1170         /* all requires must return a boolean value */
1171         o->op_flags &= ~OPf_WANT;
1172         /* FALL THROUGH */
1173     case OP_SCALAR:
1174         return scalar(o);
1175     case OP_SPLIT:
1176         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1177             if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1178                 deprecate_old("implicit split to @_");
1179         }
1180         break;
1181     }
1182     if (useless && ckWARN(WARN_VOID))
1183         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1184     return o;
1185 }
1186
1187 OP *
1188 Perl_listkids(pTHX_ OP *o)
1189 {
1190     if (o && o->op_flags & OPf_KIDS) {
1191         OP *kid;
1192         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1193             list(kid);
1194     }
1195     return o;
1196 }
1197
1198 OP *
1199 Perl_list(pTHX_ OP *o)
1200 {
1201     dVAR;
1202     OP *kid;
1203
1204     /* assumes no premature commitment */
1205     if (!o || (o->op_flags & OPf_WANT)
1206          || (PL_parser && PL_parser->error_count)
1207          || o->op_type == OP_RETURN)
1208     {
1209         return o;
1210     }
1211
1212     if ((o->op_private & OPpTARGET_MY)
1213         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1214     {
1215         return o;                               /* As if inside SASSIGN */
1216     }
1217
1218     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1219
1220     switch (o->op_type) {
1221     case OP_FLOP:
1222     case OP_REPEAT:
1223         list(cBINOPo->op_first);
1224         break;
1225     case OP_OR:
1226     case OP_AND:
1227     case OP_COND_EXPR:
1228         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1229             list(kid);
1230         break;
1231     default:
1232     case OP_MATCH:
1233     case OP_QR:
1234     case OP_SUBST:
1235     case OP_NULL:
1236         if (!(o->op_flags & OPf_KIDS))
1237             break;
1238         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1239             list(cBINOPo->op_first);
1240             return gen_constant_list(o);
1241         }
1242     case OP_LIST:
1243         listkids(o);
1244         break;
1245     case OP_LEAVE:
1246     case OP_LEAVETRY:
1247         kid = cLISTOPo->op_first;
1248         list(kid);
1249         while ((kid = kid->op_sibling)) {
1250             if (kid->op_sibling)
1251                 scalarvoid(kid);
1252             else
1253                 list(kid);
1254         }
1255         PL_curcop = &PL_compiling;
1256         break;
1257     case OP_SCOPE:
1258     case OP_LINESEQ:
1259         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1260             if (kid->op_sibling)
1261                 scalarvoid(kid);
1262             else
1263                 list(kid);
1264         }
1265         PL_curcop = &PL_compiling;
1266         break;
1267     case OP_REQUIRE:
1268         /* all requires must return a boolean value */
1269         o->op_flags &= ~OPf_WANT;
1270         return scalar(o);
1271     }
1272     return o;
1273 }
1274
1275 OP *
1276 Perl_scalarseq(pTHX_ OP *o)
1277 {
1278     dVAR;
1279     if (o) {
1280         const OPCODE type = o->op_type;
1281
1282         if (type == OP_LINESEQ || type == OP_SCOPE ||
1283             type == OP_LEAVE || type == OP_LEAVETRY)
1284         {
1285             OP *kid;
1286             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1287                 if (kid->op_sibling) {
1288                     scalarvoid(kid);
1289                 }
1290             }
1291             PL_curcop = &PL_compiling;
1292         }
1293         o->op_flags &= ~OPf_PARENS;
1294         if (PL_hints & HINT_BLOCK_SCOPE)
1295             o->op_flags |= OPf_PARENS;
1296     }
1297     else
1298         o = newOP(OP_STUB, 0);
1299     return o;
1300 }
1301
1302 STATIC OP *
1303 S_modkids(pTHX_ OP *o, I32 type)
1304 {
1305     if (o && o->op_flags & OPf_KIDS) {
1306         OP *kid;
1307         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1308             mod(kid, type);
1309     }
1310     return o;
1311 }
1312
1313 /* Propagate lvalue ("modifiable") context to an op and its children.
1314  * 'type' represents the context type, roughly based on the type of op that
1315  * would do the modifying, although local() is represented by OP_NULL.
1316  * It's responsible for detecting things that can't be modified,  flag
1317  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1318  * might have to vivify a reference in $x), and so on.
1319  *
1320  * For example, "$a+1 = 2" would cause mod() to be called with o being
1321  * OP_ADD and type being OP_SASSIGN, and would output an error.
1322  */
1323
1324 OP *
1325 Perl_mod(pTHX_ OP *o, I32 type)
1326 {
1327     dVAR;
1328     OP *kid;
1329     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1330     int localize = -1;
1331
1332     if (!o || (PL_parser && PL_parser->error_count))
1333         return o;
1334
1335     if ((o->op_private & OPpTARGET_MY)
1336         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1337     {
1338         return o;
1339     }
1340
1341     switch (o->op_type) {
1342     case OP_UNDEF:
1343         localize = 0;
1344         PL_modcount++;
1345         return o;
1346     case OP_CONST:
1347         if (!(o->op_private & OPpCONST_ARYBASE))
1348             goto nomod;
1349         localize = 0;
1350         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1351             CopARYBASE_set(&PL_compiling,
1352                            (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1353             PL_eval_start = 0;
1354         }
1355         else if (!type) {
1356             SAVECOPARYBASE(&PL_compiling);
1357             CopARYBASE_set(&PL_compiling, 0);
1358         }
1359         else if (type == OP_REFGEN)
1360             goto nomod;
1361         else
1362             Perl_croak(aTHX_ "That use of $[ is unsupported");
1363         break;
1364     case OP_STUB:
1365         if ((o->op_flags & OPf_PARENS) || PL_madskills)
1366             break;
1367         goto nomod;
1368     case OP_ENTERSUB:
1369         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1370             !(o->op_flags & OPf_STACKED)) {
1371             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1372             /* The default is to set op_private to the number of children,
1373                which for a UNOP such as RV2CV is always 1. And w're using
1374                the bit for a flag in RV2CV, so we need it clear.  */
1375             o->op_private &= ~1;
1376             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1377             assert(cUNOPo->op_first->op_type == OP_NULL);
1378             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1379             break;
1380         }
1381         else if (o->op_private & OPpENTERSUB_NOMOD)
1382             return o;
1383         else {                          /* lvalue subroutine call */
1384             o->op_private |= OPpLVAL_INTRO;
1385             PL_modcount = RETURN_UNLIMITED_NUMBER;
1386             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1387                 /* Backward compatibility mode: */
1388                 o->op_private |= OPpENTERSUB_INARGS;
1389                 break;
1390             }
1391             else {                      /* Compile-time error message: */
1392                 OP *kid = cUNOPo->op_first;
1393                 CV *cv;
1394                 OP *okid;
1395
1396                 if (kid->op_type != OP_PUSHMARK) {
1397                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1398                         Perl_croak(aTHX_
1399                                 "panic: unexpected lvalue entersub "
1400                                 "args: type/targ %ld:%"UVuf,
1401                                 (long)kid->op_type, (UV)kid->op_targ);
1402                     kid = kLISTOP->op_first;
1403                 }
1404                 while (kid->op_sibling)
1405                     kid = kid->op_sibling;
1406                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1407                     /* Indirect call */
1408                     if (kid->op_type == OP_METHOD_NAMED
1409                         || kid->op_type == OP_METHOD)
1410                     {
1411                         UNOP *newop;
1412
1413                         NewOp(1101, newop, 1, UNOP);
1414                         newop->op_type = OP_RV2CV;
1415                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1416                         newop->op_first = NULL;
1417                         newop->op_next = (OP*)newop;
1418                         kid->op_sibling = (OP*)newop;
1419                         newop->op_private |= OPpLVAL_INTRO;
1420                         newop->op_private &= ~1;
1421                         break;
1422                     }
1423
1424                     if (kid->op_type != OP_RV2CV)
1425                         Perl_croak(aTHX_
1426                                    "panic: unexpected lvalue entersub "
1427                                    "entry via type/targ %ld:%"UVuf,
1428                                    (long)kid->op_type, (UV)kid->op_targ);
1429                     kid->op_private |= OPpLVAL_INTRO;
1430                     break;      /* Postpone until runtime */
1431                 }
1432
1433                 okid = kid;
1434                 kid = kUNOP->op_first;
1435                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1436                     kid = kUNOP->op_first;
1437                 if (kid->op_type == OP_NULL)
1438                     Perl_croak(aTHX_
1439                                "Unexpected constant lvalue entersub "
1440                                "entry via type/targ %ld:%"UVuf,
1441                                (long)kid->op_type, (UV)kid->op_targ);
1442                 if (kid->op_type != OP_GV) {
1443                     /* Restore RV2CV to check lvalueness */
1444                   restore_2cv:
1445                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1446                         okid->op_next = kid->op_next;
1447                         kid->op_next = okid;
1448                     }
1449                     else
1450                         okid->op_next = NULL;
1451                     okid->op_type = OP_RV2CV;
1452                     okid->op_targ = 0;
1453                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1454                     okid->op_private |= OPpLVAL_INTRO;
1455                     okid->op_private &= ~1;
1456                     break;
1457                 }
1458
1459                 cv = GvCV(kGVOP_gv);
1460                 if (!cv)
1461                     goto restore_2cv;
1462                 if (CvLVALUE(cv))
1463                     break;
1464             }
1465         }
1466         /* FALL THROUGH */
1467     default:
1468       nomod:
1469         /* grep, foreach, subcalls, refgen */
1470         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1471             break;
1472         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1473                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1474                       ? "do block"
1475                       : (o->op_type == OP_ENTERSUB
1476                         ? "non-lvalue subroutine call"
1477                         : OP_DESC(o))),
1478                      type ? PL_op_desc[type] : "local"));
1479         return o;
1480
1481     case OP_PREINC:
1482     case OP_PREDEC:
1483     case OP_POW:
1484     case OP_MULTIPLY:
1485     case OP_DIVIDE:
1486     case OP_MODULO:
1487     case OP_REPEAT:
1488     case OP_ADD:
1489     case OP_SUBTRACT:
1490     case OP_CONCAT:
1491     case OP_LEFT_SHIFT:
1492     case OP_RIGHT_SHIFT:
1493     case OP_BIT_AND:
1494     case OP_BIT_XOR:
1495     case OP_BIT_OR:
1496     case OP_I_MULTIPLY:
1497     case OP_I_DIVIDE:
1498     case OP_I_MODULO:
1499     case OP_I_ADD:
1500     case OP_I_SUBTRACT:
1501         if (!(o->op_flags & OPf_STACKED))
1502             goto nomod;
1503         PL_modcount++;
1504         break;
1505
1506     case OP_COND_EXPR:
1507         localize = 1;
1508         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1509             mod(kid, type);
1510         break;
1511
1512     case OP_RV2AV:
1513     case OP_RV2HV:
1514         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1515            PL_modcount = RETURN_UNLIMITED_NUMBER;
1516             return o;           /* Treat \(@foo) like ordinary list. */
1517         }
1518         /* FALL THROUGH */
1519     case OP_RV2GV:
1520         if (scalar_mod_type(o, type))
1521             goto nomod;
1522         ref(cUNOPo->op_first, o->op_type);
1523         /* FALL THROUGH */
1524     case OP_ASLICE:
1525     case OP_HSLICE:
1526         if (type == OP_LEAVESUBLV)
1527             o->op_private |= OPpMAYBE_LVSUB;
1528         localize = 1;
1529         /* FALL THROUGH */
1530     case OP_AASSIGN:
1531     case OP_NEXTSTATE:
1532     case OP_DBSTATE:
1533        PL_modcount = RETURN_UNLIMITED_NUMBER;
1534         break;
1535     case OP_RV2SV:
1536         ref(cUNOPo->op_first, o->op_type);
1537         localize = 1;
1538         /* FALL THROUGH */
1539     case OP_GV:
1540     case OP_AV2ARYLEN:
1541         PL_hints |= HINT_BLOCK_SCOPE;
1542     case OP_SASSIGN:
1543     case OP_ANDASSIGN:
1544     case OP_ORASSIGN:
1545     case OP_DORASSIGN:
1546         PL_modcount++;
1547         break;
1548
1549     case OP_AELEMFAST:
1550         localize = -1;
1551         PL_modcount++;
1552         break;
1553
1554     case OP_PADAV:
1555     case OP_PADHV:
1556        PL_modcount = RETURN_UNLIMITED_NUMBER;
1557         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1558             return o;           /* Treat \(@foo) like ordinary list. */
1559         if (scalar_mod_type(o, type))
1560             goto nomod;
1561         if (type == OP_LEAVESUBLV)
1562             o->op_private |= OPpMAYBE_LVSUB;
1563         /* FALL THROUGH */
1564     case OP_PADSV:
1565         PL_modcount++;
1566         if (!type) /* local() */
1567             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1568                  PAD_COMPNAME_PV(o->op_targ));
1569         break;
1570
1571     case OP_PUSHMARK:
1572         localize = 0;
1573         break;
1574
1575     case OP_KEYS:
1576         if (type != OP_SASSIGN)
1577             goto nomod;
1578         goto lvalue_func;
1579     case OP_SUBSTR:
1580         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1581             goto nomod;
1582         /* FALL THROUGH */
1583     case OP_POS:
1584     case OP_VEC:
1585         if (type == OP_LEAVESUBLV)
1586             o->op_private |= OPpMAYBE_LVSUB;
1587       lvalue_func:
1588         pad_free(o->op_targ);
1589         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1590         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1591         if (o->op_flags & OPf_KIDS)
1592             mod(cBINOPo->op_first->op_sibling, type);
1593         break;
1594
1595     case OP_AELEM:
1596     case OP_HELEM:
1597         ref(cBINOPo->op_first, o->op_type);
1598         if (type == OP_ENTERSUB &&
1599              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1600             o->op_private |= OPpLVAL_DEFER;
1601         if (type == OP_LEAVESUBLV)
1602             o->op_private |= OPpMAYBE_LVSUB;
1603         localize = 1;
1604         PL_modcount++;
1605         break;
1606
1607     case OP_SCOPE:
1608     case OP_LEAVE:
1609     case OP_ENTER:
1610     case OP_LINESEQ:
1611         localize = 0;
1612         if (o->op_flags & OPf_KIDS)
1613             mod(cLISTOPo->op_last, type);
1614         break;
1615
1616     case OP_NULL:
1617         localize = 0;
1618         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1619             goto nomod;
1620         else if (!(o->op_flags & OPf_KIDS))
1621             break;
1622         if (o->op_targ != OP_LIST) {
1623             mod(cBINOPo->op_first, type);
1624             break;
1625         }
1626         /* FALL THROUGH */
1627     case OP_LIST:
1628         localize = 0;
1629         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1630             mod(kid, type);
1631         break;
1632
1633     case OP_RETURN:
1634         if (type != OP_LEAVESUBLV)
1635             goto nomod;
1636         break; /* mod()ing was handled by ck_return() */
1637     }
1638
1639     /* [20011101.069] File test operators interpret OPf_REF to mean that
1640        their argument is a filehandle; thus \stat(".") should not set
1641        it. AMS 20011102 */
1642     if (type == OP_REFGEN &&
1643         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1644         return o;
1645
1646     if (type != OP_LEAVESUBLV)
1647         o->op_flags |= OPf_MOD;
1648
1649     if (type == OP_AASSIGN || type == OP_SASSIGN)
1650         o->op_flags |= OPf_SPECIAL|OPf_REF;
1651     else if (!type) { /* local() */
1652         switch (localize) {
1653         case 1:
1654             o->op_private |= OPpLVAL_INTRO;
1655             o->op_flags &= ~OPf_SPECIAL;
1656             PL_hints |= HINT_BLOCK_SCOPE;
1657             break;
1658         case 0:
1659             break;
1660         case -1:
1661             if (ckWARN(WARN_SYNTAX)) {
1662                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1663                     "Useless localization of %s", OP_DESC(o));
1664             }
1665         }
1666     }
1667     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1668              && type != OP_LEAVESUBLV)
1669         o->op_flags |= OPf_REF;
1670     return o;
1671 }
1672
1673 STATIC bool
1674 S_scalar_mod_type(const OP *o, I32 type)
1675 {
1676     PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1677
1678     switch (type) {
1679     case OP_SASSIGN:
1680         if (o->op_type == OP_RV2GV)
1681             return FALSE;
1682         /* FALL THROUGH */
1683     case OP_PREINC:
1684     case OP_PREDEC:
1685     case OP_POSTINC:
1686     case OP_POSTDEC:
1687     case OP_I_PREINC:
1688     case OP_I_PREDEC:
1689     case OP_I_POSTINC:
1690     case OP_I_POSTDEC:
1691     case OP_POW:
1692     case OP_MULTIPLY:
1693     case OP_DIVIDE:
1694     case OP_MODULO:
1695     case OP_REPEAT:
1696     case OP_ADD:
1697     case OP_SUBTRACT:
1698     case OP_I_MULTIPLY:
1699     case OP_I_DIVIDE:
1700     case OP_I_MODULO:
1701     case OP_I_ADD:
1702     case OP_I_SUBTRACT:
1703     case OP_LEFT_SHIFT:
1704     case OP_RIGHT_SHIFT:
1705     case OP_BIT_AND:
1706     case OP_BIT_XOR:
1707     case OP_BIT_OR:
1708     case OP_CONCAT:
1709     case OP_SUBST:
1710     case OP_TRANS:
1711     case OP_READ:
1712     case OP_SYSREAD:
1713     case OP_RECV:
1714     case OP_ANDASSIGN:
1715     case OP_ORASSIGN:
1716     case OP_DORASSIGN:
1717         return TRUE;
1718     default:
1719         return FALSE;
1720     }
1721 }
1722
1723 STATIC bool
1724 S_is_handle_constructor(const OP *o, I32 numargs)
1725 {
1726     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1727
1728     switch (o->op_type) {
1729     case OP_PIPE_OP:
1730     case OP_SOCKPAIR:
1731         if (numargs == 2)
1732             return TRUE;
1733         /* FALL THROUGH */
1734     case OP_SYSOPEN:
1735     case OP_OPEN:
1736     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1737     case OP_SOCKET:
1738     case OP_OPEN_DIR:
1739     case OP_ACCEPT:
1740         if (numargs == 1)
1741             return TRUE;
1742         /* FALLTHROUGH */
1743     default:
1744         return FALSE;
1745     }
1746 }
1747
1748 OP *
1749 Perl_refkids(pTHX_ OP *o, I32 type)
1750 {
1751     if (o && o->op_flags & OPf_KIDS) {
1752         OP *kid;
1753         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1754             ref(kid, type);
1755     }
1756     return o;
1757 }
1758
1759 OP *
1760 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1761 {
1762     dVAR;
1763     OP *kid;
1764
1765     PERL_ARGS_ASSERT_DOREF;
1766
1767     if (!o || (PL_parser && PL_parser->error_count))
1768         return o;
1769
1770     switch (o->op_type) {
1771     case OP_ENTERSUB:
1772         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1773             !(o->op_flags & OPf_STACKED)) {
1774             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1775             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1776             assert(cUNOPo->op_first->op_type == OP_NULL);
1777             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1778             o->op_flags |= OPf_SPECIAL;
1779             o->op_private &= ~1;
1780         }
1781         break;
1782
1783     case OP_COND_EXPR:
1784         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1785             doref(kid, type, set_op_ref);
1786         break;
1787     case OP_RV2SV:
1788         if (type == OP_DEFINED)
1789             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1790         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1791         /* FALL THROUGH */
1792     case OP_PADSV:
1793         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1794             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1795                               : type == OP_RV2HV ? OPpDEREF_HV
1796                               : OPpDEREF_SV);
1797             o->op_flags |= OPf_MOD;
1798         }
1799         break;
1800
1801     case OP_RV2AV:
1802     case OP_RV2HV:
1803         if (set_op_ref)
1804             o->op_flags |= OPf_REF;
1805         /* FALL THROUGH */
1806     case OP_RV2GV:
1807         if (type == OP_DEFINED)
1808             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1809         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1810         break;
1811
1812     case OP_PADAV:
1813     case OP_PADHV:
1814         if (set_op_ref)
1815             o->op_flags |= OPf_REF;
1816         break;
1817
1818     case OP_SCALAR:
1819     case OP_NULL:
1820         if (!(o->op_flags & OPf_KIDS))
1821             break;
1822         doref(cBINOPo->op_first, type, set_op_ref);
1823         break;
1824     case OP_AELEM:
1825     case OP_HELEM:
1826         doref(cBINOPo->op_first, o->op_type, set_op_ref);
1827         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1828             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1829                               : type == OP_RV2HV ? OPpDEREF_HV
1830                               : OPpDEREF_SV);
1831             o->op_flags |= OPf_MOD;
1832         }
1833         break;
1834
1835     case OP_SCOPE:
1836     case OP_LEAVE:
1837         set_op_ref = FALSE;
1838         /* FALL THROUGH */
1839     case OP_ENTER:
1840     case OP_LIST:
1841         if (!(o->op_flags & OPf_KIDS))
1842             break;
1843         doref(cLISTOPo->op_last, type, set_op_ref);
1844         break;
1845     default:
1846         break;
1847     }
1848     return scalar(o);
1849
1850 }
1851
1852 STATIC OP *
1853 S_dup_attrlist(pTHX_ OP *o)
1854 {
1855     dVAR;
1856     OP *rop;
1857
1858     PERL_ARGS_ASSERT_DUP_ATTRLIST;
1859
1860     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1861      * where the first kid is OP_PUSHMARK and the remaining ones
1862      * are OP_CONST.  We need to push the OP_CONST values.
1863      */
1864     if (o->op_type == OP_CONST)
1865         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1866 #ifdef PERL_MAD
1867     else if (o->op_type == OP_NULL)
1868         rop = NULL;
1869 #endif
1870     else {
1871         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1872         rop = NULL;
1873         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1874             if (o->op_type == OP_CONST)
1875                 rop = append_elem(OP_LIST, rop,
1876                                   newSVOP(OP_CONST, o->op_flags,
1877                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
1878         }
1879     }
1880     return rop;
1881 }
1882
1883 STATIC void
1884 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1885 {
1886     dVAR;
1887     SV *stashsv;
1888
1889     PERL_ARGS_ASSERT_APPLY_ATTRS;
1890
1891     /* fake up C<use attributes $pkg,$rv,@attrs> */
1892     ENTER;              /* need to protect against side-effects of 'use' */
1893     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1894
1895 #define ATTRSMODULE "attributes"
1896 #define ATTRSMODULE_PM "attributes.pm"
1897
1898     if (for_my) {
1899         /* Don't force the C<use> if we don't need it. */
1900         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1901         if (svp && *svp != &PL_sv_undef)
1902             NOOP;       /* already in %INC */
1903         else
1904             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1905                              newSVpvs(ATTRSMODULE), NULL);
1906     }
1907     else {
1908         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1909                          newSVpvs(ATTRSMODULE),
1910                          NULL,
1911                          prepend_elem(OP_LIST,
1912                                       newSVOP(OP_CONST, 0, stashsv),
1913                                       prepend_elem(OP_LIST,
1914                                                    newSVOP(OP_CONST, 0,
1915                                                            newRV(target)),
1916                                                    dup_attrlist(attrs))));
1917     }
1918     LEAVE;
1919 }
1920
1921 STATIC void
1922 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1923 {
1924     dVAR;
1925     OP *pack, *imop, *arg;
1926     SV *meth, *stashsv;
1927
1928     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1929
1930     if (!attrs)
1931         return;
1932
1933     assert(target->op_type == OP_PADSV ||
1934            target->op_type == OP_PADHV ||
1935            target->op_type == OP_PADAV);
1936
1937     /* Ensure that attributes.pm is loaded. */
1938     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1939
1940     /* Need package name for method call. */
1941     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1942
1943     /* Build up the real arg-list. */
1944     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1945
1946     arg = newOP(OP_PADSV, 0);
1947     arg->op_targ = target->op_targ;
1948     arg = prepend_elem(OP_LIST,
1949                        newSVOP(OP_CONST, 0, stashsv),
1950                        prepend_elem(OP_LIST,
1951                                     newUNOP(OP_REFGEN, 0,
1952                                             mod(arg, OP_REFGEN)),
1953                                     dup_attrlist(attrs)));
1954
1955     /* Fake up a method call to import */
1956     meth = newSVpvs_share("import");
1957     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1958                    append_elem(OP_LIST,
1959                                prepend_elem(OP_LIST, pack, list(arg)),
1960                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1961     imop->op_private |= OPpENTERSUB_NOMOD;
1962
1963     /* Combine the ops. */
1964     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1965 }
1966
1967 /*
1968 =notfor apidoc apply_attrs_string
1969
1970 Attempts to apply a list of attributes specified by the C<attrstr> and
1971 C<len> arguments to the subroutine identified by the C<cv> argument which
1972 is expected to be associated with the package identified by the C<stashpv>
1973 argument (see L<attributes>).  It gets this wrong, though, in that it
1974 does not correctly identify the boundaries of the individual attribute
1975 specifications within C<attrstr>.  This is not really intended for the
1976 public API, but has to be listed here for systems such as AIX which
1977 need an explicit export list for symbols.  (It's called from XS code
1978 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1979 to respect attribute syntax properly would be welcome.
1980
1981 =cut
1982 */
1983
1984 void
1985 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1986                         const char *attrstr, STRLEN len)
1987 {
1988     OP *attrs = NULL;
1989
1990     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1991
1992     if (!len) {
1993         len = strlen(attrstr);
1994     }
1995
1996     while (len) {
1997         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1998         if (len) {
1999             const char * const sstr = attrstr;
2000             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2001             attrs = append_elem(OP_LIST, attrs,
2002                                 newSVOP(OP_CONST, 0,
2003                                         newSVpvn(sstr, attrstr-sstr)));
2004         }
2005     }
2006
2007     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2008                      newSVpvs(ATTRSMODULE),
2009                      NULL, prepend_elem(OP_LIST,
2010                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2011                                   prepend_elem(OP_LIST,
2012                                                newSVOP(OP_CONST, 0,
2013                                                        newRV((SV*)cv)),
2014                                                attrs)));
2015 }
2016
2017 STATIC OP *
2018 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2019 {
2020     dVAR;
2021     I32 type;
2022
2023     PERL_ARGS_ASSERT_MY_KID;
2024
2025     if (!o || (PL_parser && PL_parser->error_count))
2026         return o;
2027
2028     type = o->op_type;
2029     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2030         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2031         return o;
2032     }
2033
2034     if (type == OP_LIST) {
2035         OP *kid;
2036         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2037             my_kid(kid, attrs, imopsp);
2038     } else if (type == OP_UNDEF
2039 #ifdef PERL_MAD
2040                || type == OP_STUB
2041 #endif
2042                ) {
2043         return o;
2044     } else if (type == OP_RV2SV ||      /* "our" declaration */
2045                type == OP_RV2AV ||
2046                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2047         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2048             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2049                         OP_DESC(o),
2050                         PL_parser->in_my == KEY_our
2051                             ? "our"
2052                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2053         } else if (attrs) {
2054             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2055             PL_parser->in_my = FALSE;
2056             PL_parser->in_my_stash = NULL;
2057             apply_attrs(GvSTASH(gv),
2058                         (type == OP_RV2SV ? GvSV(gv) :
2059                          type == OP_RV2AV ? (SV*)GvAV(gv) :
2060                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2061                         attrs, FALSE);
2062         }
2063         o->op_private |= OPpOUR_INTRO;
2064         return o;
2065     }
2066     else if (type != OP_PADSV &&
2067              type != OP_PADAV &&
2068              type != OP_PADHV &&
2069              type != OP_PUSHMARK)
2070     {
2071         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2072                           OP_DESC(o),
2073                           PL_parser->in_my == KEY_our
2074                             ? "our"
2075                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2076         return o;
2077     }
2078     else if (attrs && type != OP_PUSHMARK) {
2079         HV *stash;
2080
2081         PL_parser->in_my = FALSE;
2082         PL_parser->in_my_stash = NULL;
2083
2084         /* check for C<my Dog $spot> when deciding package */
2085         stash = PAD_COMPNAME_TYPE(o->op_targ);
2086         if (!stash)
2087             stash = PL_curstash;
2088         apply_attrs_my(stash, o, attrs, imopsp);
2089     }
2090     o->op_flags |= OPf_MOD;
2091     o->op_private |= OPpLVAL_INTRO;
2092     if (PL_parser->in_my == KEY_state)
2093         o->op_private |= OPpPAD_STATE;
2094     return o;
2095 }
2096
2097 OP *
2098 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2099 {
2100     dVAR;
2101     OP *rops;
2102     int maybe_scalar = 0;
2103
2104     PERL_ARGS_ASSERT_MY_ATTRS;
2105
2106 /* [perl #17376]: this appears to be premature, and results in code such as
2107    C< our(%x); > executing in list mode rather than void mode */
2108 #if 0
2109     if (o->op_flags & OPf_PARENS)
2110         list(o);
2111     else
2112         maybe_scalar = 1;
2113 #else
2114     maybe_scalar = 1;
2115 #endif
2116     if (attrs)
2117         SAVEFREEOP(attrs);
2118     rops = NULL;
2119     o = my_kid(o, attrs, &rops);
2120     if (rops) {
2121         if (maybe_scalar && o->op_type == OP_PADSV) {
2122             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2123             o->op_private |= OPpLVAL_INTRO;
2124         }
2125         else
2126             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2127     }
2128     PL_parser->in_my = FALSE;
2129     PL_parser->in_my_stash = NULL;
2130     return o;
2131 }
2132
2133 OP *
2134 Perl_my(pTHX_ OP *o)
2135 {
2136     PERL_ARGS_ASSERT_MY;
2137
2138     return my_attrs(o, NULL);
2139 }
2140
2141 OP *
2142 Perl_sawparens(pTHX_ OP *o)
2143 {
2144     PERL_UNUSED_CONTEXT;
2145     if (o)
2146         o->op_flags |= OPf_PARENS;
2147     return o;
2148 }
2149
2150 OP *
2151 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2152 {
2153     OP *o;
2154     bool ismatchop = 0;
2155     const OPCODE ltype = left->op_type;
2156     const OPCODE rtype = right->op_type;
2157
2158     PERL_ARGS_ASSERT_BIND_MATCH;
2159
2160     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2161           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2162     {
2163       const char * const desc
2164           = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2165                        ? (int)rtype : OP_MATCH];
2166       const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2167              ? "@array" : "%hash");
2168       Perl_warner(aTHX_ packWARN(WARN_MISC),
2169              "Applying %s to %s will act on scalar(%s)",
2170              desc, sample, sample);
2171     }
2172
2173     if (rtype == OP_CONST &&
2174         cSVOPx(right)->op_private & OPpCONST_BARE &&
2175         cSVOPx(right)->op_private & OPpCONST_STRICT)
2176     {
2177         no_bareword_allowed(right);
2178     }
2179
2180     ismatchop = rtype == OP_MATCH ||
2181                 rtype == OP_SUBST ||
2182                 rtype == OP_TRANS;
2183     if (ismatchop && right->op_private & OPpTARGET_MY) {
2184         right->op_targ = 0;
2185         right->op_private &= ~OPpTARGET_MY;
2186     }
2187     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2188         OP *newleft;
2189
2190         right->op_flags |= OPf_STACKED;
2191         if (rtype != OP_MATCH &&
2192             ! (rtype == OP_TRANS &&
2193                right->op_private & OPpTRANS_IDENTICAL))
2194             newleft = mod(left, rtype);
2195         else
2196             newleft = left;
2197         if (right->op_type == OP_TRANS)
2198             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2199         else
2200             o = prepend_elem(rtype, scalar(newleft), right);
2201         if (type == OP_NOT)
2202             return newUNOP(OP_NOT, 0, scalar(o));
2203         return o;
2204     }
2205     else
2206         return bind_match(type, left,
2207                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2208 }
2209
2210 OP *
2211 Perl_invert(pTHX_ OP *o)
2212 {
2213     if (!o)
2214         return NULL;
2215     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2216 }
2217
2218 OP *
2219 Perl_scope(pTHX_ OP *o)
2220 {
2221     dVAR;
2222     if (o) {
2223         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2224             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2225             o->op_type = OP_LEAVE;
2226             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2227         }
2228         else if (o->op_type == OP_LINESEQ) {
2229             OP *kid;
2230             o->op_type = OP_SCOPE;
2231             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2232             kid = ((LISTOP*)o)->op_first;
2233             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2234                 op_null(kid);
2235
2236                 /* The following deals with things like 'do {1 for 1}' */
2237                 kid = kid->op_sibling;
2238                 if (kid &&
2239                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2240                     op_null(kid);
2241             }
2242         }
2243         else
2244             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2245     }
2246     return o;
2247 }
2248
2249 int
2250 Perl_block_start(pTHX_ int full)
2251 {
2252     dVAR;
2253     const int retval = PL_savestack_ix;
2254     pad_block_start(full);
2255     SAVEHINTS();
2256     PL_hints &= ~HINT_BLOCK_SCOPE;
2257     SAVECOMPILEWARNINGS();
2258     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2259     return retval;
2260 }
2261
2262 OP*
2263 Perl_block_end(pTHX_ I32 floor, OP *seq)
2264 {
2265     dVAR;
2266     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2267     OP* const retval = scalarseq(seq);
2268     LEAVE_SCOPE(floor);
2269     CopHINTS_set(&PL_compiling, PL_hints);
2270     if (needblockscope)
2271         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2272     pad_leavemy();
2273     return retval;
2274 }
2275
2276 STATIC OP *
2277 S_newDEFSVOP(pTHX)
2278 {
2279     dVAR;
2280     const PADOFFSET offset = pad_findmy("$_");
2281     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2282         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2283     }
2284     else {
2285         OP * const o = newOP(OP_PADSV, 0);
2286         o->op_targ = offset;
2287         return o;
2288     }
2289 }
2290
2291 void
2292 Perl_newPROG(pTHX_ OP *o)
2293 {
2294     dVAR;
2295
2296     PERL_ARGS_ASSERT_NEWPROG;
2297
2298     if (PL_in_eval) {
2299         if (PL_eval_root)
2300                 return;
2301         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2302                                ((PL_in_eval & EVAL_KEEPERR)
2303                                 ? OPf_SPECIAL : 0), o);
2304         PL_eval_start = linklist(PL_eval_root);
2305         PL_eval_root->op_private |= OPpREFCOUNTED;
2306         OpREFCNT_set(PL_eval_root, 1);
2307         PL_eval_root->op_next = 0;
2308         CALL_PEEP(PL_eval_start);
2309     }
2310     else {
2311         if (o->op_type == OP_STUB) {
2312             PL_comppad_name = 0;
2313             PL_compcv = 0;
2314             S_op_destroy(aTHX_ o);
2315             return;
2316         }
2317         PL_main_root = scope(sawparens(scalarvoid(o)));
2318         PL_curcop = &PL_compiling;
2319         PL_main_start = LINKLIST(PL_main_root);
2320         PL_main_root->op_private |= OPpREFCOUNTED;
2321         OpREFCNT_set(PL_main_root, 1);
2322         PL_main_root->op_next = 0;
2323         CALL_PEEP(PL_main_start);
2324         PL_compcv = 0;
2325
2326         /* Register with debugger */
2327         if (PERLDB_INTER) {
2328             CV * const cv
2329                 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2330             if (cv) {
2331                 dSP;
2332                 PUSHMARK(SP);
2333                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2334                 PUTBACK;
2335                 call_sv((SV*)cv, G_DISCARD);
2336             }
2337         }
2338     }
2339 }
2340
2341 OP *
2342 Perl_localize(pTHX_ OP *o, I32 lex)
2343 {
2344     dVAR;
2345
2346     PERL_ARGS_ASSERT_LOCALIZE;
2347
2348     if (o->op_flags & OPf_PARENS)
2349 /* [perl #17376]: this appears to be premature, and results in code such as
2350    C< our(%x); > executing in list mode rather than void mode */
2351 #if 0
2352         list(o);
2353 #else
2354         NOOP;
2355 #endif
2356     else {
2357         if ( PL_parser->bufptr > PL_parser->oldbufptr
2358             && PL_parser->bufptr[-1] == ','
2359             && ckWARN(WARN_PARENTHESIS))
2360         {
2361             char *s = PL_parser->bufptr;
2362             bool sigil = FALSE;
2363
2364             /* some heuristics to detect a potential error */
2365             while (*s && (strchr(", \t\n", *s)))
2366                 s++;
2367
2368             while (1) {
2369                 if (*s && strchr("@$%*", *s) && *++s
2370                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2371                     s++;
2372                     sigil = TRUE;
2373                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2374                         s++;
2375                     while (*s && (strchr(", \t\n", *s)))
2376                         s++;
2377                 }
2378                 else
2379                     break;
2380             }
2381             if (sigil && (*s == ';' || *s == '=')) {
2382                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2383                                 "Parentheses missing around \"%s\" list",
2384                                 lex
2385                                     ? (PL_parser->in_my == KEY_our
2386                                         ? "our"
2387                                         : PL_parser->in_my == KEY_state
2388                                             ? "state"
2389                                             : "my")
2390                                     : "local");
2391             }
2392         }
2393     }
2394     if (lex)
2395         o = my(o);
2396     else
2397         o = mod(o, OP_NULL);            /* a bit kludgey */
2398     PL_parser->in_my = FALSE;
2399     PL_parser->in_my_stash = NULL;
2400     return o;
2401 }
2402
2403 OP *
2404 Perl_jmaybe(pTHX_ OP *o)
2405 {
2406     PERL_ARGS_ASSERT_JMAYBE;
2407
2408     if (o->op_type == OP_LIST) {
2409         OP * const o2
2410             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2411         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2412     }
2413     return o;
2414 }
2415
2416 OP *
2417 Perl_fold_constants(pTHX_ register OP *o)
2418 {
2419     dVAR;
2420     register OP * VOL curop;
2421     OP *newop;
2422     VOL I32 type = o->op_type;
2423     SV * VOL sv = NULL;
2424     int ret = 0;
2425     I32 oldscope;
2426     OP *old_next;
2427     SV * const oldwarnhook = PL_warnhook;
2428     SV * const olddiehook  = PL_diehook;
2429     dJMPENV;
2430
2431     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2432
2433     if (PL_opargs[type] & OA_RETSCALAR)
2434         scalar(o);
2435     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2436         o->op_targ = pad_alloc(type, SVs_PADTMP);
2437
2438     /* integerize op, unless it happens to be C<-foo>.
2439      * XXX should pp_i_negate() do magic string negation instead? */
2440     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2441         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2442              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2443     {
2444         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2445     }
2446
2447     if (!(PL_opargs[type] & OA_FOLDCONST))
2448         goto nope;
2449
2450     switch (type) {
2451     case OP_NEGATE:
2452         /* XXX might want a ck_negate() for this */
2453         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2454         break;
2455     case OP_UCFIRST:
2456     case OP_LCFIRST:
2457     case OP_UC:
2458     case OP_LC:
2459     case OP_SLT:
2460     case OP_SGT:
2461     case OP_SLE:
2462     case OP_SGE:
2463     case OP_SCMP:
2464         /* XXX what about the numeric ops? */
2465         if (PL_hints & HINT_LOCALE)
2466             goto nope;
2467     }
2468
2469     if (PL_parser && PL_parser->error_count)
2470         goto nope;              /* Don't try to run w/ errors */
2471
2472     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2473         const OPCODE type = curop->op_type;
2474         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2475             type != OP_LIST &&
2476             type != OP_SCALAR &&
2477             type != OP_NULL &&
2478             type != OP_PUSHMARK)
2479         {
2480             goto nope;
2481         }
2482     }
2483
2484     curop = LINKLIST(o);
2485     old_next = o->op_next;
2486     o->op_next = 0;
2487     PL_op = curop;
2488
2489     oldscope = PL_scopestack_ix;
2490     create_eval_scope(G_FAKINGEVAL);
2491
2492     PL_warnhook = PERL_WARNHOOK_FATAL;
2493     PL_diehook  = NULL;
2494     JMPENV_PUSH(ret);
2495
2496     switch (ret) {
2497     case 0:
2498         CALLRUNOPS(aTHX);
2499         sv = *(PL_stack_sp--);
2500         if (o->op_targ && sv == PAD_SV(o->op_targ))     /* grab pad temp? */
2501             pad_swipe(o->op_targ,  FALSE);
2502         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2503             SvREFCNT_inc_simple_void(sv);
2504             SvTEMP_off(sv);
2505         }
2506         break;
2507     case 3:
2508         /* Something tried to die.  Abandon constant folding.  */
2509         /* Pretend the error never happened.  */
2510         sv_setpvn(ERRSV,"",0);
2511         o->op_next = old_next;
2512         break;
2513     default:
2514         JMPENV_POP;
2515         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
2516         PL_warnhook = oldwarnhook;
2517         PL_diehook  = olddiehook;
2518         /* XXX note that this croak may fail as we've already blown away
2519          * the stack - eg any nested evals */
2520         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2521     }
2522     JMPENV_POP;
2523     PL_warnhook = oldwarnhook;
2524     PL_diehook  = olddiehook;
2525
2526     if (PL_scopestack_ix > oldscope)
2527         delete_eval_scope();
2528
2529     if (ret)
2530         goto nope;
2531
2532 #ifndef PERL_MAD
2533     op_free(o);
2534 #endif
2535     assert(sv);
2536     if (type == OP_RV2GV)
2537         newop = newGVOP(OP_GV, 0, (GV*)sv);
2538     else
2539         newop = newSVOP(OP_CONST, 0, (SV*)sv);
2540     op_getmad(o,newop,'f');
2541     return newop;
2542
2543  nope:
2544     return o;
2545 }
2546
2547 OP *
2548 Perl_gen_constant_list(pTHX_ register OP *o)
2549 {
2550     dVAR;
2551     register OP *curop;
2552     const I32 oldtmps_floor = PL_tmps_floor;
2553
2554     list(o);
2555     if (PL_parser && PL_parser->error_count)
2556         return o;               /* Don't attempt to run with errors */
2557
2558     PL_op = curop = LINKLIST(o);
2559     o->op_next = 0;
2560     CALL_PEEP(curop);
2561     pp_pushmark();
2562     CALLRUNOPS(aTHX);
2563     PL_op = curop;
2564     assert (!(curop->op_flags & OPf_SPECIAL));
2565     assert(curop->op_type == OP_RANGE);
2566     pp_anonlist();
2567     PL_tmps_floor = oldtmps_floor;
2568
2569     o->op_type = OP_RV2AV;
2570     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2571     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2572     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2573     o->op_opt = 0;              /* needs to be revisited in peep() */
2574     curop = ((UNOP*)o)->op_first;
2575     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2576 #ifdef PERL_MAD
2577     op_getmad(curop,o,'O');
2578 #else
2579     op_free(curop);
2580 #endif
2581     linklist(o);
2582     return list(o);
2583 }
2584
2585 OP *
2586 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2587 {
2588     dVAR;
2589     if (!o || o->op_type != OP_LIST)
2590         o = newLISTOP(OP_LIST, 0, o, NULL);
2591     else
2592         o->op_flags &= ~OPf_WANT;
2593
2594     if (!(PL_opargs[type] & OA_MARK))
2595         op_null(cLISTOPo->op_first);
2596
2597     o->op_type = (OPCODE)type;
2598     o->op_ppaddr = PL_ppaddr[type];
2599     o->op_flags |= flags;
2600
2601     o = CHECKOP(type, o);
2602     if (o->op_type != (unsigned)type)
2603         return o;
2604
2605     return fold_constants(o);
2606 }
2607
2608 /* List constructors */
2609
2610 OP *
2611 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2612 {
2613     if (!first)
2614         return last;
2615
2616     if (!last)
2617         return first;
2618
2619     if (first->op_type != (unsigned)type
2620         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2621     {
2622         return newLISTOP(type, 0, first, last);
2623     }
2624
2625     if (first->op_flags & OPf_KIDS)
2626         ((LISTOP*)first)->op_last->op_sibling = last;
2627     else {
2628         first->op_flags |= OPf_KIDS;
2629         ((LISTOP*)first)->op_first = last;
2630     }
2631     ((LISTOP*)first)->op_last = last;
2632     return first;
2633 }
2634
2635 OP *
2636 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2637 {
2638     if (!first)
2639         return (OP*)last;
2640
2641     if (!last)
2642         return (OP*)first;
2643
2644     if (first->op_type != (unsigned)type)
2645         return prepend_elem(type, (OP*)first, (OP*)last);
2646
2647     if (last->op_type != (unsigned)type)
2648         return append_elem(type, (OP*)first, (OP*)last);
2649
2650     first->op_last->op_sibling = last->op_first;
2651     first->op_last = last->op_last;
2652     first->op_flags |= (last->op_flags & OPf_KIDS);
2653
2654 #ifdef PERL_MAD
2655     if (last->op_first && first->op_madprop) {
2656         MADPROP *mp = last->op_first->op_madprop;
2657         if (mp) {
2658             while (mp->mad_next)
2659                 mp = mp->mad_next;
2660             mp->mad_next = first->op_madprop;
2661         }
2662         else {
2663             last->op_first->op_madprop = first->op_madprop;
2664         }
2665     }
2666     first->op_madprop = last->op_madprop;
2667     last->op_madprop = 0;
2668 #endif
2669
2670     S_op_destroy(aTHX_ (OP*)last);
2671
2672     return (OP*)first;
2673 }
2674
2675 OP *
2676 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2677 {
2678     if (!first)
2679         return last;
2680
2681     if (!last)
2682         return first;
2683
2684     if (last->op_type == (unsigned)type) {
2685         if (type == OP_LIST) {  /* already a PUSHMARK there */
2686             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2687             ((LISTOP*)last)->op_first->op_sibling = first;
2688             if (!(first->op_flags & OPf_PARENS))
2689                 last->op_flags &= ~OPf_PARENS;
2690         }
2691         else {
2692             if (!(last->op_flags & OPf_KIDS)) {
2693                 ((LISTOP*)last)->op_last = first;
2694                 last->op_flags |= OPf_KIDS;
2695             }
2696             first->op_sibling = ((LISTOP*)last)->op_first;
2697             ((LISTOP*)last)->op_first = first;
2698         }
2699         last->op_flags |= OPf_KIDS;
2700         return last;
2701     }
2702
2703     return newLISTOP(type, 0, first, last);
2704 }
2705
2706 /* Constructors */
2707
2708 #ifdef PERL_MAD
2709
2710 TOKEN *
2711 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2712 {
2713     TOKEN *tk;
2714     Newxz(tk, 1, TOKEN);
2715     tk->tk_type = (OPCODE)optype;
2716     tk->tk_type = 12345;
2717     tk->tk_lval = lval;
2718     tk->tk_mad = madprop;
2719     return tk;
2720 }
2721
2722 void
2723 Perl_token_free(pTHX_ TOKEN* tk)
2724 {
2725     PERL_ARGS_ASSERT_TOKEN_FREE;
2726
2727     if (tk->tk_type != 12345)
2728         return;
2729     mad_free(tk->tk_mad);
2730     Safefree(tk);
2731 }
2732
2733 void
2734 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2735 {
2736     MADPROP* mp;
2737     MADPROP* tm;
2738
2739     PERL_ARGS_ASSERT_TOKEN_GETMAD;
2740
2741     if (tk->tk_type != 12345) {
2742         Perl_warner(aTHX_ packWARN(WARN_MISC),
2743              "Invalid TOKEN object ignored");
2744         return;
2745     }
2746     tm = tk->tk_mad;
2747     if (!tm)
2748         return;
2749
2750     /* faked up qw list? */
2751     if (slot == '(' &&
2752         tm->mad_type == MAD_SV &&
2753         SvPVX((SV*)tm->mad_val)[0] == 'q')
2754             slot = 'x';
2755
2756     if (o) {
2757         mp = o->op_madprop;
2758         if (mp) {
2759             for (;;) {
2760                 /* pretend constant fold didn't happen? */
2761                 if (mp->mad_key == 'f' &&
2762                     (o->op_type == OP_CONST ||
2763                      o->op_type == OP_GV) )
2764                 {
2765                     token_getmad(tk,(OP*)mp->mad_val,slot);
2766                     return;
2767                 }
2768                 if (!mp->mad_next)
2769                     break;
2770                 mp = mp->mad_next;
2771             }
2772             mp->mad_next = tm;
2773             mp = mp->mad_next;
2774         }
2775         else {
2776             o->op_madprop = tm;
2777             mp = o->op_madprop;
2778         }
2779         if (mp->mad_key == 'X')
2780             mp->mad_key = slot; /* just change the first one */
2781
2782         tk->tk_mad = 0;
2783     }
2784     else
2785         mad_free(tm);
2786     Safefree(tk);
2787 }
2788
2789 void
2790 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2791 {
2792     MADPROP* mp;
2793     if (!from)
2794         return;
2795     if (o) {
2796         mp = o->op_madprop;
2797         if (mp) {
2798             for (;;) {
2799                 /* pretend constant fold didn't happen? */
2800                 if (mp->mad_key == 'f' &&
2801                     (o->op_type == OP_CONST ||
2802                      o->op_type == OP_GV) )
2803                 {
2804                     op_getmad(from,(OP*)mp->mad_val,slot);
2805                     return;
2806                 }
2807                 if (!mp->mad_next)
2808                     break;
2809                 mp = mp->mad_next;
2810             }
2811             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2812         }
2813         else {
2814             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2815         }
2816     }
2817 }
2818
2819 void
2820 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2821 {
2822     MADPROP* mp;
2823     if (!from)
2824         return;
2825     if (o) {
2826         mp = o->op_madprop;
2827         if (mp) {
2828             for (;;) {
2829                 /* pretend constant fold didn't happen? */
2830                 if (mp->mad_key == 'f' &&
2831                     (o->op_type == OP_CONST ||
2832                      o->op_type == OP_GV) )
2833                 {
2834                     op_getmad(from,(OP*)mp->mad_val,slot);
2835                     return;
2836                 }
2837                 if (!mp->mad_next)
2838                     break;
2839                 mp = mp->mad_next;
2840             }
2841             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2842         }
2843         else {
2844             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2845         }
2846     }
2847     else {
2848         PerlIO_printf(PerlIO_stderr(),
2849                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2850         op_free(from);
2851     }
2852 }
2853
2854 void
2855 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2856 {
2857     MADPROP* tm;
2858     if (!mp || !o)
2859         return;
2860     if (slot)
2861         mp->mad_key = slot;
2862     tm = o->op_madprop;
2863     o->op_madprop = mp;
2864     for (;;) {
2865         if (!mp->mad_next)
2866             break;
2867         mp = mp->mad_next;
2868     }
2869     mp->mad_next = tm;
2870 }
2871
2872 void
2873 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2874 {
2875     if (!o)
2876         return;
2877     addmad(tm, &(o->op_madprop), slot);
2878 }
2879
2880 void
2881 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2882 {
2883     MADPROP* mp;
2884     if (!tm || !root)
2885         return;
2886     if (slot)
2887         tm->mad_key = slot;
2888     mp = *root;
2889     if (!mp) {
2890         *root = tm;
2891         return;
2892     }
2893     for (;;) {
2894         if (!mp->mad_next)
2895             break;
2896         mp = mp->mad_next;
2897     }
2898     mp->mad_next = tm;
2899 }
2900
2901 MADPROP *
2902 Perl_newMADsv(pTHX_ char key, SV* sv)
2903 {
2904     PERL_ARGS_ASSERT_NEWMADSV;
2905
2906     return newMADPROP(key, MAD_SV, sv, 0);
2907 }
2908
2909 MADPROP *
2910 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2911 {
2912     MADPROP *mp;
2913     Newxz(mp, 1, MADPROP);
2914     mp->mad_next = 0;
2915     mp->mad_key = key;
2916     mp->mad_vlen = vlen;
2917     mp->mad_type = type;
2918     mp->mad_val = val;
2919 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
2920     return mp;
2921 }
2922
2923 void
2924 Perl_mad_free(pTHX_ MADPROP* mp)
2925 {
2926 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2927     if (!mp)
2928         return;
2929     if (mp->mad_next)
2930         mad_free(mp->mad_next);
2931 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2932         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2933     switch (mp->mad_type) {
2934     case MAD_NULL:
2935         break;
2936     case MAD_PV:
2937         Safefree((char*)mp->mad_val);
2938         break;
2939     case MAD_OP:
2940         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
2941             op_free((OP*)mp->mad_val);
2942         break;
2943     case MAD_SV:
2944         sv_free((SV*)mp->mad_val);
2945         break;
2946     default:
2947         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2948         break;
2949     }
2950     Safefree(mp);
2951 }
2952
2953 #endif
2954
2955 OP *
2956 Perl_newNULLLIST(pTHX)
2957 {
2958     return newOP(OP_STUB, 0);
2959 }
2960
2961 OP *
2962 Perl_force_list(pTHX_ OP *o)
2963 {
2964     if (!o || o->op_type != OP_LIST)
2965         o = newLISTOP(OP_LIST, 0, o, NULL);
2966     op_null(o);
2967     return o;
2968 }
2969
2970 OP *
2971 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2972 {
2973     dVAR;
2974     LISTOP *listop;
2975
2976     NewOp(1101, listop, 1, LISTOP);
2977
2978     listop->op_type = (OPCODE)type;
2979     listop->op_ppaddr = PL_ppaddr[type];
2980     if (first || last)
2981         flags |= OPf_KIDS;
2982     listop->op_flags = (U8)flags;
2983
2984     if (!last && first)
2985         last = first;
2986     else if (!first && last)
2987         first = last;
2988     else if (first)
2989         first->op_sibling = last;
2990     listop->op_first = first;
2991     listop->op_last = last;
2992     if (type == OP_LIST) {
2993         OP* const pushop = newOP(OP_PUSHMARK, 0);
2994         pushop->op_sibling = first;
2995         listop->op_first = pushop;
2996         listop->op_flags |= OPf_KIDS;
2997         if (!last)
2998             listop->op_last = pushop;
2999     }
3000
3001     return CHECKOP(type, listop);
3002 }
3003
3004 OP *
3005 Perl_newOP(pTHX_ I32 type, I32 flags)
3006 {
3007     dVAR;
3008     OP *o;
3009     NewOp(1101, o, 1, OP);
3010     o->op_type = (OPCODE)type;
3011     o->op_ppaddr = PL_ppaddr[type];
3012     o->op_flags = (U8)flags;
3013     o->op_latefree = 0;
3014     o->op_latefreed = 0;
3015     o->op_attached = 0;
3016
3017     o->op_next = o;
3018     o->op_private = (U8)(0 | (flags >> 8));
3019     if (PL_opargs[type] & OA_RETSCALAR)
3020         scalar(o);
3021     if (PL_opargs[type] & OA_TARGET)
3022         o->op_targ = pad_alloc(type, SVs_PADTMP);
3023     return CHECKOP(type, o);
3024 }
3025
3026 OP *
3027 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3028 {
3029     dVAR;
3030     UNOP *unop;
3031
3032     if (!first)
3033         first = newOP(OP_STUB, 0);
3034     if (PL_opargs[type] & OA_MARK)
3035         first = force_list(first);
3036
3037     NewOp(1101, unop, 1, UNOP);
3038     unop->op_type = (OPCODE)type;
3039     unop->op_ppaddr = PL_ppaddr[type];
3040     unop->op_first = first;
3041     unop->op_flags = (U8)(flags | OPf_KIDS);
3042     unop->op_private = (U8)(1 | (flags >> 8));
3043     unop = (UNOP*) CHECKOP(type, unop);
3044     if (unop->op_next)
3045         return (OP*)unop;
3046
3047     return fold_constants((OP *) unop);
3048 }
3049
3050 OP *
3051 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3052 {
3053     dVAR;
3054     BINOP *binop;
3055     NewOp(1101, binop, 1, BINOP);
3056
3057     if (!first)
3058         first = newOP(OP_NULL, 0);
3059
3060     binop->op_type = (OPCODE)type;
3061     binop->op_ppaddr = PL_ppaddr[type];
3062     binop->op_first = first;
3063     binop->op_flags = (U8)(flags | OPf_KIDS);
3064     if (!last) {
3065         last = first;
3066         binop->op_private = (U8)(1 | (flags >> 8));
3067     }
3068     else {
3069         binop->op_private = (U8)(2 | (flags >> 8));
3070         first->op_sibling = last;
3071     }
3072
3073     binop = (BINOP*)CHECKOP(type, binop);
3074     if (binop->op_next || binop->op_type != (OPCODE)type)
3075         return (OP*)binop;
3076
3077     binop->op_last = binop->op_first->op_sibling;
3078
3079     return fold_constants((OP *)binop);
3080 }
3081
3082 static int uvcompare(const void *a, const void *b)
3083     __attribute__nonnull__(1)
3084     __attribute__nonnull__(2)
3085     __attribute__pure__;
3086 static int uvcompare(const void *a, const void *b)
3087 {
3088     if (*((const UV *)a) < (*(const UV *)b))
3089         return -1;
3090     if (*((const UV *)a) > (*(const UV *)b))
3091         return 1;
3092     if (*((const UV *)a+1) < (*(const UV *)b+1))
3093         return -1;
3094     if (*((const UV *)a+1) > (*(const UV *)b+1))
3095         return 1;
3096     return 0;
3097 }
3098
3099 OP *
3100 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3101 {
3102     dVAR;
3103     SV * const tstr = ((SVOP*)expr)->op_sv;
3104     SV * const rstr =
3105 #ifdef PERL_MAD
3106                         (repl->op_type == OP_NULL)
3107                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3108 #endif
3109                               ((SVOP*)repl)->op_sv;
3110     STRLEN tlen;
3111     STRLEN rlen;
3112     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3113     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3114     register I32 i;
3115     register I32 j;
3116     I32 grows = 0;
3117     register short *tbl;
3118
3119     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3120     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3121     I32 del              = o->op_private & OPpTRANS_DELETE;
3122     SV* swash;
3123
3124     PERL_ARGS_ASSERT_PMTRANS;
3125
3126     PL_hints |= HINT_BLOCK_SCOPE;
3127
3128     if (SvUTF8(tstr))
3129         o->op_private |= OPpTRANS_FROM_UTF;
3130
3131     if (SvUTF8(rstr))
3132         o->op_private |= OPpTRANS_TO_UTF;
3133
3134     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3135         SV* const listsv = newSVpvs("# comment\n");
3136         SV* transv = NULL;
3137         const U8* tend = t + tlen;
3138         const U8* rend = r + rlen;
3139         STRLEN ulen;
3140         UV tfirst = 1;
3141         UV tlast = 0;
3142         IV tdiff;
3143         UV rfirst = 1;
3144         UV rlast = 0;
3145         IV rdiff;
3146         IV diff;
3147         I32 none = 0;
3148         U32 max = 0;
3149         I32 bits;
3150         I32 havefinal = 0;
3151         U32 final = 0;
3152         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3153         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3154         U8* tsave = NULL;
3155         U8* rsave = NULL;
3156         const U32 flags = UTF8_ALLOW_DEFAULT;
3157
3158         if (!from_utf) {
3159             STRLEN len = tlen;
3160             t = tsave = bytes_to_utf8(t, &len);
3161             tend = t + len;
3162         }
3163         if (!to_utf && rlen) {
3164             STRLEN len = rlen;
3165             r = rsave = bytes_to_utf8(r, &len);
3166             rend = r + len;
3167         }
3168
3169 /* There are several snags with this code on EBCDIC:
3170    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3171    2. scan_const() in toke.c has encoded chars in native encoding which makes
3172       ranges at least in EBCDIC 0..255 range the bottom odd.
3173 */
3174
3175         if (complement) {
3176             U8 tmpbuf[UTF8_MAXBYTES+1];
3177             UV *cp;
3178             UV nextmin = 0;
3179             Newx(cp, 2*tlen, UV);
3180             i = 0;
3181             transv = newSVpvs("");
3182             while (t < tend) {
3183                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3184                 t += ulen;
3185                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3186                     t++;
3187                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3188                     t += ulen;
3189                 }
3190                 else {
3191                  cp[2*i+1] = cp[2*i];
3192                 }
3193                 i++;
3194             }
3195             qsort(cp, i, 2*sizeof(UV), uvcompare);
3196             for (j = 0; j < i; j++) {
3197                 UV  val = cp[2*j];
3198                 diff = val - nextmin;
3199                 if (diff > 0) {
3200                     t = uvuni_to_utf8(tmpbuf,nextmin);
3201                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3202                     if (diff > 1) {
3203                         U8  range_mark = UTF_TO_NATIVE(0xff);
3204                         t = uvuni_to_utf8(tmpbuf, val - 1);
3205                         sv_catpvn(transv, (char *)&range_mark, 1);
3206                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3207                     }
3208                 }
3209                 val = cp[2*j+1];
3210                 if (val >= nextmin)
3211                     nextmin = val + 1;
3212             }
3213             t = uvuni_to_utf8(tmpbuf,nextmin);
3214             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3215             {
3216                 U8 range_mark = UTF_TO_NATIVE(0xff);
3217                 sv_catpvn(transv, (char *)&range_mark, 1);
3218             }
3219             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3220                                     UNICODE_ALLOW_SUPER);
3221             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3222             t = (const U8*)SvPVX_const(transv);
3223             tlen = SvCUR(transv);
3224             tend = t + tlen;
3225             Safefree(cp);
3226         }
3227         else if (!rlen && !del) {
3228             r = t; rlen = tlen; rend = tend;
3229         }
3230         if (!squash) {
3231                 if ((!rlen && !del) || t == r ||
3232                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3233                 {
3234                     o->op_private |= OPpTRANS_IDENTICAL;
3235                 }
3236         }
3237
3238         while (t < tend || tfirst <= tlast) {
3239             /* see if we need more "t" chars */
3240             if (tfirst > tlast) {
3241                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3242                 t += ulen;
3243                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3244                     t++;
3245                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3246                     t += ulen;
3247                 }
3248                 else
3249                     tlast = tfirst;
3250             }
3251
3252             /* now see if we need more "r" chars */
3253             if (rfirst > rlast) {
3254                 if (r < rend) {
3255                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3256                     r += ulen;
3257                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3258                         r++;
3259                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3260                         r += ulen;
3261                     }
3262                     else
3263                         rlast = rfirst;
3264                 }
3265                 else {
3266                     if (!havefinal++)
3267                         final = rlast;
3268                     rfirst = rlast = 0xffffffff;
3269                 }
3270             }
3271
3272             /* now see which range will peter our first, if either. */
3273             tdiff = tlast - tfirst;
3274             rdiff = rlast - rfirst;
3275
3276             if (tdiff <= rdiff)
3277                 diff = tdiff;
3278             else
3279                 diff = rdiff;
3280
3281             if (rfirst == 0xffffffff) {
3282                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3283                 if (diff > 0)
3284                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3285                                    (long)tfirst, (long)tlast);
3286                 else
3287                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3288             }
3289             else {
3290                 if (diff > 0)
3291                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3292                                    (long)tfirst, (long)(tfirst + diff),
3293                                    (long)rfirst);
3294                 else
3295                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3296                                    (long)tfirst, (long)rfirst);
3297
3298                 if (rfirst + diff > max)
3299                     max = rfirst + diff;
3300                 if (!grows)
3301                     grows = (tfirst < rfirst &&
3302                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3303                 rfirst += diff + 1;
3304             }
3305             tfirst += diff + 1;
3306         }
3307
3308         none = ++max;
3309         if (del)
3310             del = ++max;
3311
3312         if (max > 0xffff)
3313             bits = 32;
3314         else if (max > 0xff)
3315             bits = 16;
3316         else
3317             bits = 8;
3318
3319         PerlMemShared_free(cPVOPo->op_pv);
3320         cPVOPo->op_pv = NULL;
3321
3322         swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3323 #ifdef USE_ITHREADS
3324         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3325         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3326         PAD_SETSV(cPADOPo->op_padix, swash);
3327         SvPADTMP_on(swash);
3328 #else
3329         cSVOPo->op_sv = swash;
3330 #endif
3331         SvREFCNT_dec(listsv);
3332         SvREFCNT_dec(transv);
3333
3334         if (!del && havefinal && rlen)
3335             (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3336                            newSVuv((UV)final), 0);
3337
3338         if (grows)
3339             o->op_private |= OPpTRANS_GROWS;
3340
3341         Safefree(tsave);
3342         Safefree(rsave);
3343
3344 #ifdef PERL_MAD
3345         op_getmad(expr,o,'e');
3346         op_getmad(repl,o,'r');
3347 #else
3348         op_free(expr);
3349         op_free(repl);
3350 #endif
3351         return o;
3352     }
3353
3354     tbl = (short*)cPVOPo->op_pv;
3355     if (complement) {
3356         Zero(tbl, 256, short);
3357         for (i = 0; i < (I32)tlen; i++)
3358             tbl[t[i]] = -1;
3359         for (i = 0, j = 0; i < 256; i++) {
3360             if (!tbl[i]) {
3361                 if (j >= (I32)rlen) {
3362                     if (del)
3363                         tbl[i] = -2;
3364                     else if (rlen)
3365                         tbl[i] = r[j-1];
3366                     else
3367                         tbl[i] = (short)i;
3368                 }
3369                 else {
3370                     if (i < 128 && r[j] >= 128)
3371                         grows = 1;
3372                     tbl[i] = r[j++];
3373                 }
3374             }
3375         }
3376         if (!del) {
3377             if (!rlen) {
3378                 j = rlen;
3379                 if (!squash)
3380                     o->op_private |= OPpTRANS_IDENTICAL;
3381             }
3382             else if (j >= (I32)rlen)
3383                 j = rlen - 1;
3384             else {
3385                 tbl =
3386                     (short *)
3387                     PerlMemShared_realloc(tbl,
3388                                           (0x101+rlen-j) * sizeof(short));
3389                 cPVOPo->op_pv = (char*)tbl;
3390             }
3391             tbl[0x100] = (short)(rlen - j);
3392             for (i=0; i < (I32)rlen - j; i++)
3393                 tbl[0x101+i] = r[j+i];
3394         }
3395     }
3396     else {
3397         if (!rlen && !del) {
3398             r = t; rlen = tlen;
3399             if (!squash)
3400                 o->op_private |= OPpTRANS_IDENTICAL;
3401         }
3402         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3403             o->op_private |= OPpTRANS_IDENTICAL;
3404         }
3405         for (i = 0; i < 256; i++)
3406             tbl[i] = -1;
3407         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3408             if (j >= (I32)rlen) {
3409                 if (del) {
3410                     if (tbl[t[i]] == -1)
3411                         tbl[t[i]] = -2;
3412                     continue;
3413                 }
3414                 --j;
3415             }
3416             if (tbl[t[i]] == -1) {
3417                 if (t[i] < 128 && r[j] >= 128)
3418                     grows = 1;
3419                 tbl[t[i]] = r[j];
3420             }
3421         }
3422     }
3423     if (grows)
3424         o->op_private |= OPpTRANS_GROWS;
3425 #ifdef PERL_MAD
3426     op_getmad(expr,o,'e');
3427     op_getmad(repl,o,'r');
3428 #else
3429     op_free(expr);
3430     op_free(repl);
3431 #endif
3432
3433     return o;
3434 }
3435
3436 OP *
3437 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3438 {
3439     dVAR;
3440     PMOP *pmop;
3441
3442     NewOp(1101, pmop, 1, PMOP);
3443     pmop->op_type = (OPCODE)type;
3444     pmop->op_ppaddr = PL_ppaddr[type];
3445     pmop->op_flags = (U8)flags;
3446     pmop->op_private = (U8)(0 | (flags >> 8));
3447
3448     if (PL_hints & HINT_RE_TAINT)
3449         pmop->op_pmflags |= PMf_RETAINT;
3450     if (PL_hints & HINT_LOCALE)
3451         pmop->op_pmflags |= PMf_LOCALE;
3452
3453
3454 #ifdef USE_ITHREADS
3455     assert(SvPOK(PL_regex_pad[0]));
3456     if (SvCUR(PL_regex_pad[0])) {
3457         /* Pop off the "packed" IV from the end.  */
3458         SV *const repointer_list = PL_regex_pad[0];
3459         const char *p = SvEND(repointer_list) - sizeof(IV);
3460         const IV offset = *((IV*)p);
3461
3462         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3463
3464         SvEND_set(repointer_list, p);
3465
3466         pmop->op_pmoffset = offset;
3467         /* This slot should be free, so assert this:  */
3468         assert(PL_regex_pad[offset] == &PL_sv_undef);
3469     } else {
3470         SV * const repointer = &PL_sv_undef;
3471         av_push(PL_regex_padav, repointer);
3472         pmop->op_pmoffset = av_len(PL_regex_padav);
3473         PL_regex_pad = AvARRAY(PL_regex_padav);
3474     }
3475 #endif
3476
3477     return CHECKOP(type, pmop);
3478 }
3479
3480 /* Given some sort of match op o, and an expression expr containing a
3481  * pattern, either compile expr into a regex and attach it to o (if it's
3482  * constant), or convert expr into a runtime regcomp op sequence (if it's
3483  * not)
3484  *
3485  * isreg indicates that the pattern is part of a regex construct, eg
3486  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3487  * split "pattern", which aren't. In the former case, expr will be a list
3488  * if the pattern contains more than one term (eg /a$b/) or if it contains
3489  * a replacement, ie s/// or tr///.
3490  */
3491
3492 OP *
3493 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3494 {
3495     dVAR;
3496     PMOP *pm;
3497     LOGOP *rcop;
3498     I32 repl_has_vars = 0;
3499     OP* repl = NULL;
3500     bool reglist;
3501
3502     PERL_ARGS_ASSERT_PMRUNTIME;
3503
3504     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3505         /* last element in list is the replacement; pop it */
3506         OP* kid;
3507         repl = cLISTOPx(expr)->op_last;
3508         kid = cLISTOPx(expr)->op_first;
3509         while (kid->op_sibling != repl)
3510             kid = kid->op_sibling;
3511         kid->op_sibling = NULL;
3512         cLISTOPx(expr)->op_last = kid;
3513     }
3514
3515     if (isreg && expr->op_type == OP_LIST &&
3516         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3517     {
3518         /* convert single element list to element */
3519         OP* const oe = expr;
3520         expr = cLISTOPx(oe)->op_first->op_sibling;
3521         cLISTOPx(oe)->op_first->op_sibling = NULL;
3522         cLISTOPx(oe)->op_last = NULL;
3523         op_free(oe);
3524     }
3525
3526     if (o->op_type == OP_TRANS) {
3527         return pmtrans(o, expr, repl);
3528     }
3529
3530     reglist = isreg && expr->op_type == OP_LIST;
3531     if (reglist)
3532         op_null(expr);
3533
3534     PL_hints |= HINT_BLOCK_SCOPE;
3535     pm = (PMOP*)o;
3536
3537     if (expr->op_type == OP_CONST) {
3538         SV *pat = ((SVOP*)expr)->op_sv;
3539         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3540
3541         if (o->op_flags & OPf_SPECIAL)
3542             pm_flags |= RXf_SPLIT;
3543
3544         if (DO_UTF8(pat)) {
3545             assert (SvUTF8(pat));
3546         } else if (SvUTF8(pat)) {
3547             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3548                trapped in use 'bytes'?  */
3549             /* Make a copy of the octet sequence, but without the flag on, as
3550                the compiler now honours the SvUTF8 flag on pat.  */
3551             STRLEN len;
3552             const char *const p = SvPV(pat, len);
3553             pat = newSVpvn_flags(p, len, SVs_TEMP);
3554         }
3555
3556         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3557
3558 #ifdef PERL_MAD
3559         op_getmad(expr,(OP*)pm,'e');
3560 #else
3561         op_free(expr);
3562 #endif
3563     }
3564     else {
3565         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3566             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3567                             ? OP_REGCRESET
3568                             : OP_REGCMAYBE),0,expr);
3569
3570         NewOp(1101, rcop, 1, LOGOP);
3571         rcop->op_type = OP_REGCOMP;
3572         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3573         rcop->op_first = scalar(expr);
3574         rcop->op_flags |= OPf_KIDS
3575                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3576                             | (reglist ? OPf_STACKED : 0);
3577         rcop->op_private = 1;
3578         rcop->op_other = o;
3579         if (reglist)
3580             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3581
3582         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3583         PL_cv_has_eval = 1;
3584
3585         /* establish postfix order */
3586         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3587             LINKLIST(expr);
3588             rcop->op_next = expr;
3589             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3590         }
3591         else {
3592             rcop->op_next = LINKLIST(expr);
3593             expr->op_next = (OP*)rcop;
3594         }
3595
3596         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3597     }
3598
3599     if (repl) {
3600         OP *curop;
3601         if (pm->op_pmflags & PMf_EVAL) {
3602             curop = NULL;
3603             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3604                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3605         }
3606         else if (repl->op_type == OP_CONST)
3607             curop = repl;
3608         else {
3609             OP *lastop = NULL;
3610             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3611                 if (curop->op_type == OP_SCOPE
3612                         || curop->op_type == OP_LEAVE
3613                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3614                     if (curop->op_type == OP_GV) {
3615                         GV * const gv = cGVOPx_gv(curop);
3616                         repl_has_vars = 1;
3617                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3618                             break;
3619                     }
3620                     else if (curop->op_type == OP_RV2CV)
3621                         break;
3622                     else if (curop->op_type == OP_RV2SV ||
3623                              curop->op_type == OP_RV2AV ||
3624                              curop->op_type == OP_RV2HV ||
3625                              curop->op_type == OP_RV2GV) {
3626                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3627                             break;
3628                     }
3629                     else if (curop->op_type == OP_PADSV ||
3630                              curop->op_type == OP_PADAV ||
3631                              curop->op_type == OP_PADHV ||
3632                              curop->op_type == OP_PADANY)
3633                     {
3634                         repl_has_vars = 1;
3635                     }
3636                     else if (curop->op_type == OP_PUSHRE)
3637                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3638                     else
3639                         break;
3640                 }
3641                 lastop = curop;
3642             }
3643         }
3644         if (curop == repl
3645             && !(repl_has_vars
3646                  && (!PM_GETRE(pm)
3647                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3648         {
3649             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3650             prepend_elem(o->op_type, scalar(repl), o);
3651         }
3652         else {
3653             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3654                 pm->op_pmflags |= PMf_MAYBE_CONST;
3655             }
3656             NewOp(1101, rcop, 1, LOGOP);
3657             rcop->op_type = OP_SUBSTCONT;
3658             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3659             rcop->op_first = scalar(repl);
3660             rcop->op_flags |= OPf_KIDS;
3661             rcop->op_private = 1;
3662             rcop->op_other = o;
3663
3664             /* establish postfix order */
3665             rcop->op_next = LINKLIST(repl);
3666             repl->op_next = (OP*)rcop;
3667
3668             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3669             assert(!(pm->op_pmflags & PMf_ONCE));
3670             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3671             rcop->op_next = 0;
3672         }
3673     }
3674
3675     return (OP*)pm;
3676 }
3677
3678 OP *
3679 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3680 {
3681     dVAR;
3682     SVOP *svop;
3683
3684     PERL_ARGS_ASSERT_NEWSVOP;
3685
3686     NewOp(1101, svop, 1, SVOP);
3687     svop->op_type = (OPCODE)type;
3688     svop->op_ppaddr = PL_ppaddr[type];
3689     svop->op_sv = sv;
3690     svop->op_next = (OP*)svop;
3691     svop->op_flags = (U8)flags;
3692     if (PL_opargs[type] & OA_RETSCALAR)
3693         scalar((OP*)svop);
3694     if (PL_opargs[type] & OA_TARGET)
3695         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3696     return CHECKOP(type, svop);
3697 }
3698
3699 #ifdef USE_ITHREADS
3700 OP *
3701 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3702 {
3703     dVAR;
3704     PADOP *padop;
3705
3706     PERL_ARGS_ASSERT_NEWPADOP;
3707
3708     NewOp(1101, padop, 1, PADOP);
3709     padop->op_type = (OPCODE)type;
3710     padop->op_ppaddr = PL_ppaddr[type];
3711     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3712     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3713     PAD_SETSV(padop->op_padix, sv);
3714     assert(sv);
3715     SvPADTMP_on(sv);
3716     padop->op_next = (OP*)padop;
3717     padop->op_flags = (U8)flags;
3718     if (PL_opargs[type] & OA_RETSCALAR)
3719         scalar((OP*)padop);
3720     if (PL_opargs[type] & OA_TARGET)
3721         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3722     return CHECKOP(type, padop);
3723 }
3724 #endif
3725
3726 OP *
3727 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3728 {
3729     dVAR;
3730
3731     PERL_ARGS_ASSERT_NEWGVOP;
3732
3733 #ifdef USE_ITHREADS
3734     GvIN_PAD_on(gv);
3735     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3736 #else
3737     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3738 #endif
3739 }
3740
3741 OP *
3742 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3743 {
3744     dVAR;
3745     PVOP *pvop;
3746     NewOp(1101, pvop, 1, PVOP);
3747     pvop->op_type = (OPCODE)type;
3748     pvop->op_ppaddr = PL_ppaddr[type];
3749     pvop->op_pv = pv;
3750     pvop->op_next = (OP*)pvop;
3751     pvop->op_flags = (U8)flags;
3752     if (PL_opargs[type] & OA_RETSCALAR)
3753         scalar((OP*)pvop);
3754     if (PL_opargs[type] & OA_TARGET)
3755         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3756     return CHECKOP(type, pvop);
3757 }
3758
3759 #ifdef PERL_MAD
3760 OP*
3761 #else
3762 void
3763 #endif
3764 Perl_package(pTHX_ OP *o)
3765 {
3766     dVAR;
3767     SV *const sv = cSVOPo->op_sv;
3768 #ifdef PERL_MAD
3769     OP *pegop;
3770 #endif
3771
3772     PERL_ARGS_ASSERT_PACKAGE;
3773
3774     save_hptr(&PL_curstash);
3775     save_item(PL_curstname);
3776
3777     PL_curstash = gv_stashsv(sv, GV_ADD);
3778
3779     sv_setsv(PL_curstname, sv);
3780
3781     PL_hints |= HINT_BLOCK_SCOPE;
3782     PL_parser->copline = NOLINE;
3783     PL_parser->expect = XSTATE;
3784
3785 #ifndef PERL_MAD
3786     op_free(o);
3787 #else
3788     if (!PL_madskills) {
3789         op_free(o);
3790         return NULL;
3791     }
3792
3793     pegop = newOP(OP_NULL,0);
3794     op_getmad(o,pegop,'P');
3795     return pegop;
3796 #endif
3797 }
3798
3799 #ifdef PERL_MAD
3800 OP*
3801 #else
3802 void
3803 #endif
3804 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3805 {
3806     dVAR;
3807     OP *pack;
3808     OP *imop;
3809     OP *veop;
3810 #ifdef PERL_MAD
3811     OP *pegop = newOP(OP_NULL,0);
3812 #endif
3813
3814     PERL_ARGS_ASSERT_UTILIZE;
3815
3816     if (idop->op_type != OP_CONST)
3817         Perl_croak(aTHX_ "Module name must be constant");
3818
3819     if (PL_madskills)
3820         op_getmad(idop,pegop,'U');
3821
3822     veop = NULL;
3823
3824     if (version) {
3825         SV * const vesv = ((SVOP*)version)->op_sv;
3826
3827         if (PL_madskills)
3828             op_getmad(version,pegop,'V');
3829         if (!arg && !SvNIOKp(vesv)) {
3830             arg = version;
3831         }
3832         else {
3833             OP *pack;
3834             SV *meth;
3835
3836             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3837                 Perl_croak(aTHX_ "Version number must be constant number");
3838
3839             /* Make copy of idop so we don't free it twice */
3840             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3841
3842             /* Fake up a method call to VERSION */
3843             meth = newSVpvs_share("VERSION");
3844             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3845                             append_elem(OP_LIST,
3846                                         prepend_elem(OP_LIST, pack, list(version)),
3847                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3848         }
3849     }
3850
3851     /* Fake up an import/unimport */
3852     if (arg && arg->op_type == OP_STUB) {
3853         if (PL_madskills)
3854             op_getmad(arg,pegop,'S');
3855         imop = arg;             /* no import on explicit () */
3856     }
3857     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3858         imop = NULL;            /* use 5.0; */
3859         if (!aver)
3860             idop->op_private |= OPpCONST_NOVER;
3861     }
3862     else {
3863         SV *meth;
3864
3865         if (PL_madskills)
3866             op_getmad(arg,pegop,'A');
3867
3868         /* Make copy of idop so we don't free it twice */
3869         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3870
3871         /* Fake up a method call to import/unimport */
3872         meth = aver
3873             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3874         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3875                        append_elem(OP_LIST,
3876                                    prepend_elem(OP_LIST, pack, list(arg)),
3877                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3878     }
3879
3880     /* Fake up the BEGIN {}, which does its thing immediately. */
3881     newATTRSUB(floor,
3882         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3883         NULL,
3884         NULL,
3885         append_elem(OP_LINESEQ,
3886             append_elem(OP_LINESEQ,
3887                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3888                 newSTATEOP(0, NULL, veop)),
3889             newSTATEOP(0, NULL, imop) ));
3890
3891     /* The "did you use incorrect case?" warning used to be here.
3892      * The problem is that on case-insensitive filesystems one
3893      * might get false positives for "use" (and "require"):
3894      * "use Strict" or "require CARP" will work.  This causes
3895      * portability problems for the script: in case-strict
3896      * filesystems the script will stop working.
3897      *
3898      * The "incorrect case" warning checked whether "use Foo"
3899      * imported "Foo" to your namespace, but that is wrong, too:
3900      * there is no requirement nor promise in the language that
3901      * a Foo.pm should or would contain anything in package "Foo".
3902      *
3903      * There is very little Configure-wise that can be done, either:
3904      * the case-sensitivity of the build filesystem of Perl does not
3905      * help in guessing the case-sensitivity of the runtime environment.
3906      */
3907
3908     PL_hints |= HINT_BLOCK_SCOPE;
3909     PL_parser->copline = NOLINE;
3910     PL_parser->expect = XSTATE;
3911     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3912
3913 #ifdef PERL_MAD
3914     if (!PL_madskills) {
3915         /* FIXME - don't allocate pegop if !PL_madskills */
3916         op_free(pegop);
3917         return NULL;
3918     }
3919     return pegop;
3920 #endif
3921 }
3922
3923 /*
3924 =head1 Embedding Functions
3925
3926 =for apidoc load_module
3927
3928 Loads the module whose name is pointed to by the string part of name.
3929 Note that the actual module name, not its filename, should be given.
3930 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3931 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3932 (or 0 for no flags). ver, if specified, provides version semantics
3933 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3934 arguments can be used to specify arguments to the module's import()
3935 method, similar to C<use Foo::Bar VERSION LIST>.
3936
3937 =cut */
3938
3939 void
3940 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3941 {
3942     va_list args;
3943
3944     PERL_ARGS_ASSERT_LOAD_MODULE;
3945
3946     va_start(args, ver);
3947     vload_module(flags, name, ver, &args);
3948     va_end(args);
3949 }
3950
3951 #ifdef PERL_IMPLICIT_CONTEXT
3952 void
3953 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3954 {
3955     dTHX;
3956     va_list args;
3957     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3958     va_start(args, ver);
3959     vload_module(flags, name, ver, &args);
3960     va_end(args);
3961 }
3962 #endif
3963
3964 void
3965 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3966 {
3967     dVAR;
3968     OP *veop, *imop;
3969     OP * const modname = newSVOP(OP_CONST, 0, name);
3970
3971     PERL_ARGS_ASSERT_VLOAD_MODULE;
3972
3973     modname->op_private |= OPpCONST_BARE;
3974     if (ver) {
3975         veop = newSVOP(OP_CONST, 0, ver);
3976     }
3977     else
3978         veop = NULL;
3979     if (flags & PERL_LOADMOD_NOIMPORT) {
3980         imop = sawparens(newNULLLIST());
3981     }
3982     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3983         imop = va_arg(*args, OP*);
3984     }
3985     else {
3986         SV *sv;
3987         imop = NULL;
3988         sv = va_arg(*args, SV*);
3989         while (sv) {
3990             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3991             sv = va_arg(*args, SV*);
3992         }
3993     }
3994
3995     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3996      * that it has a PL_parser to play with while doing that, and also
3997      * that it doesn't mess with any existing parser, by creating a tmp
3998      * new parser with lex_start(). This won't actually be used for much,
3999      * since pp_require() will create another parser for the real work. */
4000
4001     ENTER;
4002     SAVEVPTR(PL_curcop);
4003     lex_start(NULL, NULL, FALSE);
4004     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4005             veop, modname, imop);
4006     LEAVE;
4007 }
4008
4009 OP *
4010 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4011 {
4012     dVAR;
4013     OP *doop;
4014     GV *gv = NULL;
4015
4016     PERL_ARGS_ASSERT_DOFILE;
4017
4018     if (!force_builtin) {
4019         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4020         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4021             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4022             gv = gvp ? *gvp : NULL;
4023         }
4024     }
4025
4026     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4027         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4028                                append_elem(OP_LIST, term,
4029                                            scalar(newUNOP(OP_RV2CV, 0,
4030                                                           newGVOP(OP_GV, 0, gv))))));
4031     }
4032     else {
4033         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4034     }
4035     return doop;
4036 }
4037
4038 OP *
4039 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4040 {
4041     return newBINOP(OP_LSLICE, flags,
4042             list(force_list(subscript)),
4043             list(force_list(listval)) );
4044 }
4045
4046 STATIC I32
4047 S_is_list_assignment(pTHX_ register const OP *o)
4048 {
4049     unsigned type;
4050     U8 flags;
4051
4052     if (!o)
4053         return TRUE;
4054
4055     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4056         o = cUNOPo->op_first;
4057
4058     flags = o->op_flags;
4059     type = o->op_type;
4060     if (type == OP_COND_EXPR) {
4061         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4062         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4063
4064         if (t && f)
4065             return TRUE;
4066         if (t || f)
4067             yyerror("Assignment to both a list and a scalar");
4068         return FALSE;
4069     }
4070
4071     if (type == OP_LIST &&
4072         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4073         o->op_private & OPpLVAL_INTRO)
4074         return FALSE;
4075
4076     if (type == OP_LIST || flags & OPf_PARENS ||
4077         type == OP_RV2AV || type == OP_RV2HV ||
4078         type == OP_ASLICE || type == OP_HSLICE)
4079         return TRUE;
4080
4081     if (type == OP_PADAV || type == OP_PADHV)
4082         return TRUE;
4083
4084     if (type == OP_RV2SV)
4085         return FALSE;
4086
4087     return FALSE;
4088 }
4089
4090 OP *
4091 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4092 {
4093     dVAR;
4094     OP *o;
4095
4096     if (optype) {
4097         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4098             return newLOGOP(optype, 0,
4099                 mod(scalar(left), optype),
4100                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4101         }
4102         else {
4103             return newBINOP(optype, OPf_STACKED,
4104                 mod(scalar(left), optype), scalar(right));
4105         }
4106     }
4107
4108     if (is_list_assignment(left)) {
4109         static const char no_list_state[] = "Initialization of state variables"
4110             " in list context currently forbidden";
4111         OP *curop;
4112         bool maybe_common_vars = TRUE;
4113
4114         PL_modcount = 0;
4115         /* Grandfathering $[ assignment here.  Bletch.*/
4116         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4117         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4118         left = mod(left, OP_AASSIGN);
4119         if (PL_eval_start)
4120             PL_eval_start = 0;
4121         else if (left->op_type == OP_CONST) {
4122             /* FIXME for MAD */
4123             /* Result of assignment is always 1 (or we'd be dead already) */
4124             return newSVOP(OP_CONST, 0, newSViv(1));
4125         }
4126         curop = list(force_list(left));
4127         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4128         o->op_private = (U8)(0 | (flags >> 8));
4129
4130         if ((left->op_type == OP_LIST
4131              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4132         {
4133             OP* lop = ((LISTOP*)left)->op_first;
4134             maybe_common_vars = FALSE;
4135             while (lop) {
4136                 if (lop->op_type == OP_PADSV ||
4137                     lop->op_type == OP_PADAV ||
4138                     lop->op_type == OP_PADHV ||
4139                     lop->op_type == OP_PADANY) {
4140                     if (!(lop->op_private & OPpLVAL_INTRO))
4141                         maybe_common_vars = TRUE;
4142
4143                     if (lop->op_private & OPpPAD_STATE) {
4144                         if (left->op_private & OPpLVAL_INTRO) {
4145                             /* Each variable in state($a, $b, $c) = ... */
4146                         }
4147                         else {
4148                             /* Each state variable in
4149                                (state $a, my $b, our $c, $d, undef) = ... */
4150                         }
4151                         yyerror(no_list_state);
4152                     } else {
4153                         /* Each my variable in
4154                            (state $a, my $b, our $c, $d, undef) = ... */
4155                     }
4156                 } else if (lop->op_type == OP_UNDEF ||
4157                            lop->op_type == OP_PUSHMARK) {
4158                     /* undef may be interesting in
4159                        (state $a, undef, state $c) */
4160                 } else {
4161                     /* Other ops in the list. */
4162                     maybe_common_vars = TRUE;
4163                 }
4164                 lop = lop->op_sibling;
4165             }
4166         }
4167         else if ((left->op_private & OPpLVAL_INTRO)
4168                 && (   left->op_type == OP_PADSV
4169                     || left->op_type == OP_PADAV
4170                     || left->op_type == OP_PADHV
4171                     || left->op_type == OP_PADANY))
4172         {
4173             maybe_common_vars = FALSE;
4174             if (left->op_private & OPpPAD_STATE) {
4175                 /* All single variable list context state assignments, hence
4176                    state ($a) = ...
4177                    (state $a) = ...
4178                    state @a = ...
4179                    state (@a) = ...
4180                    (state @a) = ...
4181                    state %a = ...
4182                    state (%a) = ...
4183                    (state %a) = ...
4184                 */
4185                 yyerror(no_list_state);
4186             }
4187         }
4188
4189         /* PL_generation sorcery:
4190          * an assignment like ($a,$b) = ($c,$d) is easier than
4191          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4192          * To detect whether there are common vars, the global var
4193          * PL_generation is incremented for each assign op we compile.
4194          * Then, while compiling the assign op, we run through all the
4195          * variables on both sides of the assignment, setting a spare slot
4196          * in each of them to PL_generation. If any of them already have
4197          * that value, we know we've got commonality.  We could use a
4198          * single bit marker, but then we'd have to make 2 passes, first
4199          * to clear the flag, then to test and set it.  To find somewhere
4200          * to store these values, evil chicanery is done with SvUVX().
4201          */
4202
4203         if (maybe_common_vars) {
4204             OP *lastop = o;
4205             PL_generation++;
4206             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4207                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4208                     if (curop->op_type == OP_GV) {
4209                         GV *gv = cGVOPx_gv(curop);
4210                         if (gv == PL_defgv
4211                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4212                             break;
4213                         GvASSIGN_GENERATION_set(gv, PL_generation);
4214                     }
4215                     else if (curop->op_type == OP_PADSV ||
4216                              curop->op_type == OP_PADAV ||
4217                              curop->op_type == OP_PADHV ||
4218                              curop->op_type == OP_PADANY)
4219                     {
4220                         if (PAD_COMPNAME_GEN(curop->op_targ)
4221                                                     == (STRLEN)PL_generation)
4222                             break;
4223                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4224
4225                     }
4226                     else if (curop->op_type == OP_RV2CV)
4227                         break;
4228                     else if (curop->op_type == OP_RV2SV ||
4229                              curop->op_type == OP_RV2AV ||
4230                              curop->op_type == OP_RV2HV ||
4231                              curop->op_type == OP_RV2GV) {
4232                         if (lastop->op_type != OP_GV)   /* funny deref? */
4233                             break;
4234                     }
4235                     else if (curop->op_type == OP_PUSHRE) {
4236 #ifdef USE_ITHREADS
4237                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4238                             GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4239                             if (gv == PL_defgv
4240                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4241                                 break;
4242                             GvASSIGN_GENERATION_set(gv, PL_generation);
4243                         }
4244 #else
4245                         GV *const gv
4246                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4247                         if (gv) {
4248                             if (gv == PL_defgv
4249                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4250                                 break;
4251                             GvASSIGN_GENERATION_set(gv, PL_generation);
4252                         }
4253 #endif
4254                     }
4255                     else
4256                         break;
4257                 }
4258                 lastop = curop;
4259             }
4260             if (curop != o)
4261                 o->op_private |= OPpASSIGN_COMMON;
4262         }
4263
4264         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4265             OP* tmpop = ((LISTOP*)right)->op_first;
4266             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4267                 PMOP * const pm = (PMOP*)tmpop;
4268                 if (left->op_type == OP_RV2AV &&
4269                     !(left->op_private & OPpLVAL_INTRO) &&
4270                     !(o->op_private & OPpASSIGN_COMMON) )
4271                 {
4272                     tmpop = ((UNOP*)left)->op_first;
4273                     if (tmpop->op_type == OP_GV
4274 #ifdef USE_ITHREADS
4275                         && !pm->op_pmreplrootu.op_pmtargetoff
4276 #else
4277                         && !pm->op_pmreplrootu.op_pmtargetgv
4278 #endif
4279                         ) {
4280 #ifdef USE_ITHREADS
4281                         pm->op_pmreplrootu.op_pmtargetoff
4282                             = cPADOPx(tmpop)->op_padix;
4283                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4284 #else
4285                         pm->op_pmreplrootu.op_pmtargetgv
4286                             = (GV*)cSVOPx(tmpop)->op_sv;
4287                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4288 #endif
4289                         pm->op_pmflags |= PMf_ONCE;
4290                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4291                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4292                         tmpop->op_sibling = NULL;       /* don't free split */
4293                         right->op_next = tmpop->op_next;  /* fix starting loc */
4294                         op_free(o);                     /* blow off assign */
4295                         right->op_flags &= ~OPf_WANT;
4296                                 /* "I don't know and I don't care." */
4297                         return right;
4298                     }
4299                 }
4300                 else {
4301                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4302                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4303                     {
4304                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4305                         if (SvIVX(sv) == 0)
4306                             sv_setiv(sv, PL_modcount+1);
4307                     }
4308                 }
4309             }
4310         }
4311         return o;
4312     }
4313     if (!right)
4314         right = newOP(OP_UNDEF, 0);
4315     if (right->op_type == OP_READLINE) {
4316         right->op_flags |= OPf_STACKED;
4317         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4318     }
4319     else {
4320         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4321         o = newBINOP(OP_SASSIGN, flags,
4322             scalar(right), mod(scalar(left), OP_SASSIGN) );
4323         if (PL_eval_start)
4324             PL_eval_start = 0;
4325         else {
4326             /* FIXME for MAD */
4327             op_free(o);
4328             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4329             o->op_private |= OPpCONST_ARYBASE;
4330         }
4331     }
4332     return o;
4333 }
4334
4335 OP *
4336 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4337 {
4338     dVAR;
4339     const U32 seq = intro_my();
4340     register COP *cop;
4341
4342     NewOp(1101, cop, 1, COP);
4343     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4344         cop->op_type = OP_DBSTATE;
4345         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4346     }
4347     else {
4348         cop->op_type = OP_NEXTSTATE;
4349         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4350     }
4351     cop->op_flags = (U8)flags;
4352     CopHINTS_set(cop, PL_hints);
4353 #ifdef NATIVE_HINTS
4354     cop->op_private |= NATIVE_HINTS;
4355 #endif
4356     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4357     cop->op_next = (OP*)cop;
4358
4359     if (label) {
4360         CopLABEL_set(cop, label);
4361         PL_hints |= HINT_BLOCK_SCOPE;
4362     }
4363     cop->cop_seq = seq;
4364     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4365        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4366     */
4367     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4368     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4369     if (cop->cop_hints_hash) {
4370         HINTS_REFCNT_LOCK;
4371         cop->cop_hints_hash->refcounted_he_refcnt++;
4372         HINTS_REFCNT_UNLOCK;
4373     }
4374
4375     if (PL_parser && PL_parser->copline == NOLINE)
4376         CopLINE_set(cop, CopLINE(PL_curcop));
4377     else {
4378         CopLINE_set(cop, PL_parser->copline);
4379         if (PL_parser)
4380             PL_parser->copline = NOLINE;
4381     }
4382 #ifdef USE_ITHREADS
4383     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4384 #else
4385     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4386 #endif
4387     CopSTASH_set(cop, PL_curstash);
4388
4389     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4390         AV *av = CopFILEAVx(PL_curcop);
4391         if (av) {
4392             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4393             if (svp && *svp != &PL_sv_undef ) {
4394                 (void)SvIOK_on(*svp);
4395                 SvIV_set(*svp, PTR2IV(cop));
4396             }
4397         }
4398     }
4399
4400     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4401 }
4402
4403
4404 OP *
4405 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4406 {
4407     dVAR;
4408
4409     PERL_ARGS_ASSERT_NEWLOGOP;
4410
4411     return new_logop(type, flags, &first, &other);
4412 }
4413
4414 STATIC OP *
4415 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4416 {
4417     dVAR;
4418     LOGOP *logop;
4419     OP *o;
4420     OP *first = *firstp;
4421     OP * const other = *otherp;
4422
4423     PERL_ARGS_ASSERT_NEW_LOGOP;
4424
4425     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4426         return newBINOP(type, flags, scalar(first), scalar(other));
4427
4428     scalarboolean(first);
4429     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4430     if (first->op_type == OP_NOT
4431         && (first->op_flags & OPf_SPECIAL)
4432         && (first->op_flags & OPf_KIDS)
4433         && !PL_madskills) {
4434         if (type == OP_AND || type == OP_OR) {
4435             if (type == OP_AND)
4436                 type = OP_OR;
4437             else
4438                 type = OP_AND;
4439             o = first;
4440             first = *firstp = cUNOPo->op_first;
4441             if (o->op_next)
4442                 first->op_next = o->op_next;
4443             cUNOPo->op_first = NULL;
4444             op_free(o);
4445         }
4446     }
4447     if (first->op_type == OP_CONST) {
4448         if (first->op_private & OPpCONST_STRICT)
4449             no_bareword_allowed(first);
4450         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4451                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4452         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4453             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4454             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4455             *firstp = NULL;
4456             if (other->op_type == OP_CONST)
4457                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4458             if (PL_madskills) {
4459                 OP *newop = newUNOP(OP_NULL, 0, other);
4460                 op_getmad(first, newop, '1');
4461                 newop->op_targ = type;  /* set "was" field */
4462                 return newop;
4463             }
4464             op_free(first);
4465             return other;
4466         }
4467         else {
4468             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4469             const OP *o2 = other;
4470             if ( ! (o2->op_type == OP_LIST
4471                     && (( o2 = cUNOPx(o2)->op_first))
4472                     && o2->op_type == OP_PUSHMARK
4473                     && (( o2 = o2->op_sibling)) )
4474             )
4475                 o2 = other;
4476             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4477                         || o2->op_type == OP_PADHV)
4478                 && o2->op_private & OPpLVAL_INTRO
4479                 && !(o2->op_private & OPpPAD_STATE)
4480                 && ckWARN(WARN_DEPRECATED))
4481             {
4482                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4483                             "Deprecated use of my() in false conditional");
4484             }
4485
4486             *otherp = NULL;
4487             if (first->op_type == OP_CONST)
4488                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4489             if (PL_madskills) {
4490                 first = newUNOP(OP_NULL, 0, first);
4491                 op_getmad(other, first, '2');
4492                 first->op_targ = type;  /* set "was" field */
4493             }
4494             else
4495                 op_free(other);
4496             return first;
4497         }
4498     }
4499     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4500         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4501     {
4502         const OP * const k1 = ((UNOP*)first)->op_first;
4503         const OP * const k2 = k1->op_sibling;
4504         OPCODE warnop = 0;
4505         switch (first->op_type)
4506         {
4507         case OP_NULL:
4508             if (k2 && k2->op_type == OP_READLINE
4509                   && (k2->op_flags & OPf_STACKED)
4510                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4511             {
4512                 warnop = k2->op_type;
4513             }
4514             break;
4515
4516         case OP_SASSIGN:
4517             if (k1->op_type == OP_READDIR
4518                   || k1->op_type == OP_GLOB
4519                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4520                   || k1->op_type == OP_EACH)
4521             {
4522                 warnop = ((k1->op_type == OP_NULL)
4523                           ? (OPCODE)k1->op_targ : k1->op_type);
4524             }
4525             break;
4526         }
4527         if (warnop) {
4528             const line_t oldline = CopLINE(PL_curcop);
4529             CopLINE_set(PL_curcop, PL_parser->copline);
4530             Perl_warner(aTHX_ packWARN(WARN_MISC),
4531                  "Value of %s%s can be \"0\"; test with defined()",
4532                  PL_op_desc[warnop],
4533                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4534                   ? " construct" : "() operator"));
4535             CopLINE_set(PL_curcop, oldline);
4536         }
4537     }
4538
4539     if (!other)
4540         return first;
4541
4542     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4543         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4544
4545     NewOp(1101, logop, 1, LOGOP);
4546
4547     logop->op_type = (OPCODE)type;
4548     logop->op_ppaddr = PL_ppaddr[type];
4549     logop->op_first = first;
4550     logop->op_flags = (U8)(flags | OPf_KIDS);
4551     logop->op_other = LINKLIST(other);
4552     logop->op_private = (U8)(1 | (flags >> 8));
4553
4554     /* establish postfix order */
4555     logop->op_next = LINKLIST(first);
4556     first->op_next = (OP*)logop;
4557     first->op_sibling = other;
4558
4559     CHECKOP(type,logop);
4560
4561     o = newUNOP(OP_NULL, 0, (OP*)logop);
4562     other->op_next = o;
4563
4564     return o;
4565 }
4566
4567 OP *
4568 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4569 {
4570     dVAR;
4571     LOGOP *logop;
4572     OP *start;
4573     OP *o;
4574
4575     PERL_ARGS_ASSERT_NEWCONDOP;
4576
4577     if (!falseop)
4578         return newLOGOP(OP_AND, 0, first, trueop);
4579     if (!trueop)
4580         return newLOGOP(OP_OR, 0, first, falseop);
4581
4582     scalarboolean(first);
4583     if (first->op_type == OP_CONST) {
4584         /* Left or right arm of the conditional?  */
4585         const bool left = SvTRUE(((SVOP*)first)->op_sv);
4586         OP *live = left ? trueop : falseop;
4587         OP *const dead = left ? falseop : trueop;
4588         if (first->op_private & OPpCONST_BARE &&
4589             first->op_private & OPpCONST_STRICT) {
4590             no_bareword_allowed(first);
4591         }
4592         if (PL_madskills) {
4593             /* This is all dead code when PERL_MAD is not defined.  */
4594             live = newUNOP(OP_NULL, 0, live);
4595             op_getmad(first, live, 'C');
4596             op_getmad(dead, live, left ? 'e' : 't');
4597         } else {
4598             op_free(first);
4599             op_free(dead);
4600         }
4601         return live;
4602     }
4603     NewOp(1101, logop, 1, LOGOP);
4604     logop->op_type = OP_COND_EXPR;
4605     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4606     logop->op_first = first;
4607     logop->op_flags = (U8)(flags | OPf_KIDS);
4608     logop->op_private = (U8)(1 | (flags >> 8));
4609     logop->op_other = LINKLIST(trueop);
4610     logop->op_next = LINKLIST(falseop);
4611
4612     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4613             logop);
4614
4615     /* establish postfix order */
4616     start = LINKLIST(first);
4617     first->op_next = (OP*)logop;
4618
4619     first->op_sibling = trueop;
4620     trueop->op_sibling = falseop;
4621     o = newUNOP(OP_NULL, 0, (OP*)logop);
4622
4623     trueop->op_next = falseop->op_next = o;
4624
4625     o->op_next = start;
4626     return o;
4627 }
4628
4629 OP *
4630 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4631 {
4632     dVAR;
4633     LOGOP *range;
4634     OP *flip;
4635     OP *flop;
4636     OP *leftstart;
4637     OP *o;
4638
4639     PERL_ARGS_ASSERT_NEWRANGE;
4640
4641     NewOp(1101, range, 1, LOGOP);
4642
4643     range->op_type = OP_RANGE;
4644     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4645     range->op_first = left;
4646     range->op_flags = OPf_KIDS;
4647     leftstart = LINKLIST(left);
4648     range->op_other = LINKLIST(right);
4649     range->op_private = (U8)(1 | (flags >> 8));
4650
4651     left->op_sibling = right;
4652
4653     range->op_next = (OP*)range;
4654     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4655     flop = newUNOP(OP_FLOP, 0, flip);
4656     o = newUNOP(OP_NULL, 0, flop);
4657     linklist(flop);
4658     range->op_next = leftstart;
4659
4660     left->op_next = flip;
4661     right->op_next = flop;
4662
4663     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4664     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4665     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4666     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4667
4668     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4669     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4670
4671     flip->op_next = o;
4672     if (!flip->op_private || !flop->op_private)
4673         linklist(o);            /* blow off optimizer unless constant */
4674
4675     return o;
4676 }
4677
4678 OP *
4679 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4680 {
4681     dVAR;
4682     OP* listop;
4683     OP* o;
4684     const bool once = block && block->op_flags & OPf_SPECIAL &&
4685       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4686
4687     PERL_UNUSED_ARG(debuggable);
4688
4689     if (expr) {
4690         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4691             return block;       /* do {} while 0 does once */
4692         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4693             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4694             expr = newUNOP(OP_DEFINED, 0,
4695                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4696         } else if (expr->op_flags & OPf_KIDS) {
4697             const OP * const k1 = ((UNOP*)expr)->op_first;
4698             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4699             switch (expr->op_type) {
4700               case OP_NULL:
4701                 if (k2 && k2->op_type == OP_READLINE
4702                       && (k2->op_flags & OPf_STACKED)
4703                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4704                     expr = newUNOP(OP_DEFINED, 0, expr);
4705                 break;
4706
4707               case OP_SASSIGN:
4708                 if (k1 && (k1->op_type == OP_READDIR
4709                       || k1->op_type == OP_GLOB
4710                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4711                       || k1->op_type == OP_EACH))
4712                     expr = newUNOP(OP_DEFINED, 0, expr);
4713                 break;
4714             }
4715         }
4716     }
4717
4718     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4719      * op, in listop. This is wrong. [perl #27024] */
4720     if (!block)
4721         block = newOP(OP_NULL, 0);
4722     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4723     o = new_logop(OP_AND, 0, &expr, &listop);
4724
4725     if (listop)
4726         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4727
4728     if (once && o != listop)
4729         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4730
4731     if (o == listop)
4732         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4733
4734     o->op_flags |= flags;
4735     o = scope(o);
4736     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4737     return o;
4738 }
4739
4740 OP *
4741 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4742 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4743 {
4744     dVAR;
4745     OP *redo;
4746     OP *next = NULL;
4747     OP *listop;
4748     OP *o;
4749     U8 loopflags = 0;
4750
4751     PERL_UNUSED_ARG(debuggable);
4752
4753     if (expr) {
4754         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4755                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4756             expr = newUNOP(OP_DEFINED, 0,
4757                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4758         } else if (expr->op_flags & OPf_KIDS) {
4759             const OP * const k1 = ((UNOP*)expr)->op_first;
4760             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4761             switch (expr->op_type) {
4762               case OP_NULL:
4763                 if (k2 && k2->op_type == OP_READLINE
4764                       && (k2->op_flags & OPf_STACKED)
4765                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4766                     expr = newUNOP(OP_DEFINED, 0, expr);
4767                 break;
4768
4769               case OP_SASSIGN:
4770                 if (k1 && (k1->op_type == OP_READDIR
4771                       || k1->op_type == OP_GLOB
4772                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4773                       || k1->op_type == OP_EACH))
4774                     expr = newUNOP(OP_DEFINED, 0, expr);
4775                 break;
4776             }
4777         }
4778     }
4779
4780     if (!block)
4781         block = newOP(OP_NULL, 0);
4782     else if (cont || has_my) {
4783         block = scope(block);
4784     }
4785
4786     if (cont) {
4787         next = LINKLIST(cont);
4788     }
4789     if (expr) {
4790         OP * const unstack = newOP(OP_UNSTACK, 0);
4791         if (!next)
4792             next = unstack;
4793         cont = append_elem(OP_LINESEQ, cont, unstack);
4794     }
4795
4796     assert(block);
4797     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4798     assert(listop);
4799     redo = LINKLIST(listop);
4800
4801     if (expr) {
4802         PL_parser->copline = (line_t)whileline;
4803         scalar(listop);
4804         o = new_logop(OP_AND, 0, &expr, &listop);
4805         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4806             op_free(expr);              /* oops, it's a while (0) */
4807             op_free((OP*)loop);
4808             return NULL;                /* listop already freed by new_logop */
4809         }
4810         if (listop)
4811             ((LISTOP*)listop)->op_last->op_next =
4812                 (o == listop ? redo : LINKLIST(o));
4813     }
4814     else
4815         o = listop;
4816
4817     if (!loop) {
4818         NewOp(1101,loop,1,LOOP);
4819         loop->op_type = OP_ENTERLOOP;
4820         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4821         loop->op_private = 0;
4822         loop->op_next = (OP*)loop;
4823     }
4824
4825     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4826
4827     loop->op_redoop = redo;
4828     loop->op_lastop = o;
4829     o->op_private |= loopflags;
4830
4831     if (next)
4832         loop->op_nextop = next;
4833     else
4834         loop->op_nextop = o;
4835
4836     o->op_flags |= flags;
4837     o->op_private |= (flags >> 8);
4838     return o;
4839 }
4840
4841 OP *
4842 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4843 {
4844     dVAR;
4845     LOOP *loop;
4846     OP *wop;
4847     PADOFFSET padoff = 0;
4848     I32 iterflags = 0;
4849     I32 iterpflags = 0;
4850     OP *madsv = NULL;
4851
4852     PERL_ARGS_ASSERT_NEWFOROP;
4853
4854     if (sv) {
4855         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4856             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4857             sv->op_type = OP_RV2GV;
4858             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4859
4860             /* The op_type check is needed to prevent a possible segfault
4861              * if the loop variable is undeclared and 'strict vars' is in
4862              * effect. This is illegal but is nonetheless parsed, so we
4863              * may reach this point with an OP_CONST where we're expecting
4864              * an OP_GV.
4865              */
4866             if (cUNOPx(sv)->op_first->op_type == OP_GV
4867              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4868                 iterpflags |= OPpITER_DEF;
4869         }
4870         else if (sv->op_type == OP_PADSV) { /* private variable */
4871             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4872             padoff = sv->op_targ;
4873             if (PL_madskills)
4874                 madsv = sv;
4875             else {
4876                 sv->op_targ = 0;
4877                 op_free(sv);
4878             }
4879             sv = NULL;
4880         }
4881         else
4882             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4883         if (padoff) {
4884             SV *const namesv = PAD_COMPNAME_SV(padoff);
4885             STRLEN len;
4886             const char *const name = SvPV_const(namesv, len);
4887
4888             if (len == 2 && name[0] == '$' && name[1] == '_')
4889                 iterpflags |= OPpITER_DEF;
4890         }
4891     }
4892     else {
4893         const PADOFFSET offset = pad_findmy("$_");
4894         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4895             sv = newGVOP(OP_GV, 0, PL_defgv);
4896         }
4897         else {
4898             padoff = offset;
4899         }
4900         iterpflags |= OPpITER_DEF;
4901     }
4902     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4903         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4904         iterflags |= OPf_STACKED;
4905     }
4906     else if (expr->op_type == OP_NULL &&
4907              (expr->op_flags & OPf_KIDS) &&
4908              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4909     {
4910         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4911          * set the STACKED flag to indicate that these values are to be
4912          * treated as min/max values by 'pp_iterinit'.
4913          */
4914         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4915         LOGOP* const range = (LOGOP*) flip->op_first;
4916         OP* const left  = range->op_first;
4917         OP* const right = left->op_sibling;
4918         LISTOP* listop;
4919
4920         range->op_flags &= ~OPf_KIDS;
4921         range->op_first = NULL;
4922
4923         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4924         listop->op_first->op_next = range->op_next;
4925         left->op_next = range->op_other;
4926         right->op_next = (OP*)listop;
4927         listop->op_next = listop->op_first;
4928
4929 #ifdef PERL_MAD
4930         op_getmad(expr,(OP*)listop,'O');
4931 #else
4932         op_free(expr);
4933 #endif
4934         expr = (OP*)(listop);
4935         op_null(expr);
4936         iterflags |= OPf_STACKED;
4937     }
4938     else {
4939         expr = mod(force_list(expr), OP_GREPSTART);
4940     }
4941
4942     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4943                                append_elem(OP_LIST, expr, scalar(sv))));
4944     assert(!loop->op_next);
4945     /* for my  $x () sets OPpLVAL_INTRO;
4946      * for our $x () sets OPpOUR_INTRO */
4947     loop->op_private = (U8)iterpflags;
4948 #ifdef PL_OP_SLAB_ALLOC
4949     {
4950         LOOP *tmp;
4951         NewOp(1234,tmp,1,LOOP);
4952         Copy(loop,tmp,1,LISTOP);
4953         S_op_destroy(aTHX_ (OP*)loop);
4954         loop = tmp;
4955     }
4956 #else
4957     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4958 #endif
4959     loop->op_targ = padoff;
4960     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4961     if (madsv)
4962         op_getmad(madsv, (OP*)loop, 'v');
4963     PL_parser->copline = forline;
4964     return newSTATEOP(0, label, wop);
4965 }
4966
4967 OP*
4968 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4969 {
4970     dVAR;
4971     OP *o;
4972
4973     PERL_ARGS_ASSERT_NEWLOOPEX;
4974
4975     if (type != OP_GOTO || label->op_type == OP_CONST) {
4976         /* "last()" means "last" */
4977         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4978             o = newOP(type, OPf_SPECIAL);
4979         else {
4980             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4981                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4982                                         : ""));
4983         }
4984 #ifdef PERL_MAD
4985         op_getmad(label,o,'L');
4986 #else
4987         op_free(label);
4988 #endif
4989     }
4990     else {
4991         /* Check whether it's going to be a goto &function */
4992         if (label->op_type == OP_ENTERSUB
4993                 && !(label->op_flags & OPf_STACKED))
4994             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4995         o = newUNOP(type, OPf_STACKED, label);
4996     }
4997     PL_hints |= HINT_BLOCK_SCOPE;
4998     return o;
4999 }
5000
5001 /* if the condition is a literal array or hash
5002    (or @{ ... } etc), make a reference to it.
5003  */
5004 STATIC OP *
5005 S_ref_array_or_hash(pTHX_ OP *cond)
5006 {
5007     if (cond
5008     && (cond->op_type == OP_RV2AV
5009     ||  cond->op_type == OP_PADAV
5010     ||  cond->op_type == OP_RV2HV
5011     ||  cond->op_type == OP_PADHV))
5012
5013         return newUNOP(OP_REFGEN,
5014             0, mod(cond, OP_REFGEN));
5015
5016     else
5017         return cond;
5018 }
5019
5020 /* These construct the optree fragments representing given()
5021    and when() blocks.
5022
5023    entergiven and enterwhen are LOGOPs; the op_other pointer
5024    points up to the associated leave op. We need this so we
5025    can put it in the context and make break/continue work.
5026    (Also, of course, pp_enterwhen will jump straight to
5027    op_other if the match fails.)
5028  */
5029
5030 STATIC OP *
5031 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5032                    I32 enter_opcode, I32 leave_opcode,
5033                    PADOFFSET entertarg)
5034 {
5035     dVAR;
5036     LOGOP *enterop;
5037     OP *o;
5038
5039     PERL_ARGS_ASSERT_NEWGIVWHENOP;
5040
5041     NewOp(1101, enterop, 1, LOGOP);
5042     enterop->op_type = (optype)enter_opcode;
5043     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5044     enterop->op_flags =  (U8) OPf_KIDS;
5045     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5046     enterop->op_private = 0;
5047
5048     o = newUNOP(leave_opcode, 0, (OP *) enterop);
5049
5050     if (cond) {
5051         enterop->op_first = scalar(cond);
5052         cond->op_sibling = block;
5053
5054         o->op_next = LINKLIST(cond);
5055         cond->op_next = (OP *) enterop;
5056     }
5057     else {
5058         /* This is a default {} block */
5059         enterop->op_first = block;
5060         enterop->op_flags |= OPf_SPECIAL;
5061
5062         o->op_next = (OP *) enterop;
5063     }
5064
5065     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5066                                        entergiven and enterwhen both
5067                                        use ck_null() */
5068
5069     enterop->op_next = LINKLIST(block);
5070     block->op_next = enterop->op_other = o;
5071
5072     return o;
5073 }
5074
5075 /* Does this look like a boolean operation? For these purposes
5076    a boolean operation is:
5077      - a subroutine call [*]
5078      - a logical connective
5079      - a comparison operator
5080      - a filetest operator, with the exception of -s -M -A -C
5081      - defined(), exists() or eof()
5082      - /$re/ or $foo =~ /$re/
5083
5084    [*] possibly surprising
5085  */
5086 STATIC bool
5087 S_looks_like_bool(pTHX_ const OP *o)
5088 {
5089     dVAR;
5090
5091     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5092
5093     switch(o->op_type) {
5094         case OP_OR:
5095             return looks_like_bool(cLOGOPo->op_first);
5096
5097         case OP_AND:
5098             return (
5099                 looks_like_bool(cLOGOPo->op_first)
5100              && looks_like_bool(cLOGOPo->op_first->op_sibling));
5101
5102         case OP_NULL:
5103             return (
5104                 o->op_flags & OPf_KIDS
5105             && looks_like_bool(cUNOPo->op_first));
5106
5107         case OP_ENTERSUB:
5108
5109         case OP_NOT:    case OP_XOR:
5110         /* Note that OP_DOR is not here */
5111
5112         case OP_EQ:     case OP_NE:     case OP_LT:
5113         case OP_GT:     case OP_LE:     case OP_GE:
5114
5115         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
5116         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
5117
5118         case OP_SEQ:    case OP_SNE:    case OP_SLT:
5119         case OP_SGT:    case OP_SLE:    case OP_SGE:
5120
5121         case OP_SMARTMATCH:
5122
5123         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
5124         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
5125         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
5126         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
5127         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
5128         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
5129         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
5130         case OP_FTTEXT:   case OP_FTBINARY:
5131
5132         case OP_DEFINED: case OP_EXISTS:
5133         case OP_MATCH:   case OP_EOF:
5134
5135             return TRUE;
5136
5137         case OP_CONST:
5138             /* Detect comparisons that have been optimized away */
5139             if (cSVOPo->op_sv == &PL_sv_yes
5140             ||  cSVOPo->op_sv == &PL_sv_no)
5141
5142                 return TRUE;
5143
5144         /* FALL THROUGH */
5145         default:
5146             return FALSE;
5147     }
5148 }
5149
5150 OP *
5151 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5152 {
5153     dVAR;
5154     PERL_ARGS_ASSERT_NEWGIVENOP;
5155     return newGIVWHENOP(
5156         ref_array_or_hash(cond),
5157         block,
5158         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5159         defsv_off);
5160 }
5161
5162 /* If cond is null, this is a default {} block */
5163 OP *
5164 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5165 {
5166     const bool cond_llb = (!cond || looks_like_bool(cond));
5167     OP *cond_op;
5168
5169     PERL_ARGS_ASSERT_NEWWHENOP;
5170
5171     if (cond_llb)
5172         cond_op = cond;
5173     else {
5174         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5175                 newDEFSVOP(),
5176                 scalar(ref_array_or_hash(cond)));
5177     }
5178
5179     return newGIVWHENOP(
5180         cond_op,
5181         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5182         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5183 }
5184
5185 /*
5186 =for apidoc cv_undef
5187
5188 Clear out all the active components of a CV. This can happen either
5189 by an explicit C<undef &foo>, or by the reference count going to zero.
5190 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5191 children can still follow the full lexical scope chain.
5192
5193 =cut
5194 */
5195
5196 void
5197 Perl_cv_undef(pTHX_ CV *cv)
5198 {
5199     dVAR;
5200
5201     PERL_ARGS_ASSERT_CV_UNDEF;
5202
5203     DEBUG_X(PerlIO_printf(Perl_debug_log,
5204           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5205             PTR2UV(cv), PTR2UV(PL_comppad))
5206     );
5207
5208 #ifdef USE_ITHREADS
5209     if (CvFILE(cv) && !CvISXSUB(cv)) {
5210         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5211         Safefree(CvFILE(cv));
5212     }
5213     CvFILE(cv) = NULL;
5214 #endif
5215
5216     if (!CvISXSUB(cv) && CvROOT(cv)) {
5217         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5218             Perl_croak(aTHX_ "Can't undef active subroutine");
5219         ENTER;
5220
5221         PAD_SAVE_SETNULLPAD();
5222
5223         op_free(CvROOT(cv));
5224         CvROOT(cv) = NULL;
5225         CvSTART(cv) = NULL;
5226         LEAVE;
5227     }
5228     SvPOK_off((SV*)cv);         /* forget prototype */
5229     CvGV(cv) = NULL;
5230
5231     pad_undef(cv);
5232
5233     /* remove CvOUTSIDE unless this is an undef rather than a free */
5234     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5235         if (!CvWEAKOUTSIDE(cv))
5236             SvREFCNT_dec(CvOUTSIDE(cv));
5237         CvOUTSIDE(cv) = NULL;
5238     }
5239     if (CvCONST(cv)) {
5240         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5241         CvCONST_off(cv);
5242     }
5243     if (CvISXSUB(cv) && CvXSUB(cv)) {
5244         CvXSUB(cv) = NULL;
5245     }
5246     /* delete all flags except WEAKOUTSIDE */
5247     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5248 }
5249
5250 void
5251 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5252                     const STRLEN len)
5253 {
5254     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5255
5256     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5257        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5258     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5259          || (p && (len != SvCUR(cv) /* Not the same length.  */
5260                    || memNE(p, SvPVX_const(cv), len))))
5261          && ckWARN_d(WARN_PROTOTYPE)) {
5262         SV* const msg = sv_newmortal();
5263         SV* name = NULL;
5264
5265         if (gv)
5266             gv_efullname3(name = sv_newmortal(), gv, NULL);
5267         sv_setpvs(msg, "Prototype mismatch:");
5268         if (name)
5269             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5270         if (SvPOK(cv))
5271             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5272         else
5273             sv_catpvs(msg, ": none");
5274         sv_catpvs(msg, " vs ");
5275         if (p)
5276             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5277         else
5278             sv_catpvs(msg, "none");
5279         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5280     }
5281 }
5282
5283 static void const_sv_xsub(pTHX_ CV* cv);
5284
5285 /*
5286
5287 =head1 Optree Manipulation Functions
5288
5289 =for apidoc cv_const_sv
5290
5291 If C<cv> is a constant sub eligible for inlining. returns the constant
5292 value returned by the sub.  Otherwise, returns NULL.
5293
5294 Constant subs can be created with C<newCONSTSUB> or as described in
5295 L<perlsub/"Constant Functions">.
5296
5297 =cut
5298 */
5299 SV *
5300 Perl_cv_const_sv(pTHX_ CV *cv)
5301 {
5302     PERL_UNUSED_CONTEXT;
5303     if (!cv)
5304         return NULL;
5305     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5306         return NULL;
5307     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5308 }
5309
5310 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5311  * Can be called in 3 ways:
5312  *
5313  * !cv
5314  *      look for a single OP_CONST with attached value: return the value
5315  *
5316  * cv && CvCLONE(cv) && !CvCONST(cv)
5317  *
5318  *      examine the clone prototype, and if contains only a single
5319  *      OP_CONST referencing a pad const, or a single PADSV referencing
5320  *      an outer lexical, return a non-zero value to indicate the CV is
5321  *      a candidate for "constizing" at clone time
5322  *
5323  * cv && CvCONST(cv)
5324  *
5325  *      We have just cloned an anon prototype that was marked as a const
5326  *      candidiate. Try to grab the current value, and in the case of
5327  *      PADSV, ignore it if it has multiple references. Return the value.
5328  */
5329
5330 SV *
5331 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5332 {
5333     dVAR;
5334     SV *sv = NULL;
5335
5336     if (PL_madskills)
5337         return NULL;
5338
5339     if (!o)
5340         return NULL;
5341
5342     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5343         o = cLISTOPo->op_first->op_sibling;
5344
5345     for (; o; o = o->op_next) {
5346         const OPCODE type = o->op_type;
5347
5348         if (sv && o->op_next == o)
5349             return sv;
5350         if (o->op_next != o) {
5351             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5352                 continue;
5353             if (type == OP_DBSTATE)
5354                 continue;
5355         }
5356         if (type == OP_LEAVESUB || type == OP_RETURN)
5357             break;
5358         if (sv)
5359             return NULL;
5360         if (type == OP_CONST && cSVOPo->op_sv)
5361             sv = cSVOPo->op_sv;
5362         else if (cv && type == OP_CONST) {
5363             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5364             if (!sv)
5365                 return NULL;
5366         }
5367         else if (cv && type == OP_PADSV) {
5368             if (CvCONST(cv)) { /* newly cloned anon */
5369                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5370                 /* the candidate should have 1 ref from this pad and 1 ref
5371                  * from the parent */
5372                 if (!sv || SvREFCNT(sv) != 2)
5373                     return NULL;
5374                 sv = newSVsv(sv);
5375                 SvREADONLY_on(sv);
5376                 return sv;
5377             }
5378             else {
5379                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5380                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5381             }
5382         }
5383         else {
5384             return NULL;
5385         }
5386     }
5387     return sv;
5388 }
5389
5390 #ifdef PERL_MAD
5391 OP *
5392 #else
5393 void
5394 #endif
5395 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5396 {
5397 #if 0
5398     /* This would be the return value, but the return cannot be reached.  */
5399     OP* pegop = newOP(OP_NULL, 0);
5400 #endif
5401
5402     PERL_UNUSED_ARG(floor);
5403
5404     if (o)
5405         SAVEFREEOP(o);
5406     if (proto)
5407         SAVEFREEOP(proto);
5408     if (attrs)
5409         SAVEFREEOP(attrs);
5410     if (block)
5411         SAVEFREEOP(block);
5412     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5413 #ifdef PERL_MAD
5414     NORETURN_FUNCTION_END;
5415 #endif
5416 }
5417
5418 CV *
5419 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5420 {
5421     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5422 }
5423
5424 CV *
5425 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5426 {
5427     dVAR;
5428     const char *aname;
5429     GV *gv;
5430     const char *ps;
5431     STRLEN ps_len;
5432     register CV *cv = NULL;
5433     SV *const_sv;
5434     /* If the subroutine has no body, no attributes, and no builtin attributes
5435        then it's just a sub declaration, and we may be able to get away with
5436        storing with a placeholder scalar in the symbol table, rather than a
5437        full GV and CV.  If anything is present then it will take a full CV to
5438        store it.  */
5439     const I32 gv_fetch_flags
5440         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5441            || PL_madskills)
5442         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5443     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5444
5445     if (proto) {
5446         assert(proto->op_type == OP_CONST);
5447         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5448     }
5449     else
5450         ps = NULL;
5451
5452     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5453         SV * const sv = sv_newmortal();
5454         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5455                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5456                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5457         aname = SvPVX_const(sv);
5458     }
5459     else
5460         aname = NULL;
5461
5462     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5463         : gv_fetchpv(aname ? aname
5464                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5465                      gv_fetch_flags, SVt_PVCV);
5466
5467     if (!PL_madskills) {
5468         if (o)
5469             SAVEFREEOP(o);
5470         if (proto)
5471             SAVEFREEOP(proto);
5472         if (attrs)
5473             SAVEFREEOP(attrs);
5474     }
5475
5476     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5477                                            maximum a prototype before. */
5478         if (SvTYPE(gv) > SVt_NULL) {
5479             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5480                 && ckWARN_d(WARN_PROTOTYPE))
5481             {
5482                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5483             }
5484             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5485         }
5486         if (ps)
5487             sv_setpvn((SV*)gv, ps, ps_len);
5488         else
5489             sv_setiv((SV*)gv, -1);
5490
5491         SvREFCNT_dec(PL_compcv);
5492         cv = PL_compcv = NULL;
5493         goto done;
5494     }
5495
5496     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5497
5498 #ifdef GV_UNIQUE_CHECK
5499     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5500         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5501     }
5502 #endif
5503
5504     if (!block || !ps || *ps || attrs
5505         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5506 #ifdef PERL_MAD
5507         || block->op_type == OP_NULL
5508 #endif
5509         )
5510         const_sv = NULL;
5511     else
5512         const_sv = op_const_sv(block, NULL);
5513
5514     if (cv) {
5515         const bool exists = CvROOT(cv) || CvXSUB(cv);
5516
5517 #ifdef GV_UNIQUE_CHECK
5518         if (exists && GvUNIQUE(gv)) {
5519             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5520         }
5521 #endif
5522
5523         /* if the subroutine doesn't exist and wasn't pre-declared
5524          * with a prototype, assume it will be AUTOLOADed,
5525          * skipping the prototype check
5526          */
5527         if (exists || SvPOK(cv))
5528             cv_ckproto_len(cv, gv, ps, ps_len);
5529         /* already defined (or promised)? */
5530         if (exists || GvASSUMECV(gv)) {
5531             if ((!block
5532 #ifdef PERL_MAD
5533                  || block->op_type == OP_NULL
5534 #endif
5535                  )&& !attrs) {
5536                 if (CvFLAGS(PL_compcv)) {
5537                     /* might have had built-in attrs applied */
5538                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5539                 }
5540                 /* just a "sub foo;" when &foo is already defined */
5541                 SAVEFREESV(PL_compcv);
5542                 goto done;
5543             }
5544             if (block
5545 #ifdef PERL_MAD
5546                 && block->op_type != OP_NULL
5547 #endif
5548                 ) {
5549                 if (ckWARN(WARN_REDEFINE)
5550                     || (CvCONST(cv)
5551                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5552                 {
5553                     const line_t oldline = CopLINE(PL_curcop);
5554                     if (PL_parser && PL_parser->copline != NOLINE)
5555                         CopLINE_set(PL_curcop, PL_parser->copline);
5556                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5557                         CvCONST(cv) ? "Constant subroutine %s redefined"
5558                                     : "Subroutine %s redefined", name);
5559                     CopLINE_set(PL_curcop, oldline);
5560                 }
5561 #ifdef PERL_MAD
5562                 if (!PL_minus_c)        /* keep old one around for madskills */
5563 #endif
5564                     {
5565                         /* (PL_madskills unset in used file.) */
5566                         SvREFCNT_dec(cv);
5567                     }
5568                 cv = NULL;
5569             }
5570         }
5571     }
5572     if (const_sv) {
5573         SvREFCNT_inc_simple_void_NN(const_sv);
5574         if (cv) {
5575             assert(!CvROOT(cv) && !CvCONST(cv));
5576             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5577             CvXSUBANY(cv).any_ptr = const_sv;
5578             CvXSUB(cv) = const_sv_xsub;
5579             CvCONST_on(cv);
5580             CvISXSUB_on(cv);
5581         }
5582         else {
5583             GvCV(gv) = NULL;
5584             cv = newCONSTSUB(NULL, name, const_sv);
5585         }
5586         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5587             (CvGV(cv) && GvSTASH(CvGV(cv)))
5588                 ? GvSTASH(CvGV(cv))
5589                 : CvSTASH(cv)
5590                     ? CvSTASH(cv)
5591                     : PL_curstash
5592         );
5593         if (PL_madskills)
5594             goto install_block;
5595         op_free(block);
5596         SvREFCNT_dec(PL_compcv);
5597         PL_compcv = NULL;
5598         goto done;
5599     }
5600     if (attrs) {
5601         HV *stash;
5602         SV *rcv;
5603
5604         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5605          * before we clobber PL_compcv.
5606          */
5607         if (cv && (!block
5608 #ifdef PERL_MAD
5609                     || block->op_type == OP_NULL
5610 #endif
5611                     )) {
5612             rcv = (SV*)cv;
5613             /* Might have had built-in attributes applied -- propagate them. */
5614             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5615             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5616                 stash = GvSTASH(CvGV(cv));
5617             else if (CvSTASH(cv))
5618                 stash = CvSTASH(cv);
5619             else
5620                 stash = PL_curstash;
5621         }
5622         else {
5623             /* possibly about to re-define existing subr -- ignore old cv */
5624             rcv = (SV*)PL_compcv;
5625             if (name && GvSTASH(gv))
5626                 stash = GvSTASH(gv);
5627             else
5628                 stash = PL_curstash;
5629         }
5630         apply_attrs(stash, rcv, attrs, FALSE);
5631     }
5632     if (cv) {                           /* must reuse cv if autoloaded */
5633         if (
5634 #ifdef PERL_MAD
5635             (
5636 #endif
5637              !block
5638 #ifdef PERL_MAD
5639              || block->op_type == OP_NULL) && !PL_madskills
5640 #endif
5641              ) {
5642             /* got here with just attrs -- work done, so bug out */
5643             SAVEFREESV(PL_compcv);
5644             goto done;
5645         }
5646         /* transfer PL_compcv to cv */
5647         cv_undef(cv);
5648         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5649         if (!CvWEAKOUTSIDE(cv))
5650             SvREFCNT_dec(CvOUTSIDE(cv));
5651         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5652         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5653         CvOUTSIDE(PL_compcv) = 0;
5654         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5655         CvPADLIST(PL_compcv) = 0;
5656         /* inner references to PL_compcv must be fixed up ... */
5657         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5658         /* ... before we throw it away */
5659         SvREFCNT_dec(PL_compcv);
5660         PL_compcv = cv;
5661         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5662           ++PL_sub_generation;
5663     }
5664     else {
5665         cv = PL_compcv;
5666         if (name) {
5667             GvCV(gv) = cv;
5668             if (PL_madskills) {
5669                 if (strEQ(name, "import")) {
5670                     PL_formfeed = (SV*)cv;
5671                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5672                 }
5673             }
5674             GvCVGEN(gv) = 0;
5675             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5676         }
5677     }
5678     CvGV(cv) = gv;
5679     CvFILE_set_from_cop(cv, PL_curcop);
5680     CvSTASH(cv) = PL_curstash;
5681
5682     if (ps)
5683         sv_setpvn((SV*)cv, ps, ps_len);
5684
5685     if (PL_parser && PL_parser->error_count) {
5686         op_free(block);
5687         block = NULL;
5688         if (name) {
5689             const char *s = strrchr(name, ':');
5690             s = s ? s+1 : name;
5691             if (strEQ(s, "BEGIN")) {
5692                 const char not_safe[] =
5693                     "BEGIN not safe after errors--compilation aborted";
5694                 if (PL_in_eval & EVAL_KEEPERR)
5695                     Perl_croak(aTHX_ not_safe);
5696                 else {
5697                     /* force display of errors found but not reported */
5698                     sv_catpv(ERRSV, not_safe);
5699                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5700                 }
5701             }
5702         }
5703     }
5704  install_block:
5705     if (!block)
5706         goto done;
5707
5708     if (CvLVALUE(cv)) {
5709         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5710                              mod(scalarseq(block), OP_LEAVESUBLV));
5711         block->op_attached = 1;
5712     }
5713     else {
5714         /* This makes sub {}; work as expected.  */
5715         if (block->op_type == OP_STUB) {
5716             OP* const newblock = newSTATEOP(0, NULL, 0);
5717 #ifdef PERL_MAD
5718             op_getmad(block,newblock,'B');
5719 #else
5720             op_free(block);
5721 #endif
5722             block = newblock;
5723         }
5724         else
5725             block->op_attached = 1;
5726         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5727     }
5728     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5729     OpREFCNT_set(CvROOT(cv), 1);
5730     CvSTART(cv) = LINKLIST(CvROOT(cv));
5731     CvROOT(cv)->op_next = 0;
5732     CALL_PEEP(CvSTART(cv));
5733
5734     /* now that optimizer has done its work, adjust pad values */
5735
5736     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5737
5738     if (CvCLONE(cv)) {
5739         assert(!CvCONST(cv));
5740         if (ps && !*ps && op_const_sv(block, cv))
5741             CvCONST_on(cv);
5742     }
5743
5744     if (name || aname) {
5745         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5746             SV * const sv = newSV(0);
5747             SV * const tmpstr = sv_newmortal();
5748             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5749                                                   GV_ADDMULTI, SVt_PVHV);
5750             HV *hv;
5751
5752             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5753                            CopFILE(PL_curcop),
5754                            (long)PL_subline, (long)CopLINE(PL_curcop));
5755             gv_efullname3(tmpstr, gv, NULL);
5756             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5757                     SvCUR(tmpstr), sv, 0);
5758             hv = GvHVn(db_postponed);
5759             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5760                 CV * const pcv = GvCV(db_postponed);
5761                 if (pcv) {
5762                     dSP;
5763                     PUSHMARK(SP);
5764                     XPUSHs(tmpstr);
5765                     PUTBACK;
5766                     call_sv((SV*)pcv, G_DISCARD);
5767                 }
5768             }
5769         }
5770
5771         if (name && ! (PL_parser && PL_parser->error_count))
5772             process_special_blocks(name, gv, cv);
5773     }
5774
5775   done:
5776     if (PL_parser)
5777         PL_parser->copline = NOLINE;
5778     LEAVE_SCOPE(floor);
5779     return cv;
5780 }
5781
5782 STATIC void
5783 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5784                          CV *const cv)
5785 {
5786     const char *const colon = strrchr(fullname,':');
5787     const char *const name = colon ? colon + 1 : fullname;
5788
5789     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5790
5791     if (*name == 'B') {
5792         if (strEQ(name, "BEGIN")) {
5793             const I32 oldscope = PL_scopestack_ix;
5794             ENTER;
5795             SAVECOPFILE(&PL_compiling);
5796             SAVECOPLINE(&PL_compiling);
5797
5798             DEBUG_x( dump_sub(gv) );
5799             Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5800             GvCV(gv) = 0;               /* cv has been hijacked */
5801             call_list(oldscope, PL_beginav);
5802
5803             PL_curcop = &PL_compiling;
5804             CopHINTS_set(&PL_compiling, PL_hints);
5805             LEAVE;
5806         }
5807         else
5808             return;
5809     } else {
5810         if (*name == 'E') {
5811             if strEQ(name, "END") {
5812                 DEBUG_x( dump_sub(gv) );
5813                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5814             } else
5815                 return;
5816         } else if (*name == 'U') {
5817             if (strEQ(name, "UNITCHECK")) {
5818                 /* It's never too late to run a unitcheck block */
5819                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5820             }
5821             else
5822                 return;
5823         } else if (*name == 'C') {
5824             if (strEQ(name, "CHECK")) {
5825                 if (PL_main_start && ckWARN(WARN_VOID))
5826                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5827                                 "Too late to run CHECK block");
5828                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5829             }
5830             else
5831                 return;
5832         } else if (*name == 'I') {
5833             if (strEQ(name, "INIT")) {
5834                 if (PL_main_start && ckWARN(WARN_VOID))
5835                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5836                                 "Too late to run INIT block");
5837                 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5838             }
5839             else
5840                 return;
5841         } else
5842             return;
5843         DEBUG_x( dump_sub(gv) );
5844         GvCV(gv) = 0;           /* cv has been hijacked */
5845     }
5846 }
5847
5848 /*
5849 =for apidoc newCONSTSUB
5850
5851 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5852 eligible for inlining at compile-time.
5853
5854 =cut
5855 */
5856
5857 CV *
5858 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5859 {
5860     dVAR;
5861     CV* cv;
5862 #ifdef USE_ITHREADS
5863     const char *const temp_p = CopFILE(PL_curcop);
5864     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5865 #else
5866     SV *const temp_sv = CopFILESV(PL_curcop);
5867     STRLEN len;
5868     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5869 #endif
5870     char *const file = savepvn(temp_p, temp_p ? len : 0);
5871
5872     ENTER;
5873
5874     if (IN_PERL_RUNTIME) {
5875         /* at runtime, it's not safe to manipulate PL_curcop: it may be
5876          * an op shared between threads. Use a non-shared COP for our
5877          * dirty work */
5878          SAVEVPTR(PL_curcop);
5879          PL_curcop = &PL_compiling;
5880     }
5881     SAVECOPLINE(PL_curcop);
5882     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5883
5884     SAVEHINTS();
5885     PL_hints &= ~HINT_BLOCK_SCOPE;
5886
5887     if (stash) {
5888         SAVESPTR(PL_curstash);
5889         SAVECOPSTASH(PL_curcop);
5890         PL_curstash = stash;
5891         CopSTASH_set(PL_curcop,stash);
5892     }
5893
5894     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5895        and so doesn't get free()d.  (It's expected to be from the C pre-
5896        processor __FILE__ directive). But we need a dynamically allocated one,
5897        and we need it to get freed.  */
5898     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5899     CvXSUBANY(cv).any_ptr = sv;
5900     CvCONST_on(cv);
5901     Safefree(file);
5902
5903 #ifdef USE_ITHREADS
5904     if (stash)
5905         CopSTASH_free(PL_curcop);
5906 #endif
5907     LEAVE;
5908
5909     return cv;
5910 }
5911
5912 CV *
5913 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5914                  const char *const filename, const char *const proto,
5915                  U32 flags)
5916 {
5917     CV *cv = newXS(name, subaddr, filename);
5918
5919     PERL_ARGS_ASSERT_NEWXS_FLAGS;
5920
5921     if (flags & XS_DYNAMIC_FILENAME) {
5922         /* We need to "make arrangements" (ie cheat) to ensure that the
5923            filename lasts as long as the PVCV we just created, but also doesn't
5924            leak  */
5925         STRLEN filename_len = strlen(filename);
5926         STRLEN proto_and_file_len = filename_len;
5927         char *proto_and_file;
5928         STRLEN proto_len;
5929
5930         if (proto) {
5931             proto_len = strlen(proto);
5932             proto_and_file_len += proto_len;
5933
5934             Newx(proto_and_file, proto_and_file_len + 1, char);
5935             Copy(proto, proto_and_file, proto_len, char);
5936             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5937         } else {
5938             proto_len = 0;
5939             proto_and_file = savepvn(filename, filename_len);
5940         }
5941
5942         /* This gets free()d.  :-)  */
5943         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5944                         SV_HAS_TRAILING_NUL);
5945         if (proto) {
5946             /* This gives us the correct prototype, rather than one with the
5947                file name appended.  */
5948             SvCUR_set(cv, proto_len);
5949         } else {
5950             SvPOK_off(cv);
5951         }
5952         CvFILE(cv) = proto_and_file + proto_len;
5953     } else {
5954         sv_setpv((SV *)cv, proto);
5955     }
5956     return cv;
5957 }
5958
5959 /*
5960 =for apidoc U||newXS
5961
5962 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5963 static storage, as it is used directly as CvFILE(), without a copy being made.
5964
5965 =cut
5966 */
5967
5968 CV *
5969 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5970 {
5971     dVAR;
5972     GV * const gv = gv_fetchpv(name ? name :
5973                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5974                         GV_ADDMULTI, SVt_PVCV);
5975     register CV *cv;
5976
5977     PERL_ARGS_ASSERT_NEWXS;
5978
5979     if (!subaddr)
5980         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5981
5982     if ((cv = (name ? GvCV(gv) : NULL))) {
5983         if (GvCVGEN(gv)) {
5984             /* just a cached method */
5985             SvREFCNT_dec(cv);
5986             cv = NULL;
5987         }
5988         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5989             /* already defined (or promised) */
5990             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5991             if (ckWARN(WARN_REDEFINE)) {
5992                 GV * const gvcv = CvGV(cv);
5993                 if (gvcv) {
5994                     HV * const stash = GvSTASH(gvcv);
5995                     if (stash) {
5996                         const char *redefined_name = HvNAME_get(stash);
5997                         if ( strEQ(redefined_name,"autouse") ) {
5998                             const line_t oldline = CopLINE(PL_curcop);
5999                             if (PL_parser && PL_parser->copline != NOLINE)
6000                                 CopLINE_set(PL_curcop, PL_parser->copline);
6001                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6002                                         CvCONST(cv) ? "Constant subroutine %s redefined"
6003                                                     : "Subroutine %s redefined"
6004                                         ,name);
6005                             CopLINE_set(PL_curcop, oldline);
6006                         }
6007                     }
6008                 }
6009             }
6010             SvREFCNT_dec(cv);
6011             cv = NULL;
6012         }
6013     }
6014
6015     if (cv)                             /* must reuse cv if autoloaded */
6016         cv_undef(cv);
6017     else {
6018         cv = (CV*)newSV_type(SVt_PVCV);
6019         if (name) {
6020             GvCV(gv) = cv;
6021             GvCVGEN(gv) = 0;
6022             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6023         }
6024     }
6025     CvGV(cv) = gv;
6026     (void)gv_fetchfile(filename);
6027     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6028                                    an external constant string */
6029     CvISXSUB_on(cv);
6030     CvXSUB(cv) = subaddr;
6031
6032     if (name)
6033         process_special_blocks(name, gv, cv);
6034     else
6035         CvANON_on(cv);
6036
6037     return cv;
6038 }
6039
6040 #ifdef PERL_MAD
6041 OP *
6042 #else
6043 void
6044 #endif
6045 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6046 {
6047     dVAR;
6048     register CV *cv;
6049 #ifdef PERL_MAD
6050     OP* pegop = newOP(OP_NULL, 0);
6051 #endif
6052
6053     GV * const gv = o
6054         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6055         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6056
6057 #ifdef GV_UNIQUE_CHECK
6058     if (GvUNIQUE(gv)) {
6059         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6060     }
6061 #endif
6062     GvMULTI_on(gv);
6063     if ((cv = GvFORM(gv))) {
6064         if (ckWARN(WARN_REDEFINE)) {
6065             const line_t oldline = CopLINE(PL_curcop);
6066             if (PL_parser && PL_parser->copline != NOLINE)
6067                 CopLINE_set(PL_curcop, PL_parser->copline);
6068             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6069                         o ? "Format %"SVf" redefined"
6070                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6071             CopLINE_set(PL_curcop, oldline);
6072         }
6073         SvREFCNT_dec(cv);
6074     }
6075     cv = PL_compcv;
6076     GvFORM(gv) = cv;
6077     CvGV(cv) = gv;
6078     CvFILE_set_from_cop(cv, PL_curcop);
6079
6080
6081     pad_tidy(padtidy_FORMAT);
6082     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6083     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6084     OpREFCNT_set(CvROOT(cv), 1);
6085     CvSTART(cv) = LINKLIST(CvROOT(cv));
6086     CvROOT(cv)->op_next = 0;
6087     CALL_PEEP(CvSTART(cv));
6088 #ifdef PERL_MAD
6089     op_getmad(o,pegop,'n');
6090     op_getmad_weak(block, pegop, 'b');
6091 #else
6092     op_free(o);
6093 #endif
6094     if (PL_parser)
6095         PL_parser->copline = NOLINE;
6096     LEAVE_SCOPE(floor);
6097 #ifdef PERL_MAD
6098     return pegop;
6099 #endif
6100 }
6101
6102 OP *
6103 Perl_newANONLIST(pTHX_ OP *o)
6104 {
6105     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6106 }
6107
6108 OP *
6109 Perl_newANONHASH(pTHX_ OP *o)
6110 {
6111     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6112 }
6113
6114 OP *
6115 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6116 {
6117     return newANONATTRSUB(floor, proto, NULL, block);
6118 }
6119
6120 OP *
6121 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6122 {
6123     return newUNOP(OP_REFGEN, 0,
6124         newSVOP(OP_ANONCODE, 0,
6125                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6126 }
6127
6128 OP *
6129 Perl_oopsAV(pTHX_ OP *o)
6130 {
6131     dVAR;
6132
6133     PERL_ARGS_ASSERT_OOPSAV;
6134
6135     switch (o->op_type) {
6136     case OP_PADSV:
6137         o->op_type = OP_PADAV;
6138         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6139         return ref(o, OP_RV2AV);
6140
6141     case OP_RV2SV:
6142         o->op_type = OP_RV2AV;
6143         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6144         ref(o, OP_RV2AV);
6145         break;
6146
6147     default:
6148         if (ckWARN_d(WARN_INTERNAL))
6149             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6150         break;
6151     }
6152     return o;
6153 }
6154
6155 OP *
6156 Perl_oopsHV(pTHX_ OP *o)
6157 {
6158     dVAR;
6159
6160     PERL_ARGS_ASSERT_OOPSHV;
6161
6162     switch (o->op_type) {
6163     case OP_PADSV:
6164     case OP_PADAV:
6165         o->op_type = OP_PADHV;
6166         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6167         return ref(o, OP_RV2HV);
6168
6169     case OP_RV2SV:
6170     case OP_RV2AV:
6171         o->op_type = OP_RV2HV;
6172         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6173         ref(o, OP_RV2HV);
6174         break;
6175
6176     default:
6177         if (ckWARN_d(WARN_INTERNAL))
6178             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6179         break;
6180     }
6181     return o;
6182 }
6183
6184 OP *
6185 Perl_newAVREF(pTHX_ OP *o)
6186 {
6187     dVAR;
6188
6189     PERL_ARGS_ASSERT_NEWAVREF;
6190
6191     if (o->op_type == OP_PADANY) {
6192         o->op_type = OP_PADAV;
6193         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6194         return o;
6195     }
6196     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6197                 && ckWARN(WARN_DEPRECATED)) {
6198         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6199                 "Using an array as a reference is deprecated");
6200     }
6201     return newUNOP(OP_RV2AV, 0, scalar(o));
6202 }
6203
6204 OP *
6205 Perl_newGVREF(pTHX_ I32 type, OP *o)
6206 {
6207     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6208         return newUNOP(OP_NULL, 0, o);
6209     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6210 }
6211
6212 OP *
6213 Perl_newHVREF(pTHX_ OP *o)
6214 {
6215     dVAR;
6216
6217     PERL_ARGS_ASSERT_NEWHVREF;
6218
6219     if (o->op_type == OP_PADANY) {
6220         o->op_type = OP_PADHV;
6221         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6222         return o;
6223     }
6224     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6225                 && ckWARN(WARN_DEPRECATED)) {
6226         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6227                 "Using a hash as a reference is deprecated");
6228     }
6229     return newUNOP(OP_RV2HV, 0, scalar(o));
6230 }
6231
6232 OP *
6233 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6234 {
6235     return newUNOP(OP_RV2CV, flags, scalar(o));
6236 }
6237
6238 OP *
6239 Perl_newSVREF(pTHX_ OP *o)
6240 {
6241     dVAR;
6242
6243     PERL_ARGS_ASSERT_NEWSVREF;
6244
6245     if (o->op_type == OP_PADANY) {
6246         o->op_type = OP_PADSV;
6247         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6248         return o;
6249     }
6250     return newUNOP(OP_RV2SV, 0, scalar(o));
6251 }
6252
6253 /* Check routines. See the comments at the top of this file for details
6254  * on when these are called */
6255
6256 OP *
6257 Perl_ck_anoncode(pTHX_ OP *o)
6258 {
6259     PERL_ARGS_ASSERT_CK_ANONCODE;
6260
6261     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6262     if (!PL_madskills)
6263         cSVOPo->op_sv = NULL;
6264     return o;
6265 }
6266
6267 OP *
6268 Perl_ck_bitop(pTHX_ OP *o)
6269 {
6270     dVAR;
6271
6272     PERL_ARGS_ASSERT_CK_BITOP;
6273
6274 #define OP_IS_NUMCOMPARE(op) \
6275         ((op) == OP_LT   || (op) == OP_I_LT || \
6276          (op) == OP_GT   || (op) == OP_I_GT || \
6277          (op) == OP_LE   || (op) == OP_I_LE || \
6278          (op) == OP_GE   || (op) == OP_I_GE || \
6279          (op) == OP_EQ   || (op) == OP_I_EQ || \
6280          (op) == OP_NE   || (op) == OP_I_NE || \
6281          (op) == OP_NCMP || (op) == OP_I_NCMP)
6282     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6283     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6284             && (o->op_type == OP_BIT_OR
6285              || o->op_type == OP_BIT_AND
6286              || o->op_type == OP_BIT_XOR))
6287     {
6288         const OP * const left = cBINOPo->op_first;
6289         const OP * const right = left->op_sibling;
6290         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6291                 (left->op_flags & OPf_PARENS) == 0) ||
6292             (OP_IS_NUMCOMPARE(right->op_type) &&
6293                 (right->op_flags & OPf_PARENS) == 0))
6294             if (ckWARN(WARN_PRECEDENCE))
6295                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6296                         "Possible precedence problem on bitwise %c operator",
6297                         o->op_type == OP_BIT_OR ? '|'
6298                             : o->op_type == OP_BIT_AND ? '&' : '^'
6299                         );
6300     }
6301     return o;
6302 }
6303
6304 OP *
6305 Perl_ck_concat(pTHX_ OP *o)
6306 {
6307     const OP * const kid = cUNOPo->op_first;
6308
6309     PERL_ARGS_ASSERT_CK_CONCAT;
6310     PERL_UNUSED_CONTEXT;
6311
6312     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6313             !(kUNOP->op_first->op_flags & OPf_MOD))
6314         o->op_flags |= OPf_STACKED;
6315     return o;
6316 }
6317
6318 OP *
6319 Perl_ck_spair(pTHX_ OP *o)
6320 {
6321     dVAR;
6322
6323     PERL_ARGS_ASSERT_CK_SPAIR;
6324
6325     if (o->op_flags & OPf_KIDS) {
6326         OP* newop;
6327         OP* kid;
6328         const OPCODE type = o->op_type;
6329         o = modkids(ck_fun(o), type);
6330         kid = cUNOPo->op_first;
6331         newop = kUNOP->op_first->op_sibling;
6332         if (newop) {
6333             const OPCODE type = newop->op_type;
6334             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6335                     type == OP_PADAV || type == OP_PADHV ||
6336                     type == OP_RV2AV || type == OP_RV2HV)
6337                 return o;
6338         }
6339 #ifdef PERL_MAD
6340         op_getmad(kUNOP->op_first,newop,'K');
6341 #else
6342         op_free(kUNOP->op_first);
6343 #endif
6344         kUNOP->op_first = newop;
6345     }
6346     o->op_ppaddr = PL_ppaddr[++o->op_type];
6347     return ck_fun(o);
6348 }
6349
6350 OP *
6351 Perl_ck_delete(pTHX_ OP *o)
6352 {
6353     PERL_ARGS_ASSERT_CK_DELETE;
6354
6355     o = ck_fun(o);
6356     o->op_private = 0;
6357     if (o->op_flags & OPf_KIDS) {
6358         OP * const kid = cUNOPo->op_first;
6359         switch (kid->op_type) {
6360         case OP_ASLICE:
6361             o->op_flags |= OPf_SPECIAL;
6362             /* FALL THROUGH */
6363         case OP_HSLICE:
6364             o->op_private |= OPpSLICE;
6365             break;
6366         case OP_AELEM:
6367             o->op_flags |= OPf_SPECIAL;
6368             /* FALL THROUGH */
6369         case OP_HELEM:
6370             break;
6371         default:
6372             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6373                   OP_DESC(o));
6374         }
6375         op_null(kid);
6376     }
6377     return o;
6378 }
6379
6380 OP *
6381 Perl_ck_die(pTHX_ OP *o)
6382 {
6383     PERL_ARGS_ASSERT_CK_DIE;
6384
6385 #ifdef VMS
6386     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6387 #endif
6388     return ck_fun(o);
6389 }
6390
6391 OP *
6392 Perl_ck_eof(pTHX_ OP *o)
6393 {
6394     dVAR;
6395
6396     PERL_ARGS_ASSERT_CK_EOF;
6397
6398     if (o->op_flags & OPf_KIDS) {
6399         if (cLISTOPo->op_first->op_type == OP_STUB) {
6400             OP * const newop
6401                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6402 #ifdef PERL_MAD
6403             op_getmad(o,newop,'O');
6404 #else
6405             op_free(o);
6406 #endif
6407             o = newop;
6408         }
6409         return ck_fun(o);
6410     }
6411     return o;
6412 }
6413
6414 OP *
6415 Perl_ck_eval(pTHX_ OP *o)
6416 {
6417     dVAR;
6418
6419     PERL_ARGS_ASSERT_CK_EVAL;
6420
6421     PL_hints |= HINT_BLOCK_SCOPE;
6422     if (o->op_flags & OPf_KIDS) {
6423         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6424
6425         if (!kid) {
6426             o->op_flags &= ~OPf_KIDS;
6427             op_null(o);
6428         }
6429         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6430             LOGOP *enter;
6431 #ifdef PERL_MAD
6432             OP* const oldo = o;
6433 #endif
6434
6435             cUNOPo->op_first = 0;
6436 #ifndef PERL_MAD
6437             op_free(o);
6438 #endif
6439
6440             NewOp(1101, enter, 1, LOGOP);
6441             enter->op_type = OP_ENTERTRY;
6442             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6443             enter->op_private = 0;
6444
6445             /* establish postfix order */
6446             enter->op_next = (OP*)enter;
6447
6448             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6449             o->op_type = OP_LEAVETRY;
6450             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6451             enter->op_other = o;
6452             op_getmad(oldo,o,'O');
6453             return o;
6454         }
6455         else {
6456             scalar((OP*)kid);
6457             PL_cv_has_eval = 1;
6458         }
6459     }
6460     else {
6461 #ifdef PERL_MAD
6462         OP* const oldo = o;
6463 #else
6464         op_free(o);
6465 #endif
6466         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6467         op_getmad(oldo,o,'O');
6468     }
6469     o->op_targ = (PADOFFSET)PL_hints;
6470     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6471         /* Store a copy of %^H that pp_entereval can pick up.
6472            OPf_SPECIAL flags the opcode as being for this purpose,
6473            so that it in turn will return a copy at every
6474            eval.*/
6475         OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6476                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6477         cUNOPo->op_first->op_sibling = hhop;
6478         o->op_private |= OPpEVAL_HAS_HH;
6479     }
6480     return o;
6481 }
6482
6483 OP *
6484 Perl_ck_exit(pTHX_ OP *o)
6485 {
6486     PERL_ARGS_ASSERT_CK_EXIT;
6487
6488 #ifdef VMS
6489     HV * const table = GvHV(PL_hintgv);
6490     if (table) {
6491        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6492        if (svp && *svp && SvTRUE(*svp))
6493            o->op_private |= OPpEXIT_VMSISH;
6494     }
6495     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6496 #endif
6497     return ck_fun(o);
6498 }
6499
6500 OP *
6501 Perl_ck_exec(pTHX_ OP *o)
6502 {
6503     PERL_ARGS_ASSERT_CK_EXEC;
6504
6505     if (o->op_flags & OPf_STACKED) {
6506         OP *kid;
6507         o = ck_fun(o);
6508         kid = cUNOPo->op_first->op_sibling;
6509         if (kid->op_type == OP_RV2GV)
6510             op_null(kid);
6511     }
6512     else
6513         o = listkids(o);
6514     return o;
6515 }
6516
6517 OP *
6518 Perl_ck_exists(pTHX_ OP *o)
6519 {
6520     dVAR;
6521
6522     PERL_ARGS_ASSERT_CK_EXISTS;
6523
6524     o = ck_fun(o);
6525     if (o->op_flags & OPf_KIDS) {
6526         OP * const kid = cUNOPo->op_first;
6527         if (kid->op_type == OP_ENTERSUB) {
6528             (void) ref(kid, o->op_type);
6529             if (kid->op_type != OP_RV2CV
6530                         && !(PL_parser && PL_parser->error_count))
6531                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6532                             OP_DESC(o));
6533             o->op_private |= OPpEXISTS_SUB;
6534         }
6535         else if (kid->op_type == OP_AELEM)
6536             o->op_flags |= OPf_SPECIAL;
6537         else if (kid->op_type != OP_HELEM)
6538             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6539                         OP_DESC(o));
6540         op_null(kid);
6541     }
6542     return o;
6543 }
6544
6545 OP *
6546 Perl_ck_rvconst(pTHX_ register OP *o)
6547 {
6548     dVAR;
6549     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6550
6551     PERL_ARGS_ASSERT_CK_RVCONST;
6552
6553     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6554     if (o->op_type == OP_RV2CV)
6555         o->op_private &= ~1;
6556
6557     if (kid->op_type == OP_CONST) {
6558         int iscv;
6559         GV *gv;
6560         SV * const kidsv = kid->op_sv;
6561
6562         /* Is it a constant from cv_const_sv()? */
6563         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6564             SV * const rsv = SvRV(kidsv);
6565             const svtype type = SvTYPE(rsv);
6566             const char *badtype = NULL;
6567
6568             switch (o->op_type) {
6569             case OP_RV2SV:
6570                 if (type > SVt_PVMG)
6571                     badtype = "a SCALAR";
6572                 break;
6573             case OP_RV2AV:
6574                 if (type != SVt_PVAV)
6575                     badtype = "an ARRAY";
6576                 break;
6577             case OP_RV2HV:
6578                 if (type != SVt_PVHV)
6579                     badtype = "a HASH";
6580                 break;
6581             case OP_RV2CV:
6582                 if (type != SVt_PVCV)
6583                     badtype = "a CODE";
6584                 break;
6585             }
6586             if (badtype)
6587                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6588             return o;
6589         }
6590         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6591                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6592             /* If this is an access to a stash, disable "strict refs", because
6593              * stashes aren't auto-vivified at compile-time (unless we store
6594              * symbols in them), and we don't want to produce a run-time
6595              * stricture error when auto-vivifying the stash. */
6596             const char *s = SvPV_nolen(kidsv);
6597             const STRLEN l = SvCUR(kidsv);
6598             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6599                 o->op_private &= ~HINT_STRICT_REFS;
6600         }
6601         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6602             const char *badthing;
6603             switch (o->op_type) {
6604             case OP_RV2SV:
6605                 badthing = "a SCALAR";
6606                 break;
6607             case OP_RV2AV:
6608                 badthing = "an ARRAY";
6609                 break;
6610             case OP_RV2HV:
6611                 badthing = "a HASH";
6612                 break;
6613             default:
6614                 badthing = NULL;
6615                 break;
6616             }
6617             if (badthing)
6618                 Perl_croak(aTHX_
6619                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6620                            SVfARG(kidsv), badthing);
6621         }
6622         /*
6623          * This is a little tricky.  We only want to add the symbol if we
6624          * didn't add it in the lexer.  Otherwise we get duplicate strict
6625          * warnings.  But if we didn't add it in the lexer, we must at
6626          * least pretend like we wanted to add it even if it existed before,
6627          * or we get possible typo warnings.  OPpCONST_ENTERED says
6628          * whether the lexer already added THIS instance of this symbol.
6629          */
6630         iscv = (o->op_type == OP_RV2CV) * 2;
6631         do {
6632             gv = gv_fetchsv(kidsv,
6633                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6634                 iscv
6635                     ? SVt_PVCV
6636                     : o->op_type == OP_RV2SV
6637                         ? SVt_PV
6638                         : o->op_type == OP_RV2AV
6639                             ? SVt_PVAV
6640                             : o->op_type == OP_RV2HV
6641                                 ? SVt_PVHV
6642                                 : SVt_PVGV);
6643         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6644         if (gv) {
6645             kid->op_type = OP_GV;
6646             SvREFCNT_dec(kid->op_sv);
6647 #ifdef USE_ITHREADS
6648             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6649             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6650             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6651             GvIN_PAD_on(gv);
6652             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6653 #else
6654             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6655 #endif
6656             kid->op_private = 0;
6657             kid->op_ppaddr = PL_ppaddr[OP_GV];
6658         }
6659     }
6660     return o;
6661 }
6662
6663 OP *
6664 Perl_ck_ftst(pTHX_ OP *o)
6665 {
6666     dVAR;
6667     const I32 type = o->op_type;
6668
6669     PERL_ARGS_ASSERT_CK_FTST;
6670
6671     if (o->op_flags & OPf_REF) {
6672         NOOP;
6673     }
6674     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6675         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6676         const OPCODE kidtype = kid->op_type;
6677
6678         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6679             OP * const newop = newGVOP(type, OPf_REF,
6680                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6681 #ifdef PERL_MAD
6682             op_getmad(o,newop,'O');
6683 #else
6684             op_free(o);
6685 #endif
6686             return newop;
6687         }
6688         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6689             o->op_private |= OPpFT_ACCESS;
6690         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6691                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6692             o->op_private |= OPpFT_STACKED;
6693     }
6694     else {
6695 #ifdef PERL_MAD
6696         OP* const oldo = o;
6697 #else
6698         op_free(o);
6699 #endif
6700         if (type == OP_FTTTY)
6701             o = newGVOP(type, OPf_REF, PL_stdingv);
6702         else
6703             o = newUNOP(type, 0, newDEFSVOP());
6704         op_getmad(oldo,o,'O');
6705     }
6706     return o;
6707 }
6708
6709 OP *
6710 Perl_ck_fun(pTHX_ OP *o)
6711 {
6712     dVAR;
6713     const int type = o->op_type;
6714     register I32 oa = PL_opargs[type] >> OASHIFT;
6715
6716     PERL_ARGS_ASSERT_CK_FUN;
6717
6718     if (o->op_flags & OPf_STACKED) {
6719         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6720             oa &= ~OA_OPTIONAL;
6721         else
6722             return no_fh_allowed(o);
6723     }
6724
6725     if (o->op_flags & OPf_KIDS) {
6726         OP **tokid = &cLISTOPo->op_first;
6727         register OP *kid = cLISTOPo->op_first;
6728         OP *sibl;
6729         I32 numargs = 0;
6730
6731         if (kid->op_type == OP_PUSHMARK ||
6732             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6733         {
6734             tokid = &kid->op_sibling;
6735             kid = kid->op_sibling;
6736         }
6737         if (!kid && PL_opargs[type] & OA_DEFGV)
6738             *tokid = kid = newDEFSVOP();
6739
6740         while (oa && kid) {
6741             numargs++;
6742             sibl = kid->op_sibling;
6743 #ifdef PERL_MAD
6744             if (!sibl && kid->op_type == OP_STUB) {
6745                 numargs--;
6746                 break;
6747             }
6748 #endif
6749             switch (oa & 7) {
6750             case OA_SCALAR:
6751                 /* list seen where single (scalar) arg expected? */
6752                 if (numargs == 1 && !(oa >> 4)
6753                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6754                 {
6755                     return too_many_arguments(o,PL_op_desc[type]);
6756                 }
6757                 scalar(kid);
6758                 break;
6759             case OA_LIST:
6760                 if (oa < 16) {
6761                     kid = 0;
6762                     continue;
6763                 }
6764                 else
6765                     list(kid);
6766                 break;
6767             case OA_AVREF:
6768                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6769                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6770                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6771                         "Useless use of %s with no values",
6772                         PL_op_desc[type]);
6773
6774                 if (kid->op_type == OP_CONST &&
6775                     (kid->op_private & OPpCONST_BARE))
6776                 {
6777                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6778                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6779                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6780                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6781                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6782                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6783 #ifdef PERL_MAD
6784                     op_getmad(kid,newop,'K');
6785 #else
6786                     op_free(kid);
6787 #endif
6788                     kid = newop;
6789                     kid->op_sibling = sibl;
6790                     *tokid = kid;
6791                 }
6792                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6793                     bad_type(numargs, "array", PL_op_desc[type], kid);
6794                 mod(kid, type);
6795                 break;
6796             case OA_HVREF:
6797                 if (kid->op_type == OP_CONST &&
6798                     (kid->op_private & OPpCONST_BARE))
6799                 {
6800                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6801                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6802                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6803                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6804                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6805                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6806 #ifdef PERL_MAD
6807                     op_getmad(kid,newop,'K');
6808 #else
6809                     op_free(kid);
6810 #endif
6811                     kid = newop;
6812                     kid->op_sibling = sibl;
6813                     *tokid = kid;
6814                 }
6815                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6816                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6817                 mod(kid, type);
6818                 break;
6819             case OA_CVREF:
6820                 {
6821                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6822                     kid->op_sibling = 0;
6823                     linklist(kid);
6824                     newop->op_next = newop;
6825                     kid = newop;
6826                     kid->op_sibling = sibl;
6827                     *tokid = kid;
6828                 }
6829                 break;
6830             case OA_FILEREF:
6831                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6832                     if (kid->op_type == OP_CONST &&
6833                         (kid->op_private & OPpCONST_BARE))
6834                     {
6835                         OP * const newop = newGVOP(OP_GV, 0,
6836                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6837                         if (!(o->op_private & 1) && /* if not unop */
6838                             kid == cLISTOPo->op_last)
6839                             cLISTOPo->op_last = newop;
6840 #ifdef PERL_MAD
6841                         op_getmad(kid,newop,'K');
6842 #else
6843                         op_free(kid);
6844 #endif
6845                         kid = newop;
6846                     }
6847                     else if (kid->op_type == OP_READLINE) {
6848                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6849                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6850                     }
6851                     else {
6852                         I32 flags = OPf_SPECIAL;
6853                         I32 priv = 0;
6854                         PADOFFSET targ = 0;
6855
6856                         /* is this op a FH constructor? */
6857                         if (is_handle_constructor(o,numargs)) {
6858                             const char *name = NULL;
6859                             STRLEN len = 0;
6860
6861                             flags = 0;
6862                             /* Set a flag to tell rv2gv to vivify
6863                              * need to "prove" flag does not mean something
6864                              * else already - NI-S 1999/05/07
6865                              */
6866                             priv = OPpDEREF;
6867                             if (kid->op_type == OP_PADSV) {
6868                                 SV *const namesv
6869                                     = PAD_COMPNAME_SV(kid->op_targ);
6870                                 name = SvPV_const(namesv, len);
6871                             }
6872                             else if (kid->op_type == OP_RV2SV
6873                                      && kUNOP->op_first->op_type == OP_GV)
6874                             {
6875                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6876                                 name = GvNAME(gv);
6877                                 len = GvNAMELEN(gv);
6878                             }
6879                             else if (kid->op_type == OP_AELEM
6880                                      || kid->op_type == OP_HELEM)
6881                             {
6882                                  OP *firstop;
6883                                  OP *op = ((BINOP*)kid)->op_first;
6884                                  name = NULL;
6885                                  if (op) {
6886                                       SV *tmpstr = NULL;
6887                                       const char * const a =
6888                                            kid->op_type == OP_AELEM ?
6889                                            "[]" : "{}";
6890                                       if (((op->op_type == OP_RV2AV) ||
6891                                            (op->op_type == OP_RV2HV)) &&
6892                                           (firstop = ((UNOP*)op)->op_first) &&
6893                                           (firstop->op_type == OP_GV)) {
6894                                            /* packagevar $a[] or $h{} */
6895                                            GV * const gv = cGVOPx_gv(firstop);
6896                                            if (gv)
6897                                                 tmpstr =
6898                                                      Perl_newSVpvf(aTHX_
6899                                                                    "%s%c...%c",
6900                                                                    GvNAME(gv),
6901                                                                    a[0], a[1]);
6902                                       }
6903                                       else if (op->op_type == OP_PADAV
6904                                                || op->op_type == OP_PADHV) {
6905                                            /* lexicalvar $a[] or $h{} */
6906                                            const char * const padname =
6907                                                 PAD_COMPNAME_PV(op->op_targ);
6908                                            if (padname)
6909                                                 tmpstr =
6910                                                      Perl_newSVpvf(aTHX_
6911                                                                    "%s%c...%c",
6912                                                                    padname + 1,
6913                                                                    a[0], a[1]);
6914                                       }
6915                                       if (tmpstr) {
6916                                            name = SvPV_const(tmpstr, len);
6917                                            sv_2mortal(tmpstr);
6918                                       }
6919                                  }
6920                                  if (!name) {
6921                                       name = "__ANONIO__";
6922                                       len = 10;
6923                                  }
6924                                  mod(kid, type);
6925                             }
6926                             if (name) {
6927                                 SV *namesv;
6928                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6929                                 namesv = PAD_SVl(targ);
6930                                 SvUPGRADE(namesv, SVt_PV);
6931                                 if (*name != '$')
6932                                     sv_setpvn(namesv, "$", 1);
6933                                 sv_catpvn(namesv, name, len);
6934                             }
6935                         }
6936                         kid->op_sibling = 0;
6937                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6938                         kid->op_targ = targ;
6939                         kid->op_private |= priv;
6940                     }
6941                     kid->op_sibling = sibl;
6942                     *tokid = kid;
6943                 }
6944                 scalar(kid);
6945                 break;
6946             case OA_SCALARREF:
6947                 mod(scalar(kid), type);
6948                 break;
6949             }
6950             oa >>= 4;
6951             tokid = &kid->op_sibling;
6952             kid = kid->op_sibling;
6953         }
6954 #ifdef PERL_MAD
6955         if (kid && kid->op_type != OP_STUB)
6956             return too_many_arguments(o,OP_DESC(o));
6957         o->op_private |= numargs;
6958 #else
6959         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6960         o->op_private |= numargs;
6961         if (kid)
6962             return too_many_arguments(o,OP_DESC(o));
6963 #endif
6964         listkids(o);
6965     }
6966     else if (PL_opargs[type] & OA_DEFGV) {
6967 #ifdef PERL_MAD
6968         OP *newop = newUNOP(type, 0, newDEFSVOP());
6969         op_getmad(o,newop,'O');
6970         return newop;
6971 #else
6972         /* Ordering of these two is important to keep f_map.t passing.  */
6973         op_free(o);
6974         return newUNOP(type, 0, newDEFSVOP());
6975 #endif
6976     }
6977
6978     if (oa) {
6979         while (oa & OA_OPTIONAL)
6980             oa >>= 4;
6981         if (oa && oa != OA_LIST)
6982             return too_few_arguments(o,OP_DESC(o));
6983     }
6984     return o;
6985 }
6986
6987 OP *
6988 Perl_ck_glob(pTHX_ OP *o)
6989 {
6990     dVAR;
6991     GV *gv;
6992
6993     PERL_ARGS_ASSERT_CK_GLOB;
6994
6995     o = ck_fun(o);
6996     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6997         append_elem(OP_GLOB, o, newDEFSVOP());
6998
6999     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7000           && GvCVu(gv) && GvIMPORTED_CV(gv)))
7001     {
7002         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7003     }
7004
7005 #if !defined(PERL_EXTERNAL_GLOB)
7006     /* XXX this can be tightened up and made more failsafe. */
7007     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7008         GV *glob_gv;
7009         ENTER;
7010         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7011                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7012         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7013         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7014         GvCV(gv) = GvCV(glob_gv);
7015         SvREFCNT_inc_void((SV*)GvCV(gv));
7016         GvIMPORTED_CV_on(gv);
7017         LEAVE;
7018     }
7019 #endif /* PERL_EXTERNAL_GLOB */
7020
7021     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7022         append_elem(OP_GLOB, o,
7023                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7024         o->op_type = OP_LIST;
7025         o->op_ppaddr = PL_ppaddr[OP_LIST];
7026         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7027         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7028         cLISTOPo->op_first->op_targ = 0;
7029         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7030                     append_elem(OP_LIST, o,
7031                                 scalar(newUNOP(OP_RV2CV, 0,
7032                                                newGVOP(OP_GV, 0, gv)))));
7033         o = newUNOP(OP_NULL, 0, ck_subr(o));
7034         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7035         return o;
7036     }
7037     gv = newGVgen("main");
7038     gv_IOadd(gv);
7039     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7040     scalarkids(o);
7041     return o;
7042 }
7043
7044 OP *
7045 Perl_ck_grep(pTHX_ OP *o)
7046 {
7047     dVAR;
7048     LOGOP *gwop = NULL;
7049     OP *kid;
7050     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7051     PADOFFSET offset;
7052
7053     PERL_ARGS_ASSERT_CK_GREP;
7054
7055     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7056     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7057
7058     if (o->op_flags & OPf_STACKED) {
7059         OP* k;
7060         o = ck_sort(o);
7061         kid = cLISTOPo->op_first->op_sibling;
7062         if (!cUNOPx(kid)->op_next)
7063             Perl_croak(aTHX_ "panic: ck_grep");
7064         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7065             kid = k;
7066         }
7067         NewOp(1101, gwop, 1, LOGOP);
7068         kid->op_next = (OP*)gwop;
7069         o->op_flags &= ~OPf_STACKED;
7070     }
7071     kid = cLISTOPo->op_first->op_sibling;
7072     if (type == OP_MAPWHILE)
7073         list(kid);
7074     else
7075         scalar(kid);
7076     o = ck_fun(o);
7077     if (PL_parser && PL_parser->error_count)
7078         return o;
7079     kid = cLISTOPo->op_first->op_sibling;
7080     if (kid->op_type != OP_NULL)
7081         Perl_croak(aTHX_ "panic: ck_grep");
7082     kid = kUNOP->op_first;
7083
7084     if (!gwop)
7085         NewOp(1101, gwop, 1, LOGOP);
7086     gwop->op_type = type;
7087     gwop->op_ppaddr = PL_ppaddr[type];
7088     gwop->op_first = listkids(o);
7089     gwop->op_flags |= OPf_KIDS;
7090     gwop->op_other = LINKLIST(kid);
7091     kid->op_next = (OP*)gwop;
7092     offset = pad_findmy("$_");
7093     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7094         o->op_private = gwop->op_private = 0;
7095         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7096     }
7097     else {
7098         o->op_private = gwop->op_private = OPpGREP_LEX;
7099         gwop->op_targ = o->op_targ = offset;
7100     }
7101
7102     kid = cLISTOPo->op_first->op_sibling;
7103     if (!kid || !kid->op_sibling)
7104         return too_few_arguments(o,OP_DESC(o));
7105     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7106         mod(kid, OP_GREPSTART);
7107
7108     return (OP*)gwop;
7109 }
7110
7111 OP *
7112 Perl_ck_index(pTHX_ OP *o)
7113 {
7114     PERL_ARGS_ASSERT_CK_INDEX;
7115
7116     if (o->op_flags & OPf_KIDS) {
7117         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7118         if (kid)
7119             kid = kid->op_sibling;                      /* get past "big" */
7120         if (kid && kid->op_type == OP_CONST)
7121             fbm_compile(((SVOP*)kid)->op_sv, 0);
7122     }
7123     return ck_fun(o);
7124 }
7125
7126 OP *
7127 Perl_ck_lfun(pTHX_ OP *o)
7128 {
7129     const OPCODE type = o->op_type;
7130
7131     PERL_ARGS_ASSERT_CK_LFUN;
7132
7133     return modkids(ck_fun(o), type);
7134 }
7135
7136 OP *
7137 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7138 {
7139     PERL_ARGS_ASSERT_CK_DEFINED;
7140
7141     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7142         switch (cUNOPo->op_first->op_type) {
7143         case OP_RV2AV:
7144             /* This is needed for
7145                if (defined %stash::)
7146                to work.   Do not break Tk.
7147                */
7148             break;                      /* Globals via GV can be undef */
7149         case OP_PADAV:
7150         case OP_AASSIGN:                /* Is this a good idea? */
7151             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7152                         "defined(@array) is deprecated");
7153             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7154                         "\t(Maybe you should just omit the defined()?)\n");
7155         break;
7156         case OP_RV2HV:
7157             /* This is needed for
7158                if (defined %stash::)
7159                to work.   Do not break Tk.
7160                */
7161             break;                      /* Globals via GV can be undef */
7162         case OP_PADHV:
7163             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7164                         "defined(%%hash) is deprecated");
7165             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7166                         "\t(Maybe you should just omit the defined()?)\n");
7167             break;
7168         default:
7169             /* no warning */
7170             break;
7171         }
7172     }
7173     return ck_rfun(o);
7174 }
7175
7176 OP *
7177 Perl_ck_readline(pTHX_ OP *o)
7178 {
7179     PERL_ARGS_ASSERT_CK_READLINE;
7180
7181     if (!(o->op_flags & OPf_KIDS)) {
7182         OP * const newop
7183             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7184 #ifdef PERL_MAD
7185         op_getmad(o,newop,'O');
7186 #else
7187         op_free(o);
7188 #endif
7189         return newop;
7190     }
7191     return o;
7192 }
7193
7194 OP *
7195 Perl_ck_rfun(pTHX_ OP *o)
7196 {
7197     const OPCODE type = o->op_type;
7198
7199     PERL_ARGS_ASSERT_CK_RFUN;
7200
7201     return refkids(ck_fun(o), type);
7202 }
7203
7204 OP *
7205 Perl_ck_listiob(pTHX_ OP *o)
7206 {
7207     register OP *kid;
7208
7209     PERL_ARGS_ASSERT_CK_LISTIOB;
7210
7211     kid = cLISTOPo->op_first;
7212     if (!kid) {
7213         o = force_list(o);
7214         kid = cLISTOPo->op_first;
7215     }
7216     if (kid->op_type == OP_PUSHMARK)
7217         kid = kid->op_sibling;
7218     if (kid && o->op_flags & OPf_STACKED)
7219         kid = kid->op_sibling;
7220     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7221         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7222             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7223             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7224             cLISTOPo->op_first->op_sibling = kid;
7225             cLISTOPo->op_last = kid;
7226             kid = kid->op_sibling;
7227         }
7228     }
7229
7230     if (!kid)
7231         append_elem(o->op_type, o, newDEFSVOP());
7232
7233     return listkids(o);
7234 }
7235
7236 OP *
7237 Perl_ck_smartmatch(pTHX_ OP *o)
7238 {
7239     dVAR;
7240     if (0 == (o->op_flags & OPf_SPECIAL)) {
7241         OP *first  = cBINOPo->op_first;
7242         OP *second = first->op_sibling;
7243
7244         /* Implicitly take a reference to an array or hash */
7245         first->op_sibling = NULL;
7246         first = cBINOPo->op_first = ref_array_or_hash(first);
7247         second = first->op_sibling = ref_array_or_hash(second);
7248
7249         /* Implicitly take a reference to a regular expression */
7250         if (first->op_type == OP_MATCH) {
7251             first->op_type = OP_QR;
7252             first->op_ppaddr = PL_ppaddr[OP_QR];
7253         }
7254         if (second->op_type == OP_MATCH) {
7255             second->op_type = OP_QR;
7256             second->op_ppaddr = PL_ppaddr[OP_QR];
7257         }
7258     }
7259
7260     return o;
7261 }
7262
7263
7264 OP *
7265 Perl_ck_sassign(pTHX_ OP *o)
7266 {
7267     dVAR;
7268     OP * const kid = cLISTOPo->op_first;
7269
7270     PERL_ARGS_ASSERT_CK_SASSIGN;
7271
7272     /* has a disposable target? */
7273     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7274         && !(kid->op_flags & OPf_STACKED)
7275         /* Cannot steal the second time! */
7276         && !(kid->op_private & OPpTARGET_MY)
7277         /* Keep the full thing for madskills */
7278         && !PL_madskills
7279         )
7280     {
7281         OP * const kkid = kid->op_sibling;
7282
7283         /* Can just relocate the target. */
7284         if (kkid && kkid->op_type == OP_PADSV
7285             && !(kkid->op_private & OPpLVAL_INTRO))
7286         {
7287             kid->op_targ = kkid->op_targ;
7288             kkid->op_targ = 0;
7289             /* Now we do not need PADSV and SASSIGN. */
7290             kid->op_sibling = o->op_sibling;    /* NULL */
7291             cLISTOPo->op_first = NULL;
7292             op_free(o);
7293             op_free(kkid);
7294             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7295             return kid;
7296         }
7297     }
7298     if (kid->op_sibling) {
7299         OP *kkid = kid->op_sibling;
7300         if (kkid->op_type == OP_PADSV
7301                 && (kkid->op_private & OPpLVAL_INTRO)
7302                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7303             const PADOFFSET target = kkid->op_targ;
7304             OP *const other = newOP(OP_PADSV,
7305                                     kkid->op_flags
7306                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7307             OP *const first = newOP(OP_NULL, 0);
7308             OP *const nullop = newCONDOP(0, first, o, other);
7309             OP *const condop = first->op_next;
7310             /* hijacking PADSTALE for uninitialized state variables */
7311             SvPADSTALE_on(PAD_SVl(target));
7312
7313             condop->op_type = OP_ONCE;
7314             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7315             condop->op_targ = target;
7316             other->op_targ = target;
7317
7318             /* Because we change the type of the op here, we will skip the
7319                assinment binop->op_last = binop->op_first->op_sibling; at the
7320                end of Perl_newBINOP(). So need to do it here. */
7321             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7322
7323             return nullop;
7324         }
7325     }
7326     return o;
7327 }
7328
7329 OP *
7330 Perl_ck_match(pTHX_ OP *o)
7331 {
7332     dVAR;
7333
7334     PERL_ARGS_ASSERT_CK_MATCH;
7335
7336     if (o->op_type != OP_QR && PL_compcv) {
7337         const PADOFFSET offset = pad_findmy("$_");
7338         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7339             o->op_targ = offset;
7340             o->op_private |= OPpTARGET_MY;
7341         }
7342     }
7343     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7344         o->op_private |= OPpRUNTIME;
7345     return o;
7346 }
7347
7348 OP *
7349 Perl_ck_method(pTHX_ OP *o)
7350 {
7351     OP * const kid = cUNOPo->op_first;
7352
7353     PERL_ARGS_ASSERT_CK_METHOD;
7354
7355     if (kid->op_type == OP_CONST) {
7356         SV* sv = kSVOP->op_sv;
7357         const char * const method = SvPVX_const(sv);
7358         if (!(strchr(method, ':') || strchr(method, '\''))) {
7359             OP *cmop;
7360             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7361                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7362             }
7363             else {
7364                 kSVOP->op_sv = NULL;
7365             }
7366             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7367 #ifdef PERL_MAD
7368             op_getmad(o,cmop,'O');
7369 #else
7370             op_free(o);
7371 #endif
7372             return cmop;
7373         }
7374     }
7375     return o;
7376 }
7377
7378 OP *
7379 Perl_ck_null(pTHX_ OP *o)
7380 {
7381     PERL_ARGS_ASSERT_CK_NULL;
7382     PERL_UNUSED_CONTEXT;
7383     return o;
7384 }
7385
7386 OP *
7387 Perl_ck_open(pTHX_ OP *o)
7388 {
7389     dVAR;
7390     HV * const table = GvHV(PL_hintgv);
7391
7392     PERL_ARGS_ASSERT_CK_OPEN;
7393
7394     if (table) {
7395         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7396         if (svp && *svp) {
7397             const I32 mode = mode_from_discipline(*svp);
7398             if (mode & O_BINARY)
7399                 o->op_private |= OPpOPEN_IN_RAW;
7400             else if (mode & O_TEXT)
7401                 o->op_private |= OPpOPEN_IN_CRLF;
7402         }
7403
7404         svp = hv_fetchs(table, "open_OUT", FALSE);
7405         if (svp && *svp) {
7406             const I32 mode = mode_from_discipline(*svp);
7407             if (mode & O_BINARY)
7408                 o->op_private |= OPpOPEN_OUT_RAW;
7409             else if (mode & O_TEXT)
7410                 o->op_private |= OPpOPEN_OUT_CRLF;
7411         }
7412     }
7413     if (o->op_type == OP_BACKTICK) {
7414         if (!(o->op_flags & OPf_KIDS)) {
7415             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7416 #ifdef PERL_MAD
7417             op_getmad(o,newop,'O');
7418 #else
7419             op_free(o);
7420 #endif
7421             return newop;
7422         }
7423         return o;
7424     }
7425     {
7426          /* In case of three-arg dup open remove strictness
7427           * from the last arg if it is a bareword. */
7428          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7429          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7430          OP *oa;
7431          const char *mode;
7432
7433          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7434              (last->op_private & OPpCONST_BARE) &&
7435              (last->op_private & OPpCONST_STRICT) &&
7436              (oa = first->op_sibling) &&                /* The fh. */
7437              (oa = oa->op_sibling) &&                   /* The mode. */
7438              (oa->op_type == OP_CONST) &&
7439              SvPOK(((SVOP*)oa)->op_sv) &&
7440              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7441              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7442              (last == oa->op_sibling))                  /* The bareword. */
7443               last->op_private &= ~OPpCONST_STRICT;
7444     }
7445     return ck_fun(o);
7446 }
7447
7448 OP *
7449 Perl_ck_repeat(pTHX_ OP *o)
7450 {
7451     PERL_ARGS_ASSERT_CK_REPEAT;
7452
7453     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7454         o->op_private |= OPpREPEAT_DOLIST;
7455         cBINOPo->op_first = force_list(cBINOPo->op_first);
7456     }
7457     else
7458         scalar(o);
7459     return o;
7460 }
7461
7462 OP *
7463 Perl_ck_require(pTHX_ OP *o)
7464 {
7465     dVAR;
7466     GV* gv = NULL;
7467
7468     PERL_ARGS_ASSERT_CK_REQUIRE;
7469
7470     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7471         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7472
7473         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7474             SV * const sv = kid->op_sv;
7475             U32 was_readonly = SvREADONLY(sv);
7476             char *s;
7477             STRLEN len;
7478             const char *end;
7479
7480             if (was_readonly) {
7481                 if (SvFAKE(sv)) {
7482                     sv_force_normal_flags(sv, 0);
7483                     assert(!SvREADONLY(sv));
7484                     was_readonly = 0;
7485                 } else {
7486                     SvREADONLY_off(sv);
7487                 }
7488             }
7489
7490             s = SvPVX(sv);
7491             len = SvCUR(sv);
7492             end = s + len;
7493             for (; s < end; s++) {
7494                 if (*s == ':' && s[1] == ':') {
7495                     *s = '/';
7496                     Move(s+2, s+1, end - s - 1, char);
7497                     --end;
7498                 }
7499             }
7500             SvEND_set(sv, end);
7501             sv_catpvs(sv, ".pm");
7502             SvFLAGS(sv) |= was_readonly;
7503         }
7504     }
7505
7506     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7507         /* handle override, if any */
7508         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7509         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7510             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7511             gv = gvp ? *gvp : NULL;
7512         }
7513     }
7514
7515     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7516         OP * const kid = cUNOPo->op_first;
7517         OP * newop;
7518
7519         cUNOPo->op_first = 0;
7520 #ifndef PERL_MAD
7521         op_free(o);
7522 #endif
7523         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7524                                 append_elem(OP_LIST, kid,
7525                                             scalar(newUNOP(OP_RV2CV, 0,
7526                                                            newGVOP(OP_GV, 0,
7527                                                                    gv))))));
7528         op_getmad(o,newop,'O');
7529         return newop;
7530     }
7531
7532     return ck_fun(o);
7533 }
7534
7535 OP *
7536 Perl_ck_return(pTHX_ OP *o)
7537 {
7538     dVAR;
7539
7540     PERL_ARGS_ASSERT_CK_RETURN;
7541
7542     if (CvLVALUE(PL_compcv)) {
7543         OP *kid;
7544         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7545             mod(kid, OP_LEAVESUBLV);
7546     }
7547     return o;
7548 }
7549
7550 OP *
7551 Perl_ck_select(pTHX_ OP *o)
7552 {
7553     dVAR;
7554     OP* kid;
7555
7556     PERL_ARGS_ASSERT_CK_SELECT;
7557
7558     if (o->op_flags & OPf_KIDS) {
7559         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7560         if (kid && kid->op_sibling) {
7561             o->op_type = OP_SSELECT;
7562             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7563             o = ck_fun(o);
7564             return fold_constants(o);
7565         }
7566     }
7567     o = ck_fun(o);
7568     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7569     if (kid && kid->op_type == OP_RV2GV)
7570         kid->op_private &= ~HINT_STRICT_REFS;
7571     return o;
7572 }
7573
7574 OP *
7575 Perl_ck_shift(pTHX_ OP *o)
7576 {
7577     dVAR;
7578     const I32 type = o->op_type;
7579
7580     PERL_ARGS_ASSERT_CK_SHIFT;
7581
7582     if (!(o->op_flags & OPf_KIDS)) {
7583         OP *argop;
7584         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7585 #ifdef PERL_MAD
7586         OP * const oldo = o;
7587 #else
7588         op_free(o);
7589 #endif
7590         argop = newUNOP(OP_RV2AV, 0,
7591             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7592 #ifdef PERL_MAD
7593         o = newUNOP(type, 0, scalar(argop));
7594         op_getmad(oldo,o,'O');
7595         return o;
7596 #else
7597         return newUNOP(type, 0, scalar(argop));
7598 #endif
7599     }
7600     return scalar(modkids(ck_fun(o), type));
7601 }
7602
7603 OP *
7604 Perl_ck_sort(pTHX_ OP *o)
7605 {
7606     dVAR;
7607     OP *firstkid;
7608
7609     PERL_ARGS_ASSERT_CK_SORT;
7610
7611     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7612         HV * const hinthv = GvHV(PL_hintgv);
7613         if (hinthv) {
7614             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7615             if (svp) {
7616                 const I32 sorthints = (I32)SvIV(*svp);
7617                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7618                     o->op_private |= OPpSORT_QSORT;
7619                 if ((sorthints & HINT_SORT_STABLE) != 0)
7620                     o->op_private |= OPpSORT_STABLE;
7621             }
7622         }
7623     }
7624
7625     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7626         simplify_sort(o);
7627     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7628     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7629         OP *k = NULL;
7630         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7631
7632         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7633             linklist(kid);
7634             if (kid->op_type == OP_SCOPE) {
7635                 k = kid->op_next;
7636                 kid->op_next = 0;
7637             }
7638             else if (kid->op_type == OP_LEAVE) {
7639                 if (o->op_type == OP_SORT) {
7640                     op_null(kid);                       /* wipe out leave */
7641                     kid->op_next = kid;
7642
7643                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7644                         if (k->op_next == kid)
7645                             k->op_next = 0;
7646                         /* don't descend into loops */
7647                         else if (k->op_type == OP_ENTERLOOP
7648                                  || k->op_type == OP_ENTERITER)
7649                         {
7650                             k = cLOOPx(k)->op_lastop;
7651                         }
7652                     }
7653                 }
7654                 else
7655                     kid->op_next = 0;           /* just disconnect the leave */
7656                 k = kLISTOP->op_first;
7657             }
7658             CALL_PEEP(k);
7659
7660             kid = firstkid;
7661             if (o->op_type == OP_SORT) {
7662                 /* provide scalar context for comparison function/block */
7663                 kid = scalar(kid);
7664                 kid->op_next = kid;
7665             }
7666             else
7667                 kid->op_next = k;
7668             o->op_flags |= OPf_SPECIAL;
7669         }
7670         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7671             op_null(firstkid);
7672
7673         firstkid = firstkid->op_sibling;
7674     }
7675
7676     /* provide list context for arguments */
7677     if (o->op_type == OP_SORT)
7678         list(firstkid);
7679
7680     return o;
7681 }
7682
7683 STATIC void
7684 S_simplify_sort(pTHX_ OP *o)
7685 {
7686     dVAR;
7687     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7688     OP *k;
7689     int descending;
7690     GV *gv;
7691     const char *gvname;
7692
7693     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7694
7695     if (!(o->op_flags & OPf_STACKED))
7696         return;
7697     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7698     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7699     kid = kUNOP->op_first;                              /* get past null */
7700     if (kid->op_type != OP_SCOPE)
7701         return;
7702     kid = kLISTOP->op_last;                             /* get past scope */
7703     switch(kid->op_type) {
7704         case OP_NCMP:
7705         case OP_I_NCMP:
7706         case OP_SCMP:
7707             break;
7708         default:
7709             return;
7710     }
7711     k = kid;                                            /* remember this node*/
7712     if (kBINOP->op_first->op_type != OP_RV2SV)
7713         return;
7714     kid = kBINOP->op_first;                             /* get past cmp */
7715     if (kUNOP->op_first->op_type != OP_GV)
7716         return;
7717     kid = kUNOP->op_first;                              /* get past rv2sv */
7718     gv = kGVOP_gv;
7719     if (GvSTASH(gv) != PL_curstash)
7720         return;
7721     gvname = GvNAME(gv);
7722     if (*gvname == 'a' && gvname[1] == '\0')
7723         descending = 0;
7724     else if (*gvname == 'b' && gvname[1] == '\0')
7725         descending = 1;
7726     else
7727         return;
7728
7729     kid = k;                                            /* back to cmp */
7730     if (kBINOP->op_last->op_type != OP_RV2SV)
7731         return;
7732     kid = kBINOP->op_last;                              /* down to 2nd arg */
7733     if (kUNOP->op_first->op_type != OP_GV)
7734         return;
7735     kid = kUNOP->op_first;                              /* get past rv2sv */
7736     gv = kGVOP_gv;
7737     if (GvSTASH(gv) != PL_curstash)
7738         return;
7739     gvname = GvNAME(gv);
7740     if ( descending
7741          ? !(*gvname == 'a' && gvname[1] == '\0')
7742          : !(*gvname == 'b' && gvname[1] == '\0'))
7743         return;
7744     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7745     if (descending)
7746         o->op_private |= OPpSORT_DESCEND;
7747     if (k->op_type == OP_NCMP)
7748         o->op_private |= OPpSORT_NUMERIC;
7749     if (k->op_type == OP_I_NCMP)
7750         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7751     kid = cLISTOPo->op_first->op_sibling;
7752     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7753 #ifdef PERL_MAD
7754     op_getmad(kid,o,'S');                             /* then delete it */
7755 #else
7756     op_free(kid);                                     /* then delete it */
7757 #endif
7758 }
7759
7760 OP *
7761 Perl_ck_split(pTHX_ OP *o)
7762 {
7763     dVAR;
7764     register OP *kid;
7765
7766     PERL_ARGS_ASSERT_CK_SPLIT;
7767
7768     if (o->op_flags & OPf_STACKED)
7769         return no_fh_allowed(o);
7770
7771     kid = cLISTOPo->op_first;
7772     if (kid->op_type != OP_NULL)
7773         Perl_croak(aTHX_ "panic: ck_split");
7774     kid = kid->op_sibling;
7775     op_free(cLISTOPo->op_first);
7776     cLISTOPo->op_first = kid;
7777     if (!kid) {
7778         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7779         cLISTOPo->op_last = kid; /* There was only one element previously */
7780     }
7781
7782     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7783         OP * const sibl = kid->op_sibling;
7784         kid->op_sibling = 0;
7785         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7786         if (cLISTOPo->op_first == cLISTOPo->op_last)
7787             cLISTOPo->op_last = kid;
7788         cLISTOPo->op_first = kid;
7789         kid->op_sibling = sibl;
7790     }
7791
7792     kid->op_type = OP_PUSHRE;
7793     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7794     scalar(kid);
7795     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7796       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7797                   "Use of /g modifier is meaningless in split");
7798     }
7799
7800     if (!kid->op_sibling)
7801         append_elem(OP_SPLIT, o, newDEFSVOP());
7802
7803     kid = kid->op_sibling;
7804     scalar(kid);
7805
7806     if (!kid->op_sibling)
7807         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7808     assert(kid->op_sibling);
7809
7810     kid = kid->op_sibling;
7811     scalar(kid);
7812
7813     if (kid->op_sibling)
7814         return too_many_arguments(o,OP_DESC(o));
7815
7816     return o;
7817 }
7818
7819 OP *
7820 Perl_ck_join(pTHX_ OP *o)
7821 {
7822     const OP * const kid = cLISTOPo->op_first->op_sibling;
7823
7824     PERL_ARGS_ASSERT_CK_JOIN;
7825
7826     if (kid && kid->op_type == OP_MATCH) {
7827         if (ckWARN(WARN_SYNTAX)) {
7828             const REGEXP *re = PM_GETRE(kPMOP);
7829             const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7830             const STRLEN len = re ? RX_PRELEN(re) : 6;
7831             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7832                         "/%.*s/ should probably be written as \"%.*s\"",
7833                         (int)len, pmstr, (int)len, pmstr);
7834         }
7835     }
7836     return ck_fun(o);
7837 }
7838
7839 OP *
7840 Perl_ck_subr(pTHX_ OP *o)
7841 {
7842     dVAR;
7843     OP *prev = ((cUNOPo->op_first->op_sibling)
7844              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7845     OP *o2 = prev->op_sibling;
7846     OP *cvop;
7847     const char *proto = NULL;
7848     const char *proto_end = NULL;
7849     CV *cv = NULL;
7850     GV *namegv = NULL;
7851     int optional = 0;
7852     I32 arg = 0;
7853     I32 contextclass = 0;
7854     const char *e = NULL;
7855     bool delete_op = 0;
7856
7857     PERL_ARGS_ASSERT_CK_SUBR;
7858
7859     o->op_private |= OPpENTERSUB_HASTARG;
7860     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7861     if (cvop->op_type == OP_RV2CV) {
7862         SVOP* tmpop;
7863         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7864         op_null(cvop);          /* disable rv2cv */
7865         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7866         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7867             GV *gv = cGVOPx_gv(tmpop);
7868             cv = GvCVu(gv);
7869             if (!cv)
7870                 tmpop->op_private |= OPpEARLY_CV;
7871             else {
7872                 if (SvPOK(cv)) {
7873                     STRLEN len;
7874                     namegv = CvANON(cv) ? gv : CvGV(cv);
7875                     proto = SvPV((SV*)cv, len);
7876                     proto_end = proto + len;
7877                 }
7878             }
7879         }
7880     }
7881     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7882         if (o2->op_type == OP_CONST)
7883             o2->op_private &= ~OPpCONST_STRICT;
7884         else if (o2->op_type == OP_LIST) {
7885             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7886             if (sib && sib->op_type == OP_CONST)
7887                 sib->op_private &= ~OPpCONST_STRICT;
7888         }
7889     }
7890     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7891     if (PERLDB_SUB && PL_curstash != PL_debstash)
7892         o->op_private |= OPpENTERSUB_DB;
7893     while (o2 != cvop) {
7894         OP* o3;
7895         if (PL_madskills && o2->op_type == OP_STUB) {
7896             o2 = o2->op_sibling;
7897             continue;
7898         }
7899         if (PL_madskills && o2->op_type == OP_NULL)
7900             o3 = ((UNOP*)o2)->op_first;
7901         else
7902             o3 = o2;
7903         if (proto) {
7904             if (proto >= proto_end)
7905                 return too_many_arguments(o, gv_ename(namegv));
7906
7907             switch (*proto) {
7908             case ';':
7909                 optional = 1;
7910                 proto++;
7911                 continue;
7912             case '_':
7913                 /* _ must be at the end */
7914                 if (proto[1] && proto[1] != ';')
7915                     goto oops;
7916             case '$':
7917                 proto++;
7918                 arg++;
7919                 scalar(o2);
7920                 break;
7921             case '%':
7922             case '@':
7923                 list(o2);
7924                 arg++;
7925                 break;
7926             case '&':
7927                 proto++;
7928                 arg++;
7929                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7930                     bad_type(arg,
7931                         arg == 1 ? "block or sub {}" : "sub {}",
7932                         gv_ename(namegv), o3);
7933                 break;
7934             case '*':
7935                 /* '*' allows any scalar type, including bareword */
7936                 proto++;
7937                 arg++;
7938                 if (o3->op_type == OP_RV2GV)
7939                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7940                 else if (o3->op_type == OP_CONST)
7941                     o3->op_private &= ~OPpCONST_STRICT;
7942                 else if (o3->op_type == OP_ENTERSUB) {
7943                     /* accidental subroutine, revert to bareword */
7944                     OP *gvop = ((UNOP*)o3)->op_first;
7945                     if (gvop && gvop->op_type == OP_NULL) {
7946                         gvop = ((UNOP*)gvop)->op_first;
7947                         if (gvop) {
7948                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7949                                 ;
7950                             if (gvop &&
7951                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7952                                 (gvop = ((UNOP*)gvop)->op_first) &&
7953                                 gvop->op_type == OP_GV)
7954                             {
7955                                 GV * const gv = cGVOPx_gv(gvop);
7956                                 OP * const sibling = o2->op_sibling;
7957                                 SV * const n = newSVpvs("");
7958 #ifdef PERL_MAD
7959                                 OP * const oldo2 = o2;
7960 #else
7961                                 op_free(o2);
7962 #endif
7963                                 gv_fullname4(n, gv, "", FALSE);
7964                                 o2 = newSVOP(OP_CONST, 0, n);
7965                                 op_getmad(oldo2,o2,'O');
7966                                 prev->op_sibling = o2;
7967                                 o2->op_sibling = sibling;
7968                             }
7969                         }
7970                     }
7971                 }
7972                 scalar(o2);
7973                 break;
7974             case '[': case ']':
7975                  goto oops;
7976                  break;
7977             case '\\':
7978                 proto++;
7979                 arg++;
7980             again:
7981                 switch (*proto++) {
7982                 case '[':
7983                      if (contextclass++ == 0) {
7984                           e = strchr(proto, ']');
7985                           if (!e || e == proto)
7986                                goto oops;
7987                      }
7988                      else
7989                           goto oops;
7990                      goto again;
7991                      break;
7992                 case ']':
7993                      if (contextclass) {
7994                          const char *p = proto;
7995                          const char *const end = proto;
7996                          contextclass = 0;
7997                          while (*--p != '[');
7998                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7999                                                  (int)(end - p), p),
8000                                   gv_ename(namegv), o3);
8001                      } else
8002                           goto oops;
8003                      break;
8004                 case '*':
8005                      if (o3->op_type == OP_RV2GV)
8006                           goto wrapref;
8007                      if (!contextclass)
8008                           bad_type(arg, "symbol", gv_ename(namegv), o3);
8009                      break;
8010                 case '&':
8011                      if (o3->op_type == OP_ENTERSUB)
8012                           goto wrapref;
8013                      if (!contextclass)
8014                           bad_type(arg, "subroutine entry", gv_ename(namegv),
8015                                    o3);
8016                      break;
8017                 case '$':
8018                     if (o3->op_type == OP_RV2SV ||
8019                         o3->op_type == OP_PADSV ||
8020                         o3->op_type == OP_HELEM ||
8021                         o3->op_type == OP_AELEM)
8022                          goto wrapref;
8023                     if (!contextclass)
8024                         bad_type(arg, "scalar", gv_ename(namegv), o3);
8025                      break;
8026                 case '@':
8027                     if (o3->op_type == OP_RV2AV ||
8028                         o3->op_type == OP_PADAV)
8029                          goto wrapref;
8030                     if (!contextclass)
8031                         bad_type(arg, "array", gv_ename(namegv), o3);
8032                     break;
8033                 case '%':
8034                     if (o3->op_type == OP_RV2HV ||
8035                         o3->op_type == OP_PADHV)
8036                          goto wrapref;
8037                     if (!contextclass)
8038                          bad_type(arg, "hash", gv_ename(namegv), o3);
8039                     break;
8040                 wrapref:
8041                     {
8042                         OP* const kid = o2;
8043                         OP* const sib = kid->op_sibling;
8044                         kid->op_sibling = 0;
8045                         o2 = newUNOP(OP_REFGEN, 0, kid);
8046                         o2->op_sibling = sib;
8047                         prev->op_sibling = o2;
8048                     }
8049                     if (contextclass && e) {
8050                          proto = e + 1;
8051                          contextclass = 0;
8052                     }
8053                     break;
8054                 default: goto oops;
8055                 }
8056                 if (contextclass)
8057                      goto again;
8058                 break;
8059             case ' ':
8060                 proto++;
8061                 continue;
8062             default:
8063               oops:
8064                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8065                            gv_ename(namegv), SVfARG(cv));
8066             }
8067         }
8068         else
8069             list(o2);
8070         mod(o2, OP_ENTERSUB);
8071         prev = o2;
8072         o2 = o2->op_sibling;
8073     } /* while */
8074     if (o2 == cvop && proto && *proto == '_') {
8075         /* generate an access to $_ */
8076         o2 = newDEFSVOP();
8077         o2->op_sibling = prev->op_sibling;
8078         prev->op_sibling = o2; /* instead of cvop */
8079     }
8080     if (proto && !optional && proto_end > proto &&
8081         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8082         return too_few_arguments(o, gv_ename(namegv));
8083     if(delete_op) {
8084 #ifdef PERL_MAD
8085         OP * const oldo = o;
8086 #else
8087         op_free(o);
8088 #endif
8089         o=newSVOP(OP_CONST, 0, newSViv(0));
8090         op_getmad(oldo,o,'O');
8091     }
8092     return o;
8093 }
8094
8095 OP *
8096 Perl_ck_svconst(pTHX_ OP *o)
8097 {
8098     PERL_ARGS_ASSERT_CK_SVCONST;
8099     PERL_UNUSED_CONTEXT;
8100     SvREADONLY_on(cSVOPo->op_sv);
8101     return o;
8102 }
8103
8104 OP *
8105 Perl_ck_chdir(pTHX_ OP *o)
8106 {
8107     if (o->op_flags & OPf_KIDS) {
8108         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8109
8110         if (kid && kid->op_type == OP_CONST &&
8111             (kid->op_private & OPpCONST_BARE))
8112         {
8113             o->op_flags |= OPf_SPECIAL;
8114             kid->op_private &= ~OPpCONST_STRICT;
8115         }
8116     }
8117     return ck_fun(o);
8118 }
8119
8120 OP *
8121 Perl_ck_trunc(pTHX_ OP *o)
8122 {
8123     PERL_ARGS_ASSERT_CK_TRUNC;
8124
8125     if (o->op_flags & OPf_KIDS) {
8126         SVOP *kid = (SVOP*)cUNOPo->op_first;
8127
8128         if (kid->op_type == OP_NULL)
8129             kid = (SVOP*)kid->op_sibling;
8130         if (kid && kid->op_type == OP_CONST &&
8131             (kid->op_private & OPpCONST_BARE))
8132         {
8133             o->op_flags |= OPf_SPECIAL;
8134             kid->op_private &= ~OPpCONST_STRICT;
8135         }
8136     }
8137     return ck_fun(o);
8138 }
8139
8140 OP *
8141 Perl_ck_unpack(pTHX_ OP *o)
8142 {
8143     OP *kid = cLISTOPo->op_first;
8144
8145     PERL_ARGS_ASSERT_CK_UNPACK;
8146
8147     if (kid->op_sibling) {
8148         kid = kid->op_sibling;
8149         if (!kid->op_sibling)
8150             kid->op_sibling = newDEFSVOP();
8151     }
8152     return ck_fun(o);
8153 }
8154
8155 OP *
8156 Perl_ck_substr(pTHX_ OP *o)
8157 {
8158     PERL_ARGS_ASSERT_CK_SUBSTR;
8159
8160     o = ck_fun(o);
8161     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8162         OP *kid = cLISTOPo->op_first;
8163
8164         if (kid->op_type == OP_NULL)
8165             kid = kid->op_sibling;
8166         if (kid)
8167             kid->op_flags |= OPf_MOD;
8168
8169     }
8170     return o;
8171 }
8172
8173 OP *
8174 Perl_ck_each(pTHX_ OP *o)
8175 {
8176     dVAR;
8177     OP *kid = cLISTOPo->op_first;
8178
8179     PERL_ARGS_ASSERT_CK_EACH;
8180
8181     if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8182         const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8183             : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8184         o->op_type = new_type;
8185         o->op_ppaddr = PL_ppaddr[new_type];
8186     }
8187     else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8188                || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8189                )) {
8190         bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8191         return o;
8192     }
8193     return ck_fun(o);
8194 }
8195
8196 /* A peephole optimizer.  We visit the ops in the order they're to execute.
8197  * See the comments at the top of this file for more details about when
8198  * peep() is called */
8199
8200 void
8201 Perl_peep(pTHX_ register OP *o)
8202 {
8203     dVAR;
8204     register OP* oldop = NULL;
8205
8206     if (!o || o->op_opt)
8207         return;
8208     ENTER;
8209     SAVEOP();
8210     SAVEVPTR(PL_curcop);
8211     for (; o; o = o->op_next) {
8212         if (o->op_opt)
8213             break;
8214         /* By default, this op has now been optimised. A couple of cases below
8215            clear this again.  */
8216         o->op_opt = 1;
8217         PL_op = o;
8218         switch (o->op_type) {
8219         case OP_NEXTSTATE:
8220         case OP_DBSTATE:
8221             PL_curcop = ((COP*)o);              /* for warnings */
8222             break;
8223
8224         case OP_CONST:
8225             if (cSVOPo->op_private & OPpCONST_STRICT)
8226                 no_bareword_allowed(o);
8227 #ifdef USE_ITHREADS
8228         case OP_METHOD_NAMED:
8229             /* Relocate sv to the pad for thread safety.
8230              * Despite being a "constant", the SV is written to,
8231              * for reference counts, sv_upgrade() etc. */
8232             if (cSVOP->op_sv) {
8233                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8234                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
8235                     /* If op_sv is already a PADTMP then it is being used by
8236                      * some pad, so make a copy. */
8237                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8238                     SvREADONLY_on(PAD_SVl(ix));
8239                     SvREFCNT_dec(cSVOPo->op_sv);
8240                 }
8241                 else if (o->op_type == OP_CONST
8242                          && cSVOPo->op_sv == &PL_sv_undef) {
8243                     /* PL_sv_undef is hack - it's unsafe to store it in the
8244                        AV that is the pad, because av_fetch treats values of
8245                        PL_sv_undef as a "free" AV entry and will merrily
8246                        replace them with a new SV, causing pad_alloc to think
8247                        that this pad slot is free. (When, clearly, it is not)
8248                     */
8249                     SvOK_off(PAD_SVl(ix));
8250                     SvPADTMP_on(PAD_SVl(ix));
8251                     SvREADONLY_on(PAD_SVl(ix));
8252                 }
8253                 else {
8254                     SvREFCNT_dec(PAD_SVl(ix));
8255                     SvPADTMP_on(cSVOPo->op_sv);
8256                     PAD_SETSV(ix, cSVOPo->op_sv);
8257                     /* XXX I don't know how this isn't readonly already. */
8258                     SvREADONLY_on(PAD_SVl(ix));
8259                 }
8260                 cSVOPo->op_sv = NULL;
8261                 o->op_targ = ix;
8262             }
8263 #endif
8264             break;
8265
8266         case OP_CONCAT:
8267             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8268                 if (o->op_next->op_private & OPpTARGET_MY) {
8269                     if (o->op_flags & OPf_STACKED) /* chained concats */
8270                         break; /* ignore_optimization */
8271                     else {
8272                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8273                         o->op_targ = o->op_next->op_targ;
8274                         o->op_next->op_targ = 0;
8275                         o->op_private |= OPpTARGET_MY;
8276                     }
8277                 }
8278                 op_null(o->op_next);
8279             }
8280             break;
8281         case OP_STUB:
8282             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8283                 break; /* Scalar stub must produce undef.  List stub is noop */
8284             }
8285             goto nothin;
8286         case OP_NULL:
8287             if (o->op_targ == OP_NEXTSTATE
8288                 || o->op_targ == OP_DBSTATE)
8289             {
8290                 PL_curcop = ((COP*)o);
8291             }
8292             /* XXX: We avoid setting op_seq here to prevent later calls
8293                to peep() from mistakenly concluding that optimisation
8294                has already occurred. This doesn't fix the real problem,
8295                though (See 20010220.007). AMS 20010719 */
8296             /* op_seq functionality is now replaced by op_opt */
8297             o->op_opt = 0;
8298             /* FALL THROUGH */
8299         case OP_SCALAR:
8300         case OP_LINESEQ:
8301         case OP_SCOPE:
8302         nothin:
8303             if (oldop && o->op_next) {
8304                 oldop->op_next = o->op_next;
8305                 o->op_opt = 0;
8306                 continue;
8307             }
8308             break;
8309
8310         case OP_PADAV:
8311         case OP_GV:
8312             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8313                 OP* const pop = (o->op_type == OP_PADAV) ?
8314                             o->op_next : o->op_next->op_next;
8315                 IV i;
8316                 if (pop && pop->op_type == OP_CONST &&
8317                     ((PL_op = pop->op_next)) &&
8318                     pop->op_next->op_type == OP_AELEM &&
8319                     !(pop->op_next->op_private &
8320                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8321                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8322                                 <= 255 &&
8323                     i >= 0)
8324                 {
8325                     GV *gv;
8326                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8327                         no_bareword_allowed(pop);
8328                     if (o->op_type == OP_GV)
8329                         op_null(o->op_next);
8330                     op_null(pop->op_next);
8331                     op_null(pop);
8332                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8333                     o->op_next = pop->op_next->op_next;
8334                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8335                     o->op_private = (U8)i;
8336                     if (o->op_type == OP_GV) {
8337                         gv = cGVOPo_gv;
8338                         GvAVn(gv);
8339                     }
8340                     else
8341                         o->op_flags |= OPf_SPECIAL;
8342                     o->op_type = OP_AELEMFAST;
8343                 }
8344                 break;
8345             }
8346
8347             if (o->op_next->op_type == OP_RV2SV) {
8348                 if (!(o->op_next->op_private & OPpDEREF)) {
8349                     op_null(o->op_next);
8350                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8351                                                                | OPpOUR_INTRO);
8352                     o->op_next = o->op_next->op_next;
8353                     o->op_type = OP_GVSV;
8354                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8355                 }
8356             }
8357             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8358                 GV * const gv = cGVOPo_gv;
8359                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8360                     /* XXX could check prototype here instead of just carping */
8361                     SV * const sv = sv_newmortal();
8362                     gv_efullname3(sv, gv, NULL);
8363                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8364                                 "%"SVf"() called too early to check prototype",
8365                                 SVfARG(sv));
8366                 }
8367             }
8368             else if (o->op_next->op_type == OP_READLINE
8369                     && o->op_next->op_next->op_type == OP_CONCAT
8370                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8371             {
8372                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8373                 o->op_type   = OP_RCATLINE;
8374                 o->op_flags |= OPf_STACKED;
8375                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8376                 op_null(o->op_next->op_next);
8377                 op_null(o->op_next);
8378             }
8379
8380             break;
8381
8382         case OP_MAPWHILE:
8383         case OP_GREPWHILE:
8384         case OP_AND:
8385         case OP_OR:
8386         case OP_DOR:
8387         case OP_ANDASSIGN:
8388         case OP_ORASSIGN:
8389         case OP_DORASSIGN:
8390         case OP_COND_EXPR:
8391         case OP_RANGE:
8392         case OP_ONCE:
8393             while (cLOGOP->op_other->op_type == OP_NULL)
8394                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8395             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8396             break;
8397
8398         case OP_ENTERLOOP:
8399         case OP_ENTERITER:
8400             while (cLOOP->op_redoop->op_type == OP_NULL)
8401                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8402             peep(cLOOP->op_redoop);
8403             while (cLOOP->op_nextop->op_type == OP_NULL)
8404                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8405             peep(cLOOP->op_nextop);
8406             while (cLOOP->op_lastop->op_type == OP_NULL)
8407                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8408             peep(cLOOP->op_lastop);
8409             break;
8410
8411         case OP_SUBST:
8412             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8413             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8414                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8415                 cPMOP->op_pmstashstartu.op_pmreplstart
8416                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8417             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8418             break;
8419
8420         case OP_EXEC:
8421             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8422                 && ckWARN(WARN_SYNTAX))
8423             {
8424                 if (o->op_next->op_sibling) {
8425                     const OPCODE type = o->op_next->op_sibling->op_type;
8426                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8427                         const line_t oldline = CopLINE(PL_curcop);
8428                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8429                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8430                                     "Statement unlikely to be reached");
8431                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8432                                     "\t(Maybe you meant system() when you said exec()?)\n");
8433                         CopLINE_set(PL_curcop, oldline);
8434                     }
8435                 }
8436             }
8437             break;
8438
8439         case OP_HELEM: {
8440             UNOP *rop;
8441             SV *lexname;
8442             GV **fields;
8443             SV **svp, *sv;
8444             const char *key = NULL;
8445             STRLEN keylen;
8446
8447             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8448                 break;
8449
8450             /* Make the CONST have a shared SV */
8451             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8452             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8453                 key = SvPV_const(sv, keylen);
8454                 lexname = newSVpvn_share(key,
8455                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8456                                          0);
8457                 SvREFCNT_dec(sv);
8458                 *svp = lexname;
8459             }
8460
8461             if ((o->op_private & (OPpLVAL_INTRO)))
8462                 break;
8463
8464             rop = (UNOP*)((BINOP*)o)->op_first;
8465             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8466                 break;
8467             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8468             if (!SvPAD_TYPED(lexname))
8469                 break;
8470             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8471             if (!fields || !GvHV(*fields))
8472                 break;
8473             key = SvPV_const(*svp, keylen);
8474             if (!hv_fetch(GvHV(*fields), key,
8475                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8476             {
8477                 Perl_croak(aTHX_ "No such class field \"%s\" "
8478                            "in variable %s of type %s",
8479                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8480             }
8481
8482             break;
8483         }
8484
8485         case OP_HSLICE: {
8486             UNOP *rop;
8487             SV *lexname;
8488             GV **fields;
8489             SV **svp;
8490             const char *key;
8491             STRLEN keylen;
8492             SVOP *first_key_op, *key_op;
8493
8494             if ((o->op_private & (OPpLVAL_INTRO))
8495                 /* I bet there's always a pushmark... */
8496                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8497                 /* hmmm, no optimization if list contains only one key. */
8498                 break;
8499             rop = (UNOP*)((LISTOP*)o)->op_last;
8500             if (rop->op_type != OP_RV2HV)
8501                 break;
8502             if (rop->op_first->op_type == OP_PADSV)
8503                 /* @$hash{qw(keys here)} */
8504                 rop = (UNOP*)rop->op_first;
8505             else {
8506                 /* @{$hash}{qw(keys here)} */
8507                 if (rop->op_first->op_type == OP_SCOPE
8508                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8509                 {
8510                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8511                 }
8512                 else
8513                     break;
8514             }
8515
8516             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8517             if (!SvPAD_TYPED(lexname))
8518                 break;
8519             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8520             if (!fields || !GvHV(*fields))
8521                 break;
8522             /* Again guessing that the pushmark can be jumped over.... */
8523             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8524                 ->op_first->op_sibling;
8525             for (key_op = first_key_op; key_op;
8526                  key_op = (SVOP*)key_op->op_sibling) {
8527                 if (key_op->op_type != OP_CONST)
8528                     continue;
8529                 svp = cSVOPx_svp(key_op);
8530                 key = SvPV_const(*svp, keylen);
8531                 if (!hv_fetch(GvHV(*fields), key,
8532                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8533                 {
8534                     Perl_croak(aTHX_ "No such class field \"%s\" "
8535                                "in variable %s of type %s",
8536                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8537                 }
8538             }
8539             break;
8540         }
8541
8542         case OP_SORT: {
8543             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8544             OP *oleft;
8545             OP *o2;
8546
8547             /* check that RHS of sort is a single plain array */
8548             OP *oright = cUNOPo->op_first;
8549             if (!oright || oright->op_type != OP_PUSHMARK)
8550                 break;
8551
8552             /* reverse sort ... can be optimised.  */
8553             if (!cUNOPo->op_sibling) {
8554                 /* Nothing follows us on the list. */
8555                 OP * const reverse = o->op_next;
8556
8557                 if (reverse->op_type == OP_REVERSE &&
8558                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8559                     OP * const pushmark = cUNOPx(reverse)->op_first;
8560                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8561                         && (cUNOPx(pushmark)->op_sibling == o)) {
8562                         /* reverse -> pushmark -> sort */
8563                         o->op_private |= OPpSORT_REVERSE;
8564                         op_null(reverse);
8565                         pushmark->op_next = oright->op_next;
8566                         op_null(oright);
8567                     }
8568                 }
8569             }
8570
8571             /* make @a = sort @a act in-place */
8572
8573             oright = cUNOPx(oright)->op_sibling;
8574             if (!oright)
8575                 break;
8576             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8577                 oright = cUNOPx(oright)->op_sibling;
8578             }
8579
8580             if (!oright ||
8581                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8582                 || oright->op_next != o
8583                 || (oright->op_private & OPpLVAL_INTRO)
8584             )
8585                 break;
8586
8587             /* o2 follows the chain of op_nexts through the LHS of the
8588              * assign (if any) to the aassign op itself */
8589             o2 = o->op_next;
8590             if (!o2 || o2->op_type != OP_NULL)
8591                 break;
8592             o2 = o2->op_next;
8593             if (!o2 || o2->op_type != OP_PUSHMARK)
8594                 break;
8595             o2 = o2->op_next;
8596             if (o2 && o2->op_type == OP_GV)
8597                 o2 = o2->op_next;
8598             if (!o2
8599                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8600                 || (o2->op_private & OPpLVAL_INTRO)
8601             )
8602                 break;
8603             oleft = o2;
8604             o2 = o2->op_next;
8605             if (!o2 || o2->op_type != OP_NULL)
8606                 break;
8607             o2 = o2->op_next;
8608             if (!o2 || o2->op_type != OP_AASSIGN
8609                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8610                 break;
8611
8612             /* check that the sort is the first arg on RHS of assign */
8613
8614             o2 = cUNOPx(o2)->op_first;
8615             if (!o2 || o2->op_type != OP_NULL)
8616                 break;
8617             o2 = cUNOPx(o2)->op_first;
8618             if (!o2 || o2->op_type != OP_PUSHMARK)
8619                 break;
8620             if (o2->op_sibling != o)
8621                 break;
8622
8623             /* check the array is the same on both sides */
8624             if (oleft->op_type == OP_RV2AV) {
8625                 if (oright->op_type != OP_RV2AV
8626                     || !cUNOPx(oright)->op_first
8627                     || cUNOPx(oright)->op_first->op_type != OP_GV
8628                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8629                         cGVOPx_gv(cUNOPx(oright)->op_first)
8630                 )
8631                     break;
8632             }
8633             else if (oright->op_type != OP_PADAV
8634                 || oright->op_targ != oleft->op_targ
8635             )
8636                 break;
8637
8638             /* transfer MODishness etc from LHS arg to RHS arg */
8639             oright->op_flags = oleft->op_flags;
8640             o->op_private |= OPpSORT_INPLACE;
8641
8642             /* excise push->gv->rv2av->null->aassign */
8643             o2 = o->op_next->op_next;
8644             op_null(o2); /* PUSHMARK */
8645             o2 = o2->op_next;
8646             if (o2->op_type == OP_GV) {
8647                 op_null(o2); /* GV */
8648                 o2 = o2->op_next;
8649             }
8650             op_null(o2); /* RV2AV or PADAV */
8651             o2 = o2->op_next->op_next;
8652             op_null(o2); /* AASSIGN */
8653
8654             o->op_next = o2->op_next;
8655
8656             break;
8657         }
8658
8659         case OP_REVERSE: {
8660             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8661             OP *gvop = NULL;
8662             LISTOP *enter, *exlist;
8663
8664             enter = (LISTOP *) o->op_next;
8665             if (!enter)
8666                 break;
8667             if (enter->op_type == OP_NULL) {
8668                 enter = (LISTOP *) enter->op_next;
8669                 if (!enter)
8670                     break;
8671             }
8672             /* for $a (...) will have OP_GV then OP_RV2GV here.
8673                for (...) just has an OP_GV.  */
8674             if (enter->op_type == OP_GV) {
8675                 gvop = (OP *) enter;
8676                 enter = (LISTOP *) enter->op_next;
8677                 if (!enter)
8678                     break;
8679                 if (enter->op_type == OP_RV2GV) {
8680                   enter = (LISTOP *) enter->op_next;
8681                   if (!enter)
8682                     break;
8683                 }
8684             }
8685
8686             if (enter->op_type != OP_ENTERITER)
8687                 break;
8688
8689             iter = enter->op_next;
8690             if (!iter || iter->op_type != OP_ITER)
8691                 break;
8692
8693             expushmark = enter->op_first;
8694             if (!expushmark || expushmark->op_type != OP_NULL
8695                 || expushmark->op_targ != OP_PUSHMARK)
8696                 break;
8697
8698             exlist = (LISTOP *) expushmark->op_sibling;
8699             if (!exlist || exlist->op_type != OP_NULL
8700                 || exlist->op_targ != OP_LIST)
8701                 break;
8702
8703             if (exlist->op_last != o) {
8704                 /* Mmm. Was expecting to point back to this op.  */
8705                 break;
8706             }
8707             theirmark = exlist->op_first;
8708             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8709                 break;
8710
8711             if (theirmark->op_sibling != o) {
8712                 /* There's something between the mark and the reverse, eg
8713                    for (1, reverse (...))
8714                    so no go.  */
8715                 break;
8716             }
8717
8718             ourmark = ((LISTOP *)o)->op_first;
8719             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8720                 break;
8721
8722             ourlast = ((LISTOP *)o)->op_last;
8723             if (!ourlast || ourlast->op_next != o)
8724                 break;
8725
8726             rv2av = ourmark->op_sibling;
8727             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8728                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8729                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8730                 /* We're just reversing a single array.  */
8731                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8732                 enter->op_flags |= OPf_STACKED;
8733             }
8734
8735             /* We don't have control over who points to theirmark, so sacrifice
8736                ours.  */
8737             theirmark->op_next = ourmark->op_next;
8738             theirmark->op_flags = ourmark->op_flags;
8739             ourlast->op_next = gvop ? gvop : (OP *) enter;
8740             op_null(ourmark);
8741             op_null(o);
8742             enter->op_private |= OPpITER_REVERSED;
8743             iter->op_private |= OPpITER_REVERSED;
8744
8745             break;
8746         }
8747
8748         case OP_SASSIGN: {
8749             OP *rv2gv;
8750             UNOP *refgen, *rv2cv;
8751             LISTOP *exlist;
8752
8753             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8754                 break;
8755
8756             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8757                 break;
8758
8759             rv2gv = ((BINOP *)o)->op_last;
8760             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8761                 break;
8762
8763             refgen = (UNOP *)((BINOP *)o)->op_first;
8764
8765             if (!refgen || refgen->op_type != OP_REFGEN)
8766                 break;
8767
8768             exlist = (LISTOP *)refgen->op_first;
8769             if (!exlist || exlist->op_type != OP_NULL
8770                 || exlist->op_targ != OP_LIST)
8771                 break;
8772
8773             if (exlist->op_first->op_type != OP_PUSHMARK)
8774                 break;
8775
8776             rv2cv = (UNOP*)exlist->op_last;
8777
8778             if (rv2cv->op_type != OP_RV2CV)
8779                 break;
8780
8781             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8782             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8783             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8784
8785             o->op_private |= OPpASSIGN_CV_TO_GV;
8786             rv2gv->op_private |= OPpDONT_INIT_GV;
8787             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8788
8789             break;
8790         }
8791
8792
8793         case OP_QR:
8794         case OP_MATCH:
8795             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8796                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8797             }
8798             break;
8799         }
8800         oldop = o;
8801     }
8802     LEAVE;
8803 }
8804
8805 const char*
8806 Perl_custom_op_name(pTHX_ const OP* o)
8807 {
8808     dVAR;
8809     const IV index = PTR2IV(o->op_ppaddr);
8810     SV* keysv;
8811     HE* he;
8812
8813     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8814
8815     if (!PL_custom_op_names) /* This probably shouldn't happen */
8816         return (char *)PL_op_name[OP_CUSTOM];
8817
8818     keysv = sv_2mortal(newSViv(index));
8819
8820     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8821     if (!he)
8822         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8823
8824     return SvPV_nolen(HeVAL(he));
8825 }
8826
8827 const char*
8828 Perl_custom_op_desc(pTHX_ const OP* o)
8829 {
8830     dVAR;
8831     const IV index = PTR2IV(o->op_ppaddr);
8832     SV* keysv;
8833     HE* he;
8834
8835     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8836
8837     if (!PL_custom_op_descs)
8838         return (char *)PL_op_desc[OP_CUSTOM];
8839
8840     keysv = sv_2mortal(newSViv(index));
8841
8842     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8843     if (!he)
8844         return (char *)PL_op_desc[OP_CUSTOM];
8845
8846     return SvPV_nolen(HeVAL(he));
8847 }
8848
8849 #include "XSUB.h"
8850
8851 /* Efficient sub that returns a constant scalar value. */
8852 static void
8853 const_sv_xsub(pTHX_ CV* cv)
8854 {
8855     dVAR;
8856     dXSARGS;
8857     if (items != 0) {
8858         NOOP;
8859 #if 0
8860         Perl_croak(aTHX_ "usage: %s::%s()",
8861                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8862 #endif
8863     }
8864     EXTEND(sp, 1);
8865     ST(0) = (SV*)XSANY.any_ptr;
8866     XSRETURN(1);
8867 }
8868
8869 /*
8870  * Local variables:
8871  * c-indentation-style: bsd
8872  * c-basic-offset: 4
8873  * indent-tabs-mode: t
8874  * End:
8875  *
8876  * ex: set ts=8 sts=4 sw=4 noet:
8877  */