File Coverage

op.c
Criterion Covered Total %
statement 4357 4499 96.8
branch 3866 4844 79.8
condition n/a
subroutine n/a
total 8223 9343 88.0


line stmt bran cond sub time code
1           #line 2 "op.c"
2           /* op.c
3           *
4           * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5           * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6           *
7           * You may distribute under the terms of either the GNU General Public
8           * License or the Artistic License, as specified in the README file.
9           *
10           */
11            
12           /*
13           * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14           * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15           * youngest of the Old Took's daughters); and Mr. Drogo was his second
16           * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17           * either way, as the saying is, if you follow me.' --the Gaffer
18           *
19           * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20           */
21            
22           /* This file contains the functions that create, manipulate and optimize
23           * the OP structures that hold a compiled perl program.
24           *
25           * A Perl program is compiled into a tree of OPs. Each op contains
26           * structural pointers (eg to its siblings and the next op in the
27           * execution sequence), a pointer to the function that would execute the
28           * op, plus any data specific to that op. For example, an OP_CONST op
29           * points to the pp_const() function and to an SV containing the constant
30           * value. When pp_const() is executed, its job is to push that SV onto the
31           * stack.
32           *
33           * OPs are mainly created by the newFOO() functions, which are mainly
34           * called from the parser (in perly.y) as the code is parsed. For example
35           * the Perl code $a + $b * $c would cause the equivalent of the following
36           * to be called (oversimplifying a bit):
37           *
38           * newBINOP(OP_ADD, flags,
39           * newSVREF($a),
40           * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41           * )
42           *
43           * Note that during the build of miniperl, a temporary copy of this file
44           * is made, called opmini.c.
45           */
46            
47           /*
48           Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49            
50           A bottom-up pass
51           A top-down pass
52           An execution-order pass
53            
54           The bottom-up pass is represented by all the "newOP" routines and
55           the ck_ routines. The bottom-upness is actually driven by yacc.
56           So at the point that a ck_ routine fires, we have no idea what the
57           context is, either upward in the syntax tree, or either forward or
58           backward in the execution order. (The bottom-up parser builds that
59           part of the execution order it knows about, but if you follow the "next"
60           links around, you'll find it's actually a closed loop through the
61           top level node.)
62            
63           Whenever the bottom-up parser gets to a node that supplies context to
64           its components, it invokes that portion of the top-down pass that applies
65           to that part of the subtree (and marks the top node as processed, so
66           if a node further up supplies context, it doesn't have to take the
67           plunge again). As a particular subcase of this, as the new node is
68           built, it takes all the closed execution loops of its subcomponents
69           and links them into a new closed loop for the higher level node. But
70           it's still not the real execution order.
71            
72           The actual execution order is not known till we get a grammar reduction
73           to a top-level unit like a subroutine or file that will be called by
74           "name" rather than via a "next" pointer. At that point, we can call
75           into peep() to do that code's portion of the 3rd pass. It has to be
76           recursive, but it's recursive on basic blocks, not on tree nodes.
77           */
78            
79           /* To implement user lexical pragmas, there needs to be a way at run time to
80           get the compile time state of %^H for that block. Storing %^H in every
81           block (or even COP) would be very expensive, so a different approach is
82           taken. The (running) state of %^H is serialised into a tree of HE-like
83           structs. Stores into %^H are chained onto the current leaf as a struct
84           refcounted_he * with the key and the value. Deletes from %^H are saved
85           with a value of PL_sv_placeholder. The state of %^H at any point can be
86           turned back into a regular HV by walking back up the tree from that point's
87           leaf, ignoring any key you've already seen (placeholder or not), storing
88           the rest into the HV structure, then removing the placeholders. Hence
89           memory is only used to store the %^H deltas from the enclosing COP, rather
90           than the entire %^H on each COP.
91            
92           To cause actions on %^H to write out the serialisation records, it has
93           magic type 'H'. This magic (itself) does nothing, but its presence causes
94           the values to gain magic type 'h', which has entries for set and clear.
95           C updates C with a store
96           record, with deletes written by C. C
97           saves the current C on the save stack, so that
98           it will be correctly restored when any inner compiling scope is exited.
99           */
100            
101           #include "EXTERN.h"
102           #define PERL_IN_OP_C
103           #include "perl.h"
104           #include "keywords.h"
105           #include "feature.h"
106           #include "regcomp.h"
107            
108           #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109           #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110           #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
111            
112           /* See the explanatory comments above struct opslab in op.h. */
113            
114           #ifdef PERL_DEBUG_READONLY_OPS
115           # define PERL_SLAB_SIZE 128
116           # define PERL_MAX_SLAB_SIZE 4096
117           # include
118           #endif
119            
120           #ifndef PERL_SLAB_SIZE
121           # define PERL_SLAB_SIZE 64
122           #endif
123           #ifndef PERL_MAX_SLAB_SIZE
124           # define PERL_MAX_SLAB_SIZE 2048
125           #endif
126            
127           /* rounds up to nearest pointer */
128           #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
129           #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
130            
131           static OPSLAB *
132           S_new_slab(pTHX_ size_t sz)
133           {
134           #ifdef PERL_DEBUG_READONLY_OPS
135           OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
136           PROT_READ|PROT_WRITE,
137           MAP_ANON|MAP_PRIVATE, -1, 0);
138           DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139           (unsigned long) sz, slab));
140           if (slab == MAP_FAILED) {
141           perror("mmap failed");
142           abort();
143           }
144           slab->opslab_size = (U16)sz;
145           #else
146 40862606         OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
147           #endif
148 40862606         slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
149           return slab;
150           }
151            
152           /* requires double parens and aTHX_ */
153           #define DEBUG_S_warn(args) \
154           DEBUG_S( \
155           PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
156           )
157            
158           void *
159 881508931         Perl_Slab_Alloc(pTHX_ size_t sz)
160           {
161           dVAR;
162           OPSLAB *slab;
163           OPSLAB *slab2;
164           OPSLOT *slot;
165           OP *o;
166           size_t opsz, space;
167            
168           /* We only allocate ops from the slab during subroutine compilation.
169           We find the slab via PL_compcv, hence that must be non-NULL. It could
170           also be pointing to a subroutine which is now fully set up (CvROOT()
171           pointing to the top of the optree for that sub), or a subroutine
172           which isn't using the slab allocator. If our sanity checks aren't met,
173           don't use a slab, but allocate the OP directly from the heap. */
174 881508931 100       if (!PL_compcv || CvROOT(PL_compcv)
    100        
175 881496577 100       || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
    50        
176 12354         return PerlMemShared_calloc(1, sz);
177            
178           /* While the subroutine is under construction, the slabs are accessed via
179           CvSTART(), to avoid needing to expand PVCV by one pointer for something
180           unneeded at runtime. Once a subroutine is constructed, the slabs are
181           accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
182           allocated yet. See the commit message for 8be227ab5eaa23f2 for more
183           details. */
184 881496577 100       if (!CvSTART(PL_compcv)) {
185 33789004         CvSTART(PL_compcv) =
186           (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
187 16894502         CvSLABBED_on(PL_compcv);
188 16894502         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
189           }
190 864602075         else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
191            
192 881496577         opsz = SIZE_TO_PSIZE(sz);
193 881496577         sz = opsz + OPSLOT_HEADER_P;
194            
195           /* The slabs maintain a free list of OPs. In particular, constant folding
196           will free up OPs, so it makes sense to re-use them where possible. A
197           freed up slot is used in preference to a new allocation. */
198 881496577 100       if (slab->opslab_freed) {
199 207884490         OP **too = &slab->opslab_freed;
200 207884490         o = *too;
201           DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
202 431172708 100       while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
    100        
203           DEBUG_S_warn((aTHX_ "Alas! too small"));
204 123620202         o = *(too = &o->op_next);
205           if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
206           }
207 207884490 100       if (o) {
208 133642482         *too = o->op_next;
209 133642482 50       Zero(o, opsz, I32 *);
210 133642482         o->op_slabbed = 1;
211 133642482         return (void *)o;
212           }
213           }
214            
215           #define INIT_OPSLOT \
216           slot->opslot_slab = slab; \
217           slot->opslot_next = slab2->opslab_first; \
218           slab2->opslab_first = slot; \
219           o = &slot->opslot_op; \
220           o->op_slabbed = 1
221            
222           /* The partially-filled slab is next in the chain. */
223 747854095 100       slab2 = slab->opslab_next ? slab->opslab_next : slab;
224 747854095 100       if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
225           /* Remaining space is too small. */
226            
227           /* If we can fit a BASEOP, add it to the free chain, so as not
228           to waste it. */
229 23968104 100       if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
230 4137633         slot = &slab2->opslab_slots;
231 4137633         INIT_OPSLOT;
232 4137633         o->op_type = OP_FREED;
233 4137633         o->op_next = slab->opslab_freed;
234 4137633         slab->opslab_freed = o;
235           }
236            
237           /* Create a new slab. Make this one twice as big. */
238 23968104         slot = slab2->opslab_first;
239 292894261 100       while (slot->opslot_next) slot = slot->opslot_next;
240 23968104         slab2 = S_new_slab(aTHX_
241           (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
242           ? PERL_MAX_SLAB_SIZE
243 23968104         : (DIFF(slab2, slot)+1)*2);
244 23968104         slab2->opslab_next = slab->opslab_next;
245 23968104         slab->opslab_next = slab2;
246           }
247           assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
248            
249           /* Create a new op slot */
250 747854095         slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
251           assert(slot >= &slab2->opslab_slots);
252 747854095 100       if (DIFF(&slab2->opslab_slots, slot)
253           < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
254 20039209         slot = &slab2->opslab_slots;
255 747854095         INIT_OPSLOT;
256           DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
257 817466935         return (void *)o;
258           }
259            
260           #undef INIT_OPSLOT
261            
262           #ifdef PERL_DEBUG_READONLY_OPS
263           void
264           Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
265           {
266           PERL_ARGS_ASSERT_SLAB_TO_RO;
267            
268           if (slab->opslab_readonly) return;
269           slab->opslab_readonly = 1;
270           for (; slab; slab = slab->opslab_next) {
271           /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
272           (unsigned long) slab->opslab_size, slab));*/
273           if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
274           Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
275           (unsigned long)slab->opslab_size, errno);
276           }
277           }
278            
279           void
280           Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
281           {
282           OPSLAB *slab2;
283            
284           PERL_ARGS_ASSERT_SLAB_TO_RW;
285            
286           if (!slab->opslab_readonly) return;
287           slab2 = slab;
288           for (; slab2; slab2 = slab2->opslab_next) {
289           /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
290           (unsigned long) size, slab2));*/
291           if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
292           PROT_READ|PROT_WRITE)) {
293           Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
294           (unsigned long)slab2->opslab_size, errno);
295           }
296           }
297           slab->opslab_readonly = 0;
298           }
299            
300           #else
301           # define Slab_to_rw(op) NOOP
302           #endif
303            
304           /* This cannot possibly be right, but it was copied from the old slab
305           allocator, to which it was originally added, without explanation, in
306           commit 083fcd5. */
307           #ifdef NETWARE
308           # define PerlMemShared PerlMem
309           #endif
310            
311           void
312 264816991         Perl_Slab_Free(pTHX_ void *op)
313           {
314           dVAR;
315           OP * const o = (OP *)op;
316           OPSLAB *slab;
317            
318           PERL_ARGS_ASSERT_SLAB_FREE;
319            
320 264816991 100       if (!o->op_slabbed) {
321 428 50       if (!o->op_static)
322 428         PerlMemShared_free(op);
323 264816991         return;
324           }
325            
326 264816563         slab = OpSLAB(o);
327           /* If this op is already freed, our refcount will get screwy. */
328           assert(o->op_type != OP_FREED);
329 264816563         o->op_type = OP_FREED;
330 264816563         o->op_next = slab->opslab_freed;
331 264816563         slab->opslab_freed = o;
332           DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
333 264816563 100       OpslabREFCNT_dec_padok(slab);
334           }
335            
336           void
337 0         Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
338           {
339           dVAR;
340 0         const bool havepad = !!PL_comppad;
341           PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
342 0 0       if (havepad) {
343 0         ENTER;
344 0         PAD_SAVE_SETNULLPAD();
345           }
346 0         opslab_free(slab);
347 0 0       if (havepad) LEAVE;
348 0         }
349            
350           void
351 4050364         Perl_opslab_free(pTHX_ OPSLAB *slab)
352           {
353           dVAR;
354           OPSLAB *slab2;
355           PERL_ARGS_ASSERT_OPSLAB_FREE;
356           DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
357           assert(slab->opslab_refcnt == 1);
358 14218499 100       for (; slab; slab = slab2) {
359 8223943         slab2 = slab->opslab_next;
360           #ifdef DEBUGGING
361           slab->opslab_refcnt = ~(size_t)0;
362           #endif
363           #ifdef PERL_DEBUG_READONLY_OPS
364           DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
365           slab));
366           if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
367           perror("munmap failed");
368           abort();
369           }
370           #else
371 8223943         PerlMemShared_free(slab);
372           #endif
373           }
374 4050364         }
375            
376           void
377 215142         Perl_opslab_force_free(pTHX_ OPSLAB *slab)
378           {
379           OPSLAB *slab2;
380           OPSLOT *slot;
381           #ifdef DEBUGGING
382           size_t savestack_count = 0;
383           #endif
384           PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
385           slab2 = slab;
386           do {
387 992974 100       for (slot = slab2->opslab_first;
388 888466         slot->opslot_next;
389 671890         slot = slot->opslot_next) {
390 673506 100       if (slot->opslot_op.op_type != OP_FREED
391 3118 50       && !(slot->opslot_op.op_savefree
392           #ifdef DEBUGGING
393           && ++savestack_count
394           #endif
395           )
396           ) {
397           assert(slot->opslot_op.op_slabbed);
398 3118         op_free(&slot->opslot_op);
399 3118 100       if (slab->opslab_refcnt == 1) goto free;
400           }
401           }
402 214960 100       } while ((slab2 = slab2->opslab_next));
403           /* > 1 because the CV still holds a reference count. */
404 213526 50       if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
405           #ifdef DEBUGGING
406           assert(savestack_count == slab->opslab_refcnt-1);
407           #endif
408           /* Remove the CV’s reference count. */
409 0         slab->opslab_refcnt--;
410 215142         return;
411           }
412           free:
413 215142         opslab_free(slab);
414           }
415            
416           #ifdef PERL_DEBUG_READONLY_OPS
417           OP *
418           Perl_op_refcnt_inc(pTHX_ OP *o)
419           {
420           if(o) {
421           OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
422           if (slab && slab->opslab_readonly) {
423           Slab_to_rw(slab);
424           ++o->op_targ;
425           Slab_to_ro(slab);
426           } else {
427           ++o->op_targ;
428           }
429           }
430           return o;
431            
432           }
433            
434           PADOFFSET
435           Perl_op_refcnt_dec(pTHX_ OP *o)
436           {
437           PADOFFSET result;
438           OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
439            
440           PERL_ARGS_ASSERT_OP_REFCNT_DEC;
441            
442           if (slab && slab->opslab_readonly) {
443           Slab_to_rw(slab);
444           result = --o->op_targ;
445           Slab_to_ro(slab);
446           } else {
447           result = --o->op_targ;
448           }
449           return result;
450           }
451           #endif
452           /*
453           * In the following definition, the ", (OP*)0" is just to make the compiler
454           * think the expression is of the right type: croak actually does a Siglongjmp.
455           */
456           #define CHECKOP(type,o) \
457           ((PL_op_mask && PL_op_mask[type]) \
458           ? ( op_free((OP*)o), \
459           Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
460           (OP*)0 ) \
461           : PL_check[type](aTHX_ (OP*)o))
462            
463           #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
464            
465           #define CHANGE_TYPE(o,type) \
466           STMT_START { \
467           o->op_type = (OPCODE)type; \
468           o->op_ppaddr = PL_ppaddr[type]; \
469           } STMT_END
470            
471           STATIC SV*
472 68         S_gv_ename(pTHX_ GV *gv)
473           {
474 68         SV* const tmpsv = sv_newmortal();
475            
476           PERL_ARGS_ASSERT_GV_ENAME;
477            
478 68         gv_efullname3(tmpsv, gv, NULL);
479 68         return tmpsv;
480           }
481            
482           STATIC OP *
483 2         S_no_fh_allowed(pTHX_ OP *o)
484           {
485           PERL_ARGS_ASSERT_NO_FH_ALLOWED;
486            
487 2 50       yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
    0        
488           OP_DESC(o)));
489 2         return o;
490           }
491            
492           STATIC OP *
493           S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
494           {
495           PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
496 40         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
497           SvUTF8(namesv) | flags);
498           return o;
499           }
500            
501           STATIC OP *
502           S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
503           {
504           PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
505 12         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
506           return o;
507           }
508          
509           STATIC OP *
510 314         S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
511           {
512           PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
513            
514 314         yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
515 314         return o;
516           }
517            
518           STATIC OP *
519           S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
520           {
521           PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
522            
523 10         yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
524           SvUTF8(namesv) | flags);
525           return o;
526           }
527            
528           STATIC void
529 12         S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
530           {
531           PERL_ARGS_ASSERT_BAD_TYPE_PV;
532            
533 12 50       yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
    0        
534           (int)n, name, t, OP_DESC(kid)), flags);
535 12         }
536            
537           STATIC void
538 18         S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
539           {
540 18         SV * const namesv = gv_ename(gv);
541           PERL_ARGS_ASSERT_BAD_TYPE_GV;
542          
543 18 50       yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
    0        
544           (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
545 18         }
546            
547           STATIC void
548 74         S_no_bareword_allowed(pTHX_ OP *o)
549           {
550           PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
551            
552           if (PL_madskills)
553 74         return; /* various ok barewords are hidden in extra OP_NULL */
554 74         qerror(Perl_mess(aTHX_
555           "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
556           SVfARG(cSVOPo_sv)));
557 74         o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
558           }
559            
560           /* "register" allocation */
561            
562           PADOFFSET
563 20556280         Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
564           {
565           dVAR;
566           PADOFFSET off;
567 20556280         const bool is_our = (PL_parser->in_my == KEY_our);
568            
569           PERL_ARGS_ASSERT_ALLOCMY;
570            
571 20556280 50       if (flags & ~SVf_UTF8)
572 0         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
573           (UV)flags);
574            
575           /* Until we're using the length for real, cross check that we're being
576           told the truth. */
577           assert(strlen(name) == len);
578            
579           /* complain about "my $" etc etc */
580 20701575 50       if (len &&
    100        
    100        
    100        
581 19595415 100       !(is_our ||
    100        
582 9569265 100       isALPHA(name[1]) ||
583 149924 100       ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
    50        
    50        
    50        
    50        
584 13760 50       (name[1] == '_' && (*name == '$' || len > 2))))
585           {
586           /* name[2] is true if strlen(name) > 2 */
587 10 100       if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
    50        
588 10 100       && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
    50        
589 4 50       yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
    50        
590           name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
591           PL_parser->in_my == KEY_state ? "state" : "my"));
592           } else {
593 6 50       yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
594           PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
595           }
596           }
597 20556270 100       else if (len == 2 && name[1] == '_' && !is_our)
    100        
    100        
