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