598           /* diag_listed_as: Use of my $_ is experimental */
599 112 100       Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
600           "Use of %s $_ is experimental",
601 112         PL_parser->in_my == KEY_state
602           ? "state"
603           : "my");
604            
605           /* allocate a spare slot and store the name in that slot */
606            
607 20556280 100       off = pad_add_name_pvn(name, len,
    50        
    100        
    100        
    100        
    100        
    100        
608           (is_our ? padadd_OUR :
609           PL_parser->in_my == KEY_state ? padadd_STATE : 0)
610           | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
611           PL_parser->in_my_stash,
612           (is_our
613           /* $_ is always in main::, even with our */
614           ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
615           : NULL
616           )
617           );
618           /* anon sub prototypes contains state vars should always be cloned,
619           * otherwise the state var would be shared between anon subs */
620            
621 20556272 100       if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
    100        
622 16         CvCLONE_on(PL_compcv);
623            
624 20556272         return off;
625           }
626            
627           /*
628           =for apidoc alloccopstash
629            
630           Available only under threaded builds, this function allocates an entry in
631           C for the stash passed to it.
632            
633           =cut
634           */
635            
636           #ifdef USE_ITHREADS
637           PADOFFSET
638           Perl_alloccopstash(pTHX_ HV *hv)
639           {
640           PADOFFSET off = 0, o = 1;
641           bool found_slot = FALSE;
642            
643           PERL_ARGS_ASSERT_ALLOCCOPSTASH;
644            
645           if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
646            
647           for (; o < PL_stashpadmax; ++o) {
648           if (PL_stashpad[o] == hv) return PL_stashpadix = o;
649           if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
650           found_slot = TRUE, off = o;
651           }
652           if (!found_slot) {
653           Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
654           Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
655           off = PL_stashpadmax;
656           PL_stashpadmax += 10;
657           }
658            
659           PL_stashpad[PL_stashpadix = off] = hv;
660           return off;
661           }
662           #endif
663            
664           /* free the body of an op without examining its contents.
665           * Always use this rather than FreeOp directly */
666            
667           static void
668           S_op_destroy(pTHX_ OP *o)
669           {
670 40904021         FreeOp(o);
671           }
672            
673           /* Destructor */
674            
675           void
676 227735937         Perl_op_free(pTHX_ OP *o)
677           {
678           dVAR;
679           OPCODE type;
680            
681           /* Though ops may be freed twice, freeing the op after its slab is a
682           big no-no. */
683           assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
684           /* During the forced freeing of ops after compilation failure, kidops
685           may be freed before their parents. */
686 227735937 100       if (!o || o->op_type == OP_FREED)
    100        
687           return;
688            
689 226823189         type = o->op_type;
690 226823189 100       if (o->op_private & OPpREFCOUNTED) {
691 29181162 100       switch (type) {
692           case OP_LEAVESUB:
693           case OP_LEAVESUBLV:
694           case OP_LEAVEEVAL:
695           case OP_LEAVE:
696           case OP_SCOPE:
697           case OP_LEAVEWRITE:
698           {
699           PADOFFSET refcnt;
700           OP_REFCNT_LOCK;
701 9149031         refcnt = OpREFCNT_dec(o);
702           OP_REFCNT_UNLOCK;
703 9149031 100       if (refcnt) {
704           /* Need to find and remove any pattern match ops from the list
705           we maintain for reset(). */
706 2910239         find_and_forget_pmops(o);
707 2910239         return;
708           }
709           }
710           break;
711           default:
712           break;
713           }
714           }
715            
716           /* Call the op_free hook if it has been set. Do it now so that it's called
717           * at the right time for refcounted ops, but still before all of the kids
718           * are freed. */
719 223912950 100       CALL_OPFREEHOOK(o);
720            
721 223912950 100       if (o->op_flags & OPf_KIDS) {
722           OP *kid, *nextkid;
723 286858385 100       for (kid = cUNOPo->op_first; kid; kid = nextkid) {
724 165274623         nextkid = kid->op_sibling; /* Get before next freeing kid */
725 165274623         op_free(kid);
726           }
727           }
728 223912950 100       if (type == OP_NULL)
729 19619662         type = (OPCODE)o->op_targ;
730            
731           if (o->op_slabbed)
732           Slab_to_rw(OpSLAB(o));
733            
734           /* COP* is not cleared by op_clear() so that we may track line
735           * numbers etc even after null() */
736 223912950 100       if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
737 15401836         cop_free((COP*)o);
738           }
739            
740 223912950         op_clear(o);
741 225828402         FreeOp(o);
742           #ifdef DEBUG_LEAKING_SCALARS
743           if (PL_op == o)
744           PL_op = NULL;
745           #endif
746           }
747            
748           void
749 307419884         Perl_op_clear(pTHX_ OP *o)
750           {
751            
752           dVAR;
753            
754           PERL_ARGS_ASSERT_OP_CLEAR;
755            
756           #ifdef PERL_MAD
757           mad_free(o->op_madprop);
758           o->op_madprop = 0;
759           #endif
760            
761           retry:
762 307419884         switch (o->op_type) {
763           case OP_NULL: /* Was holding old type, if any. */
764           if (PL_madskills && o->op_targ != OP_NULL) {
765           o->op_type = (Optype)o->op_targ;
766           o->op_targ = 0;
767           goto retry;
768           }
769           case OP_ENTERTRY:
770           case OP_ENTEREVAL: /* Was holding hints. */
771 20232336         o->op_targ = 0;
772 20232336         break;
773           default:
774 184776863 100       if (!(o->op_flags & OPf_REF)
775 14497658 100       || (PL_check[o->op_type] != Perl_ck_ftst))
776           break;
777           /* FALL THROUGH */
778           case OP_GVSV:
779           case OP_GV:
780           case OP_AELEMFAST:
781           {
782 18315876         GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
783           #ifdef USE_ITHREADS
784           && PL_curpad
785           #endif
786 18315876 100       ? cGVOPo_gv : NULL;
787           /* It's possible during global destruction that the GV is freed
788           before the optree. Whilst the SvREFCNT_inc is happy to bump from
789           0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
790           will trigger an assertion failure, because the entry to sv_clear
791           checks that the scalar is not already freed. A check of for
792           !SvIS_FREED(gv) turns out to be invalid, because during global
793           destruction the reference count can be forced down to zero
794           (with SVf_BREAK set). In which case raising to 1 and then
795           dropping to 0 triggers cleanup before it should happen. I
796           *think* that this might actually be a general, systematic,
797           weakness of the whole idea of SVf_BREAK, in that code *is*
798           allowed to raise and lower references during global destruction,
799           so any *valid* code that happens to do this during global
800           destruction might well trigger premature cleanup. */
801 18315876 100       bool still_valid = gv && SvREFCNT(gv);
    50        
802            
803 18315876 100       if (still_valid)
804 18231324 50       SvREFCNT_inc_simple_void(gv);
805           #ifdef USE_ITHREADS
806           if (cPADOPo->op_padix > 0) {
807           /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
808           * may still exist on the pad */
809           pad_swipe(cPADOPo->op_padix, TRUE);
810           cPADOPo->op_padix = 0;
811           }
812           #else
813 18315876         SvREFCNT_dec(cSVOPo->op_sv);
814 18315876         cSVOPo->op_sv = NULL;
815           #endif
816 18315876 100       if (still_valid) {
817 18231324         int try_downgrade = SvREFCNT(gv) == 2;
818 18231324         SvREFCNT_dec_NN(gv);
819 18231324 100       if (try_downgrade)
820 7474607         gv_try_downgrade(gv);
821           }
822           }
823           break;
824           case OP_METHOD_NAMED:
825           case OP_CONST:
826           case OP_HINTSEVAL:
827 83131162         SvREFCNT_dec(cSVOPo->op_sv);
828 83131162         cSVOPo->op_sv = NULL;
829           #ifdef USE_ITHREADS
830           /** Bug #15654
831           Even if op_clear does a pad_free for the target of the op,
832           pad_free doesn't actually remove the sv that exists in the pad;
833           instead it lives on. This results in that it could be reused as
834           a target later on when the pad was reallocated.
835           **/
836           if(o->op_targ) {
837           pad_swipe(o->op_targ,1);
838           o->op_targ = 0;
839           }
840           #endif
841 83131162         break;
842           case OP_DUMP:
843           case OP_GOTO:
844           case OP_NEXT:
845           case OP_LAST:
846           case OP_REDO:
847 37263 100       if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
848           break;
849           /* FALL THROUGH */
850           case OP_TRANS:
851           case OP_TRANSR:
852 23342 100       if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
853           assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
854           #ifdef USE_ITHREADS
855           if (cPADOPo->op_padix > 0) {
856           pad_swipe(cPADOPo->op_padix, TRUE);
857           cPADOPo->op_padix = 0;
858           }
859           #else
860 120         SvREFCNT_dec(cSVOPo->op_sv);
861 120         cSVOPo->op_sv = NULL;
862           #endif
863           }
864           else {
865 23222         PerlMemShared_free(cPVOPo->op_pv);
866 23222         cPVOPo->op_pv = NULL;
867           }
868           break;
869           case OP_SUBST:
870 31081         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
871 31081         goto clear_pmop;
872           case OP_PUSHRE:
873           #ifdef USE_ITHREADS
874           if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
875           /* No GvIN_PAD_off here, because other references may still
876           * exist on the pad */
877           pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
878           }
879           #else
880 57050         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
881           #endif
882           /* FALL THROUGH */
883           case OP_MATCH:
884           case OP_QR:
885           clear_pmop:
886 905442 100       if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
887 905414         op_free(cPMOPo->op_code_list);
888 905442         cPMOPo->op_code_list = NULL;
889 905442         forget_pmop(cPMOPo);
890 905442         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
891           /* we use the same protection as the "SAFE" version of the PM_ macros
892           * here since sv_clean_all might release some PMOPs
893           * after PL_regex_padav has been cleared
894           * and the clearing of PL_regex_padav needs to
895           * happen before sv_clean_all
896           */
897           #ifdef USE_ITHREADS
898           if(PL_regex_pad) { /* We could be in destruction */
899           const IV offset = (cPMOPo)->op_pmoffset;
900           ReREFCNT_dec(PM_GETRE(cPMOPo));
901           PL_regex_pad[offset] = &PL_sv_undef;
902           sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
903           sizeof(offset));
904           }
905           #else
906 905442         ReREFCNT_dec(PM_GETRE(cPMOPo));
907 905442         PM_SETRE(cPMOPo, NULL);
908           #endif
909            
910 905442         break;
911           }
912            
913 307419884 100       if (o->op_targ > 0) {
914 24529676         pad_free(o->op_targ);
915 24529676         o->op_targ = 0;
916           }
917 307419884         }
918            
919           STATIC void
920 17148804         S_cop_free(pTHX_ COP* cop)
921           {
922           PERL_ARGS_ASSERT_COP_FREE;
923            
924 17148804         CopFILE_free(cop);
925 17148804 100       if (! specialWARN(cop->cop_warnings))
    100        
926 1624378         PerlMemShared_free(cop->cop_warnings);
927 17148804         cophh_free(CopHINTHASH_get(cop));
928 17148804 100       if (PL_curcop == cop)
929 1747000         PL_curcop = NULL;
930 17148804         }
931            
932           STATIC void
933 967037         S_forget_pmop(pTHX_ PMOP *const o
934           )
935           {
936 967037 100       HV * const pmstash = PmopSTASH(o);
937            
938           PERL_ARGS_ASSERT_FORGET_PMOP;
939            
940 967037 100       if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
    50        
    50        
941 26         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
942 26 50       if (mg) {
943 26         PMOP **const array = (PMOP**) mg->mg_ptr;
944 26         U32 count = mg->mg_len / sizeof(PMOP**);
945           U32 i = count;
946            
947 45 50       while (i--) {
948 32 100       if (array[i] == o) {
949           /* Found it. Move the entry at the end to overwrite it. */
950 26         array[i] = array[--count];
951 26         mg->mg_len = count * sizeof(PMOP**);
952           /* Could realloc smaller at this point always, but probably
953           not worth it. Probably worth free()ing if we're the
954           last. */
955 26 100       if(!count) {
956 20         Safefree(mg->mg_ptr);
957 20         mg->mg_ptr = NULL;
958           }
959           break;
960           }
961           }
962           }
963           }
964 967037 100       if (PL_curpm == o)
965 178         PL_curpm = NULL;
966 967037         }
967            
968           STATIC void
969 33938286         S_find_and_forget_pmops(pTHX_ OP *o)
970           {
971           PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
972            
973 33938286 100       if (o->op_flags & OPf_KIDS) {
974 17127202         OP *kid = cUNOPo->op_first;
975 56709139 100       while (kid) {
976 31028047 100       switch (kid->op_type) {
977           case OP_SUBST:
978           case OP_PUSHRE:
979           case OP_MATCH:
980           case OP_QR:
981 61595         forget_pmop((PMOP*)kid);
982           }
983 31028047         find_and_forget_pmops(kid);
984 31028047         kid = kid->op_sibling;
985           }
986           }
987 33938286         }
988            
989           void
990 83506934         Perl_op_null(pTHX_ OP *o)
991           {
992           dVAR;
993            
994           PERL_ARGS_ASSERT_OP_NULL;
995            
996 83506934 50       if (o->op_type == OP_NULL)
997 83506934         return;
998           if (!PL_madskills)
999 83506934         op_clear(o);
1000 83506934         o->op_targ = o->op_type;
1001 83506934         o->op_type = OP_NULL;
1002 83506934         o->op_ppaddr = PL_ppaddr[OP_NULL];
1003           }
1004            
1005           void
1006 0         Perl_op_refcnt_lock(pTHX)
1007           {
1008           dVAR;
1009           PERL_UNUSED_CONTEXT;
1010           OP_REFCNT_LOCK;
1011 0         }
1012            
1013           void
1014 0         Perl_op_refcnt_unlock(pTHX)
1015           {
1016           dVAR;
1017           PERL_UNUSED_CONTEXT;
1018           OP_REFCNT_UNLOCK;
1019 0         }
1020            
1021           /* Contextualizers */
1022            
1023           /*
1024           =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1025            
1026           Applies a syntactic context to an op tree representing an expression.
1027           I is the op tree, and I must be C, C,
1028           or C to specify the context to apply. The modified op tree
1029           is returned.
1030            
1031           =cut
1032           */
1033            
1034           OP *
1035 50         Perl_op_contextualize(pTHX_ OP *o, I32 context)
1036           {
1037           PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1038 50         switch (context) {
1039 46         case G_SCALAR: return scalar(o);
1040 2         case G_ARRAY: return list(o);
1041 2         case G_VOID: return scalarvoid(o);
1042           default:
1043 25         Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1044           (long) context);
1045           return o;
1046           }
1047           }
1048            
1049           /*
1050           =head1 Optree Manipulation Functions
1051            
1052           =for apidoc Am|OP*|op_linklist|OP *o
1053           This function is the implementation of the L macro. It should
1054           not be called directly.
1055            
1056           =cut
1057           */
1058            
1059           OP *
1060 309826465         Perl_op_linklist(pTHX_ OP *o)
1061           {
1062           OP *first;
1063            
1064           PERL_ARGS_ASSERT_OP_LINKLIST;
1065            
1066 309826465 50       if (o->op_next)
1067 0         return o->op_next;
1068            
1069           /* establish postfix order */
1070 309826465         first = cUNOPo->op_first;
1071 309826465 100       if (first) {
1072           OP *kid;
1073 308821804 100       o->op_next = LINKLIST(first);
1074           kid = first;
1075           for (;;) {
1076 677571657 100       if (kid->op_sibling) {
1077 368749853 100       kid->op_next = LINKLIST(kid->op_sibling);
1078 368749853         kid = kid->op_sibling;
1079           } else {
1080 308821804         kid->op_next = o;
1081           break;
1082           }
1083 368749853         }
1084           }
1085           else
1086 1004661         o->op_next = o;
1087            
1088 309826465         return o->op_next;
1089           }
1090            
1091           static OP *
1092 108046         S_scalarkids(pTHX_ OP *o)
1093           {
1094 108046 50       if (o && o->op_flags & OPf_KIDS) {
    50        
1095           OP *kid;
1096 234986 100       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1097 126940         scalar(kid);
1098           }
1099 108046         return o;
1100           }
1101            
1102           STATIC OP *
1103 26219362         S_scalarboolean(pTHX_ OP *o)
1104           {
1105           dVAR;
1106            
1107           PERL_ARGS_ASSERT_SCALARBOOLEAN;
1108            
1109 26219362 100       if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
    100        
1110 14 100       && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1111 10 100       if (ckWARN(WARN_SYNTAX)) {
1112 4         const line_t oldline = CopLINE(PL_curcop);
1113            
1114 4 50       if (PL_parser && PL_parser->copline != NOLINE) {
    50        
1115           /* This ensures that warnings are reported at the first line
1116           of the conditional, not the last. */
1117 4         CopLINE_set(PL_curcop, PL_parser->copline);
1118           }
1119 4         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1120 4         CopLINE_set(PL_curcop, oldline);
1121           }
1122           }
1123 26219362         return scalar(o);
1124           }
1125            
1126           OP *
1127 1066652324         Perl_scalar(pTHX_ OP *o)
1128           {
1129           dVAR;
1130           OP *kid;
1131            
1132           /* assumes no premature commitment */
1133 1066652324 100       if (!o || (PL_parser && PL_parser->error_count)
    100        
    100        
1134 1065783407 100       || (o->op_flags & OPf_WANT)
1135 530415953 100       || o->op_type == OP_RETURN)
1136           {
1137           return o;
1138           }
1139            
1140 530380251         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1141            
1142 530380251         switch (o->op_type) {
1143           case OP_REPEAT:
1144 147986         scalar(cBINOPo->op_first);
1145 147986         break;
1146           case OP_OR:
1147           case OP_AND:
1148           case OP_COND_EXPR:
1149 15305037 100       for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1150 8435450         scalar(kid);
1151           break;
1152           /* FALL THROUGH */
1153           case OP_SPLIT:
1154           case OP_MATCH:
1155           case OP_QR:
1156           case OP_SUBST:
1157           case OP_NULL:
1158           default:
1159 513256187 100       if (o->op_flags & OPf_KIDS) {
1160 462176976 100       for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1161 290640958         scalar(kid);
1162           }
1163           break;
1164           case OP_LEAVE:
1165           case OP_LEAVETRY:
1166 719646         kid = cLISTOPo->op_first;
1167 719646         scalar(kid);
1168 5559754         kid = kid->op_sibling;
1169           do_kids:
1170 45849747 100       while (kid) {
1171 35743270         OP *sib = kid->op_sibling;
1172 35743270 100       if (sib && kid->op_type != OP_LEAVEWHEN)
    100        
1173 25636749         scalarvoid(kid);
1174           else
1175 23377180         scalar(kid);
1176           kid = sib;
1177           }
1178 10106477         PL_curcop = &PL_compiling;
1179 10106477         break;
1180           case OP_SCOPE:
1181           case OP_LINESEQ:
1182           case OP_LIST:
1183 9386831         kid = cLISTOPo->op_first;
1184 9386831         goto do_kids;
1185           case OP_SORT:
1186 14         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1187 554549055         break;
1188           }
1189           return o;
1190           }
1191            
1192           OP *
1193 295597498         Perl_scalarvoid(pTHX_ OP *o)
1194           {
1195           dVAR;
1196           OP *kid;
1197           SV *useless_sv = NULL;
1198           const char* useless = NULL;
1199           SV* sv;
1200           U8 want;
1201            
1202           PERL_ARGS_ASSERT_SCALARVOID;
1203            
1204           /* trailing mad null ops don't count as "there" for void processing */
1205           if (PL_madskills &&
1206           o->op_type != OP_NULL &&
1207           o->op_sibling &&
1208           o->op_sibling->op_type == OP_NULL)
1209           {
1210           OP *sib;
1211           for (sib = o->op_sibling;
1212           sib && sib->op_type == OP_NULL;
1213           sib = sib->op_sibling) ;
1214          
1215           if (!sib)
1216           return o;
1217           }
1218            
1219 437666929 100       if (o->op_type == OP_NEXTSTATE
1220 295597498         || o->op_type == OP_DBSTATE
1221 171553284 100       || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
    100        
1222 32958965         || o->op_targ == OP_DBSTATE)))
1223 145559830         PL_curcop = (COP*)o; /* for warning below */
1224            
1225           /* assumes no premature commitment */
1226 295597498         want = o->op_flags & OPf_WANT;
1227 295597498 100       if ((want && want != OPf_WANT_SCALAR)
1228 186141042 100       || (PL_parser && PL_parser->error_count)
    100        
1229 186138072 100       || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
    100        
    100        
1230           {
1231           return o;
1232           }
1233            
1234 176880750 100       if ((o->op_private & OPpTARGET_MY)
1235 1040855 100       && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1236           {
1237 737126         return scalar(o); /* As if inside SASSIGN */
1238           }
1239            
1240 176143624         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1241            
1242 176143624         switch (o->op_type) {
1243           default:
1244 15281694 100       if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1245           break;
1246           /* FALL THROUGH */
1247           case OP_REPEAT:
1248 1449247 100       if (o->op_flags & OPf_STACKED)
1249           break;
1250           goto func_ops;
1251           case OP_SUBSTR:
1252 40772 100       if (o->op_private == 4)
1253           break;
1254           /* FALL THROUGH */
1255           case OP_GVSV:
1256           case OP_WANTARRAY:
1257           case OP_GV:
1258           case OP_SMARTMATCH:
1259           case OP_PADSV:
1260           case OP_PADAV:
1261           case OP_PADHV:
1262           case OP_PADANY:
1263           case OP_AV2ARYLEN:
1264           case OP_REF:
1265           case OP_REFGEN:
1266           case OP_SREFGEN:
1267           case OP_DEFINED:
1268           case OP_HEX:
1269           case OP_OCT:
1270           case OP_LENGTH:
1271           case OP_VEC:
1272           case OP_INDEX:
1273           case OP_RINDEX:
1274           case OP_SPRINTF:
1275           case OP_AELEM:
1276           case OP_AELEMFAST:
1277           case OP_AELEMFAST_LEX:
1278           case OP_ASLICE:
1279           case OP_HELEM:
1280           case OP_HSLICE:
1281           case OP_UNPACK:
1282           case OP_PACK:
1283           case OP_JOIN:
1284           case OP_LSLICE:
1285           case OP_ANONLIST:
1286           case OP_ANONHASH:
1287           case OP_SORT:
1288           case OP_REVERSE:
1289           case OP_RANGE:
1290           case OP_FLIP:
1291           case OP_FLOP:
1292           case OP_CALLER:
1293           case OP_FILENO:
1294           case OP_EOF:
1295           case OP_TELL:
1296           case OP_GETSOCKNAME:
1297           case OP_GETPEERNAME:
1298           case OP_READLINK:
1299           case OP_TELLDIR:
1300           case OP_GETPPID:
1301           case OP_GETPGRP:
1302           case OP_GETPRIORITY:
1303           case OP_TIME:
1304           case OP_TMS:
1305           case OP_LOCALTIME:
1306           case OP_GMTIME:
1307           case OP_GHBYNAME:
1308           case OP_GHBYADDR:
1309           case OP_GHOSTENT:
1310           case OP_GNBYNAME:
1311           case OP_GNBYADDR:
1312           case OP_GNETENT:
1313           case OP_GPBYNAME:
1314           case OP_GPBYNUMBER:
1315           case OP_GPROTOENT:
1316           case OP_GSBYNAME:
1317           case OP_GSBYPORT:
1318           case OP_GSERVENT:
1319           case OP_GPWNAM:
1320           case OP_GPWUID:
1321           case OP_GGRNAM:
1322           case OP_GGRGID:
1323           case OP_GETLOGIN:
1324           case OP_PROTOTYPE:
1325           case OP_RUNCV:
1326           func_ops:
1327 2883165 100       if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1328           /* Otherwise it's "Useless use of grep iterator" */
1329 1146 50       useless = OP_DESC(o);
    0        
1330           break;
1331            
1332           case OP_SPLIT:
1333 82         kid = cLISTOPo->op_first;
1334 82 50       if (kid && kid->op_type == OP_PUSHRE
    50        
1335           #ifdef USE_ITHREADS
1336           && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1337           #else
1338 82 100       && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1339           #endif
1340 8 50       useless = OP_DESC(o);
    0        
1341           break;
1342            
1343           case OP_NOT:
1344 2         kid = cUNOPo->op_first;
1345 3 50       if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
    50        
1346 3 50       kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1347           goto func_ops;
1348           }
1349           useless = "negative pattern binding (!~)";
1350           break;
1351            
1352           case OP_SUBST:
1353 988645 100       if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1354           useless = "non-destructive substitution (s///r)";
1355           break;
1356            
1357           case OP_TRANSR:
1358           useless = "non-destructive transliteration (tr///r)";
1359           break;
1360            
1361           case OP_RV2GV:
1362           case OP_RV2SV:
1363           case OP_RV2AV:
1364           case OP_RV2HV:
1365 661447 100       if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
    100        
1366 443 50       (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1367           useless = "a variable";
1368           break;
1369            
1370           case OP_CONST:
1371 272356         sv = cSVOPo_sv;
1372 272356 100       if (cSVOPo->op_private & OPpCONST_STRICT)
1373 6         no_bareword_allowed(o);
1374           else {
1375 272350 100       if (ckWARN(WARN_VOID)) {
1376           /* don't warn on optimised away booleans, eg
1377           * use constant Foo, 5; Foo || print; */
1378 114912 100       if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1379           useless = NULL;
1380           /* the constants 0 and 1 are permitted as they are
1381           conventionally used as dummies in constructs like
1382           1 while some_condition_with_side_effects; */
1383 6848 100       else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
    100        
    100        
    100        
    50        
    100        
    0        
1384           useless = NULL;
1385 28 100       else if (SvPOK(sv)) {
1386 20         SV * const dsv = newSVpvs("");
1387           useless_sv
1388 30         = Perl_newSVpvf(aTHX_
1389           "a constant (%s)",
1390 40         pv_pretty(dsv, SvPVX_const(sv),
1391           SvCUR(sv), 32, NULL, NULL,
1392           PERL_PV_PRETTY_DUMP
1393           | PERL_PV_ESCAPE_NOCLEAR
1394           | PERL_PV_ESCAPE_UNI_DETECT));
1395 20         SvREFCNT_dec_NN(dsv);
1396           }
1397 8 100       else if (SvOK(sv)) {
    50        
    50        
1398 4         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1399           }
1400           else
1401           useless = "a constant (undef)";
1402           }
1403           }
1404 272356         op_null(o); /* don't execute or even remember it */
1405 272356         break;
1406            
1407           case OP_POSTINC:
1408 319818         o->op_type = OP_PREINC; /* pre-increment is faster */
1409 319818         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1410 319818         break;
1411            
1412           case OP_POSTDEC:
1413 72728         o->op_type = OP_PREDEC; /* pre-decrement is faster */
1414 72728         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1415 72728         break;
1416            
1417           case OP_I_POSTINC:
1418 8402         o->op_type = OP_I_PREINC; /* pre-increment is faster */
1419 8402         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1420 8402         break;
1421            
1422           case OP_I_POSTDEC:
1423 4540         o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1424 4540         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1425 4540         break;
1426            
1427           case OP_SASSIGN: {
1428           OP *rv2gv;
1429           UNOP *refgen, *rv2cv;
1430           LISTOP *exlist;
1431            
1432 17842429 50       if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1433           break;
1434            
1435 17842429         rv2gv = ((BINOP *)o)->op_last;
1436 17842429 50       if (!rv2gv || rv2gv->op_type != OP_RV2GV)
    100        
1437           break;
1438            
1439 663677         refgen = (UNOP *)((BINOP *)o)->op_first;
1440            
1441 663677 50       if (!refgen || refgen->op_type != OP_REFGEN)
    100        
1442           break;
1443            
1444 539861         exlist = (LISTOP *)refgen->op_first;
1445 539861 50       if (!exlist || exlist->op_type != OP_NULL
    50        
1446 539861 50       || exlist->op_targ != OP_LIST)
1447           break;
1448            
1449 539861 50       if (exlist->op_first->op_type != OP_PUSHMARK)
1450           break;
1451            
1452 539861         rv2cv = (UNOP*)exlist->op_last;
1453            
1454 539861 100       if (rv2cv->op_type != OP_RV2CV)
1455           break;
1456            
1457           assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1458           assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1459           assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1460            
1461 377892         o->op_private |= OPpASSIGN_CV_TO_GV;
1462 377892         rv2gv->op_private |= OPpDONT_INIT_GV;
1463 377892         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1464            
1465 377892         break;
1466           }
1467            
1468           case OP_AASSIGN: {
1469 5544596         inplace_aassign(o);
1470 5544596         break;
1471           }
1472            
1473           case OP_OR:
1474           case OP_AND:
1475 12255313         kid = cLOGOPo->op_first;
1476 12255313 100       if (kid->op_type == OP_NOT
1477 618569         && (kid->op_flags & OPf_KIDS)
1478 618569 50       && !PL_madskills) {
1479 618569 100       if (o->op_type == OP_AND) {
1480 611231         o->op_type = OP_OR;
1481 611231         o->op_ppaddr = PL_ppaddr[OP_OR];
1482           } else {
1483 7338         o->op_type = OP_AND;
1484 7338         o->op_ppaddr = PL_ppaddr[OP_AND];
1485           }
1486 618569         op_null(kid);
1487           }
1488            
1489           case OP_DOR:
1490           case OP_COND_EXPR:
1491           case OP_ENTERGIVEN:
1492           case OP_ENTERWHEN:
1493 34167569 100       for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1494 18693209         scalarvoid(kid);
1495           break;
1496            
1497           case OP_NULL:
1498 17631589 100       if (o->op_flags & OPf_STACKED)
1499           break;
1500           /* FALL THROUGH */
1501           case OP_NEXTSTATE:
1502           case OP_DBSTATE:
1503           case OP_ENTERTRY:
1504           case OP_ENTER:
1505 101911778 100       if (!(o->op_flags & OPf_KIDS))
1506           break;
1507           /* FALL THROUGH */
1508           case OP_SCOPE:
1509           case OP_LEAVE:
1510           case OP_LEAVETRY:
1511           case OP_LEAVELOOP:
1512           case OP_LINESEQ:
1513           case OP_LIST:
1514           case OP_LEAVEGIVEN:
1515           case OP_LEAVEWHEN:
1516 109786061 100       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1517 79171829         scalarvoid(kid);
1518           break;
1519           case OP_ENTEREVAL:
1520 99738         scalarkids(o);
1521 99738         break;
1522           case OP_SCALAR:
1523 82         return scalar(o);
1524           }
1525            
1526 176143534 100       if (useless_sv) {
1527           /* mortalise it, in case warnings are fatal. */
1528 24         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1529           "Useless use of %"SVf" in void context",
1530           sv_2mortal(useless_sv));
1531           }
1532 176143510 100       else if (useless) {
1533 153528800         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1534           "Useless use of %s in void context",
1535           useless);
1536           }
1537           return o;
1538           }
1539            
1540           static OP *
1541 75216057         S_listkids(pTHX_ OP *o)
1542           {
1543 75216057 50       if (o && o->op_flags & OPf_KIDS) {
    50        
1544           OP *kid;
1545 243933015 100       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1546 168716958         list(kid);
1547           }
1548 75216057         return o;
1549           }
1550            
1551           OP *
1552 229345363         Perl_list(pTHX_ OP *o)
1553           {
1554           dVAR;
1555           OP *kid;
1556            
1557           /* assumes no premature commitment */
1558 229345363 100       if (!o || (o->op_flags & OPf_WANT)
    100        
1559 64526277 100       || (PL_parser && PL_parser->error_count)
    100        
1560 64524391 100       || o->op_type == OP_RETURN)
1561           {
1562           return o;
1563           }
1564            
1565 64524185 100       if ((o->op_private & OPpTARGET_MY)
1566 226094 50       && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1567           {
1568           return o; /* As if inside SASSIGN */
1569           }
1570            
1571 64524185         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1572            
1573 64524185         switch (o->op_type) {
1574           case OP_FLOP:
1575           case OP_REPEAT:
1576 107224         list(cBINOPo->op_first);
1577 118642228         break;
1578           case OP_OR:
1579           case OP_AND:
1580           case OP_COND_EXPR:
1581 1775342 100       for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1582 1153478         list(kid);
1583           break;
1584           default:
1585           case OP_MATCH:
1586           case OP_QR:
1587           case OP_SUBST:
1588           case OP_NULL:
1589 62648330 100       if (!(o->op_flags & OPf_KIDS))
1590           break;
1591 38733541 100       if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
    100        
1592 19530         list(cBINOPo->op_first);
1593 19530         return gen_constant_list(o);
1594           }
1595           case OP_LIST:
1596 39577414         listkids(o);
1597 39577414         break;
1598           case OP_LEAVE:
1599           case OP_LEAVETRY:
1600 192604         kid = cLISTOPo->op_first;
1601 192604         list(kid);
1602 240503         kid = kid->op_sibling;
1603           do_kids:
1604 989280 100       while (kid) {
1605 705916         OP *sib = kid->op_sibling;
1606 705916 100       if (sib && kid->op_type != OP_LEAVEWHEN)
    100        
1607 422534         scalarvoid(kid);
1608           else
1609 504905         list(kid);
1610           kid = sib;
1611           }
1612 283364         PL_curcop = &PL_compiling;
1613 283364         break;
1614           case OP_SCOPE:
1615           case OP_LINESEQ:
1616 90760         kid = cLISTOPo->op_first;
1617 90760         goto do_kids;
1618           }
1619           return o;
1620           }
1621            
1622           static OP *
1623 49811830         S_scalarseq(pTHX_ OP *o)
1624           {
1625           dVAR;
1626 49811830 100       if (o) {
1627 49457828         const OPCODE type = o->op_type;
1628            
1629 49457828 100       if (type == OP_LINESEQ || type == OP_SCOPE ||
1630 8580113 50       type == OP_LEAVE || type == OP_LEAVETRY)
1631           {
1632           OP *kid;
1633 253003961 100       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1634 212126252 100       if (kid->op_sibling) {
1635 171248543         scalarvoid(kid);
1636           }
1637           }
1638 40877709         PL_curcop = &PL_compiling;
1639           }
1640 49457822         o->op_flags &= ~OPf_PARENS;
1641 49457822 100       if (PL_hints & HINT_BLOCK_SCOPE)
1642 33461018         o->op_flags |= OPf_PARENS;
1643           }
1644           else
1645 354002         o = newOP(OP_STUB, 0);
1646 49811824         return o;
1647           }
1648            
1649           STATIC OP *
1650 4619499         S_modkids(pTHX_ OP *o, I32 type)
1651           {
1652 4619499 50       if (o && o->op_flags & OPf_KIDS) {
    50        
1653           OP *kid;
1654 10914879 100       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1655 6295380         op_lvalue(kid, type);
1656           }
1657 4619499         return o;
1658           }
1659            
1660           /*
1661           =for apidoc finalize_optree
1662            
1663           This function finalizes the optree. Should be called directly after
1664           the complete optree is built. It does some additional
1665           checking which can't be done in the normal ck_xxx functions and makes
1666           the tree thread-safe.
1667            
1668           =cut
1669           */
1670           void
1671 16687178         Perl_finalize_optree(pTHX_ OP* o)
1672           {
1673           PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1674            
1675 16687178         ENTER;
1676 16687178         SAVEVPTR(PL_curcop);
1677            
1678 16687178         finalize_op(o);
1679            
1680 16687164         LEAVE;
1681 16687164         }
1682            
1683           STATIC void
1684 745257967         S_finalize_op(pTHX_ OP* o)
1685           {
1686           PERL_ARGS_ASSERT_FINALIZE_OP;
1687            
1688           #if defined(PERL_MAD) && defined(USE_ITHREADS)
1689           {
1690           /* Make sure mad ops are also thread-safe */
1691           MADPROP *mp = o->op_madprop;
1692           while (mp) {
1693           if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1694           OP *prop_op = (OP *) mp->mad_val;
1695           /* We only need "Relocate sv to the pad for thread safety.", but this
1696           easiest way to make sure it traverses everything */
1697           if (prop_op->op_type == OP_CONST)
1698           cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1699           finalize_op(prop_op);
1700           }
1701           mp = mp->mad_next;
1702           }
1703           }
1704           #endif
1705            
1706 745257967         switch (o->op_type) {
1707           case OP_NEXTSTATE:
1708           case OP_DBSTATE:
1709 74201719         PL_curcop = ((COP*)o); /* for warnings */
1710 74201719         break;
1711           case OP_EXEC:
1712 7750 100       if ( o->op_sibling
1713 798 100       && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1714 4 50       && ckWARN(WARN_EXEC))
1715           {
1716 4 50       if (o->op_sibling->op_sibling) {
1717 4         const OPCODE type = o->op_sibling->op_sibling->op_type;
1718 4 50       if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
    50        
1719 4         const line_t oldline = CopLINE(PL_curcop);
1720 4         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1721 4         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1722           "Statement unlikely to be reached");
1723 4         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1724           "\t(Maybe you meant system() when you said exec()?)\n");
1725 4         CopLINE_set(PL_curcop, oldline);
1726           }
1727           }
1728           }
1729           break;
1730            
1731           case OP_GV:
1732 23462091 100       if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
    100        
1733 671698         GV * const gv = cGVOPo_gv;
1734 671698 50       if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
    100        
    100        
1735           /* XXX could check prototype here instead of just carping */
1736 2         SV * const sv = sv_newmortal();
1737 2         gv_efullname3(sv, gv, NULL);
1738 2         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1739           "%"SVf"() called too early to check prototype",
1740           SVfARG(sv));
1741           }
1742           }
1743           break;
1744            
1745           case OP_CONST:
1746 97353418 100       if (cSVOPo->op_private & OPpCONST_STRICT)
1747 48         no_bareword_allowed(o);
1748           /* FALLTHROUGH */
1749           #ifdef USE_ITHREADS
1750           case OP_HINTSEVAL:
1751           case OP_METHOD_NAMED:
1752           /* Relocate sv to the pad for thread safety.
1753           * Despite being a "constant", the SV is written to,
1754           * for reference counts, sv_upgrade() etc. */
1755           if (cSVOPo->op_sv) {
1756           const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1757           if (o->op_type != OP_METHOD_NAMED
1758           && cSVOPo->op_sv == &PL_sv_undef) {
1759           /* PL_sv_undef is hack - it's unsafe to store it in the
1760           AV that is the pad, because av_fetch treats values of
1761           PL_sv_undef as a "free" AV entry and will merrily
1762           replace them with a new SV, causing pad_alloc to think
1763           that this pad slot is free. (When, clearly, it is not)
1764           */
1765           SvOK_off(PAD_SVl(ix));
1766           SvPADTMP_on(PAD_SVl(ix));
1767           SvREADONLY_on(PAD_SVl(ix));
1768           }
1769           else {
1770           SvREFCNT_dec(PAD_SVl(ix));
1771           PAD_SETSV(ix, cSVOPo->op_sv);
1772           /* XXX I don't know how this isn't readonly already. */
1773           if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1774           }
1775           cSVOPo->op_sv = NULL;
1776           o->op_targ = ix;
1777           }
1778           #endif
1779           break;
1780            
1781           case OP_HELEM: {
1782           UNOP *rop;
1783           SV *lexname;
1784           GV **fields;
1785           SV **svp, *sv;
1786           const char *key = NULL;
1787           STRLEN keylen;
1788            
1789 11411345 100       if (((BINOP*)o)->op_last->op_type != OP_CONST)
1790           break;
1791            
1792           /* Make the CONST have a shared SV */
1793 8433099         svp = cSVOPx_svp(((BINOP*)o)->op_last);
1794 8433099 100       if ((!SvIsCOW_shared_hash(sv = *svp))
    100        
1795 8432559 100       && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
    100        
    50        
    50        
    100        
1796 8432549 100       key = SvPV_const(sv, keylen);
1797 8432549 100       lexname = newSVpvn_share(key,
1798           SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1799           0);
1800 8432549         SvREFCNT_dec_NN(sv);
1801 8432549         *svp = lexname;
1802           }
1803            
1804 8433099 100       if ((o->op_private & (OPpLVAL_INTRO)))
1805           break;
1806            
1807 8153282         rop = (UNOP*)((BINOP*)o)->op_first;
1808 8153282 100       if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
    100        
1809           break;
1810 4786714         lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1811 4786714 100       if (!SvPAD_TYPED(lexname))
1812           break;
1813 62         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1814 62 50       if (!fields || !GvHV(*fields))
    50        
1815           break;
1816 62 50       key = SvPV_const(*svp, keylen);
1817 62 100       if (!hv_fetch(GvHV(*fields), key,
    100        
1818           SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1819 25 50       Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
    50        
1820           "in variable %"SVf" of type %"HEKf,
1821           SVfARG(*svp), SVfARG(lexname),
1822 20 50       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1823           }
1824           break;
1825           }
1826            
1827           case OP_HSLICE: {
1828           UNOP *rop;
1829           SV *lexname;
1830           GV **fields;
1831           SV **svp;
1832           const char *key;
1833           STRLEN keylen;
1834           SVOP *first_key_op, *key_op;
1835            
1836 233429 100       if ((o->op_private & (OPpLVAL_INTRO))
1837           /* I bet there's always a pushmark... */
1838 193327 100       || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1839           /* hmmm, no optimization if list contains only one key. */
1840           break;
1841 108477         rop = (UNOP*)((LISTOP*)o)->op_last;
1842 108477 100       if (rop->op_type != OP_RV2HV)
1843           break;
1844 75318 100       if (rop->op_first->op_type == OP_PADSV)
1845           /* @$hash{qw(keys here)} */
1846 31588         rop = (UNOP*)rop->op_first;
1847           else {
1848           /* @{$hash}{qw(keys here)} */
1849 43730 100       if (rop->op_first->op_type == OP_SCOPE
1850 29600 100       && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1851           {
1852 27972         rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1853           }
1854           else
1855           break;
1856           }
1857            
1858 59560         lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1859 59560 100       if (!SvPAD_TYPED(lexname))
1860           break;
1861 12         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1862 12 50       if (!fields || !GvHV(*fields))
    50        
1863           break;
1864           /* Again guessing that the pushmark can be jumped over.... */
1865 24         first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1866 12         ->op_first->op_sibling;
1867 42 100       for (key_op = first_key_op; key_op;
1868 24         key_op = (SVOP*)key_op->op_sibling) {
1869 28 100       if (key_op->op_type != OP_CONST)
1870 2         continue;
1871           svp = cSVOPx_svp(key_op);
1872 26 50       key = SvPV_const(*svp, keylen);
1873 26 50       if (!hv_fetch(GvHV(*fields), key,
    100        
1874           SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1875 10 50       Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
    50        
1876           "in variable %"SVf" of type %"HEKf,
1877           SVfARG(*svp), SVfARG(lexname),
1878 8 50       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1879           }
1880           }
1881           break;
1882           }
1883            
1884           case OP_SUBST: {
1885 1215765 100       if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1886 298025         finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1887           break;
1888           }
1889           default:
1890           break;
1891           }
1892            
1893 745257953 100       if (o->op_flags & OPf_KIDS) {
1894           OP *kid;
1895 1062750824 100       for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1896 728272764         finalize_op(kid);
1897           }
1898 745257915         }
1899            
1900           /*
1901           =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1902            
1903           Propagate lvalue ("modifiable") context to an op and its children.
1904           I represents the context type, roughly based on the type of op that
1905           would do the modifying, although C is represented by OP_NULL,
1906           because it has no op type of its own (it is signalled by a flag on
1907           the lvalue op).
1908            
1909           This function detects things that can't be modified, such as C<$x+1>, and
1910           generates errors for them. For example, C<$x+1 = 2> would cause it to be
1911           called with an op of type OP_ADD and a C argument of OP_SASSIGN.
1912            
1913           It also flags things that need to behave specially in an lvalue context,
1914           such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1915            
1916           =cut
1917           */
1918            
1919           OP *
1920 105835903         Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1921           {
1922           dVAR;
1923           OP *kid;
1924           /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1925           int localize = -1;
1926            
1927 105835903 100       if (!o || (PL_parser && PL_parser->error_count))
    100        
    100        
1928           return o;
1929            
1930 105817841 100       if ((o->op_private & OPpTARGET_MY)
1931 704414 100       && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1932           {
1933           return o;
1934           }
1935            
1936           assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1937            
1938 105817525 100       if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1939            
1940 105817525         switch (o->op_type) {
1941           case OP_UNDEF:
1942 177361         PL_modcount++;
1943 177361         return o;
1944           case OP_STUB:
1945 48382 100       if ((o->op_flags & OPf_PARENS) || PL_madskills)
1946           break;
1947           goto nomod;
1948           case OP_ENTERSUB:
1949 5581257 100       if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
    100        
    100        
1950 1403324         !(o->op_flags & OPf_STACKED)) {
1951 1403248         o->op_type = OP_RV2CV; /* entersub => rv2cv */
1952           /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1953           poses, so we need it clear. */
1954 1403248         o->op_private &= ~1;
1955 1403248         o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1956           assert(cUNOPo->op_first->op_type == OP_NULL);
1957 1403248         op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1958 1403248         break;
1959           }
1960           else { /* lvalue subroutine call */
1961 3496142 100       o->op_private |= OPpLVAL_INTRO
1962           |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1963 3496142         PL_modcount = RETURN_UNLIMITED_NUMBER;
1964 3496142 100       if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
    100        
1965           /* Potential lvalue context: */
1966 3495630         o->op_private |= OPpENTERSUB_INARGS;
1967 3495630         break;
1968           }
1969           else { /* Compile-time error message: */
1970 512         OP *kid = cUNOPo->op_first;
1971           CV *cv;
1972            
1973 512 100       if (kid->op_type != OP_PUSHMARK) {
1974 490 50       if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
    50        
1975 0         Perl_croak(aTHX_
1976           "panic: unexpected lvalue entersub "
1977           "args: type/targ %ld:%"UVuf,
1978 0         (long)kid->op_type, (UV)kid->op_targ);
1979 501         kid = kLISTOP->op_first;
1980           }
1981 1156 100       while (kid->op_sibling)
1982 644         kid = kid->op_sibling;
1983 512 100       if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
    50        
1984           break; /* Postpone until runtime */
1985           }
1986            
1987 490         kid = kUNOP->op_first;
1988 490 50       if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
    0        
1989 0         kid = kUNOP->op_first;
1990 490 50       if (kid->op_type == OP_NULL)
1991 0         Perl_croak(aTHX_
1992           "Unexpected constant lvalue entersub "
1993           "entry via type/targ %ld:%"UVuf,
1994 0         (long)kid->op_type, (UV)kid->op_targ);
1995 490 100       if (kid->op_type != OP_GV) {
1996           break;
1997           }
1998            
1999 244         cv = GvCV(kGVOP_gv);
2000 244 100       if (!cv)
2001           break;
2002 226 100       if (CvLVALUE(cv))
2003           break;
2004           }
2005           }
2006           /* FALL THROUGH */
2007           default:
2008           nomod:
2009 22265383 100       if (flags & OP_LVALUE_NO_CROAK) return NULL;
2010           /* grep, foreach, subcalls, refgen */
2011 22265375 100       if (type == OP_GREPSTART || type == OP_ENTERSUB
2012 2093401 100       || type == OP_REFGEN || type == OP_LEAVESUBLV)
2013           break;
2014 66 50       yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
    50        
    0        
    100        
    50        
    0        
2015           (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2016           ? "do block"
2017           : (o->op_type == OP_ENTERSUB
2018           ? "non-lvalue subroutine call"
2019           : OP_DESC(o))),
2020           type ? PL_op_desc[type] : "local"));
2021 66         return o;
2022            
2023           case OP_PREINC:
2024           case OP_PREDEC:
2025           case OP_POW:
2026           case OP_MULTIPLY:
2027           case OP_DIVIDE:
2028           case OP_MODULO:
2029           case OP_REPEAT:
2030           case OP_ADD:
2031           case OP_SUBTRACT:
2032           case OP_CONCAT:
2033           case OP_LEFT_SHIFT:
2034           case OP_RIGHT_SHIFT:
2035           case OP_BIT_AND:
2036           case OP_BIT_XOR:
2037           case OP_BIT_OR:
2038           case OP_I_MULTIPLY:
2039           case OP_I_DIVIDE:
2040           case OP_I_MODULO:
2041           case OP_I_ADD:
2042           case OP_I_SUBTRACT:
2043 372560 100       if (!(o->op_flags & OPf_STACKED))
2044           goto nomod;
2045 64760         PL_modcount++;
2046 64760         break;
2047            
2048           case OP_COND_EXPR:
2049           localize = 1;
2050 614538 100       for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2051 409692         op_lvalue(kid, type);
2052           break;
2053            
2054           case OP_RV2AV:
2055           case OP_RV2HV:
2056 5409725 100       if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
    100        
2057 8         PL_modcount = RETURN_UNLIMITED_NUMBER;
2058 8         return o; /* Treat \(@foo) like ordinary list. */
2059           }
2060           /* FALL THROUGH */
2061           case OP_RV2GV:
2062 6576689 100       if (scalar_mod_type(o, type))
2063           goto nomod;
2064 6576671         ref(cUNOPo->op_first, o->op_type);
2065           /* FALL THROUGH */
2066           case OP_ASLICE:
2067           case OP_HSLICE:
2068           localize = 1;
2069           /* FALL THROUGH */
2070           case OP_AASSIGN:
2071 6796198 100       if (type == OP_LEAVESUBLV)
2072 32         o->op_private |= OPpMAYBE_LVSUB;
2073           /* FALL THROUGH */
2074           case OP_NEXTSTATE:
2075           case OP_DBSTATE:
2076 6796202         PL_modcount = RETURN_UNLIMITED_NUMBER;
2077 6796202         break;
2078           case OP_AV2ARYLEN:
2079 15546         PL_hints |= HINT_BLOCK_SCOPE;
2080 15546 100       if (type == OP_LEAVESUBLV)
2081 2         o->op_private |= OPpMAYBE_LVSUB;
2082 15546         PL_modcount++;
2083 15546         break;
2084           case OP_RV2SV:
2085 4228017         ref(cUNOPo->op_first, o->op_type);
2086           localize = 1;
2087           /* FALL THROUGH */
2088           case OP_GV:
2089 4228021         PL_hints |= HINT_BLOCK_SCOPE;
2090           case OP_SASSIGN:
2091           case OP_ANDASSIGN:
2092           case OP_ORASSIGN:
2093           case OP_DORASSIGN:
2094 4387864         PL_modcount++;
2095 4387864         break;
2096            
2097           case OP_AELEMFAST:
2098           case OP_AELEMFAST_LEX:
2099           localize = -1;
2100 0         PL_modcount++;
2101 0         break;
2102            
2103           case OP_PADAV:
2104           case OP_PADHV:
2105 4048874         PL_modcount = RETURN_UNLIMITED_NUMBER;
2106 4048874 100       if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
    100        
2107           return o; /* Treat \(@foo) like ordinary list. */
2108 4048858 100       if (scalar_mod_type(o, type))
2109           goto nomod;
2110 4048852 100       if (type == OP_LEAVESUBLV)
2111 16         o->op_private |= OPpMAYBE_LVSUB;
2112           /* FALL THROUGH */
2113           case OP_PADSV:
2114 46337798         PL_modcount++;
2115 46337798 100       if (!type) /* local() */
2116 4         Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2117 4         PAD_COMPNAME_SV(o->op_targ));
2118           break;
2119            
2120           case OP_PUSHMARK:
2121           localize = 0;
2122           break;
2123            
2124           case OP_KEYS:
2125           case OP_RKEYS:
2126 228925 100       if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2127           goto nomod;
2128           goto lvalue_func;
2129           case OP_SUBSTR:
2130 80511 100       if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2131           goto nomod;
2132           /* FALL THROUGH */
2133           case OP_POS:
2134           case OP_VEC:
2135           lvalue_func:
2136 231733 100       if (type == OP_LEAVESUBLV)
2137 24         o->op_private |= OPpMAYBE_LVSUB;
2138 231733 50       if (o->op_flags & OPf_KIDS)
2139 231733         op_lvalue(cBINOPo->op_first->op_sibling, type);
2140           break;
2141            
2142           case OP_AELEM:
2143           case OP_HELEM:
2144 5524151         ref(cBINOPo->op_first, o->op_type);
2145 6068677 100       if (type == OP_ENTERSUB &&
    50        
2146 1154210         !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2147 1154210         o->op_private |= OPpLVAL_DEFER;
2148 5524151 100       if (type == OP_LEAVESUBLV)
2149 5358         o->op_private |= OPpMAYBE_LVSUB;
2150           localize = 1;
2151 5524151         PL_modcount++;
2152 5524151         break;
2153            
2154           case OP_SCOPE:
2155           case OP_LEAVE:
2156           case OP_ENTER:
2157           case OP_LINESEQ:
2158           localize = 0;
2159 5882 50       if (o->op_flags & OPf_KIDS)
2160 5882         op_lvalue(cLISTOPo->op_last, type);
2161           break;
2162            
2163           case OP_NULL:
2164           localize = 0;
2165 4559285 100       if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2166           goto nomod;
2167 4555479 100       else if (!(o->op_flags & OPf_KIDS))
2168           break;
2169 4555475 100       if (o->op_targ != OP_LIST) {
2170 286506         op_lvalue(cBINOPo->op_first, type);
2171 286506         break;
2172           }
2173           /* FALL THROUGH */
2174           case OP_LIST:
2175           localize = 0;
2176 25720168 100       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2177           /* elements might be in void context because the list is
2178           in scalar context or because they are attribute sub calls */
2179 18754912 100       if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2180 18754862         op_lvalue(kid, type);
2181           break;
2182            
2183           case OP_RETURN:
2184 40 50       if (type != OP_LEAVESUBLV)
2185           goto nomod;
2186           break; /* op_lvalue()ing was handled by ck_return() */
2187            
2188           case OP_COREARGS:
2189           return o;
2190           }
2191            
2192           /* [20011101.069] File test operators interpret OPf_REF to mean that
2193           their argument is a filehandle; thus \stat(".") should not set
2194           it. AMS 20011102 */
2195 110927459 100       if (type == OP_REFGEN &&
    100        
2196 10941604         PL_check[o->op_type] == Perl_ck_ftst)
2197           return o;
2198            
2199 105640042 100       if (type != OP_LEAVESUBLV)
2200 105627600         o->op_flags |= OPf_MOD;
2201            
2202 105640042 100       if (type == OP_AASSIGN || type == OP_SASSIGN)
2203 34739817         o->op_flags |= OPf_SPECIAL|OPf_REF;
2204 70900225 100       else if (!type) { /* local() */
2205 1326589         switch (localize) {
2206           case 1:
2207 1150045         o->op_private |= OPpLVAL_INTRO;
2208 1150045         o->op_flags &= ~OPf_SPECIAL;
2209 1150045         PL_hints |= HINT_BLOCK_SCOPE;
2210 1150045         break;
2211           case 0:
2212           break;
2213           case -1:
2214 84 50       Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2215 28 0       "Useless localization of %s", OP_DESC(o));
2216           }
2217           }
2218 69573636 100       else if (type != OP_GREPSTART && type != OP_ENTERSUB
2219 18848660 100       && type != OP_LEAVESUBLV)
2220 63607081         o->op_flags |= OPf_REF;
2221           return o;
2222           }
2223            
2224           STATIC bool
2225 10635877         S_scalar_mod_type(const OP *o, I32 type)
2226           {
2227 10635877         switch (type) {
2228           case OP_POS:
2229           case OP_SASSIGN:
2230 854835 100       if (o && o->op_type == OP_RV2GV)
    100        
2231           return FALSE;
2232           /* FALL THROUGH */
2233           case OP_PREINC:
2234           case OP_PREDEC:
2235           case OP_POSTINC:
2236           case OP_POSTDEC:
2237           case OP_I_PREINC:
2238           case OP_I_PREDEC:
2239           case OP_I_POSTINC:
2240           case OP_I_POSTDEC:
2241           case OP_POW:
2242           case OP_MULTIPLY:
2243           case OP_DIVIDE:
2244           case OP_MODULO:
2245           case OP_REPEAT:
2246           case OP_ADD:
2247           case OP_SUBTRACT:
2248           case OP_I_MULTIPLY:
2249           case OP_I_DIVIDE:
2250           case OP_I_MODULO:
2251           case OP_I_ADD:
2252           case OP_I_SUBTRACT:
2253           case OP_LEFT_SHIFT:
2254           case OP_RIGHT_SHIFT:
2255           case OP_BIT_AND:
2256           case OP_BIT_XOR:
2257           case OP_BIT_OR:
2258           case OP_CONCAT:
2259           case OP_SUBST:
2260           case OP_TRANS:
2261           case OP_TRANSR:
2262           case OP_READ:
2263           case OP_SYSREAD:
2264           case OP_RECV:
2265           case OP_ANDASSIGN:
2266           case OP_ORASSIGN:
2267           case OP_DORASSIGN:
2268 5528744         return TRUE;
2269           default:
2270           return FALSE;
2271           }
2272           }
2273            
2274           STATIC bool
2275 331388         S_is_handle_constructor(const OP *o, I32 numargs)
2276           {
2277           PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2278            
2279 331388         switch (o->op_type) {
2280           case OP_PIPE_OP:
2281           case OP_SOCKPAIR:
2282 8182 100       if (numargs == 2)
2283           return TRUE;
2284           /* FALL THROUGH */
2285           case OP_SYSOPEN:
2286           case OP_OPEN:
2287           case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2288           case OP_SOCKET:
2289           case OP_OPEN_DIR:
2290           case OP_ACCEPT:
2291 129935 100       if (numargs == 1)
2292           return TRUE;
2293           /* FALLTHROUGH */
2294           default:
2295 267015         return FALSE;
2296           }
2297           }
2298            
2299           static OP *
2300           S_refkids(pTHX_ OP *o, I32 type)
2301           {
2302 2796604 50       if (o && o->op_flags & OPf_KIDS) {
    100        
2303           OP *kid;
2304 5593212 100       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2305 2796610         ref(kid, type);
2306           }
2307           return o;
2308           }
2309            
2310           OP *
2311 78747716         Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2312           {
2313           dVAR;
2314           OP *kid;
2315            
2316           PERL_ARGS_ASSERT_DOREF;
2317            
2318 78747716 50       if (!o || (PL_parser && PL_parser->error_count))
    50        
    100        
2319           return o;
2320            
2321 78747700         switch (o->op_type) {
2322           case OP_ENTERSUB:
2323 679792 100       if ((type == OP_EXISTS || type == OP_DEFINED) &&
    100        
2324 382036         !(o->op_flags & OPf_STACKED)) {
2325 337478         o->op_type = OP_RV2CV; /* entersub => rv2cv */
2326 337478         o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2327           assert(cUNOPo->op_first->op_type == OP_NULL);
2328 337478         op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2329 337478         o->op_flags |= OPf_SPECIAL;
2330 337478         o->op_private &= ~1;
2331           }
2332 158496 100       else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
    100        
2333 107102 100       o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
    100        
2334           : type == OP_RV2HV ? OPpDEREF_HV
2335           : OPpDEREF_SV);
2336 107102         o->op_flags |= OPf_MOD;
2337           }
2338            
2339           break;
2340            
2341           case OP_COND_EXPR:
2342 1842 100       for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2343 1228         doref(kid, type, set_op_ref);
2344           break;
2345           case OP_RV2SV:
2346 591736 100       if (type == OP_DEFINED)
2347 295034         o->op_flags |= OPf_SPECIAL; /* don't create GV */
2348 591736         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2349           /* FALL THROUGH */
2350           case OP_PADSV:
2351 15882668 100       if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
    100        
2352 13172768 100       o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
    100        
2353           : type == OP_RV2HV ? OPpDEREF_HV
2354           : OPpDEREF_SV);
2355 13172768         o->op_flags |= OPf_MOD;
2356           }
2357           break;
2358            
2359           case OP_RV2AV:
2360           case OP_RV2HV:
2361 27218251 100       if (set_op_ref)
2362 26597853         o->op_flags |= OPf_REF;
2363           /* FALL THROUGH */
2364           case OP_RV2GV:
2365 29176098 100       if (type == OP_DEFINED)
2366 200         o->op_flags |= OPf_SPECIAL; /* don't create GV */
2367 29176098         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2368 29176098         break;
2369            
2370           case OP_PADAV:
2371           case OP_PADHV:
2372 4693066 100       if (set_op_ref)
2373 4598440         o->op_flags |= OPf_REF;
2374           break;
2375            
2376           case OP_SCALAR:
2377           case OP_NULL:
2378 72304 100       if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2379           break;
2380 23084         doref(cBINOPo->op_first, type, set_op_ref);
2381 23084         break;
2382           case OP_AELEM:
2383           case OP_HELEM:
2384 7064833         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2385 7064833 100       if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
    100        
2386 6516745 100       o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
    100        
2387           : type == OP_RV2HV ? OPpDEREF_HV
2388           : OPpDEREF_SV);
2389 7417760         o->op_flags |= OPf_MOD;
2390           }
2391           break;
2392            
2393           case OP_SCOPE:
2394           case OP_LEAVE:
2395           set_op_ref = FALSE;
2396           /* FALL THROUGH */
2397           case OP_ENTER:
2398           case OP_LIST:
2399 1719958 50       if (!(o->op_flags & OPf_KIDS))
2400           break;
2401 1719958         doref(cLISTOPo->op_last, type, set_op_ref);
2402 1719958         break;
2403           default:
2404           break;
2405           }
2406 78747708         return scalar(o);
2407            
2408           }
2409            
2410           STATIC OP *
2411 216         S_dup_attrlist(pTHX_ OP *o)
2412           {
2413           dVAR;
2414           OP *rop;
2415            
2416           PERL_ARGS_ASSERT_DUP_ATTRLIST;
2417            
2418           /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2419           * where the first kid is OP_PUSHMARK and the remaining ones
2420           * are OP_CONST. We need to push the OP_CONST values.
2421           */
2422 216 100       if (o->op_type == OP_CONST)
2423 321         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2424           #ifdef PERL_MAD
2425           else if (o->op_type == OP_NULL)
2426           rop = NULL;
2427           #endif
2428           else {
2429           assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2430           rop = NULL;
2431 8 100       for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2432 6 100       if (o->op_type == OP_CONST)
2433 6         rop = op_append_elem(OP_LIST, rop,
2434           newSVOP(OP_CONST, o->op_flags,
2435           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2436           }
2437           }
2438 216         return rop;
2439           }
2440            
2441           STATIC void
2442 116         S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2443           {
2444           dVAR;
2445 116 50       SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
    50        
    50        
    50        
2446            
2447           PERL_ARGS_ASSERT_APPLY_ATTRS;
2448            
2449           /* fake up C */
2450 116         ENTER; /* need to protect against side-effects of 'use' */
2451            
2452           #define ATTRSMODULE "attributes"
2453           #define ATTRSMODULE_PM "attributes.pm"
2454            
2455 116         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2456           newSVpvs(ATTRSMODULE),
2457           NULL,
2458           op_prepend_elem(OP_LIST,
2459           newSVOP(OP_CONST, 0, stashsv),
2460           op_prepend_elem(OP_LIST,
2461           newSVOP(OP_CONST, 0,
2462           newRV(target)),
2463           dup_attrlist(attrs))));
2464 108         LEAVE;
2465 108         }
2466            
2467           STATIC void
2468 100         S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2469           {
2470           dVAR;
2471           OP *pack, *imop, *arg;
2472           SV *meth, *stashsv, **svp;
2473            
2474           PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2475            
2476 100 50       if (!attrs)
2477 100         return;
2478            
2479           assert(target->op_type == OP_PADSV ||
2480           target->op_type == OP_PADHV ||
2481           target->op_type == OP_PADAV);
2482            
2483           /* Ensure that attributes.pm is loaded. */
2484 100         ENTER; /* need to protect against side-effects of 'use' */
2485           /* Don't force the C if we don't need it. */
2486 100 50       svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2487 100 100       if (svp && *svp != &PL_sv_undef)
    50        
2488           NOOP; /* already in %INC */
2489           else
2490 14         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2491           newSVpvs(ATTRSMODULE), NULL);
2492 100         LEAVE;
2493            
2494           /* Need package name for method call. */
2495 100         pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2496            
2497           /* Build up the real arg-list. */
2498 100 50       stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
    50        
    50        
    50        
2499            
2500 100         arg = newOP(OP_PADSV, 0);
2501 100         arg->op_targ = target->op_targ;
2502 100         arg = op_prepend_elem(OP_LIST,
2503           newSVOP(OP_CONST, 0, stashsv),
2504           op_prepend_elem(OP_LIST,
2505           newUNOP(OP_REFGEN, 0,
2506           op_lvalue(arg, OP_REFGEN)),
2507           dup_attrlist(attrs)));
2508            
2509           /* Fake up a method call to import */
2510 100         meth = newSVpvs_share("import");
2511 100         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2512           op_append_elem(OP_LIST,
2513           op_prepend_elem(OP_LIST, pack, list(arg)),
2514           newSVOP(OP_METHOD_NAMED, 0, meth)));
2515            
2516           /* Combine the ops. */
2517 100         *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2518           }
2519            
2520           /*
2521           =notfor apidoc apply_attrs_string
2522            
2523           Attempts to apply a list of attributes specified by the C and
2524           C arguments to the subroutine identified by the C argument which
2525           is expected to be associated with the package identified by the C
2526           argument (see L). It gets this wrong, though, in that it
2527           does not correctly identify the boundaries of the individual attribute
2528           specifications within C. This is not really intended for the
2529           public API, but has to be listed here for systems such as AIX which
2530           need an explicit export list for symbols. (It's called from XS code
2531           in support of the C keyword from F.) Patches to fix it
2532           to respect attribute syntax properly would be welcome.
2533            
2534           =cut
2535           */
2536            
2537           void
2538 2         Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2539           const char *attrstr, STRLEN len)
2540           {
2541           OP *attrs = NULL;
2542            
2543           PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2544            
2545 2 50       if (!len) {
2546 2         len = strlen(attrstr);
2547           }
2548            
2549 4 100       while (len) {
2550 1 50       for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2551 2 50       if (len) {
2552           const char * const sstr = attrstr;
2553 13 100       for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2554 3         attrs = op_append_elem(OP_LIST, attrs,
2555           newSVOP(OP_CONST, 0,
2556           newSVpvn(sstr, attrstr-sstr)));
2557           }
2558           }
2559            
2560 2         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2561           newSVpvs(ATTRSMODULE),
2562           NULL, op_prepend_elem(OP_LIST,
2563           newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2564           op_prepend_elem(OP_LIST,
2565           newSVOP(OP_CONST, 0,
2566           newRV(MUTABLE_SV(cv))),
2567           attrs)));
2568 2         }
2569            
2570           STATIC OP *
2571 25785423         S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2572           {
2573           dVAR;
2574           I32 type;
2575 25785423 50       const bool stately = PL_parser && PL_parser->in_my == KEY_state;
    100        
2576            
2577           PERL_ARGS_ASSERT_MY_KID;
2578            
2579 25785423 50       if (!o || (PL_parser && PL_parser->error_count))
    50        
    100        
2580           return o;
2581            
2582 25785391         type = o->op_type;
2583           if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2584           (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2585           return o;
2586           }
2587            
2588 25785391 100       if (type == OP_LIST) {
2589           OP *kid;
2590 11915214 100       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2591 9346976         my_kid(kid, attrs, imopsp);
2592           return o;
2593 23217153 100       } else if (type == OP_UNDEF || type == OP_STUB) {
2594           return o;
2595 34296062 100       } else if (type == OP_RV2SV || /* "our" declaration */
2596 33461486 100       type == OP_RV2AV ||
2597           type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2598 970029 100       if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2599 8 50       yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
    50        
    50        
    0        
2600           OP_DESC(o),
2601           PL_parser->in_my == KEY_our
2602           ? "our"
2603           : PL_parser->in_my == KEY_state ? "state" : "my"));
2604 970021 100       } else if (attrs) {
2605 4         GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2606 4         PL_parser->in_my = FALSE;
2607 4         PL_parser->in_my_stash = NULL;
2608 4 50       apply_attrs(GvSTASH(gv),
    0        
    0        
2609           (type == OP_RV2SV ? GvSV(gv) :
2610           type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2611           type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2612           attrs);
2613           }
2614 970029         o->op_private |= OPpOUR_INTRO;
2615 970029         return o;
2616           }
2617 22154261 50       else if (type != OP_PADSV &&
2618 22154261         type != OP_PADAV &&
2619 22154261         type != OP_PADHV &&
2620 22154261         type != OP_PUSHMARK)
2621           {
2622 0 0       yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
    0        
    0        
    0        
2623           OP_DESC(o),
2624           PL_parser->in_my == KEY_our
2625           ? "our"
2626           : PL_parser->in_my == KEY_state ? "state" : "my"));
2627 0         return o;
2628           }
2629 22154261 100       else if (attrs && type != OP_PUSHMARK) {
2630           HV *stash;
2631            
2632 100         PL_parser->in_my = FALSE;
2633 100         PL_parser->in_my_stash = NULL;
2634            
2635           /* check for C when deciding package */
2636 100         stash = PAD_COMPNAME_TYPE(o->op_targ);
2637 100 100       if (!stash)
2638 86         stash = PL_curstash;
2639 100         apply_attrs_my(stash, o, attrs, imopsp);
2640           }
2641 22154261         o->op_flags |= OPf_MOD;
2642 22154261         o->op_private |= OPpLVAL_INTRO;
2643 22154261 100       if (stately)
2644 13328515         o->op_private |= OPpPAD_STATE;
2645           return o;
2646           }
2647            
2648           OP *
2649 16438447         Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2650           {
2651           dVAR;
2652           OP *rops;
2653           int maybe_scalar = 0;
2654            
2655           PERL_ARGS_ASSERT_MY_ATTRS;
2656            
2657           /* [perl #17376]: this appears to be premature, and results in code such as
2658           C< our(%x); > executing in list mode rather than void mode */
2659           #if 0
2660           if (o->op_flags & OPf_PARENS)
2661           list(o);
2662           else
2663           maybe_scalar = 1;
2664           #else
2665           maybe_scalar = 1;
2666           #endif
2667 16438447 100       if (attrs)
2668 104         SAVEFREEOP(attrs);
2669 16438447         rops = NULL;
2670 16438447         o = my_kid(o, attrs, &rops);
2671 16438447 100       if (rops) {
2672 100 100       if (maybe_scalar && o->op_type == OP_PADSV) {
2673 56         o = scalar(op_append_list(OP_LIST, rops, o));
2674 56         o->op_private |= OPpLVAL_INTRO;
2675           }
2676           else {
2677           /* The listop in rops might have a pushmark at the beginning,
2678           which will mess up list assignment. */
2679 44         LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2680 44 50       if (rops->op_type == OP_LIST &&
    0        
2681 0 0       lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2682           {
2683 0         OP * const pushmark = lrops->op_first;
2684 0         lrops->op_first = pushmark->op_sibling;
2685 0         op_free(pushmark);
2686           }
2687 44         o = op_append_list(OP_LIST, o, rops);
2688           }
2689           }
2690 16438447         PL_parser->in_my = FALSE;
2691 16438447         PL_parser->in_my_stash = NULL;
2692 16438447         return o;
2693           }
2694            
2695           OP *
2696 9534048         Perl_sawparens(pTHX_ OP *o)
2697           {
2698           PERL_UNUSED_CONTEXT;
2699 9566138 50       if (o)
2700 9566138         o->op_flags |= OPf_PARENS;
2701 9534048         return o;
2702           }
2703            
2704           OP *
2705 3316769         Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2706           {
2707           OP *o;
2708           bool ismatchop = 0;
2709 3689593         const OPCODE ltype = left->op_type;
2710 3689593         const OPCODE rtype = right->op_type;
2711            
2712           PERL_ARGS_ASSERT_BIND_MATCH;
2713            
2714 3689593 100       if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2715 3689578 100       || ltype == OP_PADHV) && ckWARN(WARN_MISC))
    100        
2716           {
2717 24         const char * const desc
2718           = PL_op_desc[(
2719 24         rtype == OP_SUBST || rtype == OP_TRANS
2720 8 50       || rtype == OP_TRANSR
2721           )
2722 32 100       ? (int)rtype : OP_MATCH];
2723 24         const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2724           GV *gv;
2725           SV * const name =
2726 24         (ltype == OP_RV2AV || ltype == OP_RV2HV)
2727 20         ? cUNOPx(left)->op_first->op_type == OP_GV
2728 8 50       && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2729 8 100       ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2730 28 100       : NULL
2731 26 100       : varname(
    100        
2732           (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2733           );
2734 24 100       if (name)
2735 12         Perl_warner(aTHX_ packWARN(WARN_MISC),
2736           "Applying %s to %"SVf" will act on scalar(%"SVf")",
2737           desc, name, name);
2738           else {
2739           const char * const sample = (isary
2740 12 100       ? "@array" : "%hash");
2741 12         Perl_warner(aTHX_ packWARN(WARN_MISC),
2742           "Applying %s to %s will act on scalar(%s)",
2743           desc, sample, sample);
2744           }
2745           }
2746            
2747 3689593 100       if (rtype == OP_CONST &&
2748 10692 100       cSVOPx(right)->op_private & OPpCONST_BARE &&
2749           cSVOPx(right)->op_private & OPpCONST_STRICT)
2750           {
2751 2         no_bareword_allowed(right);
2752           }
2753            
2754           /* !~ doesn't make sense with /r, so error on it for now */
2755 4200983 100       if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
    100        
2756 1063087         type == OP_NOT)
2757 4         yyerror("Using !~ with s///r doesn't make sense");
2758 3689593 100       if (rtype == OP_TRANSR && type == OP_NOT)
2759 2         yyerror("Using !~ with tr///r doesn't make sense");
2760            
2761 11068779         ismatchop = (rtype == OP_MATCH ||
2762 3689593         rtype == OP_SUBST ||
2763 455954 100       rtype == OP_TRANS || rtype == OP_TRANSR)
2764 5513508 100       && !(right->op_flags & OPf_SPECIAL);
    100        
2765 3689593 100       if (ismatchop && right->op_private & OPpTARGET_MY) {
    100        
2766 44         right->op_targ = 0;
2767 44         right->op_private &= ~OPpTARGET_MY;
2768           }
2769 3689593 50       if (!(right->op_flags & OPf_STACKED) && ismatchop) {
    100        
2770           OP *newleft;
2771            
2772 3316769         right->op_flags |= OPf_STACKED;
2773 3316769 100       if (rtype != OP_MATCH && rtype != OP_TRANSR &&
    100        
2774 83122 100       ! (rtype == OP_TRANS &&
2775 1131178 100       right->op_private & OPpTRANS_IDENTICAL) &&
2776 1063083 100       ! (rtype == OP_SUBST &&
2777 1063083         (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2778 1087927         newleft = op_lvalue(left, rtype);
2779           else
2780           newleft = left;
2781 3316769 100       if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2782 83138         o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2783           else
2784 3233631         o = op_prepend_elem(rtype, scalar(newleft), right);
2785 3316769 100       if (type == OP_NOT)
2786 265266         return newUNOP(OP_NOT, 0, scalar(o));
2787           return o;
2788           }
2789           else
2790 2099421         return bind_match(type, left,
2791           pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2792           }
2793            
2794           OP *
2795 657547         Perl_invert(pTHX_ OP *o)
2796           {
2797 657547 50       if (!o)
2798           return NULL;
2799 657547         return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2800           }
2801            
2802           /*
2803           =for apidoc Amx|OP *|op_scope|OP *o
2804            
2805           Wraps up an op tree with some additional ops so that at runtime a dynamic
2806           scope will be created. The original ops run in the new dynamic scope,
2807           and then, provided that they exit normally, the scope will be unwound.
2808           The additional ops used to create and unwind the dynamic scope will
2809           normally be an C/C pair, but a C op may be used
2810           instead if the ops are simple enough to not need the full dynamic scope
2811           structure.
2812            
2813           =cut
2814           */
2815            
2816           OP *
2817 14292462         Perl_op_scope(pTHX_ OP *o)
2818           {
2819           dVAR;
2820 14292462 50       if (o) {
2821 14292462 100       if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
    100        
    100        
    100        
2822 9497413         o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2823 9497413         o->op_type = OP_LEAVE;
2824 9497413         o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2825           }
2826 4795049 100       else if (o->op_type == OP_LINESEQ) {
2827           OP *kid;
2828 4747429         o->op_type = OP_SCOPE;
2829 4747429         o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2830 4747429         kid = ((LISTOP*)o)->op_first;
2831 4747429 50       if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2832 4747429         op_null(kid);
2833            
2834           /* The following deals with things like 'do {1 for 1}' */
2835 4747429         kid = kid->op_sibling;
2836 7011348 50       if (kid &&
    50        
2837 4747429         (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2838 0         op_null(kid);
2839           }
2840           }
2841           else
2842 47620         o = newLISTOP(OP_SCOPE, 0, o, NULL);
2843           }
2844 14292462         return o;
2845           }
2846            
2847           OP *
2848 316         Perl_op_unscope(pTHX_ OP *o)
2849           {
2850 316 100       if (o && o->op_type == OP_LINESEQ) {
    50        
2851 308         OP *kid = cLISTOPo->op_first;
2852 932 100       for(; kid; kid = kid->op_sibling)
2853 624 100       if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2854 312         op_null(kid);
2855           }
2856 316         return o;
2857           }
2858            
2859           int
2860 37407361         Perl_block_start(pTHX_ int full)
2861           {
2862           dVAR;
2863 37407361         const int retval = PL_savestack_ix;
2864            
2865 37407361         pad_block_start(full);
2866 37407361         SAVEHINTS();
2867 37407355         PL_hints &= ~HINT_BLOCK_SCOPE;
2868 37407355         SAVECOMPILEWARNINGS();
2869 55432314 100       PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
    100        
2870            
2871 37705535 100       CALL_BLOCK_HOOKS(bhk_start, full);
    50        
    50        
    50        
    50        
    100        
2872            
2873 37407355         return retval;
2874           }
2875            
2876           OP*
2877 37345311         Perl_block_end(pTHX_ I32 floor, OP *seq)
2878           {
2879           dVAR;
2880 37345311         const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2881 37345311         OP* retval = scalarseq(seq);
2882           OP *o;
2883            
2884 37643449 100       CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
    50        
    50        
    50        
    50        
    100        
2885            
2886 37345305 100       LEAVE_SCOPE(floor);
2887 37345305 100       if (needblockscope)
2888 23872703         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2889 37345305         o = pad_leavemy();
2890            
2891 37345305 100       if (o) {
2892           /* pad_leavemy has created a sequence of introcv ops for all my
2893           subs declared in the block. We have to replicate that list with
2894           clonecv ops, to deal with this situation:
2895            
2896           sub {
2897           my sub s1;
2898           my sub s2;
2899           sub s1 { state sub foo { \&s2 } }
2900           }->()
2901            
2902           Originally, I was going to have introcv clone the CV and turn
2903           off the stale flag. Since &s1 is declared before &s2, the
2904           introcv op for &s1 is executed (on sub entry) before the one for
2905           &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2906           cloned, since it is a state sub) closes over &s2 and expects
2907           to see it in its outer CV’s pad. If the introcv op clones &s1,
2908           then &s2 is still marked stale. Since &s1 is not active, and
2909           &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
2910           ble will not stay shared’ warning. Because it is the same stub
2911           that will be used when the introcv op for &s2 is executed, clos-
2912           ing over it is safe. Hence, we have to turn off the stale flag
2913           on all lexical subs in the block before we clone any of them.
2914           Hence, having introcv clone the sub cannot work. So we create a
2915           list of ops like this:
2916            
2917           lineseq
2918           |
2919           +-- introcv
2920           |
2921           +-- introcv
2922           |
2923           +-- introcv
2924           |
2925           .
2926           .
2927           .
2928           |
2929           +-- clonecv
2930           |
2931           +-- clonecv
2932           |
2933           +-- clonecv
2934           |
2935           .
2936           .
2937           .
2938           */
2939 86 100       OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
2940 86 100       OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
2941 22         for (;; kid = kid->op_sibling) {
2942 108         OP *newkid = newOP(OP_CLONECV, 0);
2943 108         newkid->op_targ = kid->op_targ;
2944 108         o = op_append_elem(OP_LINESEQ, o, newkid);
2945 108 100       if (kid == last) break;
2946 22         }
2947 86         retval = op_prepend_elem(OP_LINESEQ, o, retval);
2948           }
2949            
2950 37643449 100       CALL_BLOCK_HOOKS(bhk_post_end, &retval);
    50        
    100        
    50        
    50        
    100        
2951            
2952 37345305         return retval;
2953           }
2954            
2955           /*
2956           =head1 Compile-time scope hooks
2957            
2958           =for apidoc Aox||blockhook_register
2959            
2960           Register a set of hooks to be called when the Perl lexical scope changes
2961           at compile time. See L.
2962            
2963           =cut
2964           */
2965            
2966           void
2967 352         Perl_blockhook_register(pTHX_ BHK *hk)
2968           {
2969           PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2970            
2971 352         Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2972 352         }
2973            
2974           STATIC OP *
2975 161427         S_newDEFSVOP(pTHX)
2976           {
2977           dVAR;
2978 161427         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2979 161427 100       if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
    100        
2980 161381         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2981           }
2982           else {
2983 46         OP * const o = newOP(OP_PADSV, 0);
2984 46         o->op_targ = offset;
2985 83256         return o;
2986           }
2987           }
2988            
2989           void
2990 4210875         Perl_newPROG(pTHX_ OP *o)
2991           {
2992           dVAR;
2993            
2994           PERL_ARGS_ASSERT_NEWPROG;
2995            
2996 4210875 100       if (PL_in_eval) {
2997           PERL_CONTEXT *cx;
2998           I32 i;
2999 4191275 50       if (PL_eval_root)
3000           return;
3001 4191275 100       PL_eval_root = newUNOP(OP_LEAVEEVAL,
3002           ((PL_in_eval & EVAL_KEEPERR)
3003           ? OPf_SPECIAL : 0), o);
3004            
3005 4191275         cx = &cxstack[cxstack_ix];
3006           assert(CxTYPE(cx) == CXt_EVAL);
3007            
3008 4191275 100       if ((cx->blk_gimme & G_WANT) == G_VOID)
3009 405180         scalarvoid(PL_eval_root);
3010 3786095 100       else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3011 2114         list(PL_eval_root);
3012           else
3013 3783981         scalar(PL_eval_root);
3014            
3015 4191275         PL_eval_start = op_linklist(PL_eval_root);
3016 4191275         PL_eval_root->op_private |= OPpREFCOUNTED;
3017 4191275         OpREFCNT_set(PL_eval_root, 1);
3018 4191275         PL_eval_root->op_next = 0;
3019 4191275         i = PL_savestack_ix;
3020 4191275         SAVEFREEOP(o);
3021 4191275         ENTER;
3022 4191275         CALL_PEEP(PL_eval_start);
3023 4191275         finalize_optree(PL_eval_root);
3024 4191265         LEAVE;
3025 4191265         PL_savestack_ix = i;
3026           }
3027           else {
3028 19600 100       if (o->op_type == OP_STUB) {
3029           /* This block is entered if nothing is compiled for the main
3030           program. This will be the case for an genuinely empty main
3031           program, or one which only has BEGIN blocks etc, so already
3032           run and freed.
3033            
3034           Historically (5.000) the guard above was !o. However, commit
3035           f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3036           c71fccf11fde0068, changed perly.y so that newPROG() is now
3037           called with the output of block_end(), which returns a new
3038           OP_STUB for the case of an empty optree. ByteLoader (and
3039           maybe other things) also take this path, because they set up
3040           PL_main_start and PL_main_root directly, without generating an
3041           optree.
3042            
3043           If the parsing the main program aborts (due to parse errors,
3044           or due to BEGIN or similar calling exit), then newPROG()
3045           isn't even called, and hence this code path and its cleanups
3046           are skipped. This shouldn't make a make a difference:
3047           * a non-zero return from perl_parse is a failure, and
3048           perl_destruct() should be called immediately.
3049           * however, if exit(0) is called during the parse, then
3050           perl_parse() returns 0, and perl_run() is called. As
3051           PL_main_start will be NULL, perl_run() will return
3052           promptly, and the exit code will remain 0.
3053           */
3054            
3055 148         PL_comppad_name = 0;
3056 148         PL_compcv = 0;
3057           S_op_destroy(aTHX_ o);
3058           return;
3059           }
3060 38904         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3061 19452         PL_curcop = &PL_compiling;
3062 19452 50       PL_main_start = LINKLIST(PL_main_root);
3063 19452         PL_main_root->op_private |= OPpREFCOUNTED;
3064 19452         OpREFCNT_set(PL_main_root, 1);
3065 19452         PL_main_root->op_next = 0;
3066 19452         CALL_PEEP(PL_main_start);
3067 19452         finalize_optree(PL_main_root);
3068 19448         cv_forget_slab(PL_compcv);
3069 19448         PL_compcv = 0;
3070            
3071           /* Register with debugger */
3072 19448 100       if (PERLDB_INTER) {
    100        
3073 208         CV * const cv = get_cvs("DB::postponed", 0);
3074 208 100       if (cv) {
3075 190         dSP;
3076 190 50       PUSHMARK(SP);
3077 190 50       XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3078 190         PUTBACK;
3079 2127302         call_sv(MUTABLE_SV(cv), G_DISCARD);
3080           }
3081           }
3082           }
3083           }
3084            
3085           OP *
3086 16734877         Perl_localize(pTHX_ OP *o, I32 lex)
3087           {
3088           dVAR;
3089            
3090           PERL_ARGS_ASSERT_LOCALIZE;
3091            
3092 16734877 100       if (o->op_flags & OPf_PARENS)
3093           /* [perl #17376]: this appears to be premature, and results in code such as
3094           C< our(%x); > executing in list mode rather than void mode */
3095           #if 0
3096           list(o);
3097           #else
3098           NOOP;
3099           #endif
3100           else {
3101 13231357 50       if ( PL_parser->bufptr > PL_parser->oldbufptr
3102 13231357 100       && PL_parser->bufptr[-1] == ','
3103 75941 100       && ckWARN(WARN_PARENTHESIS))
3104           {
3105 58372         char *s = PL_parser->bufptr;
3106           bool sigil = FALSE;
3107            
3108           /* some heuristics to detect a potential error */
3109 147487 100       while (*s && (strchr(", \t\n", *s)))
    100        
3110 58156         s++;
3111            
3112           while (1) {
3113 64438 100       if (*s && strchr("@$%*", *s) && *++s
    100        
    50        
3114 6070 100       && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
    50        
3115 6066         s++;
3116           sigil = TRUE;
3117 27187 50       while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
    100        
    50        
3118 18268         s++;
3119 6324 100       while (*s && (strchr(", \t\n", *s)))
    100        
3120 258         s++;
3121           }
3122           else
3123           break;
3124           }
3125 58372 100       if (sigil && (*s == ';' || *s == '=')) {
    100        
3126 18 100       Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3127           "Parentheses missing around \"%s\" list",
3128           lex
3129 6         ? (PL_parser->in_my == KEY_our
3130           ? "our"
3131 6 100       : PL_parser->in_my == KEY_state
3132           ? "state"
3133 5 50       : "my")
3134           : "local");
3135           }
3136           }
3137           }
3138 16734877 100       if (lex)
3139 15722638         o = my(o);
3140           else
3141 1012239         o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3142 16734873         PL_parser->in_my = FALSE;
3143 16734873         PL_parser->in_my_stash = NULL;
3144 16734873         return o;
3145           }
3146            
3147           OP *
3148 12492836         Perl_jmaybe(pTHX_ OP *o)
3149           {
3150           PERL_ARGS_ASSERT_JMAYBE;
3151            
3152 12492836 100       if (o->op_type == OP_LIST) {
3153 4202         OP * const o2
3154 4202         = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3155 4202         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3156           }
3157 12492836         return o;
3158           }
3159            
3160           PERL_STATIC_INLINE OP *
3161 253940731         S_op_std_init(pTHX_ OP *o)
3162           {
3163 253940731         I32 type = o->op_type;
3164            
3165           PERL_ARGS_ASSERT_OP_STD_INIT;
3166            
3167 253940731 100       if (PL_opargs[type] & OA_RETSCALAR)
3168 111154622         scalar(o);
3169 253940731 100       if (PL_opargs[type] & OA_TARGET && !o->op_targ)
    100        
3170 89105812         o->op_targ = pad_alloc(type, SVs_PADTMP);
3171            
3172 253940731         return o;
3173           }
3174            
3175           PERL_STATIC_INLINE OP *
3176 253940731         S_op_integerize(pTHX_ OP *o)
3177           {
3178 253940731         I32 type = o->op_type;
3179            
3180           PERL_ARGS_ASSERT_OP_INTEGERIZE;
3181            
3182           /* integerize op. */
3183 253940731 100       if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
    100        
3184           {
3185           dVAR;
3186 311290         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3187           }
3188            
3189 253940731 100       if (type == OP_NEGATE)
3190           /* XXX might want a ck_negate() for this */
3191 384770         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3192            
3193 253940731         return o;
3194           }
3195            
3196           static OP *
3197 253940731         S_fold_constants(pTHX_ OP *o)
3198           {
3199           dVAR;
3200           OP * VOL curop;
3201           OP *newop;
3202 253940731         VOL I32 type = o->op_type;
3203 253940731         SV * VOL sv = NULL;
3204           int ret = 0;
3205           I32 oldscope;
3206           OP *old_next;
3207 253940731         SV * const oldwarnhook = PL_warnhook;
3208 253940731         SV * const olddiehook = PL_diehook;
3209           COP not_compiling;
3210           dJMPENV;
3211            
3212           PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3213            
3214 253940731 100       if (!(PL_opargs[type] & OA_FOLDCONST))
3215           goto nope;
3216            
3217 39682345         switch (type) {
3218           case OP_UCFIRST:
3219           case OP_LCFIRST:
3220           case OP_UC:
3221           case OP_LC:
3222           case OP_FC:
3223           case OP_SLT:
3224           case OP_SGT:
3225           case OP_SLE:
3226           case OP_SGE:
3227           case OP_SCMP:
3228           case OP_SPRINTF:
3229           /* XXX what about the numeric ops? */
3230 496893 100       if (IN_LOCALE_COMPILETIME)
3231           goto nope;
3232           break;
3233           case OP_PACK:
3234 80375 100       if (!cLISTOPo->op_first->op_sibling
3235 80373 100       || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3236           goto nope;
3237           {
3238 80187         SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3239 80187 50       if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3240           {
3241 80187         const char *s = SvPVX_const(sv);
3242 231649 100       while (s < SvEND(sv)) {
3243 112124 100       if (*s == 'p' || *s == 'P') goto nope;
3244 112088         s++;
3245           }
3246           }
3247           }
3248           break;
3249           case OP_REPEAT:
3250 200138 100       if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3251           }
3252            
3253 39627831 50       if (PL_parser && PL_parser->error_count)
    100        
3254           goto nope; /* Don't try to run w/ errors */
3255            
3256 73226583 50       for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
    50        
    100        
3257 68007429         const OPCODE type = curop->op_type;
3258 68007429 100       if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
    100        
3259 72454921 100       type != OP_LIST &&
3260 48948691         type != OP_SCALAR &&
3261 72447514 100       type != OP_NULL &&
3262 48943753         type != OP_PUSHMARK)
3263           {
3264           goto nope;
3265           }
3266           }
3267            
3268 5219154 50       curop = LINKLIST(o);
3269 5219154         old_next = o->op_next;
3270 5219154         o->op_next = 0;
3271 5219154         PL_op = curop;
3272            
3273 5219154         oldscope = PL_scopestack_ix;
3274 5219154         create_eval_scope(G_FAKINGEVAL);
3275            
3276           /* Verify that we don't need to save it: */
3277           assert(PL_curcop == &PL_compiling);
3278 5219154         StructCopy(&PL_compiling, ¬_compiling, COP);
3279 5219154         PL_curcop = ¬_compiling;
3280           /* The above ensures that we run with all the correct hints of the
3281           currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3282           assert(IN_PERL_RUNTIME);
3283 5219154         PL_warnhook = PERL_WARNHOOK_FATAL;
3284 5219154         PL_diehook = NULL;
3285 5219154         JMPENV_PUSH(ret);
3286            
3287 5219300         switch (ret) {
3288           case 0:
3289 5219154         CALLRUNOPS(aTHX);
3290 5219008         sv = *(PL_stack_sp--);
3291 5219008 100       if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
    100        
3292           #ifdef PERL_MAD
3293           /* Can't simply swipe the SV from the pad, because that relies on
3294           the op being freed "real soon now". Under MAD, this doesn't
3295           happen (see the #ifdef below). */
3296           sv = newSVsv(sv);
3297           #else
3298 5001520         pad_swipe(o->op_targ, FALSE);
3299           #endif
3300           }
3301 217488 100       else if (SvTEMP(sv)) { /* grab mortal temp? */
3302 65664 50       SvREFCNT_inc_simple_void(sv);
3303 65664         SvTEMP_off(sv);
3304           }
3305           else { assert(SvIMMORTAL(sv)); }
3306           break;
3307           case 3:
3308           /* Something tried to die. Abandon constant folding. */
3309           /* Pretend the error never happened. */
3310 146 50       CLEAR_ERRSV();
    50        
    50        
3311 146         o->op_next = old_next;
3312 146         break;
3313           default:
3314 0         JMPENV_POP;
3315           /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3316 0         PL_warnhook = oldwarnhook;
3317 0         PL_diehook = olddiehook;
3318           /* XXX note that this croak may fail as we've already blown away
3319           * the stack - eg any nested evals */
3320 0         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3321           }
3322 5219154         JMPENV_POP;
3323 5219154         PL_warnhook = oldwarnhook;
3324 5219154         PL_diehook = olddiehook;
3325 5219154         PL_curcop = &PL_compiling;
3326            
3327 5219154 100       if (PL_scopestack_ix > oldscope)
3328 5219008         delete_eval_scope();
3329            
3330 5219154 100       if (ret)
3331           goto nope;
3332            
3333           #ifndef PERL_MAD
3334 5219008         op_free(o);
3335           #endif
3336           assert(sv);
3337 5219008 100       if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3338 1148443 100       else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
    50        
    100        
    50        
    0        
3339 5219008 50       if (type == OP_RV2GV)
3340 0         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3341           else
3342           {
3343 5219008         newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3344 5219008         newop->op_folded = 1;
3345           }
3346           op_getmad(o,newop,'f');
3347 134368624         return newop;
3348            
3349           nope:
3350           return o;
3351           }
3352            
3353           static OP *
3354 19530         S_gen_constant_list(pTHX_ OP *o)
3355           {
3356           dVAR;
3357           OP *curop;
3358 19530         const SSize_t oldtmps_floor = PL_tmps_floor;
3359           SV **svp;
3360           AV *av;
3361            
3362 19530         list(o);
3363 19530 50       if (PL_parser && PL_parser->error_count)
    50        
3364           return o; /* Don't attempt to run with errors */
3365            
3366 19530 50       PL_op = curop = LINKLIST(o);
3367 19530         o->op_next = 0;
3368 19530         CALL_PEEP(curop);
3369 19530         Perl_pp_pushmark(aTHX);
3370 19530         CALLRUNOPS(aTHX);
3371 19530         PL_op = curop;
3372           assert (!(curop->op_flags & OPf_SPECIAL));
3373           assert(curop->op_type == OP_RANGE);
3374 19530         Perl_pp_anonlist(aTHX);
3375 19530         PL_tmps_floor = oldtmps_floor;
3376            
3377 19530         o->op_type = OP_RV2AV;
3378 19530         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3379 19530         o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3380 19530         o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3381 19530         o->op_opt = 0; /* needs to be revisited in rpeep() */
3382 19530         curop = ((UNOP*)o)->op_first;
3383 19530         av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3384 19530         ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3385 19530 100       if (AvFILLp(av) != -1)
3386 415302 100       for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3387 395780         SvPADTMP_on(*svp);
3388           #ifdef PERL_MAD
3389           op_getmad(curop,o,'O');
3390           #else
3391 19530         op_free(curop);
3392           #endif
3393 19530 50       LINKLIST(o);
3394 19530         return list(o);
3395           }
3396            
3397           OP *
3398 41883678         Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3399           {
3400           dVAR;
3401 41883678 100       if (type < 0) type = -type, flags |= OPf_SPECIAL;
3402 41883678 100       if (!o || o->op_type != OP_LIST)
    100        
3403 17913601         o = newLISTOP(OP_LIST, 0, o, NULL);
3404           else
3405 23970077         o->op_flags &= ~OPf_WANT;
3406            
3407 41883678 100       if (!(PL_opargs[type] & OA_MARK))
3408 11765191         op_null(cLISTOPo->op_first);
3409           else {
3410 30118487         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3411 30118487 100       if (kid2 && kid2->op_type == OP_COREARGS) {
    100        
3412 164         op_null(cLISTOPo->op_first);
3413 164         kid2->op_private |= OPpCOREARGS_PUSHMARK;
3414           }
3415           }
3416            
3417 41883678         o->op_type = (OPCODE)type;
3418 41883678         o->op_ppaddr = PL_ppaddr[type];
3419 41883678         o->op_flags |= flags;
3420            
3421 41883678 100       o = CHECKOP(type, o);
    100        
3422 41883676 100       if (o->op_type != (unsigned)type)
3423           return o;
3424            
3425 41502827         return fold_constants(op_integerize(op_std_init(o)));
3426           }
3427            
3428           /*
3429           =head1 Optree Manipulation Functions
3430           */
3431            
3432           /* List constructors */
3433            
3434           /*
3435           =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3436            
3437           Append an item to the list of ops contained directly within a list-type
3438           op, returning the lengthened list. I is the list-type op,
3439           and I is the op to append to the list. I specifies the
3440           intended opcode for the list. If I is not already a list of the
3441           right type, it will be upgraded into one. If either I or I
3442           is null, the other is returned unchanged.
3443            
3444           =cut
3445           */
3446            
3447           OP *
3448 96651768         Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3449           {
3450 96651768 100       if (!first)
3451           return last;
3452            
3453 93397526 100       if (!last)
3454           return first;
3455            
3456 92536373 100       if (first->op_type != (unsigned)type
3457 57287128 100       || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
    100        
3458           {
3459 35302786         return newLISTOP(type, 0, first, last);
3460           }
3461            
3462 57233587 50       if (first->op_flags & OPf_KIDS)
3463 57233587         ((LISTOP*)first)->op_last->op_sibling = last;
3464           else {
3465 0         first->op_flags |= OPf_KIDS;
3466 0         ((LISTOP*)first)->op_first = last;
3467           }
3468 57233587         ((LISTOP*)first)->op_last = last;
3469 77512482         return first;
3470           }
3471            
3472           /*
3473           =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3474            
3475           Concatenate the lists of ops contained directly within two list-type ops,
3476           returning the combined list. I and I are the list-type ops
3477           to concatenate. I specifies the intended opcode for the list.
3478           If either I or I is not already a list of the right type,
3479           it will be upgraded into one. If either I or I is null,
3480           the other is returned unchanged.
3481            
3482           =cut
3483           */
3484            
3485           OP *
3486 103035334         Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3487           {
3488 103035334 100       if (!first)
3489           return last;
3490            
3491 69784380 100       if (!last)
3492           return first;
3493            
3494 41618937 100       if (first->op_type != (unsigned)type)
3495 596561         return op_prepend_elem(type, first, last);
3496            
3497 41022376 100       if (last->op_type != (unsigned)type)
3498 1509706         return op_append_elem(type, first, last);
3499            
3500 39512670         ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3501 39512670         ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3502 39512670         first->op_flags |= (last->op_flags & OPf_KIDS);
3503            
3504           #ifdef PERL_MAD
3505           if (((LISTOP*)last)->op_first && first->op_madprop) {
3506           MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3507           if (mp) {
3508           while (mp->mad_next)
3509           mp = mp->mad_next;
3510           mp->mad_next = first->op_madprop;
3511           }
3512           else {
3513           ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3514           }
3515           }
3516           first->op_madprop = last->op_madprop;
3517           last->op_madprop = 0;
3518           #endif
3519            
3520           S_op_destroy(aTHX_ last);
3521            
3522 72387541         return first;
3523           }
3524            
3525           /*
3526           =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3527            
3528           Prepend an item to the list of ops contained directly within a list-type
3529           op, returning the lengthened list. I is the op to prepend to the
3530           list, and I is the list-type op. I specifies the intended
3531           opcode for the list. If I is not already a list of the right type,
3532           it will be upgraded into one. If either I or I is null,
3533           the other is returned unchanged.
3534            
3535           =cut
3536           */
3537            
3538           OP *
3539 109356336         Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3540           {
3541 109356336 100       if (!first)
3542           return last;
3543            
3544 109356330 100       if (!last)
3545           return first;
3546            
3547 101060003 100       if (last->op_type == (unsigned)type) {
3548 18414646 100       if (type == OP_LIST) { /* already a PUSHMARK there */
3549 3121921         first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3550 3121921         ((LISTOP*)last)->op_first->op_sibling = first;
3551 3121921 100       if (!(first->op_flags & OPf_PARENS))
3552 3121719         last->op_flags &= ~OPf_PARENS;
3553           }
3554           else {
3555 15292725 100       if (!(last->op_flags & OPf_KIDS)) {
3556 3440833         ((LISTOP*)last)->op_last = first;
3557 3440833         last->op_flags |= OPf_KIDS;
3558           }
3559 15292725         first->op_sibling = ((LISTOP*)last)->op_first;
3560 15292725         ((LISTOP*)last)->op_first = first;
3561           }
3562 18414646         last->op_flags |= OPf_KIDS;
3563 18414646         return last;
3564           }
3565            
3566 96443063         return newLISTOP(type, 0, first, last);
3567           }
3568            
3569           /* Constructors */
3570            
3571           #ifdef PERL_MAD
3572          
3573           TOKEN *
3574           Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3575           {
3576           TOKEN *tk;
3577           Newxz(tk, 1, TOKEN);
3578           tk->tk_type = (OPCODE)optype;
3579           tk->tk_type = 12345;
3580           tk->tk_lval = lval;
3581           tk->tk_mad = madprop;
3582           return tk;
3583           }
3584            
3585           void
3586           Perl_token_free(pTHX_ TOKEN* tk)
3587           {
3588           PERL_ARGS_ASSERT_TOKEN_FREE;
3589            
3590           if (tk->tk_type != 12345)
3591           return;
3592           mad_free(tk->tk_mad);
3593           Safefree(tk);
3594           }
3595            
3596           void
3597           Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3598           {
3599           MADPROP* mp;
3600           MADPROP* tm;
3601            
3602           PERL_ARGS_ASSERT_TOKEN_GETMAD;
3603            
3604           if (tk->tk_type != 12345) {
3605           Perl_warner(aTHX_ packWARN(WARN_MISC),
3606           "Invalid TOKEN object ignored");
3607           return;
3608           }
3609           tm = tk->tk_mad;
3610           if (!tm)
3611           return;
3612            
3613           /* faked up qw list? */
3614           if (slot == '(' &&
3615           tm->mad_type == MAD_SV &&
3616           SvPVX((SV *)tm->mad_val)[0] == 'q')
3617           slot = 'x';
3618            
3619           if (o) {
3620           mp = o->op_madprop;
3621           if (mp) {
3622           for (;;) {
3623           /* pretend constant fold didn't happen? */
3624           if (mp->mad_key == 'f' &&
3625           (o->op_type == OP_CONST ||
3626           o->op_type == OP_GV) )
3627           {
3628           token_getmad(tk,(OP*)mp->mad_val,slot);
3629           return;
3630           }
3631           if (!mp->mad_next)
3632           break;
3633           mp = mp->mad_next;
3634           }
3635           mp->mad_next = tm;
3636           mp = mp->mad_next;
3637           }
3638           else {
3639           o->op_madprop = tm;
3640           mp = o->op_madprop;
3641           }
3642           if (mp->mad_key == 'X')
3643           mp->mad_key = slot; /* just change the first one */
3644            
3645           tk->tk_mad = 0;
3646           }
3647           else
3648           mad_free(tm);
3649           Safefree(tk);
3650           }
3651            
3652           void
3653           Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3654           {
3655           MADPROP* mp;
3656           if (!from)
3657           return;
3658           if (o) {
3659           mp = o->op_madprop;
3660           if (mp) {
3661           for (;;) {
3662           /* pretend constant fold didn't happen? */
3663           if (mp->mad_key == 'f' &&
3664           (o->op_type == OP_CONST ||
3665           o->op_type == OP_GV) )
3666           {
3667           op_getmad(from,(OP*)mp->mad_val,slot);
3668           return;
3669           }
3670           if (!mp->mad_next)
3671           break;
3672           mp = mp->mad_next;
3673           }
3674           mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3675           }
3676           else {
3677           o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3678           }
3679           }
3680           }
3681            
3682           void
3683           Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3684           {
3685           MADPROP* mp;
3686           if (!from)
3687           return;
3688           if (o) {
3689           mp = o->op_madprop;
3690           if (mp) {
3691           for (;;) {
3692           /* pretend constant fold didn't happen? */
3693           if (mp->mad_key == 'f' &&
3694           (o->op_type == OP_CONST ||
3695           o->op_type == OP_GV) )
3696           {
3697           op_getmad(from,(OP*)mp->mad_val,slot);
3698           return;
3699           }
3700           if (!mp->mad_next)
3701           break;
3702           mp = mp->mad_next;
3703           }
3704           mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3705           }
3706           else {
3707           o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3708           }
3709           }
3710           else {
3711           PerlIO_printf(PerlIO_stderr(),
3712           "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3713           op_free(from);
3714           }
3715           }
3716            
3717           void
3718           Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3719           {
3720           MADPROP* tm;
3721           if (!mp || !o)
3722           return;
3723           if (slot)
3724           mp->mad_key = slot;
3725           tm = o->op_madprop;
3726           o->op_madprop = mp;
3727           for (;;) {
3728           if (!mp->mad_next)
3729           break;
3730           mp = mp->mad_next;
3731           }
3732           mp->mad_next = tm;
3733           }
3734            
3735           void
3736           Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3737           {
3738           if (!o)
3739           return;
3740           addmad(tm, &(o->op_madprop), slot);
3741           }
3742            
3743           void
3744           Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3745           {
3746           MADPROP* mp;
3747           if (!tm || !root)
3748           return;
3749           if (slot)
3750           tm->mad_key = slot;
3751           mp = *root;
3752           if (!mp) {
3753           *root = tm;
3754           return;
3755           }
3756           for (;;) {
3757           if (!mp->mad_next)
3758           break;
3759           mp = mp->mad_next;
3760           }
3761           mp->mad_next = tm;
3762           }
3763            
3764           MADPROP *
3765           Perl_newMADsv(pTHX_ char key, SV* sv)
3766           {
3767           PERL_ARGS_ASSERT_NEWMADSV;
3768            
3769           return newMADPROP(key, MAD_SV, sv, 0);
3770           }
3771            
3772           MADPROP *
3773           Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3774           {
3775           MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3776           mp->mad_next = 0;
3777           mp->mad_key = key;
3778           mp->mad_vlen = vlen;
3779           mp->mad_type = type;
3780           mp->mad_val = val;
3781           /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3782           return mp;
3783           }
3784            
3785           void
3786           Perl_mad_free(pTHX_ MADPROP* mp)
3787           {
3788           /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3789           if (!mp)
3790           return;
3791           if (mp->mad_next)
3792           mad_free(mp->mad_next);
3793           /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3794           PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3795           switch (mp->mad_type) {
3796           case MAD_NULL:
3797           break;
3798           case MAD_PV:
3799           Safefree(mp->mad_val);
3800           break;
3801           case MAD_OP:
3802           if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3803           op_free((OP*)mp->mad_val);
3804           break;
3805           case MAD_SV:
3806           sv_free(MUTABLE_SV(mp->mad_val));
3807           break;
3808           default:
3809           PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3810           break;
3811           }
3812           PerlMemShared_free(mp);
3813           }
3814            
3815           #endif
3816            
3817           /*
3818           =head1 Optree construction
3819            
3820           =for apidoc Am|OP *|newNULLLIST
3821            
3822           Constructs, checks, and returns a new C op, which represents an
3823           empty list expression.
3824            
3825           =cut
3826           */
3827            
3828           OP *
3829 483602         Perl_newNULLLIST(pTHX)
3830           {
3831 483602         return newOP(OP_STUB, 0);
3832           }
3833            
3834           static OP *
3835 28100116         S_force_list(pTHX_ OP *o)
3836           {
3837 28100116 100       if (!o || o->op_type != OP_LIST)
    100        
3838 16002679         o = newLISTOP(OP_LIST, 0, o, NULL);
3839 28100116         op_null(o);
3840 28100116         return o;
3841           }
3842            
3843           /*
3844           =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3845            
3846           Constructs, checks, and returns an op of any list type. I is
3847           the opcode. I gives the eight bits of C, except that
3848           C will be set automatically if required. I and I
3849           supply up to two ops to be direct children of the list op; they are
3850           consumed by this function and become part of the constructed op tree.
3851            
3852           =cut
3853           */
3854            
3855           OP *
3856 152353570         Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3857           {
3858           dVAR;
3859           LISTOP *listop;
3860            
3861           assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3862            
3863 152353570         NewOp(1101, listop, 1, LISTOP);
3864            
3865 152353570         listop->op_type = (OPCODE)type;
3866 152353570         listop->op_ppaddr = PL_ppaddr[type];
3867 152353570 100       if (first || last)
3868 151227728         flags |= OPf_KIDS;
3869 152353570         listop->op_flags = (U8)flags;
3870            
3871 152353570 100       if (!last && first)
3872           last = first;
3873 119515466 50       else if (!first && last)
3874           first = last;
3875 119515466 100       else if (first)
3876 118389624         first->op_sibling = last;
3877 152353570         listop->op_first = first;
3878 152353570         listop->op_last = last;
3879 152353570 100       if (type == OP_LIST) {
3880 72779894         OP* const pushop = newOP(OP_PUSHMARK, 0);
3881 72779894         pushop->op_sibling = first;
3882 72779894         listop->op_first = pushop;
3883 72779894         listop->op_flags |= OPf_KIDS;
3884 72779894 100       if (!last)
3885 1125842         listop->op_last = pushop;
3886           }
3887            
3888 152353570 100       return CHECKOP(type, listop);
    50        
3889           }
3890            
3891           /*
3892           =for apidoc Am|OP *|newOP|I32 type|I32 flags
3893            
3894           Constructs, checks, and returns an op of any base type (any type that
3895           has no extra fields). I is the opcode. I gives the
3896           eight bits of C, and, shifted up eight bits, the eight bits
3897           of C.
3898            
3899           =cut
3900           */
3901            
3902           OP *
3903 183382813         Perl_newOP(pTHX_ I32 type, I32 flags)
3904           {
3905           dVAR;
3906           OP *o;
3907            
3908 183382813 50       if (type == -OP_ENTEREVAL) {
3909           type = OP_ENTEREVAL;
3910 0         flags |= OPpEVAL_BYTES<<8;
3911           }
3912            
3913           assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3914           || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3915           || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3916           || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3917            
3918 183382813         NewOp(1101, o, 1, OP);
3919 183382813         o->op_type = (OPCODE)type;
3920 183382813         o->op_ppaddr = PL_ppaddr[type];
3921 183382813         o->op_flags = (U8)flags;
3922            
3923 183382813         o->op_next = o;
3924 183382813         o->op_private = (U8)(0 | (flags >> 8));
3925 183382813 100       if (PL_opargs[type] & OA_RETSCALAR)
3926 80409920         scalar(o);
3927 183382813 100       if (PL_opargs[type] & OA_TARGET)
3928 291899         o->op_targ = pad_alloc(type, SVs_PADTMP);
3929 183382813 100       return CHECKOP(type, o);
    50        
3930           }
3931            
3932           /*
3933           =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3934            
3935           Constructs, checks, and returns an op of any unary type. I is
3936           the opcode. I gives the eight bits of C, except that
3937           C will be set automatically if required, and, shifted up eight
3938           bits, the eight bits of C, except that the bit with value 1
3939           is automatically set. I supplies an optional op to be the direct
3940           child of the unary op; it is consumed by this function and become part
3941           of the constructed op tree.
3942            
3943           =cut
3944           */
3945            
3946           OP *
3947 153962874         Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3948           {
3949           dVAR;
3950           UNOP *unop;
3951            
3952 153962874 100       if (type == -OP_ENTEREVAL) {
3953           type = OP_ENTEREVAL;
3954 42         flags |= OPpEVAL_BYTES<<8;
3955           }
3956            
3957           assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3958           || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3959           || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3960           || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3961           || type == OP_SASSIGN
3962           || type == OP_ENTERTRY
3963           || type == OP_NULL );
3964            
3965 153962874 50       if (!first)
3966 0         first = newOP(OP_STUB, 0);
3967 153962874 100       if (PL_opargs[type] & OA_MARK)
3968 14614407         first = force_list(first);
3969            
3970 153962874         NewOp(1101, unop, 1, UNOP);
3971 153962874         unop->op_type = (OPCODE)type;
3972 153962874         unop->op_ppaddr = PL_ppaddr[type];
3973 153962874         unop->op_first = first;
3974 153962874         unop->op_flags = (U8)(flags | OPf_KIDS);
3975 153962874         unop->op_private = (U8)(1 | (flags >> 8));
3976 153962874 100       unop = (UNOP*) CHECKOP(type, unop);
    100        
3977 153962820 100       if (unop->op_next)
3978           return (OP*)unop;
3979            
3980 148097258         return fold_constants(op_integerize(op_std_init((OP *) unop)));
3981           }
3982            
3983           /*
3984           =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3985            
3986           Constructs, checks, and returns an op of any binary type. I
3987           is the opcode. I gives the eight bits of C, except
3988           that C will be set automatically, and, shifted up eight bits,
3989           the eight bits of C, except that the bit with value 1 or
3990           2 is automatically set as required. I and I supply up to
3991           two ops to be the direct children of the binary op; they are consumed
3992           by this function and become part of the constructed op tree.
3993            
3994           =cut
3995           */
3996            
3997           OP *
3998 71431726         Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3999           {
4000           dVAR;
4001           BINOP *binop;
4002            
4003           assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4004           || type == OP_SASSIGN || type == OP_NULL );
4005            
4006 71431726         NewOp(1101, binop, 1, BINOP);
4007            
4008 71431726 50       if (!first)
4009 0         first = newOP(OP_NULL, 0);
4010            
4011 71431726         binop->op_type = (OPCODE)type;
4012 71431726         binop->op_ppaddr = PL_ppaddr[type];
4013 71431726         binop->op_first = first;
4014 71431726         binop->op_flags = (U8)(flags | OPf_KIDS);
4015 71431726 50       if (!last) {
4016           last = first;
4017 0         binop->op_private = (U8)(1 | (flags >> 8));
4018           }
4019           else {
4020 71431726         binop->op_private = (U8)(2 | (flags >> 8));
4021 71431726         first->op_sibling = last;
4022           }
4023            
4024 71431726 100       binop = (BINOP*)CHECKOP(type, binop);
    100        
4025 71431722 100       if (binop->op_next || binop->op_type != (OPCODE)type)
    100        
4026           return (OP*)binop;
4027            
4028 70836770         binop->op_last = binop->op_first->op_sibling;
4029            
4030 71140365         return fold_constants(op_integerize(op_std_init((OP *)binop)));
4031           }
4032            
4033           static int uvcompare(const void *a, const void *b)
4034           __attribute__nonnull__(1)
4035           __attribute__nonnull__(2)
4036           __attribute__pure__;
4037 4102         static int uvcompare(const void *a, const void *b)
4038           {
4039 4102 50       if (*((const UV *)a) < (*(const UV *)b))
4040           return -1;
4041 0 0       if (*((const UV *)a) > (*(const UV *)b))
4042           return 1;
4043 0 0       if (*((const UV *)a+1) < (*(const UV *)b+1))
4044           return -1;
4045 0 0       if (*((const UV *)a+1) > (*(const UV *)b+1))
4046           return 1;
4047 2051         return 0;
4048           }
4049            
4050           static OP *
4051 84040         S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4052           {
4053           dVAR;
4054 84040         SV * const tstr = ((SVOP*)expr)->op_sv;
4055 84040         SV * const rstr =
4056           #ifdef PERL_MAD
4057           (repl->op_type == OP_NULL)
4058           ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4059           #endif
4060           ((SVOP*)repl)->op_sv;
4061           STRLEN tlen;
4062           STRLEN rlen;
4063 84040 100       const U8 *t = (U8*)SvPV_const(tstr, tlen);
4064 84040 50       const U8 *r = (U8*)SvPV_const(rstr, rlen);
4065           I32 i;
4066           I32 j;
4067           I32 grows = 0;
4068           short *tbl;
4069            
4070 84040         const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4071 84040         const I32 squash = o->op_private & OPpTRANS_SQUASH;
4072 84040         I32 del = o->op_private & OPpTRANS_DELETE;
4073           SV* swash;
4074            
4075           PERL_ARGS_ASSERT_PMTRANS;
4076            
4077 84040         PL_hints |= HINT_BLOCK_SCOPE;
4078            
4079 84040 100       if (SvUTF8(tstr))
4080 106         o->op_private |= OPpTRANS_FROM_UTF;
4081            
4082 84040 100       if (SvUTF8(rstr))
4083 110         o->op_private |= OPpTRANS_TO_UTF;
4084            
4085 84040 100       if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4086 124         SV* const listsv = newSVpvs("# comment\n");
4087           SV* transv = NULL;
4088 124         const U8* tend = t + tlen;
4089 124         const U8* rend = r + rlen;
4090           STRLEN ulen;
4091           UV tfirst = 1;
4092           UV tlast = 0;
4093           IV tdiff;
4094           UV rfirst = 1;
4095           UV rlast = 0;
4096           IV rdiff;
4097           IV diff;
4098           I32 none = 0;
4099           U32 max = 0;
4100           I32 bits;
4101           I32 havefinal = 0;
4102           U32 final = 0;
4103 124         const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4104 124         const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4105           U8* tsave = NULL;
4106           U8* rsave = NULL;
4107 124 100       const U32 flags = UTF8_ALLOW_DEFAULT;
4108            
4109 124 100       if (!from_utf) {
4110 18         STRLEN len = tlen;
4111 18         t = tsave = bytes_to_utf8(t, &len);
4112 18         tend = t + len;
4113           }
4114 124 100       if (!to_utf && rlen) {
    50        
4115 0         STRLEN len = rlen;
4116 0         r = rsave = bytes_to_utf8(r, &len);
4117 0         rend = r + len;
4118           }
4119            
4120           /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4121           * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4122           * odd. */
4123            
4124 124 100       if (complement) {
4125           U8 tmpbuf[UTF8_MAXBYTES+1];
4126           UV *cp;
4127           UV nextmin = 0;
4128 20 50       Newx(cp, 2*tlen, UV);
4129           i = 0;
4130 20         transv = newSVpvs("");
4131 1076 100       while (t < tend) {
4132 1046         cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4133 1046         t += ulen;
4134 1046 100       if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
    100        
4135 10         t++;
4136 10         cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4137 10         t += ulen;
4138           }
4139           else {
4140 1036         cp[2*i+1] = cp[2*i];
4141           }
4142 1046         i++;
4143           }
4144 20         qsort(cp, i, 2*sizeof(UV), uvcompare);
4145 1066 100       for (j = 0; j < i; j++) {
4146 1046         UV val = cp[2*j];
4147 1046         diff = val - nextmin;
4148 1046 100       if (diff > 0) {
4149 14         t = uvchr_to_utf8(tmpbuf,nextmin);
4150 14         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4151 14 100       if (diff > 1) {
4152 10         U8 range_mark = ILLEGAL_UTF8_BYTE;
4153 10         t = uvchr_to_utf8(tmpbuf, val - 1);
4154 10         sv_catpvn(transv, (char *)&range_mark, 1);
4155 10         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4156           }
4157           }
4158 1046         val = cp[2*j+1];
4159 1046 50       if (val >= nextmin)
4160 1046         nextmin = val + 1;
4161           }
4162 20         t = uvchr_to_utf8(tmpbuf,nextmin);
4163 20         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4164           {
4165 20         U8 range_mark = ILLEGAL_UTF8_BYTE;
4166 20         sv_catpvn(transv, (char *)&range_mark, 1);
4167           }
4168 20         t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4169 20         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4170 20         t = (const U8*)SvPVX_const(transv);
4171 20         tlen = SvCUR(transv);
4172 20         tend = t + tlen;
4173 20         Safefree(cp);
4174           }
4175 104 100       else if (!rlen && !del) {
4176 6         r = t; rlen = tlen; rend = tend;
4177           }
4178 124 100       if (!squash) {
4179 162 100       if ((!rlen && !del) || t == r ||
    100        
    100        
4180 114 100       (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4181           {
4182 68         o->op_private |= OPpTRANS_IDENTICAL;
4183           }
4184           }
4185            
4186 370 100       while (t < tend || tfirst <= tlast) {
4187           /* see if we need more "t" chars */
4188 246 100       if (tfirst > tlast) {
4189 228         tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4190 228         t += ulen;
4191 228 100       if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
    100        
4192 72         t++;
4193 72         tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4194 72         t += ulen;
4195           }
4196           else
4197           tlast = tfirst;
4198           }
4199            
4200           /* now see if we need more "r" chars */
4201 246 100       if (rfirst > rlast) {
4202 222 100       if (r < rend) {
4203 190         rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4204 190         r += ulen;
4205 190 100       if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
    100        
4206 42         r++;
4207 42         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4208 42         r += ulen;
4209           }
4210           else
4211           rlast = rfirst;
4212           }
4213           else {
4214 32 50       if (!havefinal++)
4215 32         final = rlast;
4216           rfirst = rlast = 0xffffffff;
4217           }
4218           }
4219            
4220           /* now see which range will peter our first, if either. */
4221 246         tdiff = tlast - tfirst;
4222 246         rdiff = rlast - rfirst;
4223            
4224 246 100       if (tdiff <= rdiff)
4225           diff = tdiff;
4226           else
4227           diff = rdiff;
4228            
4229 246 100       if (rfirst == 0xffffffff) {
4230           diff = tdiff; /* oops, pretend rdiff is infinite */
4231 44 100       if (diff > 0)
4232 32         Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4233           (long)tfirst, (long)tlast);
4234           else
4235 12         Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4236           }
4237           else {
4238 202 100       if (diff > 0)
4239 57         Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4240 38         (long)tfirst, (long)(tfirst + diff),
4241           (long)rfirst);
4242           else
4243 164         Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4244           (long)tfirst, (long)rfirst);
4245            
4246 202 100       if (rfirst + diff > max)
4247 146         max = rfirst + diff;
4248 202 100       if (!grows)
4249 224 100       grows = (tfirst < rfirst &&
    100        
4250 80 100       UNISKIP(tfirst) < UNISKIP(rfirst + diff));
    100        
    50        
    0        
    0        
    0        
    0        
    100        
    100        
    100        
    50        
    0        
    0        
    0        
4251 202         rfirst += diff + 1;
4252           }
4253 246         tfirst += diff + 1;
4254           }
4255            
4256 124         none = ++max;
4257 124 100       if (del)
4258 6         del = ++max;
4259            
4260 124 100       if (max > 0xffff)
4261           bits = 32;
4262 110 100       else if (max > 0xff)
4263           bits = 16;
4264           else
4265           bits = 8;
4266            
4267 124         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4268           #ifdef USE_ITHREADS
4269           cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4270           SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4271           PAD_SETSV(cPADOPo->op_padix, swash);
4272           SvPADTMP_on(swash);
4273           SvREADONLY_on(swash);
4274           #else
4275 124         cSVOPo->op_sv = swash;
4276           #endif
4277 124         SvREFCNT_dec(listsv);
4278 124         SvREFCNT_dec(transv);
4279            
4280 124 100       if (!del && havefinal && rlen)
    100        
4281 22         (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4282           newSVuv((UV)final), 0);
4283            
4284 124 100       if (grows)
4285 20         o->op_private |= OPpTRANS_GROWS;
4286            
4287 124         Safefree(tsave);
4288 124         Safefree(rsave);
4289            
4290           #ifdef PERL_MAD
4291           op_getmad(expr,o,'e');
4292           op_getmad(repl,o,'r');
4293           #else
4294 124         op_free(expr);
4295 124         op_free(repl);
4296           #endif
4297 124         return o;
4298           }
4299            
4300 83916 100       tbl = (short*)PerlMemShared_calloc(
    100        
4301           (o->op_private & OPpTRANS_COMPLEMENT) &&
4302           !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4303           sizeof(short));
4304 83916         cPVOPo->op_pv = (char*)tbl;
4305 83916 100       if (complement) {
4306 1514986 100       for (i = 0; i < (I32)tlen; i++)
4307 1510706         tbl[t[i]] = -1;
4308 2103480 100       for (i = 0, j = 0; i < 256; i++) {
4309 2099200 100       if (!tbl[i]) {
4310 588494 100       if (j >= (I32)rlen) {
4311 588490 100       if (del)
4312 205198         tbl[i] = -2;
4313 383292 100       else if (rlen)
4314 1018         tbl[i] = r[j-1];
4315           else
4316 382274         tbl[i] = (short)i;
4317           }
4318           else {
4319 4 50       if (i < 128 && r[j] >= 128)
    50        
4320           grows = 1;
4321 4         tbl[i] = r[j++];
4322           }
4323           }
4324           }
4325 8200 100       if (!del) {
4326 7214 100       if (!rlen) {
4327 7202         j = rlen;
4328 7202 50       if (!squash)
4329 7202         o->op_private |= OPpTRANS_IDENTICAL;
4330           }
4331 12 100       else if (j >= (I32)rlen)
4332 4         j = rlen - 1;
4333           else {
4334 8         tbl =
4335           (short *)
4336 8         PerlMemShared_realloc(tbl,
4337           (0x101+rlen-j) * sizeof(short));
4338 8         cPVOPo->op_pv = (char*)tbl;
4339           }
4340 7214         tbl[0x100] = (short)(rlen - j);
4341 7230 100       for (i=0; i < (I32)rlen - j; i++)
4342 16         tbl[0x101+i] = r[j+i];
4343           }
4344           }
4345           else {
4346 75716 100       if (!rlen && !del) {
4347 45972         r = t; rlen = tlen;
4348 45972 50       if (!squash)
4349 45972         o->op_private |= OPpTRANS_IDENTICAL;
4350           }
4351 29744 100       else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
    100        
    100        
4352 66         o->op_private |= OPpTRANS_IDENTICAL;
4353           }
4354 19459012 100       for (i = 0; i < 256; i++)
4355 19383296         tbl[i] = -1;
4356 976270 100       for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4357 935172 100       if (j >= (I32)rlen) {
4358 106356 100       if (del) {
4359 51948 100       if (tbl[t[i]] == -1)
4360 50776         tbl[t[i]] = -2;
4361 51948         continue;
4362           }
4363 54408         --j;
4364           }
4365 883224 100       if (tbl[t[i]] == -1) {
4366 883218 100       if (t[i] < 128 && r[j] >= 128)
    100        
4367           grows = 1;
4368 883218         tbl[t[i]] = r[j];
4369           }
4370           }
4371           }
4372            
4373 83916 100       if(del && rlen == tlen) {
    100        
4374 2         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4375 83914 100       } else if(rlen > tlen && !complement) {
4376 2         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4377           }
4378            
4379 83916 100       if (grows)
4380 80         o->op_private |= OPpTRANS_GROWS;
4381           #ifdef PERL_MAD
4382           op_getmad(expr,o,'e');
4383           op_getmad(repl,o,'r');
4384           #else
4385 83916         op_free(expr);
4386 83916         op_free(repl);
4387           #endif
4388            
4389 83978         return o;
4390           }
4391            
4392           /*
4393           =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4394            
4395           Constructs, checks, and returns an op of any pattern matching type.
4396           I is the opcode. I gives the eight bits of C
4397           and, shifted up eight bits, the eight bits of C.
4398 </