This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Un-const magic virtual tables; this consting breaks the nasty
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
acde74e1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 17 */
18
166f8a29
DM		 19/* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
21 *
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
28 * stack.
29 *
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
34 *
35 * newBINOP(OP_ADD, flags,
36 * newSVREF($a),
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
38 * )
39 *
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
42 */
ccfc67b7 43
61b743bb
DM		 44/*
45Perl's compiler is essentially a 3-pass compiler with interleaved phases:
46
47 A bottom-up pass
48 A top-down pass
49 An execution-order pass
50
51The bottom-up pass is represented by all the "newOP" routines and
52the ck_ routines. The bottom-upness is actually driven by yacc.
53So at the point that a ck_ routine fires, we have no idea what the
54context is, either upward in the syntax tree, or either forward or
55backward in the execution order. (The bottom-up parser builds that
56part of the execution order it knows about, but if you follow the "next"
57links around, you'll find it's actually a closed loop through the
58top level node.
59
60Whenever the bottom-up parser gets to a node that supplies context to
61its components, it invokes that portion of the top-down pass that applies
62to that part of the subtree (and marks the top node as processed, so
63if a node further up supplies context, it doesn't have to take the
64plunge again). As a particular subcase of this, as the new node is
65built, it takes all the closed execution loops of its subcomponents
66and links them into a new closed loop for the higher level node. But
67it's still not the real execution order.
68
69The actual execution order is not known till we get a grammar reduction
70to a top-level unit like a subroutine or file that will be called by
71"name" rather than via a "next" pointer. At that point, we can call
72into peep() to do that code's portion of the 3rd pass. It has to be
73recursive, but it's recursive on basic blocks, not on tree nodes.
74*/
75
79072805 76#include "EXTERN.h"
864dbfa3 77#define PERL_IN_OP_C
79072805 78#include "perl.h"
77ca0c92 79#include "keywords.h"
79072805 80
a07e034d 81#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 82
238a4c30
NIS		 83#if defined(PL_OP_SLAB_ALLOC)
84
85#ifndef PERL_SLAB_SIZE
86#define PERL_SLAB_SIZE 2048
87#endif
88
c7e45529
AE		 89void *
90Perl_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 91{
5a8e194f
NIS		 92 /*
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
97 */
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 99 if ((PL_OpSpace -= sz) < 0) {
083fcd59
JH		 100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
101 if (!PL_OpPtr) {
238a4c30
NIS		 102 return NULL;
103 }
5a8e194f
NIS		 104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
109 */
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
114 */
5a8e194f 115 PL_OpPtr += PERL_SLAB_SIZE;
238a4c30
NIS		 116 }
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
119 PL_OpPtr -= sz;
5a8e194f 120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
126}
127
c7e45529
AE		 128void
129Perl_Slab_Free(pTHX_ void *op)
238a4c30 130{
551405c4 131 I32 * const * const ptr = (I32 **) op;
aec46f14 132 I32 * const slab = ptr[-1];
5a8e194f
NIS		 133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30
NIS		 135 assert( *slab > 0 );
136 if (--(*slab) == 0) {
7e4e8c89
NC		 137# ifdef NETWARE
138# define PerlMemShared PerlMem
139# endif
083fcd59
JH		 140
141 PerlMemShared_free(slab);
238a4c30
NIS		 142 if (slab == PL_OpSlab) {
143 PL_OpSpace = 0;
144 }
145 }
b7dc083c 146}
b7dc083c 147#endif
e50aee73 148/*
5dc0d613 149 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 150 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 151 */
11343788 152#define CHECKOP(type,o) \
3280af22 153 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 154 ? ( op_free((OP*)o), \
cb77fdf0 155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
28757baa 156 Nullop ) \
fc0dc3b3 157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 158
e6438c1a 159#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 160
8b6b16e7 161STATIC const char*
cea2e8a9 162S_gv_ename(pTHX_ GV *gv)
4633a7c4 163{
46c461b5 164 SV* const tmpsv = sv_newmortal();
46fc3d4c 165 gv_efullname3(tmpsv, gv, Nullch);
8b6b16e7 166 return SvPV_nolen_const(tmpsv);
4633a7c4
LW		 167}
168
76e3520e 169STATIC OP *
cea2e8a9 170S_no_fh_allowed(pTHX_ OP *o)
79072805 171{
cea2e8a9 172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 173 OP_DESC(o)));
11343788 174 return o;
79072805
LW		 175}
176
76e3520e 177STATIC OP *
bfed75c6 178S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 179{
cea2e8a9 180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 181 return o;
79072805
LW		 182}
183
76e3520e 184STATIC OP *
bfed75c6 185S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 186{
cea2e8a9 187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 188 return o;
79072805
LW		 189}
190
76e3520e 191STATIC void
6867be6d 192S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 193{
cea2e8a9 194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 195 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 196}
197
7a52d87a 198STATIC void
6867be6d 199S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 200{
5a844595 201 qerror(Perl_mess(aTHX_
35c1215d
NC		 202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
203 cSVOPo_sv));
7a52d87a
GS		 204}
205
79072805
LW		 206/* "register" allocation */
207
208PADOFFSET
dd2155a4 209Perl_allocmy(pTHX_ char *name)
93a17b20 210{
97aff369 211 dVAR;
a0d0e21e 212 PADOFFSET off;
3edf23ff 213 const bool is_our = (PL_in_my == KEY_our);
a0d0e21e 214
59f00321 215 /* complain about "my $<special_var>" etc etc */
6b58708b 216 if (*name &&
3edf23ff 217 !(is_our ||
155aba94 218 isALPHA(name[1]) ||
39e02b42 219 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
6b58708b 220 (name[1] == '_' && (*name == '$' || name[2]))))
834a4ddd 221 {
6b58708b 222 /* name[2] is true if strlen(name) > 2 */
c4d0567e 223 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS		 224 /* 1999-02-27 mjd@plover.com */
225 char *p;
226 p = strchr(name, '\0');
227 /* The next block assumes the buffer is at least 205 chars
228 long. At present, it's always at least 256 chars. */
229 if (p-name > 200) {
230 strcpy(name+200, "...");
231 p = name+199;
232 }
233 else {
234 p[1] = '\0';
235 }
236 /* Move everything else down one character */
237 for (; p-name > 2; p--)
238 *p = *(p-1);
46fc3d4c 239 name[2] = toCTRL(name[1]);
240 name[1] = '^';
241 }
cea2e8a9 242 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 243 }
748a9306 244
dd2155a4 245 /* check for duplicate declaration */
3edf23ff 246 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
33b8ce05 247
dd2155a4
DM		 248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
3edf23ff 251 name, is_our ? "our" : "my"));
6b35e009
GS		 252 }
253
dd2155a4 254 /* allocate a spare slot and store the name in that slot */
93a17b20 255
dd2155a4
DM		 256 off = pad_add_name(name,
257 PL_in_my_stash,
3edf23ff 258 (is_our
133706a6
RGS		 259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 261 : NULL
dd2155a4
DM		 262 ),
263 0 /* not fake */
264 );
265 return off;
79072805
LW		 266}
267
79072805
LW		 268/* Destructor */
269
270void
864dbfa3 271Perl_op_free(pTHX_ OP *o)
79072805 272{
27da23d5 273 dVAR;
acb36ea4 274 OPCODE type;
4026c95a 275 PADOFFSET refcnt;
79072805 276
2814eb74 277 if (!o || o->op_static)
79072805
LW		 278 return;
279
7934575e
GS		 280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
282 case OP_LEAVESUB:
283 case OP_LEAVESUBLV:
284 case OP_LEAVEEVAL:
285 case OP_LEAVE:
286 case OP_SCOPE:
287 case OP_LEAVEWRITE:
288 OP_REFCNT_LOCK;
4026c95a 289 refcnt = OpREFCNT_dec(o);
7934575e 290 OP_REFCNT_UNLOCK;
4026c95a
SH		 291 if (refcnt)
292 return;
7934575e
GS		 293 break;
294 default:
295 break;
296 }
297 }
298
11343788 299 if (o->op_flags & OPf_KIDS) {
6867be6d 300 register OP *kid, *nextkid;
11343788 301 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 302 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 303 op_free(kid);
85e6fe83 304 }
79072805 305 }
acb36ea4
GS		 306 type = o->op_type;
307 if (type == OP_NULL)
eb160463 308 type = (OPCODE)o->op_targ;
acb36ea4
GS		 309
310 /* COP* is not cleared by op_clear() so that we may track line
311 * numbers etc even after null() */
312 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
313 cop_free((COP*)o);
314
315 op_clear(o);
238a4c30 316 FreeOp(o);
4d494880
DM		 317#ifdef DEBUG_LEAKING_SCALARS
318 if (PL_op == o)
319 PL_op = Nullop;
320#endif
acb36ea4 321}
79072805 322
93c66552
DM		 323void
324Perl_op_clear(pTHX_ OP *o)
acb36ea4 325{
13137afc 326
27da23d5 327 dVAR;
11343788 328 switch (o->op_type) {
acb36ea4
GS		 329 case OP_NULL: /* Was holding old type, if any. */
330 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 331 o->op_targ = 0;
a0d0e21e 332 break;
a6006777 333 default:
ac4c12e7 334 if (!(o->op_flags & OPf_REF)
0b94c7bb 335 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 336 break;
337 /* FALL THROUGH */
463ee0b2 338 case OP_GVSV:
79072805 339 case OP_GV:
a6006777 340 case OP_AELEMFAST:
6a077020
DM		 341 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
342 /* not an OP_PADAV replacement */
350de78d 343#ifdef USE_ITHREADS
6a077020
DM		 344 if (cPADOPo->op_padix > 0) {
345 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
346 * may still exist on the pad */
347 pad_swipe(cPADOPo->op_padix, TRUE);
348 cPADOPo->op_padix = 0;
349 }
350de78d 350#else
6a077020
DM		 351 SvREFCNT_dec(cSVOPo->op_sv);
352 cSVOPo->op_sv = Nullsv;
350de78d 353#endif
6a077020 354 }
79072805 355 break;
a1ae71d2 356 case OP_METHOD_NAMED:
79072805 357 case OP_CONST:
11343788 358 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 359 cSVOPo->op_sv = Nullsv;
3b1c21fa
AB		 360#ifdef USE_ITHREADS
361 /** Bug #15654
362 Even if op_clear does a pad_free for the target of the op,
6a077020 363 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 364 instead it lives on. This results in that it could be reused as
365 a target later on when the pad was reallocated.
366 **/
367 if(o->op_targ) {
368 pad_swipe(o->op_targ,1);
369 o->op_targ = 0;
370 }
371#endif
79072805 372 break;
748a9306
LW		 373 case OP_GOTO:
374 case OP_NEXT:
375 case OP_LAST:
376 case OP_REDO:
11343788 377 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 378 break;
379 /* FALL THROUGH */
a0d0e21e 380 case OP_TRANS:
acb36ea4 381 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 382 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS		 383 cSVOPo->op_sv = Nullsv;
384 }
385 else {
a0ed51b3 386 Safefree(cPVOPo->op_pv);
acb36ea4
GS		 387 cPVOPo->op_pv = Nullch;
388 }
a0d0e21e
LW		 389 break;
390 case OP_SUBST:
11343788 391 op_free(cPMOPo->op_pmreplroot);
971a9dd3 392 goto clear_pmop;
748a9306 393 case OP_PUSHRE:
971a9dd3 394#ifdef USE_ITHREADS
ba89bb6e 395 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM		 396 /* No GvIN_PAD_off here, because other references may still
397 * exist on the pad */
398 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS		 399 }
400#else
401 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
402#endif
403 /* FALL THROUGH */
a0d0e21e 404 case OP_MATCH:
8782bef2 405 case OP_QR:
971a9dd3 406clear_pmop:
cb55de95 407 {
551405c4 408 HV * const pmstash = PmopSTASH(cPMOPo);
0565a181 409 if (pmstash && !SvIS_FREED(pmstash)) {
551405c4 410 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
8d2f4536
NC		 411 if (mg) {
412 PMOP *pmop = (PMOP*) mg->mg_obj;
413 PMOP *lastpmop = NULL;
414 while (pmop) {
415 if (cPMOPo == pmop) {
416 if (lastpmop)
417 lastpmop->op_pmnext = pmop->op_pmnext;
418 else
419 mg->mg_obj = (SV*) pmop->op_pmnext;
420 break;
421 }
422 lastpmop = pmop;
423 pmop = pmop->op_pmnext;
cb55de95 424 }
cb55de95 425 }
83da49e6 426 }
05ec9bb3 427 PmopSTASH_free(cPMOPo);
cb55de95 428 }
971a9dd3 429 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM		 430 /* we use the "SAFE" version of the PM_ macros here
431 * since sv_clean_all might release some PMOPs
432 * after PL_regex_padav has been cleared
433 * and the clearing of PL_regex_padav needs to
434 * happen before sv_clean_all
435 */
436 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
437 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB		 438#ifdef USE_ITHREADS
439 if(PL_regex_pad) { /* We could be in destruction */
440 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 441 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 442 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
443 }
1eb1540c 444#endif
13137afc 445
a0d0e21e 446 break;
79072805
LW		 447 }
448
743e66e6 449 if (o->op_targ > 0) {
11343788 450 pad_free(o->op_targ);
743e66e6
GS		 451 o->op_targ = 0;
452 }
79072805
LW		 453}
454
76e3520e 455STATIC void
3eb57f73
HS		 456S_cop_free(pTHX_ COP* cop)
457{
05ec9bb3
NIS		 458 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
459 CopFILE_free(cop);
460 CopSTASH_free(cop);
0453d815 461 if (! specialWARN(cop->cop_warnings))
3eb57f73 462 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS		 463 if (! specialCopIO(cop->cop_io)) {
464#ifdef USE_ITHREADS
042f6df8 465#if 0
05ec9bb3
NIS		 466 STRLEN len;
467 char *s = SvPV(cop->cop_io,len);
b178108d
JH		 468 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
469#endif
05ec9bb3 470#else
ac27b0f5 471 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS		 472#endif
473 }
3eb57f73
HS		 474}
475
93c66552
DM		 476void
477Perl_op_null(pTHX_ OP *o)
8990e307 478{
27da23d5 479 dVAR;
acb36ea4
GS		 480 if (o->op_type == OP_NULL)
481 return;
482 op_clear(o);
11343788
MB		 483 o->op_targ = o->op_type;
484 o->op_type = OP_NULL;
22c35a8c 485 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 486}
487
4026c95a
SH		 488void
489Perl_op_refcnt_lock(pTHX)
490{
27da23d5 491 dVAR;
4026c95a
SH		 492 OP_REFCNT_LOCK;
493}
494
495void
496Perl_op_refcnt_unlock(pTHX)
497{
27da23d5 498 dVAR;
4026c95a
SH		 499 OP_REFCNT_UNLOCK;
500}
501
79072805
LW		 502/* Contextualizers */
503
463ee0b2 504#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 505
506OP *
864dbfa3 507Perl_linklist(pTHX_ OP *o)
79072805 508{
3edf23ff 509 OP *first;
79072805 510
11343788
MB		 511 if (o->op_next)
512 return o->op_next;
79072805
LW		 513
514 /* establish postfix order */
3edf23ff
AL		 515 first = cUNOPo->op_first;
516 if (first) {
6867be6d 517 register OP *kid;
3edf23ff
AL		 518 o->op_next = LINKLIST(first);
519 kid = first;
520 for (;;) {
521 if (kid->op_sibling) {
79072805 522 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 523 kid = kid->op_sibling;
524 } else {
11343788 525 kid->op_next = o;
3edf23ff
AL		 526 break;
527 }
79072805
LW		 528 }
529 }
530 else
11343788 531 o->op_next = o;
79072805 532
11343788 533 return o->op_next;
79072805
LW		 534}
535
536OP *
864dbfa3 537Perl_scalarkids(pTHX_ OP *o)
79072805 538{
11343788 539 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 540 OP *kid;
11343788 541 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 542 scalar(kid);
543 }
11343788 544 return o;
79072805
LW		 545}
546
76e3520e 547STATIC OP *
cea2e8a9 548S_scalarboolean(pTHX_ OP *o)
8990e307 549{
97aff369 550 dVAR;
d008e5eb 551 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 552 if (ckWARN(WARN_SYNTAX)) {
6867be6d 553 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 554
d008e5eb 555 if (PL_copline != NOLINE)
57843af0 556 CopLINE_set(PL_curcop, PL_copline);
9014280d 557 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 558 CopLINE_set(PL_curcop, oldline);
d008e5eb 559 }
a0d0e21e 560 }
11343788 561 return scalar(o);
8990e307
LW		 562}
563
564OP *
864dbfa3 565Perl_scalar(pTHX_ OP *o)
79072805 566{
27da23d5 567 dVAR;
79072805
LW		 568 OP *kid;
569
a0d0e21e 570 /* assumes no premature commitment */
551405c4 571 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
5dc0d613 572 || o->op_type == OP_RETURN)
7e363e51 573 {
11343788 574 return o;
7e363e51 575 }
79072805 576
5dc0d613 577 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 578
11343788 579 switch (o->op_type) {
79072805 580 case OP_REPEAT:
11343788 581 scalar(cBINOPo->op_first);
8990e307 582 break;
79072805
LW		 583 case OP_OR:
584 case OP_AND:
585 case OP_COND_EXPR:
11343788 586 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 587 scalar(kid);
79072805 588 break;
a0d0e21e 589 case OP_SPLIT:
11343788 590 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 591 if (!kPMOP->op_pmreplroot)
12bcd1a6 592 deprecate_old("implicit split to @_");
a0d0e21e
LW		 593 }
594 /* FALL THROUGH */
79072805 595 case OP_MATCH:
8782bef2 596 case OP_QR:
79072805
LW		 597 case OP_SUBST:
598 case OP_NULL:
8990e307 599 default:
11343788
MB		 600 if (o->op_flags & OPf_KIDS) {
601 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 602 scalar(kid);
603 }
79072805
LW		 604 break;
605 case OP_LEAVE:
606 case OP_LEAVETRY:
5dc0d613 607 kid = cLISTOPo->op_first;
54310121 608 scalar(kid);
155aba94 609 while ((kid = kid->op_sibling)) {
54310121 610 if (kid->op_sibling)
611 scalarvoid(kid);
612 else
613 scalar(kid);
614 }
3280af22 615 WITH_THR(PL_curcop = &PL_compiling);
54310121 616 break;
748a9306 617 case OP_SCOPE:
79072805 618 case OP_LINESEQ:
8990e307 619 case OP_LIST:
11343788 620 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 621 if (kid->op_sibling)
622 scalarvoid(kid);
623 else
624 scalar(kid);
625 }
3280af22 626 WITH_THR(PL_curcop = &PL_compiling);
79072805 627 break;
a801c63c
RGS		 628 case OP_SORT:
629 if (ckWARN(WARN_VOID))
9014280d 630 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 631 }
11343788 632 return o;
79072805
LW		 633}
634
635OP *
864dbfa3 636Perl_scalarvoid(pTHX_ OP *o)
79072805 637{
27da23d5 638 dVAR;
79072805 639 OP *kid;
c445ea15 640 const char* useless = NULL;
8990e307 641 SV* sv;
2ebea0a1
GS		 642 U8 want;
643
acb36ea4
GS		 644 if (o->op_type == OP_NEXTSTATE
645 || o->op_type == OP_SETSTATE
646 || o->op_type == OP_DBSTATE
647 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
648 || o->op_targ == OP_SETSTATE
649 || o->op_targ == OP_DBSTATE)))
2ebea0a1 650 PL_curcop = (COP*)o; /* for warning below */
79072805 651
54310121 652 /* assumes no premature commitment */
2ebea0a1
GS		 653 want = o->op_flags & OPf_WANT;
654 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 655 || o->op_type == OP_RETURN)
7e363e51 656 {
11343788 657 return o;
7e363e51 658 }
79072805 659
b162f9ea 660 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 661 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
662 {
b162f9ea 663 return scalar(o); /* As if inside SASSIGN */
7e363e51 664 }
1c846c1f 665
5dc0d613 666 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 667
11343788 668 switch (o->op_type) {
79072805 669 default:
22c35a8c 670 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 671 break;
36477c24 672 /* FALL THROUGH */
673 case OP_REPEAT:
11343788 674 if (o->op_flags & OPf_STACKED)
8990e307 675 break;
5d82c453
GA		 676 goto func_ops;
677 case OP_SUBSTR:
678 if (o->op_private == 4)
679 break;
8990e307
LW		 680 /* FALL THROUGH */
681 case OP_GVSV:
682 case OP_WANTARRAY:
683 case OP_GV:
684 case OP_PADSV:
685 case OP_PADAV:
686 case OP_PADHV:
687 case OP_PADANY:
688 case OP_AV2ARYLEN:
8990e307 689 case OP_REF:
a0d0e21e
LW		 690 case OP_REFGEN:
691 case OP_SREFGEN:
8990e307
LW		 692 case OP_DEFINED:
693 case OP_HEX:
694 case OP_OCT:
695 case OP_LENGTH:
8990e307
LW		 696 case OP_VEC:
697 case OP_INDEX:
698 case OP_RINDEX:
699 case OP_SPRINTF:
700 case OP_AELEM:
701 case OP_AELEMFAST:
702 case OP_ASLICE:
8990e307
LW		 703 case OP_HELEM:
704 case OP_HSLICE:
705 case OP_UNPACK:
706 case OP_PACK:
8990e307
LW		 707 case OP_JOIN:
708 case OP_LSLICE:
709 case OP_ANONLIST:
710 case OP_ANONHASH:
711 case OP_SORT:
712 case OP_REVERSE:
713 case OP_RANGE:
714 case OP_FLIP:
715 case OP_FLOP:
716 case OP_CALLER:
717 case OP_FILENO:
718 case OP_EOF:
719 case OP_TELL:
720 case OP_GETSOCKNAME:
721 case OP_GETPEERNAME:
722 case OP_READLINK:
723 case OP_TELLDIR:
724 case OP_GETPPID:
725 case OP_GETPGRP:
726 case OP_GETPRIORITY:
727 case OP_TIME:
728 case OP_TMS:
729 case OP_LOCALTIME:
730 case OP_GMTIME:
731 case OP_GHBYNAME:
732 case OP_GHBYADDR:
733 case OP_GHOSTENT:
734 case OP_GNBYNAME:
735 case OP_GNBYADDR:
736 case OP_GNETENT:
737 case OP_GPBYNAME:
738 case OP_GPBYNUMBER:
739 case OP_GPROTOENT:
740 case OP_GSBYNAME:
741 case OP_GSBYPORT:
742 case OP_GSERVENT:
743 case OP_GPWNAM:
744 case OP_GPWUID:
745 case OP_GGRNAM:
746 case OP_GGRGID:
747 case OP_GETLOGIN:
78e1b766 748 case OP_PROTOTYPE:
5d82c453 749 func_ops:
64aac5a9 750 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 751 useless = OP_DESC(o);
8990e307
LW		 752 break;
753
9f82cd5f
YST		 754 case OP_NOT:
755 kid = cUNOPo->op_first;
756 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
757 kid->op_type != OP_TRANS) {
758 goto func_ops;
759 }
760 useless = "negative pattern binding (!~)";
761 break;
762
8990e307
LW		 763 case OP_RV2GV:
764 case OP_RV2SV:
765 case OP_RV2AV:
766 case OP_RV2HV:
192587c2 767 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 768 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 769 useless = "a variable";
770 break;
79072805
LW		 771
772 case OP_CONST:
7766f137 773 sv = cSVOPo_sv;
7a52d87a
GS		 774 if (cSVOPo->op_private & OPpCONST_STRICT)
775 no_bareword_allowed(o);
776 else {
d008e5eb
GS		 777 if (ckWARN(WARN_VOID)) {
778 useless = "a constant";
e7fec78e 779 /* don't warn on optimised away booleans, eg
b5a930ec 780 * use constant Foo, 5; Foo || print; */
e7fec78e
DM		 781 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
782 useless = 0;
960b4253
MG		 783 /* the constants 0 and 1 are permitted as they are
784 conventionally used as dummies in constructs like
785 1 while some_condition_with_side_effects; */
e7fec78e 786 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d008e5eb
GS		 787 useless = 0;
788 else if (SvPOK(sv)) {
a52fe3ac
A		 789 /* perl4's way of mixing documentation and code
790 (before the invention of POD) was based on a
791 trick to mix nroff and perl code. The trick was
792 built upon these three nroff macros being used in
793 void context. The pink camel has the details in
794 the script wrapman near page 319. */
6136c704
AL		 795 const char * const maybe_macro = SvPVX_const(sv);
796 if (strnEQ(maybe_macro, "di", 2) ||
797 strnEQ(maybe_macro, "ds", 2) ||
798 strnEQ(maybe_macro, "ig", 2))
d008e5eb
GS		 799 useless = 0;
800 }
8990e307
LW		 801 }
802 }
93c66552 803 op_null(o); /* don't execute or even remember it */
79072805
LW		 804 break;
805
806 case OP_POSTINC:
11343788 807 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 808 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 809 break;
810
811 case OP_POSTDEC:
11343788 812 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 813 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 814 break;
815
679d6c4e
HS		 816 case OP_I_POSTINC:
817 o->op_type = OP_I_PREINC; /* pre-increment is faster */
818 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
819 break;
820
821 case OP_I_POSTDEC:
822 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
823 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
824 break;
825
79072805
LW		 826 case OP_OR:
827 case OP_AND:
c963b151 828 case OP_DOR:
79072805 829 case OP_COND_EXPR:
0d863452
RH		 830 case OP_ENTERGIVEN:
831 case OP_ENTERWHEN:
11343788 832 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 833 scalarvoid(kid);
834 break;
5aabfad6 835
a0d0e21e 836 case OP_NULL:
11343788 837 if (o->op_flags & OPf_STACKED)
a0d0e21e 838 break;
5aabfad6 839 /* FALL THROUGH */
2ebea0a1
GS		 840 case OP_NEXTSTATE:
841 case OP_DBSTATE:
79072805
LW		 842 case OP_ENTERTRY:
843 case OP_ENTER:
11343788 844 if (!(o->op_flags & OPf_KIDS))
79072805 845 break;
54310121 846 /* FALL THROUGH */
463ee0b2 847 case OP_SCOPE:
79072805
LW		 848 case OP_LEAVE:
849 case OP_LEAVETRY:
a0d0e21e 850 case OP_LEAVELOOP:
79072805 851 case OP_LINESEQ:
79072805 852 case OP_LIST:
0d863452
RH		 853 case OP_LEAVEGIVEN:
854 case OP_LEAVEWHEN:
11343788 855 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 856 scalarvoid(kid);
857 break;
c90c0ff4 858 case OP_ENTEREVAL:
5196be3e 859 scalarkids(o);
c90c0ff4 860 break;
5aabfad6 861 case OP_REQUIRE:
c90c0ff4 862 /* all requires must return a boolean value */
5196be3e 863 o->op_flags &= ~OPf_WANT;
d6483035
GS		 864 /* FALL THROUGH */
865 case OP_SCALAR:
5196be3e 866 return scalar(o);
a0d0e21e 867 case OP_SPLIT:
11343788 868 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 869 if (!kPMOP->op_pmreplroot)
12bcd1a6 870 deprecate_old("implicit split to @_");
a0d0e21e
LW		 871 }
872 break;
79072805 873 }
411caa50 874 if (useless && ckWARN(WARN_VOID))
9014280d 875 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 876 return o;
79072805
LW		 877}
878
879OP *
864dbfa3 880Perl_listkids(pTHX_ OP *o)
79072805 881{
11343788 882 if (o && o->op_flags & OPf_KIDS) {
6867be6d 883 OP *kid;
11343788 884 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 885 list(kid);
886 }
11343788 887 return o;
79072805
LW		 888}
889
890OP *
864dbfa3 891Perl_list(pTHX_ OP *o)
79072805 892{
27da23d5 893 dVAR;
79072805
LW		 894 OP *kid;
895
a0d0e21e 896 /* assumes no premature commitment */
3280af22 897 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 898 || o->op_type == OP_RETURN)
7e363e51 899 {
11343788 900 return o;
7e363e51 901 }
79072805 902
b162f9ea 903 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 904 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
905 {
b162f9ea 906 return o; /* As if inside SASSIGN */
7e363e51 907 }
1c846c1f 908
5dc0d613 909 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 910
11343788 911 switch (o->op_type) {
79072805
LW		 912 case OP_FLOP:
913 case OP_REPEAT:
11343788 914 list(cBINOPo->op_first);
79072805
LW		 915 break;
916 case OP_OR:
917 case OP_AND:
918 case OP_COND_EXPR:
11343788 919 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 920 list(kid);
921 break;
922 default:
923 case OP_MATCH:
8782bef2 924 case OP_QR:
79072805
LW		 925 case OP_SUBST:
926 case OP_NULL:
11343788 927 if (!(o->op_flags & OPf_KIDS))
79072805 928 break;
11343788
MB		 929 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
930 list(cBINOPo->op_first);
931 return gen_constant_list(o);
79072805
LW		 932 }
933 case OP_LIST:
11343788 934 listkids(o);
79072805
LW		 935 break;
936 case OP_LEAVE:
937 case OP_LEAVETRY:
5dc0d613 938 kid = cLISTOPo->op_first;
54310121 939 list(kid);
155aba94 940 while ((kid = kid->op_sibling)) {
54310121 941 if (kid->op_sibling)
942 scalarvoid(kid);
943 else
944 list(kid);
945 }
3280af22 946 WITH_THR(PL_curcop = &PL_compiling);
54310121 947 break;
748a9306 948 case OP_SCOPE:
79072805 949 case OP_LINESEQ:
11343788 950 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 951 if (kid->op_sibling)
952 scalarvoid(kid);
953 else
954 list(kid);
955 }
3280af22 956 WITH_THR(PL_curcop = &PL_compiling);
79072805 957 break;
c90c0ff4 958 case OP_REQUIRE:
959 /* all requires must return a boolean value */
5196be3e
MB		 960 o->op_flags &= ~OPf_WANT;
961 return scalar(o);
79072805 962 }
11343788 963 return o;
79072805
LW		 964}
965
966OP *
864dbfa3 967Perl_scalarseq(pTHX_ OP *o)
79072805 968{
97aff369 969 dVAR;
11343788
MB		 970 if (o) {
971 if (o->op_type == OP_LINESEQ ||
972 o->op_type == OP_SCOPE ||
973 o->op_type == OP_LEAVE ||
974 o->op_type == OP_LEAVETRY)
463ee0b2 975 {
6867be6d 976 OP *kid;
11343788 977 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 978 if (kid->op_sibling) {
463ee0b2 979 scalarvoid(kid);
ed6116ce 980 }
463ee0b2 981 }
3280af22 982 PL_curcop = &PL_compiling;
79072805 983 }
11343788 984 o->op_flags &= ~OPf_PARENS;
3280af22 985 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 986 o->op_flags |= OPf_PARENS;
79072805 987 }
8990e307 988 else
11343788
MB		 989 o = newOP(OP_STUB, 0);
990 return o;
79072805
LW		 991}
992
76e3520e 993STATIC OP *
cea2e8a9 994S_modkids(pTHX_ OP *o, I32 type)
79072805 995{
11343788 996 if (o && o->op_flags & OPf_KIDS) {
6867be6d 997 OP *kid;
11343788 998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 999 mod(kid, type);
79072805 1000 }
11343788 1001 return o;
79072805
LW		 1002}
1003
ff7298cb 1004/* Propagate lvalue ("modifiable") context to an op and its children.
ddeae0f1
DM		 1005 * 'type' represents the context type, roughly based on the type of op that
1006 * would do the modifying, although local() is represented by OP_NULL.
1007 * It's responsible for detecting things that can't be modified, flag
1008 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1009 * might have to vivify a reference in $x), and so on.
1010 *
1011 * For example, "$a+1 = 2" would cause mod() to be called with o being
1012 * OP_ADD and type being OP_SASSIGN, and would output an error.
1013 */
1014
79072805 1015OP *
864dbfa3 1016Perl_mod(pTHX_ OP *o, I32 type)
79072805 1017{
27da23d5 1018 dVAR;
79072805 1019 OP *kid;
ddeae0f1
DM		 1020 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1021 int localize = -1;
79072805 1022
3280af22 1023 if (!o || PL_error_count)
11343788 1024 return o;
79072805 1025
b162f9ea 1026 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1028 {
b162f9ea 1029 return o;
7e363e51 1030 }
1c846c1f 1031
11343788 1032 switch (o->op_type) {
68dc0745 1033 case OP_UNDEF:
ddeae0f1 1034 localize = 0;
3280af22 1035 PL_modcount++;
5dc0d613 1036 return o;
a0d0e21e 1037 case OP_CONST:
11343788 1038 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1039 goto nomod;
54dc0f91 1040 localize = 0;
3280af22 1041 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1042 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1043 PL_eval_start = 0;
a0d0e21e
LW		 1044 }
1045 else if (!type) {
3280af22
NIS		 1046 SAVEI32(PL_compiling.cop_arybase);
1047 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 1048 }
1049 else if (type == OP_REFGEN)
1050 goto nomod;
1051 else
cea2e8a9 1052 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1053 break;
5f05dabc 1054 case OP_STUB:
5196be3e 1055 if (o->op_flags & OPf_PARENS)
5f05dabc 1056 break;
1057 goto nomod;
a0d0e21e
LW		 1058 case OP_ENTERSUB:
1059 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1060 !(o->op_flags & OPf_STACKED)) {
1061 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC		 1062 /* The default is to set op_private to the number of children,
1063 which for a UNOP such as RV2CV is always 1. And w're using
1064 the bit for a flag in RV2CV, so we need it clear. */
1065 o->op_private &= ~1;
22c35a8c 1066 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1067 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1068 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1069 break;
1070 }
95f0a2f1
SB		 1071 else if (o->op_private & OPpENTERSUB_NOMOD)
1072 return o;
cd06dffe
GS		 1073 else { /* lvalue subroutine call */
1074 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1075 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1076 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1077 /* Backward compatibility mode: */
1078 o->op_private |= OPpENTERSUB_INARGS;
1079 break;
1080 }
1081 else { /* Compile-time error message: */
1082 OP *kid = cUNOPo->op_first;
1083 CV *cv;
1084 OP *okid;
1085
1086 if (kid->op_type == OP_PUSHMARK)
1087 goto skip_kids;
1088 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1089 Perl_croak(aTHX_
1090 "panic: unexpected lvalue entersub "
55140b79 1091 "args: type/targ %ld:%"UVuf,
3d811634 1092 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1093 kid = kLISTOP->op_first;
1094 skip_kids:
1095 while (kid->op_sibling)
1096 kid = kid->op_sibling;
1097 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1098 /* Indirect call */
1099 if (kid->op_type == OP_METHOD_NAMED
1100 || kid->op_type == OP_METHOD)
1101 {
87d7fd28 1102 UNOP *newop;
b2ffa427 1103
87d7fd28 1104 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1105 newop->op_type = OP_RV2CV;
1106 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 1107 newop->op_first = Nullop;
1108 newop->op_next = (OP*)newop;
1109 kid->op_sibling = (OP*)newop;
349fd7b7 1110 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1111 newop->op_private &= ~1;
cd06dffe
GS		 1112 break;
1113 }
b2ffa427 1114
cd06dffe
GS		 1115 if (kid->op_type != OP_RV2CV)
1116 Perl_croak(aTHX_
1117 "panic: unexpected lvalue entersub "
55140b79 1118 "entry via type/targ %ld:%"UVuf,
3d811634 1119 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1120 kid->op_private |= OPpLVAL_INTRO;
1121 break; /* Postpone until runtime */
1122 }
b2ffa427
NIS		 1123
1124 okid = kid;
cd06dffe
GS		 1125 kid = kUNOP->op_first;
1126 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1127 kid = kUNOP->op_first;
b2ffa427 1128 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1129 Perl_croak(aTHX_
1130 "Unexpected constant lvalue entersub "
55140b79 1131 "entry via type/targ %ld:%"UVuf,
3d811634 1132 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1133 if (kid->op_type != OP_GV) {
1134 /* Restore RV2CV to check lvalueness */
1135 restore_2cv:
1136 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1137 okid->op_next = kid->op_next;
1138 kid->op_next = okid;
1139 }
1140 else
1141 okid->op_next = Nullop;
1142 okid->op_type = OP_RV2CV;
1143 okid->op_targ = 0;
1144 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1145 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1146 okid->op_private &= ~1;
cd06dffe
GS		 1147 break;
1148 }
b2ffa427 1149
638eceb6 1150 cv = GvCV(kGVOP_gv);
1c846c1f 1151 if (!cv)
cd06dffe
GS		 1152 goto restore_2cv;
1153 if (CvLVALUE(cv))
1154 break;
1155 }
1156 }
79072805
LW		 1157 /* FALL THROUGH */
1158 default:
a0d0e21e 1159 nomod:
e26a4975
DM		 1160 /* grep, foreach, subcalls, refgen, m//g */
1161 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
1162 || type == OP_MATCH)
a0d0e21e 1163 break;
cea2e8a9 1164 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1165 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1166 ? "do block"
1167 : (o->op_type == OP_ENTERSUB
1168 ? "non-lvalue subroutine call"
53e06cf0 1169 : OP_DESC(o))),
22c35a8c 1170 type ? PL_op_desc[type] : "local"));
11343788 1171 return o;
79072805 1172
a0d0e21e
LW		 1173 case OP_PREINC:
1174 case OP_PREDEC:
1175 case OP_POW:
1176 case OP_MULTIPLY:
1177 case OP_DIVIDE:
1178 case OP_MODULO:
1179 case OP_REPEAT:
1180 case OP_ADD:
1181 case OP_SUBTRACT:
1182 case OP_CONCAT:
1183 case OP_LEFT_SHIFT:
1184 case OP_RIGHT_SHIFT:
1185 case OP_BIT_AND:
1186 case OP_BIT_XOR:
1187 case OP_BIT_OR:
1188 case OP_I_MULTIPLY:
1189 case OP_I_DIVIDE:
1190 case OP_I_MODULO:
1191 case OP_I_ADD:
1192 case OP_I_SUBTRACT:
11343788 1193 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1194 goto nomod;
3280af22 1195 PL_modcount++;
a0d0e21e 1196 break;
b2ffa427 1197
79072805 1198 case OP_COND_EXPR:
ddeae0f1 1199 localize = 1;
11343788 1200 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1201 mod(kid, type);
79072805
LW		 1202 break;
1203
1204 case OP_RV2AV:
1205 case OP_RV2HV:
11343788 1206 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1207 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1208 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1209 }
1210 /* FALL THROUGH */
79072805 1211 case OP_RV2GV:
5dc0d613 1212 if (scalar_mod_type(o, type))
3fe9a6f1 1213 goto nomod;
11343788 1214 ref(cUNOPo->op_first, o->op_type);
79072805 1215 /* FALL THROUGH */
79072805
LW		 1216 case OP_ASLICE:
1217 case OP_HSLICE:
78f9721b
SM		 1218 if (type == OP_LEAVESUBLV)
1219 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1220 localize = 1;
78f9721b
SM		 1221 /* FALL THROUGH */
1222 case OP_AASSIGN:
93a17b20
LW		 1223 case OP_NEXTSTATE:
1224 case OP_DBSTATE:
e6438c1a 1225 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1226 break;
463ee0b2 1227 case OP_RV2SV:
aeea060c 1228 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1229 localize = 1;
463ee0b2 1230 /* FALL THROUGH */
79072805 1231 case OP_GV:
463ee0b2 1232 case OP_AV2ARYLEN:
3280af22 1233 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1234 case OP_SASSIGN:
bf4b1e52
GS		 1235 case OP_ANDASSIGN:
1236 case OP_ORASSIGN:
c963b151 1237 case OP_DORASSIGN:
ddeae0f1
DM		 1238 PL_modcount++;
1239 break;
1240
8990e307 1241 case OP_AELEMFAST:
6a077020 1242 localize = -1;
3280af22 1243 PL_modcount++;
8990e307
LW		 1244 break;
1245
748a9306
LW		 1246 case OP_PADAV:
1247 case OP_PADHV:
e6438c1a 1248 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1249 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1250 return o; /* Treat \(@foo) like ordinary list. */
1251 if (scalar_mod_type(o, type))
3fe9a6f1 1252 goto nomod;
78f9721b
SM		 1253 if (type == OP_LEAVESUBLV)
1254 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1255 /* FALL THROUGH */
1256 case OP_PADSV:
3280af22 1257 PL_modcount++;
ddeae0f1 1258 if (!type) /* local() */
cea2e8a9 1259 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1260 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1261 break;
1262
748a9306 1263 case OP_PUSHMARK:
ddeae0f1 1264 localize = 0;
748a9306 1265 break;
b2ffa427 1266
69969c6f
SB		 1267 case OP_KEYS:
1268 if (type != OP_SASSIGN)
1269 goto nomod;
5d82c453
GA		 1270 goto lvalue_func;
1271 case OP_SUBSTR:
1272 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1273 goto nomod;
5f05dabc 1274 /* FALL THROUGH */
a0d0e21e 1275 case OP_POS:
463ee0b2 1276 case OP_VEC:
78f9721b
SM		 1277 if (type == OP_LEAVESUBLV)
1278 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1279 lvalue_func:
11343788
MB		 1280 pad_free(o->op_targ);
1281 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1282 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1283 if (o->op_flags & OPf_KIDS)
1284 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1285 break;
a0d0e21e 1286
463ee0b2
LW		 1287 case OP_AELEM:
1288 case OP_HELEM:
11343788 1289 ref(cBINOPo->op_first, o->op_type);
68dc0745 1290 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1291 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1292 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1293 if (type == OP_LEAVESUBLV)
1294 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1295 localize = 1;
3280af22 1296 PL_modcount++;
463ee0b2
LW		 1297 break;
1298
1299 case OP_SCOPE:
1300 case OP_LEAVE:
1301 case OP_ENTER:
78f9721b 1302 case OP_LINESEQ:
ddeae0f1 1303 localize = 0;
11343788
MB		 1304 if (o->op_flags & OPf_KIDS)
1305 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1306 break;
1307
1308 case OP_NULL:
ddeae0f1 1309 localize = 0;
638bc118
GS		 1310 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1311 goto nomod;
1312 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1313 break;
11343788
MB		 1314 if (o->op_targ != OP_LIST) {
1315 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1316 break;
1317 }
1318 /* FALL THROUGH */
463ee0b2 1319 case OP_LIST:
ddeae0f1 1320 localize = 0;
11343788 1321 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1322 mod(kid, type);
1323 break;
78f9721b
SM		 1324
1325 case OP_RETURN:
1326 if (type != OP_LEAVESUBLV)
1327 goto nomod;
1328 break; /* mod()ing was handled by ck_return() */
463ee0b2 1329 }
58d95175 1330
8be1be90
AMS		 1331 /* [20011101.069] File test operators interpret OPf_REF to mean that
1332 their argument is a filehandle; thus \stat(".") should not set
1333 it. AMS 20011102 */
1334 if (type == OP_REFGEN &&
1335 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1336 return o;
1337
1338 if (type != OP_LEAVESUBLV)
1339 o->op_flags |= OPf_MOD;
1340
1341 if (type == OP_AASSIGN || type == OP_SASSIGN)
1342 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1343 else if (!type) { /* local() */
1344 switch (localize) {
1345 case 1:
1346 o->op_private |= OPpLVAL_INTRO;
1347 o->op_flags &= ~OPf_SPECIAL;
1348 PL_hints |= HINT_BLOCK_SCOPE;
1349 break;
1350 case 0:
1351 break;
1352 case -1:
1353 if (ckWARN(WARN_SYNTAX)) {
1354 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1355 "Useless localization of %s", OP_DESC(o));
1356 }
1357 }
463ee0b2 1358 }
8be1be90
AMS		 1359 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1360 && type != OP_LEAVESUBLV)
1361 o->op_flags |= OPf_REF;
11343788 1362 return o;
463ee0b2
LW		 1363}
1364
864dbfa3 1365STATIC bool
6867be6d 1366S_scalar_mod_type(pTHX_ const OP *o, I32 type)
3fe9a6f1 1367{
1368 switch (type) {
1369 case OP_SASSIGN:
5196be3e 1370 if (o->op_type == OP_RV2GV)
3fe9a6f1 1371 return FALSE;
1372 /* FALL THROUGH */
1373 case OP_PREINC:
1374 case OP_PREDEC:
1375 case OP_POSTINC:
1376 case OP_POSTDEC:
1377 case OP_I_PREINC:
1378 case OP_I_PREDEC:
1379 case OP_I_POSTINC:
1380 case OP_I_POSTDEC:
1381 case OP_POW:
1382 case OP_MULTIPLY:
1383 case OP_DIVIDE:
1384 case OP_MODULO:
1385 case OP_REPEAT:
1386 case OP_ADD:
1387 case OP_SUBTRACT:
1388 case OP_I_MULTIPLY:
1389 case OP_I_DIVIDE:
1390 case OP_I_MODULO:
1391 case OP_I_ADD:
1392 case OP_I_SUBTRACT:
1393 case OP_LEFT_SHIFT:
1394 case OP_RIGHT_SHIFT:
1395 case OP_BIT_AND:
1396 case OP_BIT_XOR:
1397 case OP_BIT_OR:
1398 case OP_CONCAT:
1399 case OP_SUBST:
1400 case OP_TRANS:
49e9fbe6
GS		 1401 case OP_READ:
1402 case OP_SYSREAD:
1403 case OP_RECV:
bf4b1e52
GS		 1404 case OP_ANDASSIGN:
1405 case OP_ORASSIGN:
3fe9a6f1 1406 return TRUE;
1407 default:
1408 return FALSE;
1409 }
1410}
1411
35cd451c 1412STATIC bool
504618e9 1413S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
35cd451c
GS		 1414{
1415 switch (o->op_type) {
1416 case OP_PIPE_OP:
1417 case OP_SOCKPAIR:
504618e9 1418 if (numargs == 2)
35cd451c
GS		 1419 return TRUE;
1420 /* FALL THROUGH */
1421 case OP_SYSOPEN:
1422 case OP_OPEN:
ded8aa31 1423 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1424 case OP_SOCKET:
1425 case OP_OPEN_DIR:
1426 case OP_ACCEPT:
504618e9 1427 if (numargs == 1)
35cd451c
GS		 1428 return TRUE;
1429 /* FALL THROUGH */
1430 default:
1431 return FALSE;
1432 }
1433}
1434
463ee0b2 1435OP *
864dbfa3 1436Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1437{
11343788 1438 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1439 OP *kid;
11343788 1440 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1441 ref(kid, type);
1442 }
11343788 1443 return o;
463ee0b2
LW		 1444}
1445
1446OP *
e4c5ccf3 1447Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1448{
27da23d5 1449 dVAR;
463ee0b2 1450 OP *kid;
463ee0b2 1451
3280af22 1452 if (!o || PL_error_count)
11343788 1453 return o;
463ee0b2 1454
11343788 1455 switch (o->op_type) {
a0d0e21e 1456 case OP_ENTERSUB:
afebc493 1457 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1458 !(o->op_flags & OPf_STACKED)) {
1459 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1460 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1461 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1462 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1463 o->op_flags |= OPf_SPECIAL;
e26df76a 1464 o->op_private &= ~1;
8990e307
LW		 1465 }
1466 break;
aeea060c 1467
463ee0b2 1468 case OP_COND_EXPR:
11343788 1469 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1470 doref(kid, type, set_op_ref);
463ee0b2 1471 break;
8990e307 1472 case OP_RV2SV:
35cd451c
GS		 1473 if (type == OP_DEFINED)
1474 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1475 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1476 /* FALL THROUGH */
1477 case OP_PADSV:
5f05dabc 1478 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1479 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1480 : type == OP_RV2HV ? OPpDEREF_HV
1481 : OPpDEREF_SV);
11343788 1482 o->op_flags |= OPf_MOD;
a0d0e21e 1483 }
8990e307 1484 break;
1c846c1f 1485
2faa37cc 1486 case OP_THREADSV:
a863c7d1
MB		 1487 o->op_flags |= OPf_MOD; /* XXX ??? */
1488 break;
1489
463ee0b2
LW		 1490 case OP_RV2AV:
1491 case OP_RV2HV:
e4c5ccf3
RH		 1492 if (set_op_ref)
1493 o->op_flags |= OPf_REF;
8990e307 1494 /* FALL THROUGH */
463ee0b2 1495 case OP_RV2GV:
35cd451c
GS		 1496 if (type == OP_DEFINED)
1497 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1498 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1499 break;
8990e307 1500
463ee0b2
LW		 1501 case OP_PADAV:
1502 case OP_PADHV:
e4c5ccf3
RH		 1503 if (set_op_ref)
1504 o->op_flags |= OPf_REF;
79072805 1505 break;
aeea060c 1506
8990e307 1507 case OP_SCALAR:
79072805 1508 case OP_NULL:
11343788 1509 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1510 break;
e4c5ccf3 1511 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1512 break;
1513 case OP_AELEM:
1514 case OP_HELEM:
e4c5ccf3 1515 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1516 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1517 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1518 : type == OP_RV2HV ? OPpDEREF_HV
1519 : OPpDEREF_SV);
11343788 1520 o->op_flags |= OPf_MOD;
8990e307 1521 }
79072805
LW		 1522 break;
1523
463ee0b2 1524 case OP_SCOPE:
79072805 1525 case OP_LEAVE:
e4c5ccf3
RH		 1526 set_op_ref = FALSE;
1527 /* FALL THROUGH */
79072805 1528 case OP_ENTER:
8990e307 1529 case OP_LIST:
11343788 1530 if (!(o->op_flags & OPf_KIDS))
79072805 1531 break;
e4c5ccf3 1532 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1533 break;
a0d0e21e
LW		 1534 default:
1535 break;
79072805 1536 }
11343788 1537 return scalar(o);
8990e307 1538
79072805
LW		 1539}
1540
09bef843
SB		 1541STATIC OP *
1542S_dup_attrlist(pTHX_ OP *o)
1543{
97aff369 1544 dVAR;
0bd48802 1545 OP *rop;
09bef843
SB		 1546
1547 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1548 * where the first kid is OP_PUSHMARK and the remaining ones
1549 * are OP_CONST. We need to push the OP_CONST values.
1550 */
1551 if (o->op_type == OP_CONST)
1552 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1553 else {
1554 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
0bd48802 1555 rop = Nullop;
09bef843
SB		 1556 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1557 if (o->op_type == OP_CONST)
1558 rop = append_elem(OP_LIST, rop,
1559 newSVOP(OP_CONST, o->op_flags,
1560 SvREFCNT_inc(cSVOPo->op_sv)));
1561 }
1562 }
1563 return rop;
1564}
1565
1566STATIC void
95f0a2f1 1567S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1568{
27da23d5 1569 dVAR;
09bef843
SB		 1570 SV *stashsv;
1571
1572 /* fake up C<use attributes $pkg,$rv,@attrs> */
1573 ENTER; /* need to protect against side-effects of 'use' */
1574 SAVEINT(PL_expect);
5aaec2b4 1575 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1576
09bef843 1577#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1578#define ATTRSMODULE_PM "attributes.pm"
1579
1580 if (for_my) {
95f0a2f1 1581 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1582 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1
SB		 1583 if (svp && *svp != &PL_sv_undef)
1584 ; /* already in %INC */
1585 else
1586 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1587 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1588 }
1589 else {
1590 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 1591 newSVpvs(ATTRSMODULE),
1592 NULL,
95f0a2f1
SB		 1593 prepend_elem(OP_LIST,
1594 newSVOP(OP_CONST, 0, stashsv),
1595 prepend_elem(OP_LIST,
1596 newSVOP(OP_CONST, 0,
1597 newRV(target)),
1598 dup_attrlist(attrs))));
1599 }
09bef843
SB		 1600 LEAVE;
1601}
1602
95f0a2f1
SB		 1603STATIC void
1604S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1605{
97aff369 1606 dVAR;
95f0a2f1
SB		 1607 OP *pack, *imop, *arg;
1608 SV *meth, *stashsv;
1609
1610 if (!attrs)
1611 return;
1612
1613 assert(target->op_type == OP_PADSV ||
1614 target->op_type == OP_PADHV ||
1615 target->op_type == OP_PADAV);
1616
1617 /* Ensure that attributes.pm is loaded. */
dd2155a4 1618 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1619
1620 /* Need package name for method call. */
6136c704 1621 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1622
1623 /* Build up the real arg-list. */
5aaec2b4
NC		 1624 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1625
95f0a2f1
SB		 1626 arg = newOP(OP_PADSV, 0);
1627 arg->op_targ = target->op_targ;
1628 arg = prepend_elem(OP_LIST,
1629 newSVOP(OP_CONST, 0, stashsv),
1630 prepend_elem(OP_LIST,
1631 newUNOP(OP_REFGEN, 0,
1632 mod(arg, OP_REFGEN)),
1633 dup_attrlist(attrs)));
1634
1635 /* Fake up a method call to import */
18916d0d 1636 meth = newSVpvs_share("import");
95f0a2f1
SB		 1637 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1638 append_elem(OP_LIST,
1639 prepend_elem(OP_LIST, pack, list(arg)),
1640 newSVOP(OP_METHOD_NAMED, 0, meth)));
1641 imop->op_private |= OPpENTERSUB_NOMOD;
1642
1643 /* Combine the ops. */
1644 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1645}
1646
1647/*
1648=notfor apidoc apply_attrs_string
1649
1650Attempts to apply a list of attributes specified by the C<attrstr> and
1651C<len> arguments to the subroutine identified by the C<cv> argument which
1652is expected to be associated with the package identified by the C<stashpv>
1653argument (see L<attributes>). It gets this wrong, though, in that it
1654does not correctly identify the boundaries of the individual attribute
1655specifications within C<attrstr>. This is not really intended for the
1656public API, but has to be listed here for systems such as AIX which
1657need an explicit export list for symbols. (It's called from XS code
1658in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1659to respect attribute syntax properly would be welcome.
1660
1661=cut
1662*/
1663
be3174d2 1664void
6867be6d
AL		 1665Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1666 const char *attrstr, STRLEN len)
be3174d2
GS		 1667{
1668 OP *attrs = Nullop;
1669
1670 if (!len) {
1671 len = strlen(attrstr);
1672 }
1673
1674 while (len) {
1675 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1676 if (len) {
890ce7af 1677 const char * const sstr = attrstr;
be3174d2
GS		 1678 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1679 attrs = append_elem(OP_LIST, attrs,
1680 newSVOP(OP_CONST, 0,
1681 newSVpvn(sstr, attrstr-sstr)));
1682 }
1683 }
1684
1685 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 1686 newSVpvs(ATTRSMODULE),
be3174d2
GS		 1687 Nullsv, prepend_elem(OP_LIST,
1688 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1689 prepend_elem(OP_LIST,
1690 newSVOP(OP_CONST, 0,
1691 newRV((SV*)cv)),
1692 attrs)));
1693}
1694
09bef843 1695STATIC OP *
95f0a2f1 1696S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1697{
97aff369 1698 dVAR;
93a17b20
LW		 1699 I32 type;
1700
3280af22 1701 if (!o || PL_error_count)
11343788 1702 return o;
93a17b20 1703
11343788 1704 type = o->op_type;
93a17b20 1705 if (type == OP_LIST) {
6867be6d 1706 OP *kid;
11343788 1707 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1708 my_kid(kid, attrs, imopsp);
dab48698 1709 } else if (type == OP_UNDEF) {
7766148a 1710 return o;
77ca0c92
LW		 1711 } else if (type == OP_RV2SV || /* "our" declaration */
1712 type == OP_RV2AV ||
1713 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS		 1714 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1715 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1716 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1717 } else if (attrs) {
551405c4 1718 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1ce0b88c 1719 PL_in_my = FALSE;
5c284bb0 1720 PL_in_my_stash = NULL;
1ce0b88c
RGS		 1721 apply_attrs(GvSTASH(gv),
1722 (type == OP_RV2SV ? GvSV(gv) :
1723 type == OP_RV2AV ? (SV*)GvAV(gv) :
1724 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1725 attrs, FALSE);
1726 }
192587c2 1727 o->op_private |= OPpOUR_INTRO;
77ca0c92 1728 return o;
95f0a2f1
SB		 1729 }
1730 else if (type != OP_PADSV &&
93a17b20
LW		 1731 type != OP_PADAV &&
1732 type != OP_PADHV &&
1733 type != OP_PUSHMARK)
1734 {
eb64745e 1735 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1736 OP_DESC(o),
eb64745e 1737 PL_in_my == KEY_our ? "our" : "my"));
11343788 1738 return o;
93a17b20 1739 }
09bef843
SB		 1740 else if (attrs && type != OP_PUSHMARK) {
1741 HV *stash;
09bef843 1742
eb64745e 1743 PL_in_my = FALSE;
5c284bb0 1744 PL_in_my_stash = NULL;
eb64745e 1745
09bef843 1746 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1747 stash = PAD_COMPNAME_TYPE(o->op_targ);
1748 if (!stash)
09bef843 1749 stash = PL_curstash;
95f0a2f1 1750 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1751 }
11343788
MB		 1752 o->op_flags |= OPf_MOD;
1753 o->op_private |= OPpLVAL_INTRO;
1754 return o;
93a17b20
LW		 1755}
1756
1757OP *
09bef843
SB		 1758Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1759{
97aff369 1760 dVAR;
0bd48802 1761 OP *rops;
95f0a2f1
SB		 1762 int maybe_scalar = 0;
1763
d2be0de5 1764/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1765 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1766#if 0
09bef843
SB		 1767 if (o->op_flags & OPf_PARENS)
1768 list(o);
95f0a2f1
SB		 1769 else
1770 maybe_scalar = 1;
d2be0de5
YST		 1771#else
1772 maybe_scalar = 1;
1773#endif
09bef843
SB		 1774 if (attrs)
1775 SAVEFREEOP(attrs);
0bd48802 1776 rops = Nullop;
95f0a2f1
SB		 1777 o = my_kid(o, attrs, &rops);
1778 if (rops) {
1779 if (maybe_scalar && o->op_type == OP_PADSV) {
1780 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1781 o->op_private |= OPpLVAL_INTRO;
1782 }
1783 else
1784 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1785 }
eb64745e 1786 PL_in_my = FALSE;
5c284bb0 1787 PL_in_my_stash = NULL;
eb64745e 1788 return o;
09bef843
SB		 1789}
1790
1791OP *
1792Perl_my(pTHX_ OP *o)
1793{
95f0a2f1 1794 return my_attrs(o, Nullop);
09bef843
SB		 1795}
1796
1797OP *
864dbfa3 1798Perl_sawparens(pTHX_ OP *o)
79072805
LW		 1799{
1800 if (o)
1801 o->op_flags |= OPf_PARENS;
1802 return o;
1803}
1804
1805OP *
864dbfa3 1806Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1807{
11343788 1808 OP *o;
59f00321 1809 bool ismatchop = 0;
79072805 1810
041457d9 1811 if ( (left->op_type == OP_RV2AV ||
599cee73
PM		 1812 left->op_type == OP_RV2HV ||
1813 left->op_type == OP_PADAV ||
041457d9
DM		 1814 left->op_type == OP_PADHV)
1815 && ckWARN(WARN_MISC))
1816 {
551405c4 1817 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 1818 right->op_type == OP_TRANS)
1819 ? right->op_type : OP_MATCH];
551405c4 1820 const char * const sample = ((left->op_type == OP_RV2AV ||
dff6d3cd
GS		 1821 left->op_type == OP_PADAV)
1822 ? "@array" : "%hash");
9014280d 1823 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1824 "Applying %s to %s will act on scalar(%s)",
599cee73 1825 desc, sample, sample);
2ae324a7 1826 }
1827
5cc9e5c9
RH		 1828 if (right->op_type == OP_CONST &&
1829 cSVOPx(right)->op_private & OPpCONST_BARE &&
1830 cSVOPx(right)->op_private & OPpCONST_STRICT)
1831 {
1832 no_bareword_allowed(right);
1833 }
1834
59f00321
RGS		 1835 ismatchop = right->op_type == OP_MATCH ||
1836 right->op_type == OP_SUBST ||
1837 right->op_type == OP_TRANS;
1838 if (ismatchop && right->op_private & OPpTARGET_MY) {
1839 right->op_targ = 0;
1840 right->op_private &= ~OPpTARGET_MY;
1841 }
1842 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1843 right->op_flags |= OPf_STACKED;
e26a4975
DM		 1844 /* s/// and tr/// modify their arg.
1845 * m//g also indirectly modifies the arg by setting pos magic on it */
1846 if ( (right->op_type == OP_MATCH &&
1847 (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
1848 || (right->op_type == OP_SUBST)
1849 || (right->op_type == OP_TRANS &&
1850 ! (right->op_private & OPpTRANS_IDENTICAL))
1851 )
463ee0b2 1852 left = mod(left, right->op_type);
79072805 1853 if (right->op_type == OP_TRANS)
11343788 1854 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1855 else
11343788 1856 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1857 if (type == OP_NOT)
11343788
MB		 1858 return newUNOP(OP_NOT, 0, scalar(o));
1859 return o;
79072805
LW		 1860 }
1861 else
1862 return bind_match(type, left,
131b3ad0 1863 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 1864}
1865
1866OP *
864dbfa3 1867Perl_invert(pTHX_ OP *o)
79072805 1868{
11343788
MB		 1869 if (!o)
1870 return o;
79072805 1871 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1872 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1873}
1874
1875OP *
864dbfa3 1876Perl_scope(pTHX_ OP *o)
79072805 1877{
27da23d5 1878 dVAR;
79072805 1879 if (o) {
3280af22 1880 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1881 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1882 o->op_type = OP_LEAVE;
22c35a8c 1883 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1884 }
fdb22418
HS		 1885 else if (o->op_type == OP_LINESEQ) {
1886 OP *kid;
1887 o->op_type = OP_SCOPE;
1888 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1889 kid = ((LISTOP*)o)->op_first;
59110972 1890 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 1891 op_null(kid);
59110972
RH		 1892
1893 /* The following deals with things like 'do {1 for 1}' */
1894 kid = kid->op_sibling;
1895 if (kid &&
1896 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1897 op_null(kid);
1898 }
463ee0b2 1899 }
fdb22418
HS		 1900 else
1901 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
79072805
LW		 1902 }
1903 return o;
1904}
1905
a0d0e21e 1906int
864dbfa3 1907Perl_block_start(pTHX_ int full)
79072805 1908{
97aff369 1909 dVAR;
73d840c0 1910 const int retval = PL_savestack_ix;
dd2155a4 1911 pad_block_start(full);
b3ac6de7 1912 SAVEHINTS();
3280af22 1913 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1914 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1915 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 1916 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1917 SAVEFREESV(PL_compiling.cop_warnings) ;
1918 }
ac27b0f5
NIS		 1919 SAVESPTR(PL_compiling.cop_io);
1920 if (! specialCopIO(PL_compiling.cop_io)) {
1921 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1922 SAVEFREESV(PL_compiling.cop_io) ;
1923 }
a0d0e21e
LW		 1924 return retval;
1925}
1926
1927OP*
864dbfa3 1928Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1929{
97aff369 1930 dVAR;
6867be6d 1931 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 1932 OP* const retval = scalarseq(seq);
e9818f4e 1933 LEAVE_SCOPE(floor);
eb160463 1934 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1935 if (needblockscope)
3280af22 1936 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1937 pad_leavemy();
a0d0e21e
LW		 1938 return retval;
1939}
1940
76e3520e 1941STATIC OP *
cea2e8a9 1942S_newDEFSVOP(pTHX)
54b9620d 1943{
97aff369 1944 dVAR;
6867be6d 1945 const I32 offset = pad_findmy("$_");
59f00321
RGS		 1946 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1947 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1948 }
1949 else {
551405c4 1950 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 1951 o->op_targ = offset;
1952 return o;
1953 }
54b9620d
MB		 1954}
1955
a0d0e21e 1956void
864dbfa3 1957Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1958{
97aff369 1959 dVAR;
3280af22 1960 if (PL_in_eval) {
b295d113
TH		 1961 if (PL_eval_root)
1962 return;
faef0170
HS		 1963 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1964 ((PL_in_eval & EVAL_KEEPERR)
1965 ? OPf_SPECIAL : 0), o);
3280af22 1966 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 1967 PL_eval_root->op_private |= OPpREFCOUNTED;
1968 OpREFCNT_set(PL_eval_root, 1);
3280af22 1969 PL_eval_root->op_next = 0;
a2efc822 1970 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 1971 }
1972 else {
6be89cf9
AE		 1973 if (o->op_type == OP_STUB) {
1974 PL_comppad_name = 0;
1975 PL_compcv = 0;
2a4f803a 1976 FreeOp(o);
a0d0e21e 1977 return;
6be89cf9 1978 }
3280af22
NIS		 1979 PL_main_root = scope(sawparens(scalarvoid(o)));
1980 PL_curcop = &PL_compiling;
1981 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 1982 PL_main_root->op_private |= OPpREFCOUNTED;
1983 OpREFCNT_set(PL_main_root, 1);
3280af22 1984 PL_main_root->op_next = 0;
a2efc822 1985 CALL_PEEP(PL_main_start);
3280af22 1986 PL_compcv = 0;
3841441e 1987
4fdae800 1988 /* Register with debugger */
84902520 1989 if (PERLDB_INTER) {
551405c4 1990 CV * const cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 1991 if (cv) {
1992 dSP;
924508f0 1993 PUSHMARK(SP);
cc49e20b 1994 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1995 PUTBACK;
864dbfa3 1996 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 1997 }
1998 }
79072805 1999 }
79072805
LW		 2000}
2001
2002OP *
864dbfa3 2003Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2004{
97aff369 2005 dVAR;
79072805 2006 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2007/* [perl #17376]: this appears to be premature, and results in code such as
2008 C< our(%x); > executing in list mode rather than void mode */
2009#if 0
79072805 2010 list(o);
d2be0de5
YST		 2011#else
2012 ;
2013#endif
8990e307 2014 else {
041457d9
DM		 2015 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2016 && ckWARN(WARN_PARENTHESIS))
64420d0d
JH		 2017 {
2018 char *s = PL_bufptr;
bac662ee 2019 bool sigil = FALSE;
64420d0d 2020
8473848f 2021 /* some heuristics to detect a potential error */
bac662ee 2022 while (*s && (strchr(", \t\n", *s)))
64420d0d 2023 s++;
8473848f 2024
bac662ee
TS		 2025 while (1) {
2026 if (*s && strchr("@$%*", *s) && *++s
2027 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2028 s++;
2029 sigil = TRUE;
2030 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2031 s++;
2032 while (*s && (strchr(", \t\n", *s)))
2033 s++;
2034 }
2035 else
2036 break;
2037 }
2038 if (sigil && (*s == ';' || *s == '=')) {
2039 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS		 2040 "Parentheses missing around \"%s\" list",
2041 lex ? (PL_in_my == KEY_our ? "our" : "my")
2042 : "local");
2043 }
8990e307
LW		 2044 }
2045 }
93a17b20 2046 if (lex)
eb64745e 2047 o = my(o);
93a17b20 2048 else
eb64745e
GS		 2049 o = mod(o, OP_NULL); /* a bit kludgey */
2050 PL_in_my = FALSE;
5c284bb0 2051 PL_in_my_stash = NULL;
eb64745e 2052 return o;
79072805
LW		 2053}
2054
2055OP *
864dbfa3 2056Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2057{
2058 if (o->op_type == OP_LIST) {
6136c704 2059 OP * const o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV)));
554b3eca 2060 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2061 }
2062 return o;
2063}
2064
2065OP *
864dbfa3 2066Perl_fold_constants(pTHX_ register OP *o)
79072805 2067{
27da23d5 2068 dVAR;
79072805
LW		 2069 register OP *curop;
2070 I32 type = o->op_type;
748a9306 2071 SV *sv;
79072805 2072
22c35a8c 2073 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2074 scalar(o);
b162f9ea 2075 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2076 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2077
eac055e9
GS		 2078 /* integerize op, unless it happens to be C<-foo>.
2079 * XXX should pp_i_negate() do magic string negation instead? */
2080 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2081 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2082 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2083 {
22c35a8c 2084 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2085 }
85e6fe83 2086
22c35a8c 2087 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2088 goto nope;
2089
de939608 2090 switch (type) {
7a52d87a
GS		 2091 case OP_NEGATE:
2092 /* XXX might want a ck_negate() for this */
2093 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2094 break;
de939608
CS		 2095 case OP_UCFIRST:
2096 case OP_LCFIRST:
2097 case OP_UC:
2098 case OP_LC:
69dcf70c
MB		 2099 case OP_SLT:
2100 case OP_SGT:
2101 case OP_SLE:
2102 case OP_SGE:
2103 case OP_SCMP:
2de3dbcc
JH		 2104 /* XXX what about the numeric ops? */
2105 if (PL_hints & HINT_LOCALE)
de939608
CS		 2106 goto nope;
2107 }
2108
3280af22 2109 if (PL_error_count)
a0d0e21e
LW		 2110 goto nope; /* Don't try to run w/ errors */
2111
79072805 2112 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 2113 if ((curop->op_type != OP_CONST ||
2114 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 2115 curop->op_type != OP_LIST &&
2116 curop->op_type != OP_SCALAR &&
2117 curop->op_type != OP_NULL &&
2118 curop->op_type != OP_PUSHMARK)
2119 {
79072805
LW		 2120 goto nope;
2121 }
2122 }
2123
2124 curop = LINKLIST(o);
2125 o->op_next = 0;
533c011a 2126 PL_op = curop;
cea2e8a9 2127 CALLRUNOPS(aTHX);
3280af22 2128 sv = *(PL_stack_sp--);
748a9306 2129 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 2130 pad_swipe(o->op_targ, FALSE);
748a9306
LW		 2131 else if (SvTEMP(sv)) { /* grab mortal temp? */
2132 (void)SvREFCNT_inc(sv);
2133 SvTEMP_off(sv);
85e6fe83 2134 }
79072805
LW		 2135 op_free(o);
2136 if (type == OP_RV2GV)
b1cb66bf 2137 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 2138 return newSVOP(OP_CONST, 0, sv);
aeea060c 2139
79072805 2140 nope:
79072805
LW		 2141 return o;
2142}
2143
2144OP *
864dbfa3 2145Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2146{
27da23d5 2147 dVAR;
79072805 2148 register OP *curop;
6867be6d 2149 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2150
a0d0e21e 2151 list(o);
3280af22 2152 if (PL_error_count)
a0d0e21e
LW		 2153 return o; /* Don't attempt to run with errors */
2154
533c011a 2155 PL_op = curop = LINKLIST(o);
a0d0e21e 2156 o->op_next = 0;
a2efc822 2157 CALL_PEEP(curop);
cea2e8a9
GS		 2158 pp_pushmark();
2159 CALLRUNOPS(aTHX);
533c011a 2160 PL_op = curop;
cea2e8a9 2161 pp_anonlist();
3280af22 2162 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2163
2164 o->op_type = OP_RV2AV;
22c35a8c 2165 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2166 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2167 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2168 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2169 curop = ((UNOP*)o)->op_first;
3280af22 2170 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2171 op_free(curop);
79072805
LW		 2172 linklist(o);
2173 return list(o);
2174}
2175
2176OP *
864dbfa3 2177Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2178{
27da23d5 2179 dVAR;
11343788
MB		 2180 if (!o || o->op_type != OP_LIST)
2181 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2182 else
5dc0d613 2183 o->op_flags &= ~OPf_WANT;
79072805 2184
22c35a8c 2185 if (!(PL_opargs[type] & OA_MARK))
93c66552 2186 op_null(cLISTOPo->op_first);
8990e307 2187
eb160463 2188 o->op_type = (OPCODE)type;
22c35a8c 2189 o->op_ppaddr = PL_ppaddr[type];
11343788 2190 o->op_flags |= flags;
79072805 2191
11343788 2192 o = CHECKOP(type, o);
fe2774ed 2193 if (o->op_type != (unsigned)type)
11343788 2194 return o;
79072805 2195
11343788 2196 return fold_constants(o);
79072805
LW		 2197}
2198
2199/* List constructors */
2200
2201OP *
864dbfa3 2202Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2203{
2204 if (!first)
2205 return last;
8990e307
LW		 2206
2207 if (!last)
79072805 2208 return first;
8990e307 2209
fe2774ed 2210 if (first->op_type != (unsigned)type
155aba94
GS		 2211 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2212 {
2213 return newLISTOP(type, 0, first, last);
2214 }
79072805 2215
a0d0e21e
LW		 2216 if (first->op_flags & OPf_KIDS)
2217 ((LISTOP*)first)->op_last->op_sibling = last;
2218 else {
2219 first->op_flags |= OPf_KIDS;
2220 ((LISTOP*)first)->op_first = last;
2221 }
2222 ((LISTOP*)first)->op_last = last;
a0d0e21e 2223 return first;
79072805
LW		 2224}
2225
2226OP *
864dbfa3 2227Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2228{
2229 if (!first)
2230 return (OP*)last;
8990e307
LW		 2231
2232 if (!last)
79072805 2233 return (OP*)first;
8990e307 2234
fe2774ed 2235 if (first->op_type != (unsigned)type)
79072805 2236 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2237
fe2774ed 2238 if (last->op_type != (unsigned)type)
79072805
LW		 2239 return append_elem(type, (OP*)first, (OP*)last);
2240
2241 first->op_last->op_sibling = last->op_first;
2242 first->op_last = last->op_last;
117dada2 2243 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2244
238a4c30
NIS		 2245 FreeOp(last);
2246
79072805
LW		 2247 return (OP*)first;
2248}
2249
2250OP *
864dbfa3 2251Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2252{
2253 if (!first)
2254 return last;
8990e307
LW		 2255
2256 if (!last)
79072805 2257 return first;
8990e307 2258
fe2774ed 2259 if (last->op_type == (unsigned)type) {
8990e307
LW		 2260 if (type == OP_LIST) { /* already a PUSHMARK there */
2261 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2262 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2263 if (!(first->op_flags & OPf_PARENS))
2264 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2265 }
2266 else {
2267 if (!(last->op_flags & OPf_KIDS)) {
2268 ((LISTOP*)last)->op_last = first;
2269 last->op_flags |= OPf_KIDS;
2270 }
2271 first->op_sibling = ((LISTOP*)last)->op_first;
2272 ((LISTOP*)last)->op_first = first;
79072805 2273 }
117dada2 2274 last->op_flags |= OPf_KIDS;
79072805
LW		 2275 return last;
2276 }
2277
2278 return newLISTOP(type, 0, first, last);
2279}
2280
2281/* Constructors */
2282
2283OP *
864dbfa3 2284Perl_newNULLLIST(pTHX)
79072805 2285{
8990e307
LW		 2286 return newOP(OP_STUB, 0);
2287}
2288
2289OP *
864dbfa3 2290Perl_force_list(pTHX_ OP *o)
8990e307 2291{
11343788
MB		 2292 if (!o || o->op_type != OP_LIST)
2293 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2294 op_null(o);
11343788 2295 return o;
79072805
LW		 2296}
2297
2298OP *
864dbfa3 2299Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2300{
27da23d5 2301 dVAR;
79072805
LW		 2302 LISTOP *listop;
2303
b7dc083c 2304 NewOp(1101, listop, 1, LISTOP);
79072805 2305
eb160463 2306 listop->op_type = (OPCODE)type;
22c35a8c 2307 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2308 if (first || last)
2309 flags |= OPf_KIDS;
eb160463 2310 listop->op_flags = (U8)flags;
79072805
LW		 2311
2312 if (!last && first)
2313 last = first;
2314 else if (!first && last)
2315 first = last;
8990e307
LW		 2316 else if (first)
2317 first->op_sibling = last;
79072805
LW		 2318 listop->op_first = first;
2319 listop->op_last = last;
8990e307 2320 if (type == OP_LIST) {
551405c4 2321 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2322 pushop->op_sibling = first;
2323 listop->op_first = pushop;
2324 listop->op_flags |= OPf_KIDS;
2325 if (!last)
2326 listop->op_last = pushop;
2327 }
79072805 2328
463d09e6 2329 return CHECKOP(type, listop);
79072805
LW		 2330}
2331
2332OP *
864dbfa3 2333Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2334{
27da23d5 2335 dVAR;
11343788 2336 OP *o;
b7dc083c 2337 NewOp(1101, o, 1, OP);
eb160463 2338 o->op_type = (OPCODE)type;
22c35a8c 2339 o->op_ppaddr = PL_ppaddr[type];
eb160463 2340 o->op_flags = (U8)flags;
79072805 2341
11343788 2342 o->op_next = o;
eb160463 2343 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2344 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2345 scalar(o);
22c35a8c 2346 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2347 o->op_targ = pad_alloc(type, SVs_PADTMP);
2348 return CHECKOP(type, o);
79072805
LW		 2349}
2350
2351OP *
864dbfa3 2352Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2353{
27da23d5 2354 dVAR;
79072805
LW		 2355 UNOP *unop;
2356
93a17b20 2357 if (!first)
aeea060c 2358 first = newOP(OP_STUB, 0);
22c35a8c 2359 if (PL_opargs[type] & OA_MARK)
8990e307 2360 first = force_list(first);
93a17b20 2361
b7dc083c 2362 NewOp(1101, unop, 1, UNOP);
eb160463 2363 unop->op_type = (OPCODE)type;
22c35a8c 2364 unop->op_ppaddr = PL_ppaddr[type];
79072805 2365 unop->op_first = first;
585ec06d 2366 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2367 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2368 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2369 if (unop->op_next)
2370 return (OP*)unop;
2371
a0d0e21e 2372 return fold_constants((OP *) unop);
79072805
LW		 2373}
2374
2375OP *
864dbfa3 2376Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2377{
27da23d5 2378 dVAR;
79072805 2379 BINOP *binop;
b7dc083c 2380 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2381
2382 if (!first)
2383 first = newOP(OP_NULL, 0);
2384
eb160463 2385 binop->op_type = (OPCODE)type;
22c35a8c 2386 binop->op_ppaddr = PL_ppaddr[type];
79072805 2387 binop->op_first = first;
585ec06d 2388 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2389 if (!last) {
2390 last = first;
eb160463 2391 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2392 }
2393 else {
eb160463 2394 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2395 first->op_sibling = last;
2396 }
2397
e50aee73 2398 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2399 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2400 return (OP*)binop;
2401
7284ab6f 2402 binop->op_last = binop->op_first->op_sibling;
79072805 2403
a0d0e21e 2404 return fold_constants((OP *)binop);
79072805
LW		 2405}
2406
abb2c242
JH		 2407static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2408static int uvcompare(const void *a, const void *b)
2b9d42f0 2409{
e1ec3a88 2410 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2411 return -1;
e1ec3a88 2412 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2413 return 1;
e1ec3a88 2414 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2415 return -1;
e1ec3a88 2416 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2417 return 1;
a0ed51b3
LW		 2418 return 0;
2419}
2420
79072805 2421OP *
864dbfa3 2422Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2423{
97aff369 2424 dVAR;
2d03de9c
AL		 2425 SV * const tstr = ((SVOP*)expr)->op_sv;
2426 SV * const rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2427 STRLEN tlen;
2428 STRLEN rlen;
5c144d81
NC		 2429 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2430 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 2431 register I32 i;
2432 register I32 j;
9b877dbb 2433 I32 grows = 0;
79072805
LW		 2434 register short *tbl;
2435
551405c4
AL		 2436 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2437 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2438 I32 del = o->op_private & OPpTRANS_DELETE;
800b4dc4 2439 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 2440
036b4402
GS		 2441 if (SvUTF8(tstr))
2442 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2443
2444 if (SvUTF8(rstr))
036b4402 2445 o->op_private |= OPpTRANS_TO_UTF;
79072805 2446
a0ed51b3 2447 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 2448 SV* const listsv = newSVpvs("# comment\n");
c445ea15 2449 SV* transv = NULL;
5c144d81
NC		 2450 const U8* tend = t + tlen;
2451 const U8* rend = r + rlen;
ba210ebe 2452 STRLEN ulen;
84c133a0
RB		 2453 UV tfirst = 1;
2454 UV tlast = 0;
2455 IV tdiff;
2456 UV rfirst = 1;
2457 UV rlast = 0;
2458 IV rdiff;
2459 IV diff;
a0ed51b3
LW		 2460 I32 none = 0;
2461 U32 max = 0;
2462 I32 bits;
a0ed51b3 2463 I32 havefinal = 0;
9c5ffd7c 2464 U32 final = 0;
551405c4
AL		 2465 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2466 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2467 U8* tsave = NULL;
2468 U8* rsave = NULL;
2469
2470 if (!from_utf) {
2471 STRLEN len = tlen;
5c144d81 2472 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 2473 tend = t + len;
2474 }
2475 if (!to_utf && rlen) {
2476 STRLEN len = rlen;
5c144d81 2477 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 2478 rend = r + len;
2479 }
a0ed51b3 2480
2b9d42f0
NIS		 2481/* There are several snags with this code on EBCDIC:
2482 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2483 2. scan_const() in toke.c has encoded chars in native encoding which makes
2484 ranges at least in EBCDIC 0..255 range the bottom odd.
2485*/
2486
a0ed51b3 2487 if (complement) {
89ebb4a3 2488 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2489 UV *cp;
a0ed51b3 2490 UV nextmin = 0;
a02a5408 2491 Newx(cp, 2*tlen, UV);
a0ed51b3 2492 i = 0;
396482e1 2493 transv = newSVpvs("");
a0ed51b3 2494 while (t < tend) {
2b9d42f0
NIS		 2495 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2496 t += ulen;
2497 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2498 t++;
2b9d42f0
NIS		 2499 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2500 t += ulen;
a0ed51b3 2501 }
2b9d42f0
NIS		 2502 else {
2503 cp[2*i+1] = cp[2*i];
2504 }
2505 i++;
a0ed51b3 2506 }
2b9d42f0 2507 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2508 for (j = 0; j < i; j++) {
2b9d42f0 2509 UV val = cp[2*j];
a0ed51b3
LW		 2510 diff = val - nextmin;
2511 if (diff > 0) {
9041c2e3 2512 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2513 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2514 if (diff > 1) {
2b9d42f0 2515 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2516 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2517 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2518 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2519 }
2520 }
2b9d42f0 2521 val = cp[2*j+1];
a0ed51b3
LW		 2522 if (val >= nextmin)
2523 nextmin = val + 1;
2524 }
9041c2e3 2525 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2526 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2527 {
2528 U8 range_mark = UTF_TO_NATIVE(0xff);
2529 sv_catpvn(transv, (char *)&range_mark, 1);
2530 }
b851fbc1
JH		 2531 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2532 UNICODE_ALLOW_SUPER);
dfe13c55 2533 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 2534 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 2535 tlen = SvCUR(transv);
2536 tend = t + tlen;
455d824a 2537 Safefree(cp);
a0ed51b3
LW		 2538 }
2539 else if (!rlen && !del) {
2540 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2541 }
2542 if (!squash) {
05d340b8 2543 if ((!rlen && !del) || t == r ||
12ae5dfc 2544 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2545 {
4757a243 2546 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2547 }
a0ed51b3
LW		 2548 }
2549
2550 while (t < tend || tfirst <= tlast) {
2551 /* see if we need more "t" chars */
2552 if (tfirst > tlast) {
9041c2e3 2553 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2554 t += ulen;
2b9d42f0 2555 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2556 t++;
9041c2e3 2557 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2558 t += ulen;
2559 }
2560 else
2561 tlast = tfirst;
2562 }
2563
2564 /* now see if we need more "r" chars */
2565 if (rfirst > rlast) {
2566 if (r < rend) {
9041c2e3 2567 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2568 r += ulen;
2b9d42f0 2569 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2570 r++;
9041c2e3 2571 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2572 r += ulen;
2573 }
2574 else
2575 rlast = rfirst;
2576 }
2577 else {
2578 if (!havefinal++)
2579 final = rlast;
2580 rfirst = rlast = 0xffffffff;
2581 }
2582 }
2583
2584 /* now see which range will peter our first, if either. */
2585 tdiff = tlast - tfirst;
2586 rdiff = rlast - rfirst;
2587
2588 if (tdiff <= rdiff)
2589 diff = tdiff;
2590 else
2591 diff = rdiff;
2592
2593 if (rfirst == 0xffffffff) {
2594 diff = tdiff; /* oops, pretend rdiff is infinite */
2595 if (diff > 0)
894356b3
GS		 2596 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2597 (long)tfirst, (long)tlast);
a0ed51b3 2598 else
894356b3 2599 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2600 }
2601 else {
2602 if (diff > 0)
894356b3
GS		 2603 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2604 (long)tfirst, (long)(tfirst + diff),
2605 (long)rfirst);
a0ed51b3 2606 else
894356b3
GS		 2607 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2608 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2609
2610 if (rfirst + diff > max)
2611 max = rfirst + diff;
9b877dbb 2612 if (!grows)
45005bfb
JH		 2613 grows = (tfirst < rfirst &&
2614 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2615 rfirst += diff + 1;
a0ed51b3
LW		 2616 }
2617 tfirst += diff + 1;
2618 }
2619
2620 none = ++max;
2621 if (del)
2622 del = ++max;
2623
2624 if (max > 0xffff)
2625 bits = 32;
2626 else if (max > 0xff)
2627 bits = 16;
2628 else
2629 bits = 8;
2630
455d824a 2631 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2632 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2633 SvREFCNT_dec(listsv);
2634 if (transv)
2635 SvREFCNT_dec(transv);
2636
45005bfb 2637 if (!del && havefinal && rlen)
b448e4fe
JH		 2638 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2639 newSVuv((UV)final), 0);
a0ed51b3 2640
9b877dbb 2641 if (grows)
a0ed51b3
LW		 2642 o->op_private |= OPpTRANS_GROWS;
2643
9b877dbb
IH		 2644 if (tsave)
2645 Safefree(tsave);
2646 if (rsave)
2647 Safefree(rsave);
2648
a0ed51b3
LW		 2649 op_free(expr);
2650 op_free(repl);
2651 return o;
2652 }
2653
2654 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2655 if (complement) {
2656 Zero(tbl, 256, short);
eb160463 2657 for (i = 0; i < (I32)tlen; i++)
ec49126f 2658 tbl[t[i]] = -1;
79072805
LW		 2659 for (i = 0, j = 0; i < 256; i++) {
2660 if (!tbl[i]) {
eb160463 2661 if (j >= (I32)rlen) {
a0ed51b3 2662 if (del)
79072805
LW		 2663 tbl[i] = -2;
2664 else if (rlen)
ec49126f 2665 tbl[i] = r[j-1];
79072805 2666 else
eb160463 2667 tbl[i] = (short)i;
79072805 2668 }
9b877dbb
IH		 2669 else {
2670 if (i < 128 && r[j] >= 128)
2671 grows = 1;
ec49126f 2672 tbl[i] = r[j++];
9b877dbb 2673 }
79072805
LW		 2674 }
2675 }
05d340b8
JH		 2676 if (!del) {
2677 if (!rlen) {
2678 j = rlen;
2679 if (!squash)
2680 o->op_private |= OPpTRANS_IDENTICAL;
2681 }
eb160463 2682 else if (j >= (I32)rlen)
05d340b8
JH		 2683 j = rlen - 1;
2684 else
2685 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
585ec06d 2686 tbl[0x100] = (short)(rlen - j);
eb160463 2687 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 2688 tbl[0x101+i] = r[j+i];
2689 }
79072805
LW		 2690 }
2691 else {
a0ed51b3 2692 if (!rlen && !del) {
79072805 2693 r = t; rlen = tlen;
5d06d08e 2694 if (!squash)
4757a243 2695 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2696 }
94bfe852
RGS		 2697 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2698 o->op_private |= OPpTRANS_IDENTICAL;
2699 }
79072805
LW		 2700 for (i = 0; i < 256; i++)
2701 tbl[i] = -1;
eb160463
GS		 2702 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2703 if (j >= (I32)rlen) {
a0ed51b3 2704 if (del) {
ec49126f 2705 if (tbl[t[i]] == -1)
2706 tbl[t[i]] = -2;
79072805
LW		 2707 continue;
2708 }
2709 --j;
2710 }
9b877dbb
IH		 2711 if (tbl[t[i]] == -1) {
2712 if (t[i] < 128 && r[j] >= 128)
2713 grows = 1;
ec49126f 2714 tbl[t[i]] = r[j];
9b877dbb 2715 }
79072805
LW		 2716 }
2717 }
9b877dbb
IH		 2718 if (grows)
2719 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2720 op_free(expr);
2721 op_free(repl);
2722
11343788 2723 return o;
79072805
LW		 2724}
2725
2726OP *
864dbfa3 2727Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 2728{
27da23d5 2729 dVAR;
79072805
LW		 2730 PMOP *pmop;
2731
b7dc083c 2732 NewOp(1101, pmop, 1, PMOP);
eb160463 2733 pmop->op_type = (OPCODE)type;
22c35a8c 2734 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 2735 pmop->op_flags = (U8)flags;
2736 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2737
3280af22 2738 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2739 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2740 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2741 pmop->op_pmpermflags |= PMf_LOCALE;
2742 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2743
debc9467 2744#ifdef USE_ITHREADS
551405c4
AL		 2745 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2746 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2747 pmop->op_pmoffset = SvIV(repointer);
2748 SvREPADTMP_off(repointer);
2749 sv_setiv(repointer,0);
2750 } else {
2751 SV * const repointer = newSViv(0);
2752 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2753 pmop->op_pmoffset = av_len(PL_regex_padav);
2754 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 2755 }
debc9467 2756#endif
1eb1540c 2757
1fcf4c12 2758 /* link into pm list */
3280af22 2759 if (type != OP_TRANS && PL_curstash) {
8d2f4536
NC		 2760 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2761
2762 if (!mg) {
2763 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2764 }
2765 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2766 mg->mg_obj = (SV*)pmop;
cb55de95 2767 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2768 }
2769
463d09e6 2770 return CHECKOP(type, pmop);
79072805
LW		 2771}
2772
131b3ad0
DM		 2773/* Given some sort of match op o, and an expression expr containing a
2774 * pattern, either compile expr into a regex and attach it to o (if it's
2775 * constant), or convert expr into a runtime regcomp op sequence (if it's
2776 * not)
2777 *
2778 * isreg indicates that the pattern is part of a regex construct, eg
2779 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2780 * split "pattern", which aren't. In the former case, expr will be a list
2781 * if the pattern contains more than one term (eg /a$b/) or if it contains
2782 * a replacement, ie s/// or tr///.
2783 */
2784
79072805 2785OP *
131b3ad0 2786Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 2787{
27da23d5 2788 dVAR;
79072805
LW		 2789 PMOP *pm;
2790 LOGOP *rcop;
ce862d02 2791 I32 repl_has_vars = 0;
131b3ad0
DM		 2792 OP* repl = Nullop;
2793 bool reglist;
2794
2795 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2796 /* last element in list is the replacement; pop it */
2797 OP* kid;
2798 repl = cLISTOPx(expr)->op_last;
2799 kid = cLISTOPx(expr)->op_first;
2800 while (kid->op_sibling != repl)
2801 kid = kid->op_sibling;
2802 kid->op_sibling = Nullop;
2803 cLISTOPx(expr)->op_last = kid;
2804 }
79072805 2805
131b3ad0
DM		 2806 if (isreg && expr->op_type == OP_LIST &&
2807 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2808 {
2809 /* convert single element list to element */
0bd48802 2810 OP* const oe = expr;
131b3ad0
DM		 2811 expr = cLISTOPx(oe)->op_first->op_sibling;
2812 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2813 cLISTOPx(oe)->op_last = Nullop;
2814 op_free(oe);
2815 }
2816
2817 if (o->op_type == OP_TRANS) {
11343788 2818 return pmtrans(o, expr, repl);
131b3ad0
DM		 2819 }
2820
2821 reglist = isreg && expr->op_type == OP_LIST;
2822 if (reglist)
2823 op_null(expr);
79072805 2824
3280af22 2825 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2826 pm = (PMOP*)o;
79072805
LW		 2827
2828 if (expr->op_type == OP_CONST) {
463ee0b2 2829 STRLEN plen;
6136c704 2830 SV * const pat = ((SVOP*)expr)->op_sv;
5c144d81 2831 const char *p = SvPV_const(pat, plen);
770526c1 2832 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
5c144d81
NC		 2833 U32 was_readonly = SvREADONLY(pat);
2834
2835 if (was_readonly) {
2836 if (SvFAKE(pat)) {
2837 sv_force_normal_flags(pat, 0);
2838 assert(!SvREADONLY(pat));
2839 was_readonly = 0;
2840 } else {
2841 SvREADONLY_off(pat);
2842 }
2843 }
2844
93a17b20 2845 sv_setpvn(pat, "\\s+", 3);
5c144d81
NC		 2846
2847 SvFLAGS(pat) |= was_readonly;
2848
2849 p = SvPV_const(pat, plen);
79072805
LW		 2850 pm->op_pmflags |= PMf_SKIPWHITE;
2851 }
5b71a6a7 2852 if (DO_UTF8(pat))
a5961de5 2853 pm->op_pmdynflags |= PMdf_UTF8;
5c144d81
NC		 2854 /* FIXME - can we make this function take const char * args? */
2855 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
aaa362c4 2856 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2857 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 2858 op_free(expr);
2859 }
2860 else {
3280af22 2861 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2862 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2863 ? OP_REGCRESET
2864 : OP_REGCMAYBE),0,expr);
463ee0b2 2865
b7dc083c 2866 NewOp(1101, rcop, 1, LOGOP);
79072805 2867 rcop->op_type = OP_REGCOMP;
22c35a8c 2868 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2869 rcop->op_first = scalar(expr);
131b3ad0
DM		 2870 rcop->op_flags |= OPf_KIDS
2871 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2872 | (reglist ? OPf_STACKED : 0);
79072805 2873 rcop->op_private = 1;
11343788 2874 rcop->op_other = o;
131b3ad0
DM		 2875 if (reglist)
2876 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2877
b5c19bd7
DM		 2878 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2879 PL_cv_has_eval = 1;
79072805
LW		 2880
2881 /* establish postfix order */
3280af22 2882 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 2883 LINKLIST(expr);
2884 rcop->op_next = expr;
2885 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2886 }
2887 else {
2888 rcop->op_next = LINKLIST(expr);
2889 expr->op_next = (OP*)rcop;
2890 }
79072805 2891
11343788 2892 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 2893 }
2894
2895 if (repl) {
748a9306 2896 OP *curop;
0244c3a4 2897 if (pm->op_pmflags & PMf_EVAL) {
6136c704 2898 curop = NULL;
8bafa735 2899 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2900 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2901 }
748a9306
LW		 2902 else if (repl->op_type == OP_CONST)
2903 curop = repl;
79072805 2904 else {
c445ea15 2905 OP *lastop = NULL;
79072805 2906 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2907 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2908 if (curop->op_type == OP_GV) {
6136c704 2909 GV * const gv = cGVOPx_gv(curop);
ce862d02 2910 repl_has_vars = 1;
f702bf4a 2911 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 2912 break;
2913 }
2914 else if (curop->op_type == OP_RV2CV)
2915 break;
2916 else if (curop->op_type == OP_RV2SV ||
2917 curop->op_type == OP_RV2AV ||
2918 curop->op_type == OP_RV2HV ||
2919 curop->op_type == OP_RV2GV) {
2920 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2921 break;
2922 }
748a9306
LW		 2923 else if (curop->op_type == OP_PADSV ||
2924 curop->op_type == OP_PADAV ||
2925 curop->op_type == OP_PADHV ||
554b3eca 2926 curop->op_type == OP_PADANY) {
ce862d02 2927 repl_has_vars = 1;
748a9306 2928 }
1167e5da
SM		 2929 else if (curop->op_type == OP_PUSHRE)
2930 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 2931 else
2932 break;
2933 }
2934 lastop = curop;
2935 }
748a9306 2936 }
ce862d02 2937 if (curop == repl
1c846c1f 2938 && !(repl_has_vars
aaa362c4
RS		 2939 && (!PM_GETRE(pm)
2940 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2941 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2942 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2943 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 2944 }
2945 else {
aaa362c4 2946 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 2947 pm->op_pmflags |= PMf_MAYBE_CONST;
2948 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2949 }
b7dc083c 2950 NewOp(1101, rcop, 1, LOGOP);
748a9306 2951 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2952 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 2953 rcop->op_first = scalar(repl);
2954 rcop->op_flags |= OPf_KIDS;
2955 rcop->op_private = 1;
11343788 2956 rcop->op_other = o;
748a9306
LW		 2957
2958 /* establish postfix order */
2959 rcop->op_next = LINKLIST(repl);
2960 repl->op_next = (OP*)rcop;
2961
2962 pm->op_pmreplroot = scalar((OP*)rcop);
2963 pm->op_pmreplstart = LINKLIST(rcop);
2964 rcop->op_next = 0;
79072805
LW		 2965 }
2966 }
2967
2968 return (OP*)pm;
2969}
2970
2971OP *
864dbfa3 2972Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 2973{
27da23d5 2974 dVAR;
79072805 2975 SVOP *svop;
b7dc083c 2976 NewOp(1101, svop, 1, SVOP);
eb160463 2977 svop->op_type = (OPCODE)type;
22c35a8c 2978 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2979 svop->op_sv = sv;
2980 svop->op_next = (OP*)svop;
eb160463 2981 svop->op_flags = (U8)flags;
22c35a8c 2982 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2983 scalar((OP*)svop);
22c35a8c 2984 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2985 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2986 return CHECKOP(type, svop);
79072805
LW		 2987}
2988
2989OP *
350de78d
GS		 2990Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2991{
27da23d5 2992 dVAR;
350de78d
GS		 2993 PADOP *padop;
2994 NewOp(1101, padop, 1, PADOP);
eb160463 2995 padop->op_type = (OPCODE)type;
350de78d
GS		 2996 padop->op_ppaddr = PL_ppaddr[type];
2997 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 2998 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2999 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 3000 if (sv)
3001 SvPADTMP_on(sv);
350de78d 3002 padop->op_next = (OP*)padop;
eb160463 3003 padop->op_flags = (U8)flags;
350de78d
GS		 3004 if (PL_opargs[type] & OA_RETSCALAR)
3005 scalar((OP*)padop);
3006 if (PL_opargs[type] & OA_TARGET)
3007 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3008 return CHECKOP(type, padop);
3009}
3010
3011OP *
864dbfa3 3012Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3013{
27da23d5 3014 dVAR;
350de78d 3015#ifdef USE_ITHREADS
ce50c033
AMS		 3016 if (gv)
3017 GvIN_PAD_on(gv);
350de78d
GS		 3018 return newPADOP(type, flags, SvREFCNT_inc(gv));
3019#else
7934575e 3020 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3021#endif
79072805
LW		 3022}
3023
3024OP *
864dbfa3 3025Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 3026{
27da23d5 3027 dVAR;
79072805 3028 PVOP *pvop;
b7dc083c 3029 NewOp(1101, pvop, 1, PVOP);
eb160463 3030 pvop->op_type = (OPCODE)type;
22c35a8c 3031 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3032 pvop->op_pv = pv;
3033 pvop->op_next = (OP*)pvop;
eb160463 3034 pvop->op_flags = (U8)flags;
22c35a8c 3035 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3036 scalar((OP*)pvop);
22c35a8c 3037 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3038 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3039 return CHECKOP(type, pvop);
79072805
LW		 3040}
3041
79072805 3042void
864dbfa3 3043Perl_package(pTHX_ OP *o)
79072805 3044{
97aff369 3045 dVAR;
6867be6d 3046 const char *name;
de11ba31 3047 STRLEN len;
79072805 3048
3280af22
NIS		 3049 save_hptr(&PL_curstash);
3050 save_item(PL_curstname);
de11ba31 3051
5c144d81 3052 name = SvPV_const(cSVOPo->op_sv, len);
de11ba31
AMS		 3053 PL_curstash = gv_stashpvn(name, len, TRUE);
3054 sv_setpvn(PL_curstname, name, len);
3055 op_free(o);
3056
7ad382f4 3057 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3058 PL_copline = NOLINE;
3059 PL_expect = XSTATE;
79072805
LW		 3060}
3061
85e6fe83 3062void
88d95a4d 3063Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3064{
97aff369 3065 dVAR;
a0d0e21e 3066 OP *pack;
a0d0e21e 3067 OP *imop;
b1cb66bf 3068 OP *veop;
85e6fe83 3069
88d95a4d 3070 if (idop->op_type != OP_CONST)
cea2e8a9 3071 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3072
b1cb66bf 3073 veop = Nullop;
3074
aec46f14 3075 if (version) {
551405c4 3076 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3077
aec46f14 3078 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3079 arg = version;
3080 }
3081 else {
3082 OP *pack;
0f79a09d 3083 SV *meth;
b1cb66bf 3084
44dcb63b 3085 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3086 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3087
88d95a4d
JH		 3088 /* Make copy of idop so we don't free it twice */
3089 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3090
3091 /* Fake up a method call to VERSION */
18916d0d 3092 meth = newSVpvs_share("VERSION");
b1cb66bf 3093 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3094 append_elem(OP_LIST,
0f79a09d
GS		 3095 prepend_elem(OP_LIST, pack, list(version)),
3096 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3097 }
3098 }
aeea060c 3099
a0d0e21e 3100 /* Fake up an import/unimport */
4633a7c4
LW		 3101 if (arg && arg->op_type == OP_STUB)
3102 imop = arg; /* no import on explicit () */
88d95a4d 3103 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf 3104 imop = Nullop; /* use 5.0; */
468aa647
RGS		 3105 if (!aver)
3106 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3107 }
4633a7c4 3108 else {
0f79a09d
GS		 3109 SV *meth;
3110
88d95a4d
JH		 3111 /* Make copy of idop so we don't free it twice */
3112 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 3113
3114 /* Fake up a method call to import/unimport */
427d62a4 3115 meth = aver
18916d0d 3116 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 3117 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3118 append_elem(OP_LIST,
3119 prepend_elem(OP_LIST, pack, list(arg)),
3120 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3121 }
3122
a0d0e21e 3123 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3124 newATTRSUB(floor,
18916d0d 3125 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4633a7c4 3126 Nullop,
09bef843 3127 Nullop,
a0d0e21e 3128 append_elem(OP_LINESEQ,
b1cb66bf 3129 append_elem(OP_LINESEQ,
88d95a4d 3130 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 3131 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3132 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3133
70f5e4ed
JH		 3134 /* The "did you use incorrect case?" warning used to be here.
3135 * The problem is that on case-insensitive filesystems one
3136 * might get false positives for "use" (and "require"):
3137 * "use Strict" or "require CARP" will work. This causes
3138 * portability problems for the script: in case-strict
3139 * filesystems the script will stop working.
3140 *
3141 * The "incorrect case" warning checked whether "use Foo"
3142 * imported "Foo" to your namespace, but that is wrong, too:
3143 * there is no requirement nor promise in the language that
3144 * a Foo.pm should or would contain anything in package "Foo".
3145 *
3146 * There is very little Configure-wise that can be done, either:
3147 * the case-sensitivity of the build filesystem of Perl does not
3148 * help in guessing the case-sensitivity of the runtime environment.
3149 */
18fc9488 3150
c305c6a0 3151 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3152 PL_copline = NOLINE;
3153 PL_expect = XSTATE;
8ec8fbef 3154 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW		 3155}
3156
7d3fb230 3157/*
ccfc67b7
JH		 3158=head1 Embedding Functions
3159
7d3fb230
BS		 3160=for apidoc load_module
3161
3162Loads the module whose name is pointed to by the string part of name.
3163Note that the actual module name, not its filename, should be given.
3164Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3165PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3166(or 0 for no flags). ver, if specified, provides version semantics
3167similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3168arguments can be used to specify arguments to the module's import()
3169method, similar to C<use Foo::Bar VERSION LIST>.
3170
3171=cut */
3172
e4783991
GS		 3173void
3174Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3175{
3176 va_list args;
3177 va_start(args, ver);
3178 vload_module(flags, name, ver, &args);
3179 va_end(args);
3180}
3181
3182#ifdef PERL_IMPLICIT_CONTEXT
3183void
3184Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3185{
3186 dTHX;
3187 va_list args;
3188 va_start(args, ver);
3189 vload_module(flags, name, ver, &args);
3190 va_end(args);
3191}
3192#endif
3193
3194void
3195Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3196{
97aff369 3197 dVAR;
551405c4 3198 OP *veop, *imop;
e4783991 3199
551405c4 3200 OP * const modname = newSVOP(OP_CONST, 0, name);
e4783991
GS		 3201 modname->op_private |= OPpCONST_BARE;
3202 if (ver) {
3203 veop = newSVOP(OP_CONST, 0, ver);
3204 }
3205 else
3206 veop = Nullop;
3207 if (flags & PERL_LOADMOD_NOIMPORT) {
3208 imop = sawparens(newNULLLIST());
3209 }
3210 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3211 imop = va_arg(*args, OP*);
3212 }
3213 else {
3214 SV *sv;
3215 imop = Nullop;
3216 sv = va_arg(*args, SV*);
3217 while (sv) {
3218 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3219 sv = va_arg(*args, SV*);
3220 }
3221 }
81885997 3222 {
6867be6d
AL		 3223 const line_t ocopline = PL_copline;
3224 COP * const ocurcop = PL_curcop;
3225 const int oexpect = PL_expect;
81885997
GS		 3226
3227 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3228 veop, modname, imop);
3229 PL_expect = oexpect;
3230 PL_copline = ocopline;
834a3ffa 3231 PL_curcop = ocurcop;
81885997 3232 }
e4783991
GS		 3233}
3234
79072805 3235OP *
850e8516 3236Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 3237{
97aff369 3238 dVAR;
78ca652e 3239 OP *doop;
850e8516 3240 GV *gv = Nullgv;
78ca652e 3241
850e8516 3242 if (!force_builtin) {
f776e3cd 3243 gv = gv_fetchpv("do", 0, SVt_PVCV);
850e8516 3244 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 3245 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
551405c4 3246 gv = gvp ? *gvp : Nullgv;
850e8516
RGS		 3247 }
3248 }
78ca652e 3249
b9f751c0 3250 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3251 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3252 append_elem(OP_LIST, term,
3253 scalar(newUNOP(OP_RV2CV, 0,
3254 newGVOP(OP_GV, 0,
3255 gv))))));
3256 }
3257 else {
3258 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3259 }
3260 return doop;
3261}
3262
3263OP *
864dbfa3 3264Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3265{
3266 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3267 list(force_list(subscript)),
3268 list(force_list(listval)) );
79072805
LW		 3269}
3270
76e3520e 3271STATIC I32
504618e9 3272S_is_list_assignment(pTHX_ register const OP *o)
79072805 3273{
11343788 3274 if (!o)
79072805
LW		 3275 return TRUE;
3276
11343788
MB		 3277 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3278 o = cUNOPo->op_first;
79072805 3279
11343788 3280 if (o->op_type == OP_COND_EXPR) {
504618e9
AL		 3281 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3282 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3283
3284 if (t && f)
3285 return TRUE;
3286 if (t || f)
3287 yyerror("Assignment to both a list and a scalar");
3288 return FALSE;
3289 }
3290
95f0a2f1
SB		 3291 if (o->op_type == OP_LIST &&
3292 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3293 o->op_private & OPpLVAL_INTRO)
3294 return FALSE;
3295
11343788
MB		 3296 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3297 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3298 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3299 return TRUE;
3300
11343788 3301 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3302 return TRUE;
3303
11343788 3304 if (o->op_type == OP_RV2SV)
79072805
LW		 3305 return FALSE;
3306
3307 return FALSE;
3308}
3309
3310OP *
864dbfa3 3311Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3312{
97aff369 3313 dVAR;
11343788 3314 OP *o;
79072805 3315
a0d0e21e 3316 if (optype) {
c963b151 3317 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3318 return newLOGOP(optype, 0,
3319 mod(scalar(left), optype),
3320 newUNOP(OP_SASSIGN, 0, scalar(right)));
3321 }
3322 else {
3323 return newBINOP(optype, OPf_STACKED,
3324 mod(scalar(left), optype), scalar(right));
3325 }
3326 }
3327
504618e9 3328 if (is_list_assignment(left)) {
10c8fecd
GS		 3329 OP *curop;
3330
3280af22 3331 PL_modcount = 0;
dbfe47cf
RD		 3332 /* Grandfathering $[ assignment here. Bletch.*/
3333 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3334 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
463ee0b2 3335 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3336 if (PL_eval_start)
3337 PL_eval_start = 0;
dbfe47cf
RD		 3338 else if (left->op_type == OP_CONST) {
3339 /* Result of assignment is always 1 (or we'd be dead already) */
3340 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 3341 }
10c8fecd
GS		 3342 curop = list(force_list(left));
3343 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3344 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3345
3346 /* PL_generation sorcery:
3347 * an assignment like ($a,$b) = ($c,$d) is easier than
3348 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3349 * To detect whether there are common vars, the global var
3350 * PL_generation is incremented for each assign op we compile.
3351 * Then, while compiling the assign op, we run through all the
3352 * variables on both sides of the assignment, setting a spare slot
3353 * in each of them to PL_generation. If any of them already have
3354 * that value, we know we've got commonality. We could use a
3355 * single bit marker, but then we'd have to make 2 passes, first
3356 * to clear the flag, then to test and set it. To find somewhere
3357 * to store these values, evil chicanery is done with SvCUR().
3358 */
3359
a0d0e21e 3360 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3361 OP *lastop = o;
3280af22 3362 PL_generation++;
11343788 3363 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3364 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3365 if (curop->op_type == OP_GV) {
638eceb6 3366 GV *gv = cGVOPx_gv(curop);
eb160463 3367 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3368 break;
b162af07 3369 SvCUR_set(gv, PL_generation);
79072805 3370 }
748a9306
LW		 3371 else if (curop->op_type == OP_PADSV ||
3372 curop->op_type == OP_PADAV ||
3373 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3374 curop->op_type == OP_PADANY)
3375 {
3376 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3377 == (STRLEN)PL_generation)
748a9306 3378 break;
b162af07 3379 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 3380
748a9306 3381 }
79072805
LW		 3382 else if (curop->op_type == OP_RV2CV)
3383 break;
3384 else if (curop->op_type == OP_RV2SV ||
3385 curop->op_type == OP_RV2AV ||
3386 curop->op_type == OP_RV2HV ||
3387 curop->op_type == OP_RV2GV) {
3388 if (lastop->op_type != OP_GV) /* funny deref? */
3389 break;
3390 }
1167e5da
SM		 3391 else if (curop->op_type == OP_PUSHRE) {
3392 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3393#ifdef USE_ITHREADS
dd2155a4
DM		 3394 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3395 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3396#else
1167e5da 3397 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3398#endif
eb160463 3399 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3400 break;
b162af07 3401 SvCUR_set(gv, PL_generation);
b2ffa427 3402 }
1167e5da 3403 }
79072805
LW		 3404 else
3405 break;
3406 }
3407 lastop = curop;
3408 }
11343788 3409 if (curop != o)
10c8fecd 3410 o->op_private |= OPpASSIGN_COMMON;
79072805 3411 }
c07a80fd 3412 if (right && right->op_type == OP_SPLIT) {
3413 OP* tmpop;
3414 if ((tmpop = ((LISTOP*)right)->op_first) &&
3415 tmpop->op_type == OP_PUSHRE)
3416 {
551405c4 3417 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 3418 if (left->op_type == OP_RV2AV &&
3419 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3420 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3421 {
3422 tmpop = ((UNOP*)left)->op_first;
3423 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3424#ifdef USE_ITHREADS
ba89bb6e 3425 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3426 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3427#else
3428 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3429 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3430#endif
c07a80fd 3431 pm->op_pmflags |= PMf_ONCE;
11343788 3432 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3433 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3434 tmpop->op_sibling = Nullop; /* don't free split */
3435 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3436 op_free(o); /* blow off assign */
54310121 3437 right->op_flags &= ~OPf_WANT;
a5f75d66 3438 /* "I don't know and I don't care." */
c07a80fd 3439 return right;
3440 }
3441 }
3442 else {
e6438c1a 3443 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3444 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3445 {
3446 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3447 if (SvIVX(sv) == 0)
3280af22 3448 sv_setiv(sv, PL_modcount+1);
c07a80fd 3449 }
3450 }
3451 }
3452 }
11343788 3453 return o;
79072805
LW		 3454 }
3455 if (!right)
3456 right = newOP(OP_UNDEF, 0);
3457 if (right->op_type == OP_READLINE) {
3458 right->op_flags |= OPf_STACKED;
463ee0b2 3459 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3460 }
a0d0e21e 3461 else {
3280af22 3462 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3463 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3464 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3465 if (PL_eval_start)
3466 PL_eval_start = 0;
748a9306 3467 else {
dbfe47cf 3468 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
a0d0e21e
LW		 3469 }
3470 }
11343788 3471 return o;
79072805
LW		 3472}
3473
3474OP *
864dbfa3 3475Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3476{
27da23d5 3477 dVAR;
e1ec3a88 3478 const U32 seq = intro_my();
79072805
LW		 3479 register COP *cop;
3480
b7dc083c 3481 NewOp(1101, cop, 1, COP);
57843af0 3482 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3483 cop->op_type = OP_DBSTATE;
22c35a8c 3484 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3485 }
3486 else {
3487 cop->op_type = OP_NEXTSTATE;
22c35a8c 3488 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3489 }
eb160463
GS		 3490 cop->op_flags = (U8)flags;
3491 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3492#ifdef NATIVE_HINTS
3493 cop->op_private |= NATIVE_HINTS;
3494#endif
e24b16f9 3495 PL_compiling.op_private = cop->op_private;
79072805
LW		 3496 cop->op_next = (OP*)cop;
3497
463ee0b2
LW		 3498 if (label) {
3499 cop->cop_label = label;
3280af22 3500 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3501 }
bbce6d69 3502 cop->cop_seq = seq;
3280af22 3503 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3504 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3505 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3506 else
599cee73 3507 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3508 if (specialCopIO(PL_curcop->cop_io))
3509 cop->cop_io = PL_curcop->cop_io;
3510 else
3511 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3512
79072805 3513
3280af22 3514 if (PL_copline == NOLINE)
57843af0 3515 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3516 else {
57843af0 3517 CopLINE_set(cop, PL_copline);
3280af22 3518 PL_copline = NOLINE;
79072805 3519 }
57843af0 3520#ifdef USE_ITHREADS
f4dd75d9 3521 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3522#else
f4dd75d9 3523 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3524#endif
11faa288 3525 CopSTASH_set(cop, PL_curstash);
79072805 3526
3280af22 3527 if (PERLDB_LINE && PL_curstash != PL_debstash) {
fe8247eb 3528 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
2d03de9c
AL		 3529 if (svp && *svp != &PL_sv_undef ) {
3530 (void)SvIOK_on(*svp);
45977657 3531 SvIV_set(*svp, PTR2IV(cop));
1eb1540c 3532 }
93a17b20
LW		 3533 }
3534
722969e2 3535 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3536}
3537
bbce6d69 3538
79072805 3539OP *
864dbfa3 3540Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3541{
27da23d5 3542 dVAR;
883ffac3
CS		 3543 return new_logop(type, flags, &first, &other);
3544}
3545
3bd495df 3546STATIC OP *
cea2e8a9 3547S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3548{
27da23d5 3549 dVAR;
79072805 3550 LOGOP *logop;
11343788 3551 OP *o;
883ffac3 3552 OP *first = *firstp;
b22e6366 3553 OP * const other = *otherp;
79072805 3554
a0d0e21e
LW		 3555 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3556 return newBINOP(type, flags, scalar(first), scalar(other));
3557
8990e307 3558 scalarboolean(first);
79072805
LW		 3559 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3560 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3561 if (type == OP_AND || type == OP_OR) {
3562 if (type == OP_AND)
3563 type = OP_OR;
3564 else
3565 type = OP_AND;
11343788 3566 o = first;
883ffac3 3567 first = *firstp = cUNOPo->op_first;
11343788
MB		 3568 if (o->op_next)
3569 first->op_next = o->op_next;
3570 cUNOPo->op_first = Nullop;
3571 op_free(o);
79072805
LW		 3572 }
3573 }
3574 if (first->op_type == OP_CONST) {
39a440a3
DM		 3575 if (first->op_private & OPpCONST_STRICT)
3576 no_bareword_allowed(first);
041457d9 3577 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
989dfb19 3578 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
75cc09e4
MHM		 3579 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3580 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3581 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
79072805 3582 op_free(first);
883ffac3 3583 *firstp = Nullop;
d6fee5c7
DM		 3584 if (other->op_type == OP_CONST)
3585 other->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW		 3586 return other;
3587 }
3588 else {
7921d0f2 3589 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 3590 const OP *o2 = other;
7921d0f2
DM		 3591 if ( ! (o2->op_type == OP_LIST
3592 && (( o2 = cUNOPx(o2)->op_first))
3593 && o2->op_type == OP_PUSHMARK
3594 && (( o2 = o2->op_sibling)) )
3595 )
3596 o2 = other;
3597 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3598 || o2->op_type == OP_PADHV)
3599 && o2->op_private & OPpLVAL_INTRO
3600 && ckWARN(WARN_DEPRECATED))
3601 {
3602 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3603 "Deprecated use of my() in false conditional");
3604 }
3605
79072805 3606 op_free(other);
883ffac3 3607 *otherp = Nullop;
d6fee5c7
DM		 3608 if (first->op_type == OP_CONST)
3609 first->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW		 3610 return first;
3611 }
3612 }
041457d9
DM		 3613 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3614 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 3615 {
b22e6366
AL		 3616 const OP * const k1 = ((UNOP*)first)->op_first;
3617 const OP * const k2 = k1->op_sibling;
a6006777 3618 OPCODE warnop = 0;
3619 switch (first->op_type)
3620 {
3621 case OP_NULL:
3622 if (k2 && k2->op_type == OP_READLINE
3623 && (k2->op_flags & OPf_STACKED)
1c846c1f 3624 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3625 {
a6006777 3626 warnop = k2->op_type;
72b16652 3627 }
a6006777 3628 break;
3629
3630 case OP_SASSIGN:
68dc0745 3631 if (k1->op_type == OP_READDIR
3632 || k1->op_type == OP_GLOB
72b16652 3633 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3634 || k1->op_type == OP_EACH)
72b16652
GS		 3635 {
3636 warnop = ((k1->op_type == OP_NULL)
eb160463 3637 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3638 }
a6006777 3639 break;
3640 }
8ebc5c01 3641 if (warnop) {
6867be6d 3642 const line_t oldline = CopLINE(PL_curcop);
57843af0 3643 CopLINE_set(PL_curcop, PL_copline);
9014280d 3644 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3645 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3646 PL_op_desc[warnop],
68dc0745 3647 ((warnop == OP_READLINE || warnop == OP_GLOB)
3648 ? " construct" : "() operator"));
57843af0 3649 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3650 }
a6006777 3651 }
79072805
LW		 3652
3653 if (!other)
3654 return first;
3655
c963b151 3656 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 3657 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3658
b7dc083c 3659 NewOp(1101, logop, 1, LOGOP);
79072805 3660
eb160463 3661 logop->op_type = (OPCODE)type;
22c35a8c 3662 logop->op_ppaddr = PL_ppaddr[type];
79072805 3663 logop->op_first = first;
585ec06d 3664 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 3665 logop->op_other = LINKLIST(other);
eb160463 3666 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3667
3668 /* establish postfix order */
3669 logop->op_next = LINKLIST(first);
3670 first->op_next = (OP*)logop;
3671 first->op_sibling = other;
3672
463d09e6
RGS		 3673 CHECKOP(type,logop);
3674
11343788
MB		 3675 o = newUNOP(OP_NULL, 0, (OP*)logop);
3676 other->op_next = o;
79072805 3677
11343788 3678 return o;
79072805
LW		 3679}
3680
3681OP *
864dbfa3 3682Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3683{
27da23d5 3684 dVAR;
1a67a97c
SM		 3685 LOGOP *logop;
3686 OP *start;
11343788 3687 OP *o;
79072805 3688
b1cb66bf 3689 if (!falseop)
3690 return newLOGOP(OP_AND, 0, first, trueop);
3691 if (!trueop)
3692 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3693
8990e307 3694 scalarboolean(first);
79072805 3695 if (first->op_type == OP_CONST) {
2bc6235c 3696 if (first->op_private & OPpCONST_BARE &&
b22e6366
AL		 3697 first->op_private & OPpCONST_STRICT) {
3698 no_bareword_allowed(first);
3699 }
79072805
LW		 3700 if (SvTRUE(((SVOP*)first)->op_sv)) {
3701 op_free(first);
b1cb66bf 3702 op_free(falseop);
3703 return trueop;
79072805
LW		 3704 }
3705 else {
3706 op_free(first);
b1cb66bf 3707 op_free(trueop);
3708 return falseop;
79072805
LW		 3709 }
3710 }
1a67a97c
SM		 3711 NewOp(1101, logop, 1, LOGOP);
3712 logop->op_type = OP_COND_EXPR;
3713 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3714 logop->op_first = first;
585ec06d 3715 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3716 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 3717 logop->op_other = LINKLIST(trueop);
3718 logop->op_next = LINKLIST(falseop);
79072805 3719
463d09e6
RGS		 3720 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3721 logop);
79072805
LW		 3722
3723 /* establish postfix order */
1a67a97c
SM		 3724 start = LINKLIST(first);
3725 first->op_next = (OP*)logop;
79072805 3726
b1cb66bf 3727 first->op_sibling = trueop;
3728 trueop->op_sibling = falseop;
1a67a97c 3729 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3730
1a67a97c 3731 trueop->op_next = falseop->op_next = o;
79072805 3732
1a67a97c 3733 o->op_next = start;
11343788 3734 return o;
79072805
LW		 3735}
3736
3737OP *
864dbfa3 3738Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3739{
27da23d5 3740 dVAR;
1a67a97c 3741 LOGOP *range;
79072805
LW		 3742 OP *flip;
3743 OP *flop;
1a67a97c 3744 OP *leftstart;
11343788 3745 OP *o;
79072805 3746
1a67a97c 3747 NewOp(1101, range, 1, LOGOP);
79072805 3748
1a67a97c
SM		 3749 range->op_type = OP_RANGE;
3750 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3751 range->op_first = left;
3752 range->op_flags = OPf_KIDS;
3753 leftstart = LINKLIST(left);
3754 range->op_other = LINKLIST(right);
eb160463 3755 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3756
3757 left->op_sibling = right;
3758
1a67a97c
SM		 3759 range->op_next = (OP*)range;
3760 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3761 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3762 o = newUNOP(OP_NULL, 0, flop);
79072805 3763 linklist(flop);
1a67a97c 3764 range->op_next = leftstart;
79072805
LW		 3765
3766 left->op_next = flip;
3767 right->op_next = flop;
3768
1a67a97c
SM		 3769 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3770 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3771 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3772 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3773
3774 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3775 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3776
11343788 3777 flip->op_next = o;
79072805 3778 if (!flip->op_private || !flop->op_private)
11343788 3779 linklist(o); /* blow off optimizer unless constant */
79072805 3780
11343788 3781 return o;
79072805
LW		 3782}
3783
3784OP *
864dbfa3 3785Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 3786{
97aff369 3787 dVAR;
463ee0b2 3788 OP* listop;
11343788 3789 OP* o;
73d840c0 3790 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 3791 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 3792
3793 PERL_UNUSED_ARG(debuggable);
93a17b20 3794
463ee0b2
LW		 3795 if (expr) {
3796 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3797 return block; /* do {} while 0 does once */
fb73857a 3798 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3799 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 3800 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3801 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 3802 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 3803 const OP * const k1 = ((UNOP*)expr)->op_first;
3804 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 3805 switch (expr->op_type) {
1c846c1f 3806 case OP_NULL:
55d729e4
GS		 3807 if (k2 && k2->op_type == OP_READLINE
3808 && (k2->op_flags & OPf_STACKED)
1c846c1f 3809 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3810 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3811 break;
55d729e4
GS		 3812
3813 case OP_SASSIGN:
3814 if (k1->op_type == OP_READDIR
3815 || k1->op_type == OP_GLOB
6531c3e6 3816 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3817 || k1->op_type == OP_EACH)
3818 expr = newUNOP(OP_DEFINED, 0, expr);
3819 break;
3820 }
774d564b 3821 }
463ee0b2 3822 }
93a17b20 3823
e1548254
RGS		 3824 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3825 * op, in listop. This is wrong. [perl #27024] */
3826 if (!block)
3827 block = newOP(OP_NULL, 0);
8990e307 3828 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 3829 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 3830
883ffac3
CS		 3831 if (listop)
3832 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 3833
11343788
MB		 3834 if (once && o != listop)
3835 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 3836
11343788
MB		 3837 if (o == listop)
3838 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 3839
11343788
MB		 3840 o->op_flags |= flags;
3841 o = scope(o);
3842 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3843 return o;
79072805
LW		 3844}
3845
3846OP *
a034e688
DM		 3847Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3848whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 3849{
27da23d5 3850 dVAR;
79072805 3851 OP *redo;
c445ea15 3852 OP *next = NULL;
79072805 3853 OP *listop;
11343788 3854 OP *o;
1ba6ee2b 3855 U8 loopflags = 0;
46c461b5
AL		 3856
3857 PERL_UNUSED_ARG(debuggable);
79072805 3858
2d03de9c
AL		 3859 if (expr) {
3860 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3861 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3862 expr = newUNOP(OP_DEFINED, 0,
3863 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3864 } else if (expr->op_flags & OPf_KIDS) {
3865 const OP * const k1 = ((UNOP*)expr)->op_first;
3866 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3867 switch (expr->op_type) {
3868 case OP_NULL:
3869 if (k2 && k2->op_type == OP_READLINE
3870 && (k2->op_flags & OPf_STACKED)
3871 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3872 expr = newUNOP(OP_DEFINED, 0, expr);
3873 break;
55d729e4 3874
2d03de9c
AL		 3875 case OP_SASSIGN:
3876 if (k1->op_type == OP_READDIR
3877 || k1->op_type == OP_GLOB
3878 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3879 || k1->op_type == OP_EACH)
3880 expr = newUNOP(OP_DEFINED, 0, expr);
3881 break;
3882 }
55d729e4 3883 }
748a9306 3884 }
79072805
LW		 3885
3886 if (!block)
3887 block = newOP(OP_NULL, 0);
a034e688 3888 else if (cont || has_my) {
87246558
GS		 3889 block = scope(block);
3890 }
79072805 3891
1ba6ee2b 3892 if (cont) {
79072805 3893 next = LINKLIST(cont);
1ba6ee2b 3894 }
fb73857a 3895 if (expr) {
551405c4 3896 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 3897 if (!next)
3898 next = unstack;
3899 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 3900 }
79072805 3901
463ee0b2 3902 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 3903 redo = LINKLIST(listop);
3904
3905 if (expr) {
eb160463 3906 PL_copline = (line_t)whileline;
883ffac3
CS		 3907 scalar(listop);
3908 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 3909 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 3910 op_free(expr); /* oops, it's a while (0) */
463ee0b2 3911 op_free((OP*)loop);
883ffac3 3912 return Nullop; /* listop already freed by new_logop */
463ee0b2 3913 }
883ffac3 3914 if (listop)
497b47a8 3915 ((LISTOP*)listop)->op_last->op_next =
883ffac3 3916 (o == listop ? redo : LINKLIST(o));
79072805
LW		 3917 }
3918 else
11343788 3919 o = listop;
79072805
LW		 3920
3921 if (!loop) {
b7dc083c 3922 NewOp(1101,loop,1,LOOP);
79072805 3923 loop->op_type = OP_ENTERLOOP;
22c35a8c 3924 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 3925 loop->op_private = 0;
3926 loop->op_next = (OP*)loop;
3927 }
3928
11343788 3929 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 3930
3931 loop->op_redoop = redo;
11343788 3932 loop->op_lastop = o;
1ba6ee2b 3933 o->op_private |= loopflags;
79072805
LW		 3934
3935 if (next)
3936 loop->op_nextop = next;
3937 else
11343788 3938 loop->op_nextop = o;
79072805 3939
11343788
MB		 3940 o->op_flags |= flags;
3941 o->op_private |= (flags >> 8);
3942 return o;
79072805
LW		 3943}
3944
3945OP *
66a1b24b 3946Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 3947{
27da23d5 3948 dVAR;
79072805 3949 LOOP *loop;
fb73857a 3950 OP *wop;
4bbc6d12 3951 PADOFFSET padoff = 0;
4633a7c4 3952 I32 iterflags = 0;
241416b8 3953 I32 iterpflags = 0;
79072805 3954
79072805 3955 if (sv) {
85e6fe83 3956 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 3957 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 3958 sv->op_type = OP_RV2GV;
22c35a8c 3959 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0d863452
RH		 3960 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3961 iterpflags |= OPpITER_DEF;
79072805 3962 }
85e6fe83 3963 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 3964 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 3965 padoff = sv->op_targ;
743e66e6 3966 sv->op_targ = 0;
85e6fe83
LW		 3967 op_free(sv);
3968 sv = Nullop;
3969 }
54b9620d
MB		 3970 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3971 padoff = sv->op_targ;
743e66e6 3972 sv->op_targ = 0;
54b9620d
MB		 3973 iterflags |= OPf_SPECIAL;
3974 op_free(sv);
3975 sv = Nullop;
3976 }
79072805 3977 else
cea2e8a9 3978 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
0d863452
RH		 3979 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3980 iterpflags |= OPpITER_DEF;
79072805
LW		 3981 }
3982 else {
73d840c0 3983 const I32 offset = pad_findmy("$_");
aabe9514
RGS		 3984 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3985 sv = newGVOP(OP_GV, 0, PL_defgv);
3986 }
3987 else {
3988 padoff = offset;
aabe9514 3989 }
0d863452 3990 iterpflags |= OPpITER_DEF;
79072805 3991 }
5f05dabc 3992 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 3993 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 3994 iterflags |= OPf_STACKED;
3995 }
89ea2908
GA		 3996 else if (expr->op_type == OP_NULL &&
3997 (expr->op_flags & OPf_KIDS) &&
3998 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3999 {
4000 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4001 * set the STACKED flag to indicate that these values are to be
4002 * treated as min/max values by 'pp_iterinit'.
4003 */
551405c4
AL		 4004 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4005 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 4006 OP* const left = range->op_first;
4007 OP* const right = left->op_sibling;
5152d7c7 4008 LISTOP* listop;
89ea2908
GA		 4009
4010 range->op_flags &= ~OPf_KIDS;
4011 range->op_first = Nullop;
4012
5152d7c7 4013 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4014 listop->op_first->op_next = range->op_next;
4015 left->op_next = range->op_other;
5152d7c7
GS		 4016 right->op_next = (OP*)listop;
4017 listop->op_next = listop->op_first;
89ea2908
GA		 4018
4019 op_free(expr);
5152d7c7 4020 expr = (OP*)(listop);
93c66552 4021 op_null(expr);
89ea2908
GA		 4022 iterflags |= OPf_STACKED;
4023 }
4024 else {
4025 expr = mod(force_list(expr), OP_GREPSTART);
4026 }
4027
4633a7c4 4028 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4029 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4030 assert(!loop->op_next);
241416b8 4031 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 4032 * for our $x () sets OPpOUR_INTRO */
c5661c80 4033 loop->op_private = (U8)iterpflags;
b7dc083c 4034#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4035 {
4036 LOOP *tmp;
4037 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 4038 Copy(loop,tmp,1,LISTOP);
238a4c30 4039 FreeOp(loop);
155aba94
GS		 4040 loop = tmp;
4041 }
b7dc083c 4042#else
85e6fe83 4043 Renew(loop, 1, LOOP);
1c846c1f 4044#endif
85e6fe83 4045 loop->op_targ = padoff;
a034e688 4046 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
3280af22 4047 PL_copline = forline;
fb73857a 4048 return newSTATEOP(0, label, wop);
79072805
LW		 4049}
4050
8990e307 4051OP*
864dbfa3 4052Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4053{
97aff369 4054 dVAR;
11343788 4055 OP *o;
2d8e6c8d 4056
8990e307 4057 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4058 /* "last()" means "last" */
4059 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4060 o = newOP(type, OPf_SPECIAL);
4061 else {
4062 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
8b6b16e7 4063 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
cdaebead
MB		 4064 : ""));
4065 }
8990e307
LW		 4066 op_free(label);
4067 }
4068 else {
e3aba57a
RGS		 4069 /* Check whether it's going to be a goto &function */
4070 if (label->op_type == OP_ENTERSUB
4071 && !(label->op_flags & OPf_STACKED))
a0d0e21e 4072 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4073 o = newUNOP(type, OPf_STACKED, label);
8990e307 4074 }
3280af22 4075 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4076 return o;
8990e307
LW		 4077}
4078
0d863452
RH		 4079/* if the condition is a literal array or hash
4080 (or @{ ... } etc), make a reference to it.
4081 */
4082STATIC OP *
4083S_ref_array_or_hash(pTHX_ OP *cond)
4084{
4085 if (cond
4086 && (cond->op_type == OP_RV2AV
4087 || cond->op_type == OP_PADAV
4088 || cond->op_type == OP_RV2HV
4089 || cond->op_type == OP_PADHV))
4090
4091 return newUNOP(OP_REFGEN,
4092 0, mod(cond, OP_REFGEN));
4093
4094 else
4095 return cond;
4096}
4097
4098/* These construct the optree fragments representing given()
4099 and when() blocks.
4100
4101 entergiven and enterwhen are LOGOPs; the op_other pointer
4102 points up to the associated leave op. We need this so we
4103 can put it in the context and make break/continue work.
4104 (Also, of course, pp_enterwhen will jump straight to
4105 op_other if the match fails.)
4106 */
4107
4108STATIC
4109OP *
4110S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4111 I32 enter_opcode, I32 leave_opcode,
4112 PADOFFSET entertarg)
4113{
97aff369 4114 dVAR;
0d863452
RH		 4115 LOGOP *enterop;
4116 OP *o;
4117
4118 NewOp(1101, enterop, 1, LOGOP);
4119 enterop->op_type = enter_opcode;
4120 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4121 enterop->op_flags = (U8) OPf_KIDS;
4122 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4123 enterop->op_private = 0;
4124
4125 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4126
4127 if (cond) {
4128 enterop->op_first = scalar(cond);
4129 cond->op_sibling = block;
4130
4131 o->op_next = LINKLIST(cond);
4132 cond->op_next = (OP *) enterop;
4133 }
4134 else {
4135 /* This is a default {} block */
4136 enterop->op_first = block;
4137 enterop->op_flags |= OPf_SPECIAL;
4138
4139 o->op_next = (OP *) enterop;
4140 }
4141
4142 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4143 entergiven and enterwhen both
4144 use ck_null() */
4145
4146 enterop->op_next = LINKLIST(block);
4147 block->op_next = enterop->op_other = o;
4148
4149 return o;
4150}
4151
4152/* Does this look like a boolean operation? For these purposes
4153 a boolean operation is:
4154 - a subroutine call [*]
4155 - a logical connective
4156 - a comparison operator
4157 - a filetest operator, with the exception of -s -M -A -C
4158 - defined(), exists() or eof()
4159 - /$re/ or $foo =~ /$re/
4160
4161 [*] possibly surprising
4162 */
4163STATIC
4164bool
4165S_looks_like_bool(pTHX_ OP *o)
4166{
97aff369 4167 dVAR;
0d863452
RH		 4168 switch(o->op_type) {
4169 case OP_OR:
4170 return looks_like_bool(cLOGOPo->op_first);
4171
4172 case OP_AND:
4173 return (
4174 looks_like_bool(cLOGOPo->op_first)
4175 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4176
4177 case OP_ENTERSUB:
4178
4179 case OP_NOT: case OP_XOR:
4180 /* Note that OP_DOR is not here */
4181
4182 case OP_EQ: case OP_NE: case OP_LT:
4183 case OP_GT: case OP_LE: case OP_GE:
4184
4185 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4186 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4187
4188 case OP_SEQ: case OP_SNE: case OP_SLT:
4189 case OP_SGT: case OP_SLE: case OP_SGE:
4190
4191 case OP_SMARTMATCH:
4192
4193 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4194 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4195 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4196 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4197 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4198 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4199 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4200 case OP_FTTEXT: case OP_FTBINARY:
4201
4202 case OP_DEFINED: case OP_EXISTS:
4203 case OP_MATCH: case OP_EOF:
4204
4205 return TRUE;
4206
4207 case OP_CONST:
4208 /* Detect comparisons that have been optimized away */
4209 if (cSVOPo->op_sv == &PL_sv_yes
4210 || cSVOPo->op_sv == &PL_sv_no)
4211
4212 return TRUE;
4213
4214 /* FALL THROUGH */
4215 default:
4216 return FALSE;
4217 }
4218}
4219
4220OP *
4221Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4222{
97aff369 4223 dVAR;
0d863452
RH		 4224 assert( cond );
4225 return newGIVWHENOP(
4226 ref_array_or_hash(cond),
4227 block,
4228 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4229 defsv_off);
4230}
4231
4232/* If cond is null, this is a default {} block */
4233OP *
4234Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4235{
4236 bool cond_llb = (!cond || looks_like_bool(cond));
4237 OP *cond_op;
4238
4239 if (cond_llb)
4240 cond_op = cond;
4241 else {
4242 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4243 newDEFSVOP(),
4244 scalar(ref_array_or_hash(cond)));
4245 }
4246
4247 return newGIVWHENOP(
4248 cond_op,
4249 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4250 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4251}
4252
7dafbf52
DM		 4253/*
4254=for apidoc cv_undef
4255
4256Clear out all the active components of a CV. This can happen either
4257by an explicit C<undef &foo>, or by the reference count going to zero.
4258In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4259children can still follow the full lexical scope chain.
4260
4261=cut
4262*/
4263
79072805 4264void
864dbfa3 4265Perl_cv_undef(pTHX_ CV *cv)
79072805 4266{
27da23d5 4267 dVAR;
a636914a 4268#ifdef USE_ITHREADS
35f1c1c7
SB		 4269 if (CvFILE(cv) && !CvXSUB(cv)) {
4270 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 4271 Safefree(CvFILE(cv));
a636914a 4272 }
f3e31eb5 4273 CvFILE(cv) = 0;
a636914a
RH		 4274#endif
4275
a0d0e21e
LW		 4276 if (!CvXSUB(cv) && CvROOT(cv)) {
4277 if (CvDEPTH(cv))
cea2e8a9 4278 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 4279 ENTER;
a0d0e21e 4280
f3548bdc 4281 PAD_SAVE_SETNULLPAD();
a0d0e21e 4282
282f25c9 4283 op_free(CvROOT(cv));
79072805 4284 CvROOT(cv) = Nullop;
8f476eee 4285 CvSTART(cv) = Nullop;
8990e307 4286 LEAVE;
79072805 4287 }
1d5db326 4288 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 4289 CvGV(cv) = Nullgv;
a3985cdc
DM		 4290
4291 pad_undef(cv);
4292
7dafbf52
DM		 4293 /* remove CvOUTSIDE unless this is an undef rather than a free */
4294 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4295 if (!CvWEAKOUTSIDE(cv))
4296 SvREFCNT_dec(CvOUTSIDE(cv));
4297 CvOUTSIDE(cv) = Nullcv;
4298 }
beab0874
JT		 4299 if (CvCONST(cv)) {
4300 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4301 CvCONST_off(cv);
4302 }
50762d59
DM		 4303 if (CvXSUB(cv)) {
4304 CvXSUB(cv) = 0;
4305 }
7dafbf52
DM		 4306 /* delete all flags except WEAKOUTSIDE */
4307 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 4308}
4309
3fe9a6f1 4310void
35a4481c 4311Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
3fe9a6f1 4312{
b15aece3 4313 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 4314 SV* const msg = sv_newmortal();
3fe9a6f1 4315 SV* name = Nullsv;
4316
4317 if (gv)
46fc3d4c 4318 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4319 sv_setpv(msg, "Prototype mismatch:");
4320 if (name)
894356b3 4321 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 4322 if (SvPOK(cv))
e1ec3a88 4323 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
ebe643b9 4324 else
396482e1
GA		 4325 sv_catpvs(msg, ": none");
4326 sv_catpvs(msg, " vs ");
46fc3d4c 4327 if (p)
cea2e8a9 4328 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 4329 else
396482e1 4330 sv_catpvs(msg, "none");
9014280d 4331 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 4332 }
4333}
4334
35f1c1c7
SB		 4335static void const_sv_xsub(pTHX_ CV* cv);
4336
beab0874 4337/*
ccfc67b7
JH		 4338
4339=head1 Optree Manipulation Functions
4340
beab0874
JT		 4341=for apidoc cv_const_sv
4342
4343If C<cv> is a constant sub eligible for inlining. returns the constant
4344value returned by the sub. Otherwise, returns NULL.
4345
4346Constant subs can be created with C<newCONSTSUB> or as described in
4347L<perlsub/"Constant Functions">.
4348
4349=cut
4350*/
760ac839 4351SV *
864dbfa3 4352Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4353{
5069cc75
NC		 4354 if (!cv)
4355 return NULL;
4356 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4357 return NULL;
4358 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
fe5e78ed 4359}
760ac839 4360
b5c19bd7
DM		 4361/* op_const_sv: examine an optree to determine whether it's in-lineable.
4362 * Can be called in 3 ways:
4363 *
4364 * !cv
4365 * look for a single OP_CONST with attached value: return the value
4366 *
4367 * cv && CvCLONE(cv) && !CvCONST(cv)
4368 *
4369 * examine the clone prototype, and if contains only a single
4370 * OP_CONST referencing a pad const, or a single PADSV referencing
4371 * an outer lexical, return a non-zero value to indicate the CV is
4372 * a candidate for "constizing" at clone time
4373 *
4374 * cv && CvCONST(cv)
4375 *
4376 * We have just cloned an anon prototype that was marked as a const
4377 * candidiate. Try to grab the current value, and in the case of
4378 * PADSV, ignore it if it has multiple references. Return the value.
4379 */
4380
fe5e78ed 4381SV *
6867be6d 4382Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 4383{
97aff369 4384 dVAR;
fe5e78ed
GS		 4385 SV *sv = Nullsv;
4386
0f79a09d 4387 if (!o)
fe5e78ed 4388 return Nullsv;
1c846c1f
NIS		 4389
4390 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4391 o = cLISTOPo->op_first->op_sibling;
4392
4393 for (; o; o = o->op_next) {
890ce7af 4394 const OPCODE type = o->op_type;
fe5e78ed 4395
1c846c1f 4396 if (sv && o->op_next == o)
fe5e78ed 4397 return sv;
e576b457
JT		 4398 if (o->op_next != o) {
4399 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4400 continue;
4401 if (type == OP_DBSTATE)
4402 continue;
4403 }
54310121 4404 if (type == OP_LEAVESUB || type == OP_RETURN)
4405 break;
4406 if (sv)
4407 return Nullsv;
7766f137 4408 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4409 sv = cSVOPo->op_sv;
b5c19bd7 4410 else if (cv && type == OP_CONST) {
dd2155a4 4411 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874
JT		 4412 if (!sv)
4413 return Nullsv;
b5c19bd7
DM		 4414 }
4415 else if (cv && type == OP_PADSV) {
4416 if (CvCONST(cv)) { /* newly cloned anon */
4417 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4418 /* the candidate should have 1 ref from this pad and 1 ref
4419 * from the parent */
4420 if (!sv || SvREFCNT(sv) != 2)
4421 return Nullsv;
beab0874 4422 sv = newSVsv(sv);
b5c19bd7
DM		 4423 SvREADONLY_on(sv);
4424 return sv;
4425 }
4426 else {
4427 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4428 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 4429 }
760ac839 4430 }
b5c19bd7 4431 else {
54310121 4432 return Nullsv;
b5c19bd7 4433 }
760ac839
LW		 4434 }
4435 return sv;
4436}
4437
09bef843
SB		 4438void
4439Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4440{
46c461b5
AL		 4441 PERL_UNUSED_ARG(floor);
4442
09bef843
SB		 4443 if (o)
4444 SAVEFREEOP(o);
4445 if (proto)
4446 SAVEFREEOP(proto);
4447 if (attrs)
4448 SAVEFREEOP(attrs);
4449 if (block)
4450 SAVEFREEOP(block);
4451 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4452}
4453
748a9306 4454CV *
864dbfa3 4455Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4456{
09bef843
SB		 4457 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4458}
4459
4460CV *
4461Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4462{
27da23d5 4463 dVAR;
6867be6d 4464 const char *aname;
83ee9e09 4465 GV *gv;
5c144d81 4466 const char *ps;
ea6e9374 4467 STRLEN ps_len;
c445ea15 4468 register CV *cv = NULL;
beab0874 4469 SV *const_sv;
b48b272a
NC		 4470 /* If the subroutine has no body, no attributes, and no builtin attributes
4471 then it's just a sub declaration, and we may be able to get away with
4472 storing with a placeholder scalar in the symbol table, rather than a
4473 full GV and CV. If anything is present then it will take a full CV to
4474 store it. */
4475 const I32 gv_fetch_flags
4476 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4477 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8b6b16e7 4478 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
8e742a20
MHM		 4479
4480 if (proto) {
4481 assert(proto->op_type == OP_CONST);
5c144d81 4482 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 4483 }
4484 else
4485 ps = Nullch;
4486
83ee9e09 4487 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 4488 SV * const sv = sv_newmortal();
c99da370
JH		 4489 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4490 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 4491 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
b15aece3 4492 aname = SvPVX_const(sv);
83ee9e09
GS		 4493 }
4494 else
4495 aname = Nullch;
61dbb99a 4496
61dbb99a 4497 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
7a5fd60d
NC		 4498 : gv_fetchpv(aname ? aname
4499 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
61dbb99a 4500 gv_fetch_flags, SVt_PVCV);
83ee9e09 4501
11343788 4502 if (o)
5dc0d613 4503 SAVEFREEOP(o);
3fe9a6f1 4504 if (proto)
4505 SAVEFREEOP(proto);
09bef843
SB		 4506 if (attrs)
4507 SAVEFREEOP(attrs);
3fe9a6f1 4508
09bef843 4509 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4510 maximum a prototype before. */
4511 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4512 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4513 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4514 {
9014280d 4515 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4516 }
55d729e4
GS		 4517 cv_ckproto((CV*)gv, NULL, ps);
4518 }
4519 if (ps)
ea6e9374 4520 sv_setpvn((SV*)gv, ps, ps_len);
55d729e4
GS		 4521 else
4522 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4523 SvREFCNT_dec(PL_compcv);
4524 cv = PL_compcv = NULL;
4525 PL_sub_generation++;
beab0874 4526 goto done;
55d729e4
GS		 4527 }
4528
beab0874
JT		 4529 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4530
7fb37951
AMS		 4531#ifdef GV_UNIQUE_CHECK
4532 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4533 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4534 }
4535#endif
4536
2e8a6c53 4537 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
beab0874
JT		 4538 const_sv = Nullsv;
4539 else
4540 const_sv = op_const_sv(block, Nullcv);
4541
4542 if (cv) {
6867be6d 4543 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4544
7fb37951
AMS		 4545#ifdef GV_UNIQUE_CHECK
4546 if (exists && GvUNIQUE(gv)) {
4547 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4548 }
4549#endif
4550
60ed1d8c
GS		 4551 /* if the subroutine doesn't exist and wasn't pre-declared
4552 * with a prototype, assume it will be AUTOLOADed,
4553 * skipping the prototype check
4554 */
4555 if (exists || SvPOK(cv))
01ec43d0 4556 cv_ckproto(cv, gv, ps);
68dc0745 4557 /* already defined (or promised)? */
60ed1d8c 4558 if (exists || GvASSUMECV(gv)) {
09bef843 4559 if (!block && !attrs) {
d3cea301
SB		 4560 if (CvFLAGS(PL_compcv)) {
4561 /* might have had built-in attrs applied */
4562 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4563 }
aa689395 4564 /* just a "sub foo;" when &foo is already defined */
3280af22 4565 SAVEFREESV(PL_compcv);
aa689395 4566 goto done;
4567 }
beab0874
JT		 4568 if (block) {
4569 if (ckWARN(WARN_REDEFINE)
4570 || (CvCONST(cv)
4571 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4572 {
6867be6d 4573 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4574 if (PL_copline != NOLINE)
4575 CopLINE_set(PL_curcop, PL_copline);
9014280d 4576 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4577 CvCONST(cv) ? "Constant subroutine %s redefined"
4578 : "Subroutine %s redefined", name);
4579 CopLINE_set(PL_curcop, oldline);
4580 }
4581 SvREFCNT_dec(cv);
4582 cv = Nullcv;
79072805 4583 }
79072805
LW		 4584 }
4585 }
beab0874 4586 if (const_sv) {
7fc63493 4587 (void)SvREFCNT_inc(const_sv);
beab0874 4588 if (cv) {
0768512c 4589 assert(!CvROOT(cv) && !CvCONST(cv));
c69006e4 4590 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
beab0874
JT		 4591 CvXSUBANY(cv).any_ptr = const_sv;
4592 CvXSUB(cv) = const_sv_xsub;
4593 CvCONST_on(cv);
beab0874
JT		 4594 }
4595 else {
4596 GvCV(gv) = Nullcv;
4597 cv = newCONSTSUB(NULL, name, const_sv);
4598 }
4599 op_free(block);
4600 SvREFCNT_dec(PL_compcv);
4601 PL_compcv = NULL;
4602 PL_sub_generation++;
4603 goto done;
4604 }
09bef843
SB		 4605 if (attrs) {
4606 HV *stash;
4607 SV *rcv;
4608
4609 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4610 * before we clobber PL_compcv.
4611 */
4612 if (cv && !block) {
4613 rcv = (SV*)cv;
020f0e03
SB		 4614 /* Might have had built-in attributes applied -- propagate them. */
4615 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4616 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4617 stash = GvSTASH(CvGV(cv));
a9164de8 4618 else if (CvSTASH(cv))
09bef843
SB		 4619 stash = CvSTASH(cv);
4620 else
4621 stash = PL_curstash;
4622 }
4623 else {
4624 /* possibly about to re-define existing subr -- ignore old cv */
4625 rcv = (SV*)PL_compcv;
a9164de8 4626 if (name && GvSTASH(gv))
09bef843
SB		 4627 stash = GvSTASH(gv);
4628 else
4629 stash = PL_curstash;
4630 }
95f0a2f1 4631 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4632 }
a0d0e21e 4633 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4634 if (!block) {
4635 /* got here with just attrs -- work done, so bug out */
4636 SAVEFREESV(PL_compcv);
4637 goto done;
4638 }
a3985cdc 4639 /* transfer PL_compcv to cv */
4633a7c4 4640 cv_undef(cv);
3280af22 4641 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 4642 if (!CvWEAKOUTSIDE(cv))
4643 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 4644 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4645 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4646 CvOUTSIDE(PL_compcv) = 0;
4647 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4648 CvPADLIST(PL_compcv) = 0;
282f25c9 4649 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4650 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4651 /* ... before we throw it away */
3280af22 4652 SvREFCNT_dec(PL_compcv);
b5c19bd7 4653 PL_compcv = cv;
a933f601
IZ		 4654 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4655 ++PL_sub_generation;
a0d0e21e
LW		 4656 }
4657 else {
3280af22 4658 cv = PL_compcv;
44a8e56a 4659 if (name) {
4660 GvCV(gv) = cv;
4661 GvCVGEN(gv) = 0;
3280af22 4662 PL_sub_generation++;
44a8e56a 4663 }
a0d0e21e 4664 }
65c50114 4665 CvGV(cv) = gv;
a636914a 4666 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4667 CvSTASH(cv) = PL_curstash;
8990e307 4668
3fe9a6f1 4669 if (ps)
ea6e9374 4670 sv_setpvn((SV*)cv, ps, ps_len);
4633a7c4 4671
3280af22 4672 if (PL_error_count) {
c07a80fd 4673 op_free(block);
4674 block = Nullop;
68dc0745 4675 if (name) {
6867be6d 4676 const char *s = strrchr(name, ':');
68dc0745 4677 s = s ? s+1 : name;
6d4c2119 4678 if (strEQ(s, "BEGIN")) {
e1ec3a88 4679 const char not_safe[] =
6d4c2119 4680 "BEGIN not safe after errors--compilation aborted";
faef0170 4681 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4682 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4683 else {
4684 /* force display of errors found but not reported */
38a03e6e 4685 sv_catpv(ERRSV, not_safe);
35c1215d 4686 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4687 }
4688 }
68dc0745 4689 }
c07a80fd 4690 }
beab0874
JT		 4691 if (!block)
4692 goto done;
a0d0e21e 4693
7766f137 4694 if (CvLVALUE(cv)) {
78f9721b
SM		 4695 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4696 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4697 }
4698 else {
09c2fd24
AE		 4699 /* This makes sub {}; work as expected. */
4700 if (block->op_type == OP_STUB) {
4701 op_free(block);
4702 block = newSTATEOP(0, Nullch, 0);
4703 }
7766f137
GS		 4704 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4705 }
4706 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4707 OpREFCNT_set(CvROOT(cv), 1);
4708 CvSTART(cv) = LINKLIST(CvROOT(cv));
4709 CvROOT(cv)->op_next = 0;
a2efc822 4710 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4711
4712 /* now that optimizer has done its work, adjust pad values */
54310121 4713
dd2155a4
DM		 4714 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4715
4716 if (CvCLONE(cv)) {
beab0874
JT		 4717 assert(!CvCONST(cv));
4718 if (ps && !*ps && op_const_sv(block, cv))
4719 CvCONST_on(cv);
a0d0e21e 4720 }
79072805 4721
83ee9e09 4722 if (name || aname) {
6867be6d 4723 const char *s;
0bd48802 4724 const char * const tname = (name ? name : aname);
44a8e56a 4725
3280af22 4726 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 4727 SV * const sv = newSV(0);
c4420975 4728 SV * const tmpstr = sv_newmortal();
dcda55fc 4729 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
44a8e56a 4730 HV *hv;
4731
ed094faf
GS		 4732 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4733 CopFILE(PL_curcop),
cc49e20b 4734 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4735 gv_efullname3(tmpstr, gv, Nullch);
b15aece3 4736 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4737 hv = GvHVn(db_postponed);
551405c4
AL		 4738 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4739 CV * const pcv = GvCV(db_postponed);
4740 if (pcv) {
4741 dSP;
4742 PUSHMARK(SP);
4743 XPUSHs(tmpstr);
4744 PUTBACK;
4745 call_sv((SV*)pcv, G_DISCARD);
4746 }
44a8e56a 4747 }
4748 }
79072805 4749
83ee9e09 4750 if ((s = strrchr(tname,':')))
28757baa 4751 s++;
4752 else
83ee9e09 4753 s = tname;
ed094faf 4754
7d30b5c4 4755 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4756 goto done;
4757
7678c486 4758 if (strEQ(s, "BEGIN") && !PL_error_count) {
6867be6d 4759 const I32 oldscope = PL_scopestack_ix;
28757baa 4760 ENTER;
57843af0
GS		 4761 SAVECOPFILE(&PL_compiling);
4762 SAVECOPLINE(&PL_compiling);
28757baa 4763
3280af22
NIS		 4764 if (!PL_beginav)
4765 PL_beginav = newAV();
28757baa 4766 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4767 av_push(PL_beginav, (SV*)cv);
4768 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4769 call_list(oldscope, PL_beginav);
a6006777 4770
3280af22 4771 PL_curcop = &PL_compiling;
eb160463 4772 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4773 LEAVE;
4774 }
3280af22
NIS		 4775 else if (strEQ(s, "END") && !PL_error_count) {
4776 if (!PL_endav)
4777 PL_endav = newAV();
ed094faf 4778 DEBUG_x( dump_sub(gv) );
3280af22 4779 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4780 av_store(PL_endav, 0, (SV*)cv);
4781 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4782 }
7d30b5c4
GS		 4783 else if (strEQ(s, "CHECK") && !PL_error_count) {
4784 if (!PL_checkav)
4785 PL_checkav = newAV();
ed094faf 4786 DEBUG_x( dump_sub(gv) );
ddda08b7 4787 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4788 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4789 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4790 av_store(PL_checkav, 0, (SV*)cv);
4791 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4792 }
3280af22
NIS		 4793 else if (strEQ(s, "INIT") && !PL_error_count) {
4794 if (!PL_initav)
4795 PL_initav = newAV();
ed094faf 4796 DEBUG_x( dump_sub(gv) );
ddda08b7 4797 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4798 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4799 av_push(PL_initav, (SV*)cv);
4800 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4801 }
79072805 4802 }
a6006777 4803
aa689395 4804 done:
3280af22 4805 PL_copline = NOLINE;
8990e307 4806 LEAVE_SCOPE(floor);
a0d0e21e 4807 return cv;
79072805
LW		 4808}
4809
b099ddc0 4810/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4811/*
4812=for apidoc newCONSTSUB
4813
4814Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4815eligible for inlining at compile-time.
4816
4817=cut
4818*/
4819
beab0874 4820CV *
e1ec3a88 4821Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 4822{
27da23d5 4823 dVAR;
beab0874 4824 CV* cv;
5476c433 4825
11faa288 4826 ENTER;
11faa288 4827
f4dd75d9 4828 SAVECOPLINE(PL_curcop);
11faa288 4829 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4830
4831 SAVEHINTS();
3280af22 4832 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4833
4834 if (stash) {
4835 SAVESPTR(PL_curstash);
4836 SAVECOPSTASH(PL_curcop);
4837 PL_curstash = stash;
05ec9bb3 4838 CopSTASH_set(PL_curcop,stash);
11faa288 4839 }
5476c433 4840
91a15d0d 4841 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4842 CvXSUBANY(cv).any_ptr = sv;
4843 CvCONST_on(cv);
c69006e4 4844 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5476c433 4845
65e66c80 4846#ifdef USE_ITHREADS
02f28d44
MHM		 4847 if (stash)
4848 CopSTASH_free(PL_curcop);
65e66c80 4849#endif
11faa288 4850 LEAVE;
beab0874
JT		 4851
4852 return cv;
5476c433
JD		 4853}
4854
954c1994
GS		 4855/*
4856=for apidoc U||newXS
4857
4858Used by C<xsubpp> to hook up XSUBs as Perl subs.
4859
4860=cut
4861*/
4862
57d3b86d 4863CV *
bfed75c6 4864Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 4865{
97aff369 4866 dVAR;
9a957fbc 4867 GV * const gv = gv_fetchpv(name ? name :
c99da370
JH		 4868 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4869 GV_ADDMULTI, SVt_PVCV);
79072805 4870 register CV *cv;
44a8e56a 4871
1ecdd9a8
HS		 4872 if (!subaddr)
4873 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4874
155aba94 4875 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4876 if (GvCVGEN(gv)) {
4877 /* just a cached method */
4878 SvREFCNT_dec(cv);
66a1b24b 4879 cv = Nullcv;
44a8e56a 4880 }
4881 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4882 /* already defined (or promised) */
1df70142 4883 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 4884 if (ckWARN(WARN_REDEFINE)) {
4885 GV * const gvcv = CvGV(cv);
4886 if (gvcv) {
4887 HV * const stash = GvSTASH(gvcv);
4888 if (stash) {
4889 const char *name = HvNAME_get(stash);
4890 if ( strEQ(name,"autouse") ) {
4891 const line_t oldline = CopLINE(PL_curcop);
4892 if (PL_copline != NOLINE)
4893 CopLINE_set(PL_curcop, PL_copline);
4894 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4895 CvCONST(cv) ? "Constant subroutine %s redefined"
4896 : "Subroutine %s redefined"
4897 ,name);
4898 CopLINE_set(PL_curcop, oldline);
4899 }
4900 }
4901 }
a0d0e21e
LW		 4902 }
4903 SvREFCNT_dec(cv);
66a1b24b 4904 cv = Nullcv;
79072805 4905 }
79072805 4906 }
44a8e56a 4907
4908 if (cv) /* must reuse cv if autoloaded */
4909 cv_undef(cv);
a0d0e21e 4910 else {
561b68a9 4911 cv = (CV*)newSV(0);
a0d0e21e 4912 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4913 if (name) {
4914 GvCV(gv) = cv;
4915 GvCVGEN(gv) = 0;
3280af22 4916 PL_sub_generation++;
44a8e56a 4917 }
a0d0e21e 4918 }
65c50114 4919 CvGV(cv) = gv;
b195d487 4920 (void)gv_fetchfile(filename);
dd374669 4921 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 4922 an external constant string */
a0d0e21e 4923 CvXSUB(cv) = subaddr;
44a8e56a 4924
28757baa 4925 if (name) {
e1ec3a88 4926 const char *s = strrchr(name,':');
28757baa 4927 if (s)
4928 s++;
4929 else
4930 s = name;
ed094faf 4931
7d30b5c4 4932 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4933 goto done;
4934
28757baa 4935 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4936 if (!PL_beginav)
4937 PL_beginav = newAV();
ea2f84a3
GS		 4938 av_push(PL_beginav, (SV*)cv);
4939 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4940 }
4941 else if (strEQ(s, "END")) {
3280af22
NIS		 4942 if (!PL_endav)
4943 PL_endav = newAV();
4944 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4945 av_store(PL_endav, 0, (SV*)cv);
4946 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4947 }
7d30b5c4
GS		 4948 else if (strEQ(s, "CHECK")) {
4949 if (!PL_checkav)
4950 PL_checkav = newAV();
ddda08b7 4951 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4952 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4953 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4954 av_store(PL_checkav, 0, (SV*)cv);
4955 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4956 }
7d07dbc2 4957 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4958 if (!PL_initav)
4959 PL_initav = newAV();
ddda08b7 4960 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4961 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4962 av_push(PL_initav, (SV*)cv);
4963 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4964 }
28757baa 4965 }
8990e307 4966 else
a5f75d66 4967 CvANON_on(cv);
44a8e56a 4968
ed094faf 4969done:
a0d0e21e 4970 return cv;
79072805
LW		 4971}
4972
4973void
864dbfa3 4974Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 4975{
97aff369 4976 dVAR;
79072805 4977 register CV *cv;
79072805 4978
0bd48802 4979 GV * const gv = o
f776e3cd
NC		 4980 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4981 : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
0bd48802 4982
7fb37951
AMS		 4983#ifdef GV_UNIQUE_CHECK
4984 if (GvUNIQUE(gv)) {
4985 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4986 }
4987#endif
a5f75d66 4988 GvMULTI_on(gv);
155aba94 4989 if ((cv = GvFORM(gv))) {
599cee73 4990 if (ckWARN(WARN_REDEFINE)) {
6867be6d 4991 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4992 if (PL_copline != NOLINE)
4993 CopLINE_set(PL_curcop, PL_copline);
7a5fd60d
NC		 4994 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4995 o ? "Format %"SVf" redefined"
4996 : "Format STDOUT redefined" ,cSVOPo->op_sv);
57843af0 4997 CopLINE_set(PL_curcop, oldline);
79072805 4998 }
8990e307 4999 SvREFCNT_dec(cv);
79072805 5000 }
3280af22 5001 cv = PL_compcv;
79072805 5002 GvFORM(gv) = cv;
65c50114 5003 CvGV(cv) = gv;
a636914a 5004 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5005
a0d0e21e 5006
dd2155a4 5007 pad_tidy(padtidy_FORMAT);
79072805 5008 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5009 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5010 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5011 CvSTART(cv) = LINKLIST(CvROOT(cv));
5012 CvROOT(cv)->op_next = 0;
a2efc822 5013 CALL_PEEP(CvSTART(cv));
11343788 5014 op_free(o);
3280af22 5015 PL_copline = NOLINE;
8990e307 5016 LEAVE_SCOPE(floor);
79072805
LW		 5017}
5018
5019OP *
864dbfa3 5020Perl_newANONLIST(pTHX_ OP *o)
79072805 5021{
93a17b20 5022 return newUNOP(OP_REFGEN, 0,
11343788 5023 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 5024}
5025
5026OP *
864dbfa3 5027Perl_newANONHASH(pTHX_ OP *o)
79072805 5028{
93a17b20 5029 return newUNOP(OP_REFGEN, 0,
11343788 5030 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 5031}
5032
5033OP *
864dbfa3 5034Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5035{
09bef843
SB		 5036 return newANONATTRSUB(floor, proto, Nullop, block);
5037}
5038
5039OP *
5040Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5041{
a0d0e21e 5042 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5043 newSVOP(OP_ANONCODE, 0,
5044 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5045}
5046
5047OP *
864dbfa3 5048Perl_oopsAV(pTHX_ OP *o)
79072805 5049{
27da23d5 5050 dVAR;
ed6116ce
LW		 5051 switch (o->op_type) {
5052 case OP_PADSV:
5053 o->op_type = OP_PADAV;
22c35a8c 5054 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5055 return ref(o, OP_RV2AV);
b2ffa427 5056
ed6116ce 5057 case OP_RV2SV:
79072805 5058 o->op_type = OP_RV2AV;
22c35a8c 5059 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5060 ref(o, OP_RV2AV);
ed6116ce
LW		 5061 break;
5062
5063 default:
0453d815 5064 if (ckWARN_d(WARN_INTERNAL))
9014280d 5065 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 5066 break;
5067 }
79072805
LW		 5068 return o;
5069}
5070
5071OP *
864dbfa3 5072Perl_oopsHV(pTHX_ OP *o)
79072805 5073{
27da23d5 5074 dVAR;
ed6116ce
LW		 5075 switch (o->op_type) {
5076 case OP_PADSV:
5077 case OP_PADAV:
5078 o->op_type = OP_PADHV;
22c35a8c 5079 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5080 return ref(o, OP_RV2HV);
ed6116ce
LW		 5081
5082 case OP_RV2SV:
5083 case OP_RV2AV:
79072805 5084 o->op_type = OP_RV2HV;
22c35a8c 5085 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5086 ref(o, OP_RV2HV);
ed6116ce
LW		 5087 break;
5088
5089 default:
0453d815 5090 if (ckWARN_d(WARN_INTERNAL))
9014280d 5091 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 5092 break;
5093 }
79072805
LW		 5094 return o;
5095}
5096
5097OP *
864dbfa3 5098Perl_newAVREF(pTHX_ OP *o)
79072805 5099{
27da23d5 5100 dVAR;
ed6116ce
LW		 5101 if (o->op_type == OP_PADANY) {
5102 o->op_type = OP_PADAV;
22c35a8c 5103 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5104 return o;
ed6116ce 5105 }
a1063b2d 5106 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 5107 && ckWARN(WARN_DEPRECATED)) {
5108 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5109 "Using an array as a reference is deprecated");
5110 }
79072805
LW		 5111 return newUNOP(OP_RV2AV, 0, scalar(o));
5112}
5113
5114OP *
864dbfa3 5115Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5116{
82092f1d 5117 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5118 return newUNOP(OP_NULL, 0, o);
748a9306 5119 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5120}
5121
5122OP *
864dbfa3 5123Perl_newHVREF(pTHX_ OP *o)
79072805 5124{
27da23d5 5125 dVAR;
ed6116ce
LW		 5126 if (o->op_type == OP_PADANY) {
5127 o->op_type = OP_PADHV;
22c35a8c 5128 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5129 return o;
ed6116ce 5130 }
a1063b2d 5131 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 5132 && ckWARN(WARN_DEPRECATED)) {
5133 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5134 "Using a hash as a reference is deprecated");
5135 }
79072805
LW		 5136 return newUNOP(OP_RV2HV, 0, scalar(o));
5137}
5138
5139OP *
864dbfa3 5140Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5141{
c07a80fd 5142 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5143}
5144
5145OP *
864dbfa3 5146Perl_newSVREF(pTHX_ OP *o)
79072805 5147{
27da23d5 5148 dVAR;
ed6116ce
LW		 5149 if (o->op_type == OP_PADANY) {
5150 o->op_type = OP_PADSV;
22c35a8c 5151 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5152 return o;
ed6116ce 5153 }
224a4551
MB		 5154 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5155 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5156 return o;
224a4551 5157 }
79072805
LW		 5158 return newUNOP(OP_RV2SV, 0, scalar(o));
5159}
5160
61b743bb
DM		 5161/* Check routines. See the comments at the top of this file for details
5162 * on when these are called */
79072805
LW		 5163
5164OP *
cea2e8a9 5165Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5166{
dd2155a4 5167 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 5168 cSVOPo->op_sv = Nullsv;
5dc0d613 5169 return o;
5f05dabc 5170}
5171
5172OP *
cea2e8a9 5173Perl_ck_bitop(pTHX_ OP *o)
55497cff 5174{
97aff369 5175 dVAR;
276b2a0c
RGS		 5176#define OP_IS_NUMCOMPARE(op) \
5177 ((op) == OP_LT || (op) == OP_I_LT || \
5178 (op) == OP_GT || (op) == OP_I_GT || \
5179 (op) == OP_LE || (op) == OP_I_LE || \
5180 (op) == OP_GE || (op) == OP_I_GE || \
5181 (op) == OP_EQ || (op) == OP_I_EQ || \
5182 (op) == OP_NE || (op) == OP_I_NE || \
5183 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 5184 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 5185 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5186 && (o->op_type == OP_BIT_OR
5187 || o->op_type == OP_BIT_AND
5188 || o->op_type == OP_BIT_XOR))
276b2a0c 5189 {
1df70142
AL		 5190 const OP * const left = cBINOPo->op_first;
5191 const OP * const right = left->op_sibling;
96a925ab
YST		 5192 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5193 (left->op_flags & OPf_PARENS) == 0) ||
5194 (OP_IS_NUMCOMPARE(right->op_type) &&
5195 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 5196 if (ckWARN(WARN_PRECEDENCE))
5197 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5198 "Possible precedence problem on bitwise %c operator",
5199 o->op_type == OP_BIT_OR ? '|'
5200 : o->op_type == OP_BIT_AND ? '&' : '^'
5201 );
5202 }
5dc0d613 5203 return o;
55497cff 5204}
5205
5206OP *
cea2e8a9 5207Perl_ck_concat(pTHX_ OP *o)
79072805 5208{
0bd48802 5209 const OP * const kid = cUNOPo->op_first;
df91b2c5
AE		 5210 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5211 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 5212 o->op_flags |= OPf_STACKED;
11343788 5213 return o;
79072805
LW		 5214}
5215
5216OP *
cea2e8a9 5217Perl_ck_spair(pTHX_ OP *o)
79072805 5218{
27da23d5 5219 dVAR;
11343788 5220 if (o->op_flags & OPf_KIDS) {
79072805 5221 OP* newop;
a0d0e21e 5222 OP* kid;
6867be6d 5223 const OPCODE type = o->op_type;
5dc0d613 5224 o = modkids(ck_fun(o), type);
11343788 5225 kid = cUNOPo->op_first;
a0d0e21e
LW		 5226 newop = kUNOP->op_first->op_sibling;
5227 if (newop &&
5228 (newop->op_sibling ||
22c35a8c 5229 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5230 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5231 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 5232
11343788 5233 return o;
a0d0e21e
LW		 5234 }
5235 op_free(kUNOP->op_first);
5236 kUNOP->op_first = newop;
5237 }
22c35a8c 5238 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5239 return ck_fun(o);
a0d0e21e
LW		 5240}
5241
5242OP *
cea2e8a9 5243Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5244{
11343788 5245 o = ck_fun(o);
5dc0d613 5246 o->op_private = 0;
11343788 5247 if (o->op_flags & OPf_KIDS) {
551405c4 5248 OP * const kid = cUNOPo->op_first;
01020589
GS		 5249 switch (kid->op_type) {
5250 case OP_ASLICE:
5251 o->op_flags |= OPf_SPECIAL;
5252 /* FALL THROUGH */
5253 case OP_HSLICE:
5dc0d613 5254 o->op_private |= OPpSLICE;
01020589
GS		 5255 break;
5256 case OP_AELEM:
5257 o->op_flags |= OPf_SPECIAL;
5258 /* FALL THROUGH */
5259 case OP_HELEM:
5260 break;
5261 default:
5262 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5263 OP_DESC(o));
01020589 5264 }
93c66552 5265 op_null(kid);
79072805 5266 }
11343788 5267 return o;
79072805
LW		 5268}
5269
5270OP *
96e176bf
CL		 5271Perl_ck_die(pTHX_ OP *o)
5272{
5273#ifdef VMS
5274 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5275#endif
5276 return ck_fun(o);
5277}
5278
5279OP *
cea2e8a9 5280Perl_ck_eof(pTHX_ OP *o)
79072805 5281{
97aff369 5282 dVAR;
6867be6d 5283 const I32 type = o->op_type;
79072805 5284
11343788
MB		 5285 if (o->op_flags & OPf_KIDS) {
5286 if (cLISTOPo->op_first->op_type == OP_STUB) {
5287 op_free(o);
8fde6460 5288 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 5289 }
11343788 5290 return ck_fun(o);
79072805 5291 }
11343788 5292 return o;
79072805
LW		 5293}
5294
5295OP *
cea2e8a9 5296Perl_ck_eval(pTHX_ OP *o)
79072805 5297{
27da23d5 5298 dVAR;
3280af22 5299 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5300 if (o->op_flags & OPf_KIDS) {
46c461b5 5301 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 5302
93a17b20 5303 if (!kid) {
11343788 5304 o->op_flags &= ~OPf_KIDS;
93c66552 5305 op_null(o);
79072805 5306 }
b14574b4 5307 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 5308 LOGOP *enter;
5309
11343788
MB		 5310 cUNOPo->op_first = 0;
5311 op_free(o);
79072805 5312
b7dc083c 5313 NewOp(1101, enter, 1, LOGOP);
79072805 5314 enter->op_type = OP_ENTERTRY;
22c35a8c 5315 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5316 enter->op_private = 0;
5317
5318 /* establish postfix order */
5319 enter->op_next = (OP*)enter;
5320
11343788
MB		 5321 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5322 o->op_type = OP_LEAVETRY;
22c35a8c 5323 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5324 enter->op_other = o;
5325 return o;
79072805 5326 }
b5c19bd7 5327 else {
473986ff 5328 scalar((OP*)kid);
b5c19bd7
DM		 5329 PL_cv_has_eval = 1;
5330 }
79072805
LW		 5331 }
5332 else {
11343788 5333 op_free(o);
54b9620d 5334 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5335 }
3280af22 5336 o->op_targ = (PADOFFSET)PL_hints;
7168684c 5337 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
0d863452
RH		 5338 /* Store a copy of %^H that pp_entereval can pick up */
5339 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5340 cUNOPo->op_first->op_sibling = hhop;
5341 o->op_private |= OPpEVAL_HAS_HH;
5342 }
11343788 5343 return o;
79072805
LW		 5344}
5345
5346OP *
d98f61e7
GS		 5347Perl_ck_exit(pTHX_ OP *o)
5348{
5349#ifdef VMS
551405c4 5350 HV * const table = GvHV(PL_hintgv);
d98f61e7 5351 if (table) {
a4fc7abc 5352 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 5353 if (svp && *svp && SvTRUE(*svp))
5354 o->op_private |= OPpEXIT_VMSISH;
5355 }
96e176bf 5356 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 5357#endif
5358 return ck_fun(o);
5359}
5360
5361OP *
cea2e8a9 5362Perl_ck_exec(pTHX_ OP *o)
79072805 5363{
11343788 5364 if (o->op_flags & OPf_STACKED) {
6867be6d 5365 OP *kid;
11343788
MB		 5366 o = ck_fun(o);
5367 kid = cUNOPo->op_first->op_sibling;
8990e307 5368 if (kid->op_type == OP_RV2GV)
93c66552 5369 op_null(kid);
79072805 5370 }
463ee0b2 5371 else
11343788
MB		 5372 o = listkids(o);
5373 return o;
79072805
LW		 5374}
5375
5376OP *
cea2e8a9 5377Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5378{
97aff369 5379 dVAR;
5196be3e
MB		 5380 o = ck_fun(o);
5381 if (o->op_flags & OPf_KIDS) {
46c461b5 5382 OP * const kid = cUNOPo->op_first;
afebc493
GS		 5383 if (kid->op_type == OP_ENTERSUB) {
5384 (void) ref(kid, o->op_type);
5385 if (kid->op_type != OP_RV2CV && !PL_error_count)
5386 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 5387 OP_DESC(o));
afebc493
GS		 5388 o->op_private |= OPpEXISTS_SUB;
5389 }
5390 else if (kid->op_type == OP_AELEM)
01020589
GS		 5391 o->op_flags |= OPf_SPECIAL;
5392 else if (kid->op_type != OP_HELEM)
5393 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 5394 OP_DESC(o));
93c66552 5395 op_null(kid);
5f05dabc 5396 }
5196be3e 5397 return o;
5f05dabc 5398}
5399
79072805 5400OP *
cea2e8a9 5401Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5402{
27da23d5 5403 dVAR;
0bd48802 5404 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5405
3280af22 5406 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 5407 if (o->op_type == OP_RV2CV)
5408 o->op_private &= ~1;
5409
79072805 5410 if (kid->op_type == OP_CONST) {
44a8e56a 5411 int iscv;
5412 GV *gv;
504618e9 5413 SV * const kidsv = kid->op_sv;
44a8e56a 5414
779c5bc9
GS		 5415 /* Is it a constant from cv_const_sv()? */
5416 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 5417 SV * const rsv = SvRV(kidsv);
504618e9 5418 const int svtype = SvTYPE(rsv);
e1ec3a88 5419 const char *badtype = Nullch;
779c5bc9
GS		 5420
5421 switch (o->op_type) {
5422 case OP_RV2SV:
5423 if (svtype > SVt_PVMG)
5424 badtype = "a SCALAR";
5425 break;
5426 case OP_RV2AV:
5427 if (svtype != SVt_PVAV)
5428 badtype = "an ARRAY";
5429 break;
5430 case OP_RV2HV:
6d822dc4 5431 if (svtype != SVt_PVHV)
779c5bc9 5432 badtype = "a HASH";
779c5bc9
GS		 5433 break;
5434 case OP_RV2CV:
5435 if (svtype != SVt_PVCV)
5436 badtype = "a CODE";
5437 break;
5438 }
5439 if (badtype)
cea2e8a9 5440 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5441 return o;
5442 }
ce10b5d1
RGS		 5443 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5444 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5445 /* If this is an access to a stash, disable "strict refs", because
5446 * stashes aren't auto-vivified at compile-time (unless we store
5447 * symbols in them), and we don't want to produce a run-time
5448 * stricture error when auto-vivifying the stash. */
5449 const char *s = SvPV_nolen(kidsv);
5450 const STRLEN l = SvCUR(kidsv);
5451 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5452 o->op_private &= ~HINT_STRICT_REFS;
5453 }
5454 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
e1ec3a88 5455 const char *badthing = Nullch;
5dc0d613 5456 switch (o->op_type) {
44a8e56a 5457 case OP_RV2SV:
5458 badthing = "a SCALAR";
5459 break;
5460 case OP_RV2AV:
5461 badthing = "an ARRAY";
5462 break;
5463 case OP_RV2HV:
5464 badthing = "a HASH";
5465 break;
5466 }
5467 if (badthing)
1c846c1f 5468 Perl_croak(aTHX_
7a5fd60d
NC		 5469 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5470 kidsv, badthing);
44a8e56a 5471 }
93233ece
CS		 5472 /*
5473 * This is a little tricky. We only want to add the symbol if we
5474 * didn't add it in the lexer. Otherwise we get duplicate strict
5475 * warnings. But if we didn't add it in the lexer, we must at
5476 * least pretend like we wanted to add it even if it existed before,
5477 * or we get possible typo warnings. OPpCONST_ENTERED says
5478 * whether the lexer already added THIS instance of this symbol.
5479 */
5196be3e 5480 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5481 do {
7a5fd60d 5482 gv = gv_fetchsv(kidsv,
748a9306 5483 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5484 iscv
5485 ? SVt_PVCV
11343788 5486 : o->op_type == OP_RV2SV
a0d0e21e 5487 ? SVt_PV
11343788 5488 : o->op_type == OP_RV2AV
a0d0e21e 5489 ? SVt_PVAV
11343788 5490 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5491 ? SVt_PVHV
5492 : SVt_PVGV);
93233ece
CS		 5493 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5494 if (gv) {
5495 kid->op_type = OP_GV;
5496 SvREFCNT_dec(kid->op_sv);
350de78d 5497#ifdef USE_ITHREADS
638eceb6 5498 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5499 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 5500 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 5501 GvIN_PAD_on(gv);
dd2155a4 5502 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 5503#else
93233ece 5504 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5505#endif
23f1ca44 5506 kid->op_private = 0;
76cd736e 5507 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5508 }
79072805 5509 }
11343788 5510 return o;
79072805
LW		 5511}
5512
5513OP *
cea2e8a9 5514Perl_ck_ftst(pTHX_ OP *o)
79072805 5515{
27da23d5 5516 dVAR;
6867be6d 5517 const I32 type = o->op_type;
79072805 5518
d0dca557
JD		 5519 if (o->op_flags & OPf_REF) {
5520 /* nothing */
5521 }
5522 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 5523 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5524
5525 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 5526 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 5527 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11343788 5528 op_free(o);
d0dca557 5529 o = newop;
181bc48d 5530 return o;
79072805 5531 }
1af34c76
JH		 5532 else {
5533 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5534 OP_IS_FILETEST_ACCESS(o))
5535 o->op_private |= OPpFT_ACCESS;
5536 }
fbb0b3b3
RGS		 5537 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5538 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5539 o->op_private |= OPpFT_STACKED;
79072805
LW		 5540 }
5541 else {
11343788 5542 op_free(o);
79072805 5543 if (type == OP_FTTTY)
8fde6460 5544 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5545 else
d0dca557 5546 o = newUNOP(type, 0, newDEFSVOP());
79072805 5547 }
11343788 5548 return o;
79072805
LW		 5549}
5550
5551OP *
cea2e8a9 5552Perl_ck_fun(pTHX_ OP *o)
79072805 5553{
97aff369 5554 dVAR;
6867be6d 5555 const int type = o->op_type;
22c35a8c 5556 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5557
11343788 5558 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5559 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5560 oa &= ~OA_OPTIONAL;
5561 else
11343788 5562 return no_fh_allowed(o);
79072805
LW		 5563 }
5564
11343788 5565 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 5566 OP **tokid = &cLISTOPo->op_first;
5567 register OP *kid = cLISTOPo->op_first;
5568 OP *sibl;
5569 I32 numargs = 0;
5570
8990e307 5571 if (kid->op_type == OP_PUSHMARK ||
155aba94 5572 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5573 {
79072805
LW		 5574 tokid = &kid->op_sibling;
5575 kid = kid->op_sibling;
5576 }
22c35a8c 5577 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5578 *tokid = kid = newDEFSVOP();
79072805
LW		 5579
5580 while (oa && kid) {
5581 numargs++;
5582 sibl = kid->op_sibling;
5583 switch (oa & 7) {
5584 case OA_SCALAR:
62c18ce2
GS		 5585 /* list seen where single (scalar) arg expected? */
5586 if (numargs == 1 && !(oa >> 4)
5587 && kid->op_type == OP_LIST && type != OP_SCALAR)
5588 {
5589 return too_many_arguments(o,PL_op_desc[type]);
5590 }
79072805
LW		 5591 scalar(kid);
5592 break;
5593 case OA_LIST:
5594 if (oa < 16) {
5595 kid = 0;
5596 continue;
5597 }
5598 else
5599 list(kid);
5600 break;
5601 case OA_AVREF:
936edb8b 5602 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5603 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5604 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5605 "Useless use of %s with no values",
936edb8b 5606 PL_op_desc[type]);
b2ffa427 5607
79072805 5608 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5609 (kid->op_private & OPpCONST_BARE))
5610 {
551405c4 5611 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 5612 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 5613 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5614 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d
NC		 5615 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5616 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5617 op_free(kid);
5618 kid = newop;
5619 kid->op_sibling = sibl;
5620 *tokid = kid;
5621 }
8990e307 5622 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5623 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5624 mod(kid, type);
79072805
LW		 5625 break;
5626 case OA_HVREF:
5627 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5628 (kid->op_private & OPpCONST_BARE))
5629 {
551405c4 5630 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 5631 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 5632 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5633 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d
NC		 5634 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5635 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5636 op_free(kid);
5637 kid = newop;
5638 kid->op_sibling = sibl;
5639 *tokid = kid;
5640 }
8990e307 5641 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5642 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5643 mod(kid, type);
79072805
LW		 5644 break;
5645 case OA_CVREF:
5646 {
551405c4 5647 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5648 kid->op_sibling = 0;
5649 linklist(kid);
5650 newop->op_next = newop;
5651 kid = newop;
5652 kid->op_sibling = sibl;
5653 *tokid = kid;
5654 }
5655 break;
5656 case OA_FILEREF:
c340be78 5657 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5658 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5659 (kid->op_private & OPpCONST_BARE))
5660 {
0bd48802 5661 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 5662 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 5663 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5664 kid == cLISTOPo->op_last)
364daeac 5665 cLISTOPo->op_last = newop;
79072805
LW		 5666 op_free(kid);
5667 kid = newop;
5668 }
1ea32a52
GS		 5669 else if (kid->op_type == OP_READLINE) {
5670 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5671 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5672 }
79072805 5673 else {
35cd451c 5674 I32 flags = OPf_SPECIAL;
a6c40364 5675 I32 priv = 0;
2c8ac474
GS		 5676 PADOFFSET targ = 0;
5677
35cd451c 5678 /* is this op a FH constructor? */
853846ea 5679 if (is_handle_constructor(o,numargs)) {
e1ec3a88 5680 const char *name = Nullch;
dd2155a4 5681 STRLEN len = 0;
2c8ac474
GS		 5682
5683 flags = 0;
5684 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5685 * need to "prove" flag does not mean something
5686 * else already - NI-S 1999/05/07
2c8ac474
GS		 5687 */
5688 priv = OPpDEREF;
5689 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5690 name = PAD_COMPNAME_PV(kid->op_targ);
5691 /* SvCUR of a pad namesv can't be trusted
5692 * (see PL_generation), so calc its length
5693 * manually */
5694 if (name)
5695 len = strlen(name);
5696
2c8ac474
GS		 5697 }
5698 else if (kid->op_type == OP_RV2SV
5699 && kUNOP->op_first->op_type == OP_GV)
5700 {
0bd48802 5701 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 5702 name = GvNAME(gv);
5703 len = GvNAMELEN(gv);
5704 }
afd1915d
GS		 5705 else if (kid->op_type == OP_AELEM
5706 || kid->op_type == OP_HELEM)
5707 {
551405c4 5708 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 5709 name = NULL;
551405c4 5710 if (op) {
0c4b0a3f 5711 SV *tmpstr = Nullsv;
551405c4 5712 const char * const a =
0c4b0a3f
JH		 5713 kid->op_type == OP_AELEM ?
5714 "[]" : "{}";
5715 if (((op->op_type == OP_RV2AV) ||
5716 (op->op_type == OP_RV2HV)) &&
5717 (op = ((UNOP*)op)->op_first) &&
5718 (op->op_type == OP_GV)) {
5719 /* packagevar $a[] or $h{} */
551405c4 5720 GV * const gv = cGVOPx_gv(op);
0c4b0a3f
JH		 5721 if (gv)
5722 tmpstr =
5723 Perl_newSVpvf(aTHX_
5724 "%s%c...%c",
5725 GvNAME(gv),
5726 a[0], a[1]);
5727 }
5728 else if (op->op_type == OP_PADAV
5729 || op->op_type == OP_PADHV) {
5730 /* lexicalvar $a[] or $h{} */
551405c4 5731 const char * const padname =
0c4b0a3f
JH		 5732 PAD_COMPNAME_PV(op->op_targ);
5733 if (padname)
5734 tmpstr =
5735 Perl_newSVpvf(aTHX_
5736 "%s%c...%c",
5737 padname + 1,
5738 a[0], a[1]);
0c4b0a3f
JH		 5739 }
5740 if (tmpstr) {
93524f2b 5741 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 5742 sv_2mortal(tmpstr);
5743 }
5744 }
5745 if (!name) {
5746 name = "__ANONIO__";
5747 len = 10;
5748 }
5749 mod(kid, type);
afd1915d 5750 }
2c8ac474
GS		 5751 if (name) {
5752 SV *namesv;
5753 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5754 namesv = PAD_SVl(targ);
862a34c6 5755 SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5756 if (*name != '$')
5757 sv_setpvn(namesv, "$", 1);
5758 sv_catpvn(namesv, name, len);
5759 }
853846ea 5760 }
79072805 5761 kid->op_sibling = 0;
35cd451c 5762 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5763 kid->op_targ = targ;
5764 kid->op_private |= priv;
79072805
LW		 5765 }
5766 kid->op_sibling = sibl;
5767 *tokid = kid;
5768 }
5769 scalar(kid);
5770 break;
5771 case OA_SCALARREF:
a0d0e21e 5772 mod(scalar(kid), type);
79072805
LW		 5773 break;
5774 }
5775 oa >>= 4;
5776 tokid = &kid->op_sibling;
5777 kid = kid->op_sibling;
5778 }
11343788 5779 o->op_private |= numargs;
79072805 5780 if (kid)
53e06cf0 5781 return too_many_arguments(o,OP_DESC(o));
11343788 5782 listkids(o);
79072805 5783 }
22c35a8c 5784 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5785 op_free(o);
54b9620d 5786 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5787 }
5788
79072805
LW		 5789 if (oa) {
5790 while (oa & OA_OPTIONAL)
5791 oa >>= 4;
5792 if (oa && oa != OA_LIST)
53e06cf0 5793 return too_few_arguments(o,OP_DESC(o));
79072805 5794 }
11343788 5795 return o;
79072805
LW		 5796}
5797
5798OP *
cea2e8a9 5799Perl_ck_glob(pTHX_ OP *o)
79072805 5800{
27da23d5 5801 dVAR;
fb73857a 5802 GV *gv;
5803
649da076 5804 o = ck_fun(o);
1f2bfc8a 5805 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5806 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5807
f776e3cd 5808 if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
b9f751c0
GS		 5809 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5810 {
f776e3cd 5811 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 5812 }
b1cb66bf 5813
52bb0670 5814#if !defined(PERL_EXTERNAL_GLOB)
72b16652 5815 /* XXX this can be tightened up and made more failsafe. */
f444d496 5816 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 5817 GV *glob_gv;
72b16652 5818 ENTER;
00ca71c1 5819 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
396482e1 5820 newSVpvs("File::Glob"), Nullsv, Nullsv, Nullsv);
f776e3cd
NC		 5821 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5822 glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 5823 GvCV(gv) = GvCV(glob_gv);
7fc63493 5824 (void)SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5825 GvIMPORTED_CV_on(gv);
72b16652
GS		 5826 LEAVE;
5827 }
52bb0670 5828#endif /* PERL_EXTERNAL_GLOB */
72b16652 5829
b9f751c0 5830 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5831 append_elem(OP_GLOB, o,
80252599 5832 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5833 o->op_type = OP_LIST;
22c35a8c 5834 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5835 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5836 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 5837 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 5838 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5839 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5840 scalar(newUNOP(OP_RV2CV, 0,
5841 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5842 o = newUNOP(OP_NULL, 0, ck_subr(o));
5843 o->op_targ = OP_GLOB; /* hint at what it used to be */
5844 return o;
b1cb66bf 5845 }
5846 gv = newGVgen("main");
a0d0e21e 5847 gv_IOadd(gv);
11343788
MB		 5848 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5849 scalarkids(o);
649da076 5850 return o;
79072805
LW		 5851}
5852
5853OP *
cea2e8a9 5854Perl_ck_grep(pTHX_ OP *o)
79072805 5855{
27da23d5 5856 dVAR;
79072805
LW		 5857 LOGOP *gwop;
5858 OP *kid;
6867be6d 5859 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
59f00321 5860 I32 offset;
79072805 5861
22c35a8c 5862 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5863 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5864
11343788 5865 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5866 OP* k;
11343788
MB		 5867 o = ck_sort(o);
5868 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 5869 if (!cUNOPx(kid)->op_next)
5870 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 5871 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 5872 kid = k;
5873 }
5874 kid->op_next = (OP*)gwop;
11343788 5875 o->op_flags &= ~OPf_STACKED;
93a17b20 5876 }
11343788 5877 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5878 if (type == OP_MAPWHILE)
5879 list(kid);
5880 else
5881 scalar(kid);
11343788 5882 o = ck_fun(o);
3280af22 5883 if (PL_error_count)
11343788 5884 return o;
aeea060c 5885 kid = cLISTOPo->op_first->op_sibling;
79072805 5886 if (kid->op_type != OP_NULL)
cea2e8a9 5887 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5888 kid = kUNOP->op_first;
5889
a0d0e21e 5890 gwop->op_type = type;
22c35a8c 5891 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5892 gwop->op_first = listkids(o);
79072805 5893 gwop->op_flags |= OPf_KIDS;
79072805 5894 gwop->op_other = LINKLIST(kid);
79072805 5895 kid->op_next = (OP*)gwop;
59f00321
RGS		 5896 offset = pad_findmy("$_");
5897 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5898 o->op_private = gwop->op_private = 0;
5899 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5900 }
5901 else {
5902 o->op_private = gwop->op_private = OPpGREP_LEX;
5903 gwop->op_targ = o->op_targ = offset;
5904 }
79072805 5905
11343788 5906 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5907 if (!kid || !kid->op_sibling)
53e06cf0 5908 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5909 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5910 mod(kid, OP_GREPSTART);
5911
79072805
LW		 5912 return (OP*)gwop;
5913}
5914
5915OP *
cea2e8a9 5916Perl_ck_index(pTHX_ OP *o)
79072805 5917{
11343788
MB		 5918 if (o->op_flags & OPf_KIDS) {
5919 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5920 if (kid)
5921 kid = kid->op_sibling; /* get past "big" */
79072805 5922 if (kid && kid->op_type == OP_CONST)
2779dcf1 5923 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5924 }
11343788 5925 return ck_fun(o);
79072805
LW		 5926}
5927
5928OP *
cea2e8a9 5929Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5930{
5931 /* XXX length optimization goes here */
11343788 5932 return ck_fun(o);
79072805
LW		 5933}
5934
5935OP *
cea2e8a9 5936Perl_ck_lfun(pTHX_ OP *o)
79072805 5937{
6867be6d 5938 const OPCODE type = o->op_type;
5dc0d613 5939 return modkids(ck_fun(o), type);
79072805
LW		 5940}
5941
5942OP *
cea2e8a9 5943Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5944{
12bcd1a6 5945 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5946 switch (cUNOPo->op_first->op_type) {
5947 case OP_RV2AV:
a8739d98
JH		 5948 /* This is needed for
5949 if (defined %stash::)
5950 to work. Do not break Tk.
5951 */
1c846c1f 5952 break; /* Globals via GV can be undef */
d0334bed
GS		 5953 case OP_PADAV:
5954 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5955 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5956 "defined(@array) is deprecated");
12bcd1a6 5957 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5958 "\t(Maybe you should just omit the defined()?)\n");
69794302 5959 break;
d0334bed 5960 case OP_RV2HV:
a8739d98
JH		 5961 /* This is needed for
5962 if (defined %stash::)
5963 to work. Do not break Tk.
5964 */
1c846c1f 5965 break; /* Globals via GV can be undef */
d0334bed 5966 case OP_PADHV:
12bcd1a6 5967 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5968 "defined(%%hash) is deprecated");
12bcd1a6 5969 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5970 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5971 break;
5972 default:
5973 /* no warning */
5974 break;
5975 }
69794302
MJD		 5976 }
5977 return ck_rfun(o);
5978}
5979
5980OP *
cea2e8a9 5981Perl_ck_rfun(pTHX_ OP *o)
8990e307 5982{
6867be6d 5983 const OPCODE type = o->op_type;
5dc0d613 5984 return refkids(ck_fun(o), type);
8990e307
LW		 5985}
5986
5987OP *
cea2e8a9 5988Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5989{
5990 register OP *kid;
aeea060c 5991
11343788 5992 kid = cLISTOPo->op_first;
79072805 5993 if (!kid) {
11343788
MB		 5994 o = force_list(o);
5995 kid = cLISTOPo->op_first;
79072805
LW		 5996 }
5997 if (kid->op_type == OP_PUSHMARK)
5998 kid = kid->op_sibling;
11343788 5999 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6000 kid = kid->op_sibling;
6001 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6002 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6003 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6004 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6005 cLISTOPo->op_first->op_sibling = kid;
6006 cLISTOPo->op_last = kid;
79072805
LW		 6007 kid = kid->op_sibling;
6008 }
6009 }
b2ffa427 6010
79072805 6011 if (!kid)
54b9620d 6012 append_elem(o->op_type, o, newDEFSVOP());
79072805 6013
2de3dbcc 6014 return listkids(o);
bbce6d69 6015}
6016
6017OP *
0d863452
RH		 6018Perl_ck_say(pTHX_ OP *o)
6019{
6020 o = ck_listiob(o);
6021 o->op_type = OP_PRINT;
6022 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
396482e1 6023 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
0d863452
RH		 6024 return o;
6025}
6026
6027OP *
6028Perl_ck_smartmatch(pTHX_ OP *o)
6029{
97aff369 6030 dVAR;
0d863452
RH		 6031 if (0 == (o->op_flags & OPf_SPECIAL)) {
6032 OP *first = cBINOPo->op_first;
6033 OP *second = first->op_sibling;
6034
6035 /* Implicitly take a reference to an array or hash */
6036 first->op_sibling = Nullop;
6037 first = cBINOPo->op_first = ref_array_or_hash(first);
6038 second = first->op_sibling = ref_array_or_hash(second);
6039
6040 /* Implicitly take a reference to a regular expression */
6041 if (first->op_type == OP_MATCH) {
6042 first->op_type = OP_QR;
6043 first->op_ppaddr = PL_ppaddr[OP_QR];
6044 }
6045 if (second->op_type == OP_MATCH) {
6046 second->op_type = OP_QR;
6047 second->op_ppaddr = PL_ppaddr[OP_QR];
6048 }
6049 }
6050
6051 return o;
6052}
6053
6054
6055OP *
b162f9ea
IZ		 6056Perl_ck_sassign(pTHX_ OP *o)
6057{
6058 OP *kid = cLISTOPo->op_first;
6059 /* has a disposable target? */
6060 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6061 && !(kid->op_flags & OPf_STACKED)
6062 /* Cannot steal the second time! */
6063 && !(kid->op_private & OPpTARGET_MY))
b162f9ea 6064 {
551405c4 6065 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 6066
6067 /* Can just relocate the target. */
2c2d71f5
JH		 6068 if (kkid && kkid->op_type == OP_PADSV
6069 && !(kkid->op_private & OPpLVAL_INTRO))
6070 {
b162f9ea 6071 kid->op_targ = kkid->op_targ;
743e66e6 6072 kkid->op_targ = 0;
b162f9ea
IZ		 6073 /* Now we do not need PADSV and SASSIGN. */
6074 kid->op_sibling = o->op_sibling; /* NULL */
6075 cLISTOPo->op_first = NULL;
6076 op_free(o);
6077 op_free(kkid);
6078 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6079 return kid;
6080 }
6081 }
6082 return o;
6083}
6084
6085OP *
cea2e8a9 6086Perl_ck_match(pTHX_ OP *o)
79072805 6087{
97aff369 6088 dVAR;
0d863452 6089 if (o->op_type != OP_QR && PL_compcv) {
6867be6d 6090 const I32 offset = pad_findmy("$_");
59f00321
RGS		 6091 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6092 o->op_targ = offset;
6093 o->op_private |= OPpTARGET_MY;
6094 }
6095 }
6096 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6097 o->op_private |= OPpRUNTIME;
11343788 6098 return o;
79072805
LW		 6099}
6100
6101OP *
f5d5a27c
CS		 6102Perl_ck_method(pTHX_ OP *o)
6103{
551405c4 6104 OP * const kid = cUNOPo->op_first;
f5d5a27c
CS		 6105 if (kid->op_type == OP_CONST) {
6106 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 6107 const char * const method = SvPVX_const(sv);
6108 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 6109 OP *cmop;
1c846c1f 6110 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 6111 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 6112 }
6113 else {
6114 kSVOP->op_sv = Nullsv;
6115 }
f5d5a27c 6116 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 6117 op_free(o);
6118 return cmop;
6119 }
6120 }
6121 return o;
6122}
6123
6124OP *
cea2e8a9 6125Perl_ck_null(pTHX_ OP *o)
79072805 6126{
11343788 6127 return o;
79072805
LW		 6128}
6129
6130OP *
16fe6d59
GS		 6131Perl_ck_open(pTHX_ OP *o)
6132{
97aff369 6133 dVAR;
551405c4 6134 HV * const table = GvHV(PL_hintgv);
16fe6d59 6135 if (table) {
a4fc7abc 6136 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 6137 if (svp && *svp) {
551405c4 6138 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6139 if (mode & O_BINARY)
6140 o->op_private |= OPpOPEN_IN_RAW;
6141 else if (mode & O_TEXT)
6142 o->op_private |= OPpOPEN_IN_CRLF;
6143 }
6144
a4fc7abc 6145 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 6146 if (svp && *svp) {
551405c4 6147 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6148 if (mode & O_BINARY)
6149 o->op_private |= OPpOPEN_OUT_RAW;
6150 else if (mode & O_TEXT)
6151 o->op_private |= OPpOPEN_OUT_CRLF;
6152 }
6153 }
6154 if (o->op_type == OP_BACKTICK)
6155 return o;
3b82e551
JH		 6156 {
6157 /* In case of three-arg dup open remove strictness
6158 * from the last arg if it is a bareword. */
551405c4
AL		 6159 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6160 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 6161 OP *oa;
b15aece3 6162 const char *mode;
3b82e551
JH		 6163
6164 if ((last->op_type == OP_CONST) && /* The bareword. */
6165 (last->op_private & OPpCONST_BARE) &&
6166 (last->op_private & OPpCONST_STRICT) &&
6167 (oa = first->op_sibling) && /* The fh. */
6168 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 6169 (oa->op_type == OP_CONST) &&
3b82e551 6170 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 6171 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 6172 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6173 (last == oa->op_sibling)) /* The bareword. */
6174 last->op_private &= ~OPpCONST_STRICT;
6175 }
16fe6d59
GS		 6176 return ck_fun(o);
6177}
6178
6179OP *
cea2e8a9 6180Perl_ck_repeat(pTHX_ OP *o)
79072805 6181{
11343788
MB		 6182 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6183 o->op_private |= OPpREPEAT_DOLIST;
6184 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6185 }
6186 else
11343788
MB		 6187 scalar(o);
6188 return o;
79072805
LW		 6189}
6190
6191OP *
cea2e8a9 6192Perl_ck_require(pTHX_ OP *o)
8990e307 6193{
97aff369 6194 dVAR;
a72a1c8b 6195 GV* gv = Nullgv;
ec4ab249 6196
11343788 6197 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 6198 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6199
6200 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6201 SV * const sv = kid->op_sv;
5c144d81 6202 U32 was_readonly = SvREADONLY(sv);
8990e307 6203 char *s;
5c144d81
NC		 6204
6205 if (was_readonly) {
6206 if (SvFAKE(sv)) {
6207 sv_force_normal_flags(sv, 0);
6208 assert(!SvREADONLY(sv));
6209 was_readonly = 0;
6210 } else {
6211 SvREADONLY_off(sv);
6212 }
6213 }
6214
6215 for (s = SvPVX(sv); *s; s++) {
a0d0e21e 6216 if (*s == ':' && s[1] == ':') {
42d9b98d 6217 const STRLEN len = strlen(s+2)+1;
a0d0e21e 6218 *s = '/';
42d9b98d 6219 Move(s+2, s+1, len, char);
5c144d81 6220 SvCUR_set(sv, SvCUR(sv) - 1);
a0d0e21e 6221 }
8990e307 6222 }
396482e1 6223 sv_catpvs(sv, ".pm");
5c144d81 6224 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 6225 }
6226 }
ec4ab249 6227
a72a1c8b
RGS		 6228 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6229 /* handle override, if any */
f776e3cd 6230 gv = gv_fetchpv("require", 0, SVt_PVCV);
d6a985f2 6231 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 6232 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
551405c4 6233 gv = gvp ? *gvp : Nullgv;
d6a985f2 6234 }
a72a1c8b 6235 }
ec4ab249 6236
b9f751c0 6237 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 6238 OP * const kid = cUNOPo->op_first;
ec4ab249
GA		 6239 cUNOPo->op_first = 0;
6240 op_free(o);
6241 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6242 append_elem(OP_LIST, kid,
6243 scalar(newUNOP(OP_RV2CV, 0,
6244 newGVOP(OP_GV, 0,
6245 gv))))));
6246 }
6247
11343788 6248 return ck_fun(o);
8990e307
LW		 6249}
6250
78f9721b
SM		 6251OP *
6252Perl_ck_return(pTHX_ OP *o)
6253{
97aff369 6254 dVAR;
78f9721b 6255 if (CvLVALUE(PL_compcv)) {
6867be6d 6256 OP *kid;
78f9721b
SM		 6257 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6258 mod(kid, OP_LEAVESUBLV);
6259 }
6260 return o;
6261}
6262
79072805 6263OP *
cea2e8a9 6264Perl_ck_select(pTHX_ OP *o)
79072805 6265{
27da23d5 6266 dVAR;
c07a80fd 6267 OP* kid;
11343788
MB		 6268 if (o->op_flags & OPf_KIDS) {
6269 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6270 if (kid && kid->op_sibling) {
11343788 6271 o->op_type = OP_SSELECT;
22c35a8c 6272 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6273 o = ck_fun(o);
6274 return fold_constants(o);
79072805
LW		 6275 }
6276 }
11343788
MB		 6277 o = ck_fun(o);
6278 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6279 if (kid && kid->op_type == OP_RV2GV)
6280 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6281 return o;
79072805
LW		 6282}
6283
6284OP *
cea2e8a9 6285Perl_ck_shift(pTHX_ OP *o)
79072805 6286{
97aff369 6287 dVAR;
6867be6d 6288 const I32 type = o->op_type;
79072805 6289
11343788 6290 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 6291 OP *argop;
b2ffa427 6292
11343788 6293 op_free(o);
6d4ff0d2 6294 argop = newUNOP(OP_RV2AV, 0,
8fde6460 6295 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 6296 return newUNOP(type, 0, scalar(argop));
79072805 6297 }
11343788 6298 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6299}
6300
6301OP *
cea2e8a9 6302Perl_ck_sort(pTHX_ OP *o)
79072805 6303{
97aff369 6304 dVAR;
8e3f9bdf 6305 OP *firstkid;
bbce6d69 6306
7b9ef140
RH		 6307 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6308 {
a4fc7abc 6309 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 6310 if (hinthv) {
a4fc7abc 6311 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 6312 if (svp) {
a4fc7abc 6313 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 6314 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6315 o->op_private |= OPpSORT_QSORT;
6316 if ((sorthints & HINT_SORT_STABLE) != 0)
6317 o->op_private |= OPpSORT_STABLE;
6318 }
6319 }
6320 }
6321
9ea6e965 6322 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6323 simplify_sort(o);
8e3f9bdf
GS		 6324 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6325 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 6326 OP *k = NULL;
8e3f9bdf 6327 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6328
463ee0b2 6329 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6330 linklist(kid);
463ee0b2
LW		 6331 if (kid->op_type == OP_SCOPE) {
6332 k = kid->op_next;
6333 kid->op_next = 0;
79072805 6334 }
463ee0b2 6335 else if (kid->op_type == OP_LEAVE) {
11343788 6336 if (o->op_type == OP_SORT) {
93c66552 6337 op_null(kid); /* wipe out leave */
748a9306 6338 kid->op_next = kid;
463ee0b2 6339
748a9306
LW		 6340 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6341 if (k->op_next == kid)
6342 k->op_next = 0;
71a29c3c
GS		 6343 /* don't descend into loops */
6344 else if (k->op_type == OP_ENTERLOOP
6345 || k->op_type == OP_ENTERITER)
6346 {
6347 k = cLOOPx(k)->op_lastop;
6348 }
748a9306 6349 }
463ee0b2 6350 }
748a9306
LW		 6351 else
6352 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6353 k = kLISTOP->op_first;
463ee0b2 6354 }
a2efc822 6355 CALL_PEEP(k);
a0d0e21e 6356
8e3f9bdf
GS		 6357 kid = firstkid;
6358 if (o->op_type == OP_SORT) {
6359 /* provide scalar context for comparison function/block */
6360 kid = scalar(kid);
a0d0e21e 6361 kid->op_next = kid;
8e3f9bdf 6362 }
a0d0e21e
LW		 6363 else
6364 kid->op_next = k;
11343788 6365 o->op_flags |= OPf_SPECIAL;
79072805 6366 }
c6e96bcb 6367 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6368 op_null(firstkid);
8e3f9bdf
GS		 6369
6370 firstkid = firstkid->op_sibling;
79072805 6371 }
bbce6d69 6372
8e3f9bdf
GS		 6373 /* provide list context for arguments */
6374 if (o->op_type == OP_SORT)
6375 list(firstkid);
6376
11343788 6377 return o;
79072805 6378}
bda4119b
GS		 6379
6380STATIC void
cea2e8a9 6381S_simplify_sort(pTHX_ OP *o)
9c007264 6382{
97aff369 6383 dVAR;
9c007264
JH		 6384 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6385 OP *k;
eb209983 6386 int descending;
350de78d 6387 GV *gv;
770526c1 6388 const char *gvname;
9c007264
JH		 6389 if (!(o->op_flags & OPf_STACKED))
6390 return;
f776e3cd
NC		 6391 GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6392 GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
82092f1d 6393 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6394 if (kid->op_type != OP_SCOPE)
6395 return;
6396 kid = kLISTOP->op_last; /* get past scope */
6397 switch(kid->op_type) {
6398 case OP_NCMP:
6399 case OP_I_NCMP:
6400 case OP_SCMP:
6401 break;
6402 default:
6403 return;
6404 }
6405 k = kid; /* remember this node*/
6406 if (kBINOP->op_first->op_type != OP_RV2SV)
6407 return;
6408 kid = kBINOP->op_first; /* get past cmp */
6409 if (kUNOP->op_first->op_type != OP_GV)
6410 return;
6411 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6412 gv = kGVOP_gv;
350de78d 6413 if (GvSTASH(gv) != PL_curstash)
9c007264 6414 return;
770526c1
NC		 6415 gvname = GvNAME(gv);
6416 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 6417 descending = 0;
770526c1 6418 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 6419 descending = 1;
9c007264
JH		 6420 else
6421 return;
eb209983 6422
9c007264
JH		 6423 kid = k; /* back to cmp */
6424 if (kBINOP->op_last->op_type != OP_RV2SV)
6425 return;
6426 kid = kBINOP->op_last; /* down to 2nd arg */
6427 if (kUNOP->op_first->op_type != OP_GV)
6428 return;
6429 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6430 gv = kGVOP_gv;
770526c1
NC		 6431 if (GvSTASH(gv) != PL_curstash)
6432 return;
6433 gvname = GvNAME(gv);
6434 if ( descending
6435 ? !(*gvname == 'a' && gvname[1] == '\0')
6436 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 6437 return;
6438 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 6439 if (descending)
6440 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 6441 if (k->op_type == OP_NCMP)
6442 o->op_private |= OPpSORT_NUMERIC;
6443 if (k->op_type == OP_I_NCMP)
6444 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6445 kid = cLISTOPo->op_first->op_sibling;
6446 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6447 op_free(kid); /* then delete it */
9c007264 6448}
79072805
LW		 6449
6450OP *
cea2e8a9 6451Perl_ck_split(pTHX_ OP *o)
79072805 6452{
27da23d5 6453 dVAR;
79072805 6454 register OP *kid;
aeea060c 6455
11343788
MB		 6456 if (o->op_flags & OPf_STACKED)
6457 return no_fh_allowed(o);
79072805 6458
11343788 6459 kid = cLISTOPo->op_first;
8990e307 6460 if (kid->op_type != OP_NULL)
cea2e8a9 6461 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6462 kid = kid->op_sibling;
11343788
MB		 6463 op_free(cLISTOPo->op_first);
6464 cLISTOPo->op_first = kid;
85e6fe83 6465 if (!kid) {
396482e1 6466 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 6467 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6468 }
79072805 6469
de4bf5b3 6470 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 6471 OP * const sibl = kid->op_sibling;
463ee0b2 6472 kid->op_sibling = 0;
131b3ad0 6473 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 6474 if (cLISTOPo->op_first == cLISTOPo->op_last)
6475 cLISTOPo->op_last = kid;
6476 cLISTOPo->op_first = kid;
79072805
LW		 6477 kid->op_sibling = sibl;
6478 }
6479
6480 kid->op_type = OP_PUSHRE;
22c35a8c 6481 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 6482 scalar(kid);
041457d9 6483 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 6484 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6485 "Use of /g modifier is meaningless in split");
6486 }
79072805
LW		 6487
6488 if (!kid->op_sibling)
54b9620d 6489 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6490
6491 kid = kid->op_sibling;
6492 scalar(kid);
6493
6494 if (!kid->op_sibling)
11343788 6495 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6496
6497 kid = kid->op_sibling;
6498 scalar(kid);
6499
6500 if (kid->op_sibling)
53e06cf0 6501 return too_many_arguments(o,OP_DESC(o));
79072805 6502
11343788 6503 return o;
79072805
LW		 6504}
6505
6506OP *
1c846c1f 6507Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 6508{
551405c4 6509 const OP * const kid = cLISTOPo->op_first->op_sibling;
041457d9
DM		 6510 if (kid && kid->op_type == OP_MATCH) {
6511 if (ckWARN(WARN_SYNTAX)) {
6867be6d
AL		 6512 const REGEXP *re = PM_GETRE(kPMOP);
6513 const char *pmstr = re ? re->precomp : "STRING";
9014280d 6514 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 6515 "/%s/ should probably be written as \"%s\"",
6516 pmstr, pmstr);
6517 }
6518 }
6519 return ck_fun(o);
6520}
6521
6522OP *
cea2e8a9 6523Perl_ck_subr(pTHX_ OP *o)
79072805 6524{
97aff369 6525 dVAR;
11343788
MB		 6526 OP *prev = ((cUNOPo->op_first->op_sibling)
6527 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6528 OP *o2 = prev->op_sibling;
4633a7c4 6529 OP *cvop;
c445ea15
AL		 6530 char *proto = NULL;
6531 CV *cv = NULL;
6532 GV *namegv = NULL;
4633a7c4
LW		 6533 int optional = 0;
6534 I32 arg = 0;
5b794e05 6535 I32 contextclass = 0;
c445ea15 6536 char *e = NULL;
0723351e 6537 bool delete_op = 0;
4633a7c4 6538
d3011074 6539 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6540 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6541 if (cvop->op_type == OP_RV2CV) {
6542 SVOP* tmpop;
11343788 6543 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6544 op_null(cvop); /* disable rv2cv */
4633a7c4 6545 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6546 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6547 GV *gv = cGVOPx_gv(tmpop);
350de78d 6548 cv = GvCVu(gv);
76cd736e
GS		 6549 if (!cv)
6550 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 6551 else {
6552 if (SvPOK(cv)) {
6553 namegv = CvANON(cv) ? gv : CvGV(cv);
8b6b16e7 6554 proto = SvPV_nolen((SV*)cv);
06492da6
SF		 6555 }
6556 if (CvASSERTION(cv)) {
6557 if (PL_hints & HINT_ASSERTING) {
6558 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6559 o->op_private |= OPpENTERSUB_DB;
6560 }
8fa7688f 6561 else {
0723351e 6562 delete_op = 1;
041457d9 6563 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
8fa7688f
SF		 6564 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6565 "Impossible to activate assertion call");
6566 }
6567 }
06492da6 6568 }
46fc3d4c 6569 }
4633a7c4
LW		 6570 }
6571 }
f5d5a27c 6572 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6573 if (o2->op_type == OP_CONST)
6574 o2->op_private &= ~OPpCONST_STRICT;
58a40671 6575 else if (o2->op_type == OP_LIST) {
551405c4 6576 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
58a40671
GS		 6577 if (o && o->op_type == OP_CONST)
6578 o->op_private &= ~OPpCONST_STRICT;
6579 }
7a52d87a 6580 }
3280af22
NIS		 6581 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6582 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6583 o->op_private |= OPpENTERSUB_DB;
6584 while (o2 != cvop) {
4633a7c4
LW		 6585 if (proto) {
6586 switch (*proto) {
6587 case '\0':
5dc0d613 6588 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6589 case ';':
6590 optional = 1;
6591 proto++;
6592 continue;
6593 case '$':
6594 proto++;
6595 arg++;
11343788 6596 scalar(o2);
4633a7c4
LW		 6597 break;
6598 case '%':
6599 case '@':
11343788 6600 list(o2);
4633a7c4
LW		 6601 arg++;
6602 break;
6603 case '&':
6604 proto++;
6605 arg++;
11343788 6606 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6607 bad_type(arg,
6608 arg == 1 ? "block or sub {}" : "sub {}",
6609 gv_ename(namegv), o2);
4633a7c4
LW		 6610 break;
6611 case '*':
2ba6ecf4 6612 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6613 proto++;
6614 arg++;
11343788 6615 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6616 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6617 else if (o2->op_type == OP_CONST)
6618 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6619 else if (o2->op_type == OP_ENTERSUB) {
6620 /* accidental subroutine, revert to bareword */
6621 OP *gvop = ((UNOP*)o2)->op_first;
6622 if (gvop && gvop->op_type == OP_NULL) {
6623 gvop = ((UNOP*)gvop)->op_first;
6624 if (gvop) {
6625 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6626 ;
6627 if (gvop &&
6628 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6629 (gvop = ((UNOP*)gvop)->op_first) &&
6630 gvop->op_type == OP_GV)
6631 {
551405c4
AL		 6632 GV * const gv = cGVOPx_gv(gvop);
6633 OP * const sibling = o2->op_sibling;
396482e1 6634 SV * const n = newSVpvs("");
9675f7ac 6635 op_free(o2);
2a797ae2 6636 gv_fullname4(n, gv, "", FALSE);
2692f720 6637 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6638 prev->op_sibling = o2;
6639 o2->op_sibling = sibling;
6640 }
6641 }
6642 }
6643 }
2ba6ecf4
GS		 6644 scalar(o2);
6645 break;
5b794e05
JH		 6646 case '[': case ']':
6647 goto oops;
6648 break;
4633a7c4
LW		 6649 case '\\':
6650 proto++;
6651 arg++;
5b794e05 6652 again:
4633a7c4 6653 switch (*proto++) {
5b794e05
JH		 6654 case '[':
6655 if (contextclass++ == 0) {
841d93c8 6656 e = strchr(proto, ']');
5b794e05
JH		 6657 if (!e || e == proto)
6658 goto oops;
6659 }
6660 else
6661 goto oops;
6662 goto again;
6663 break;
6664 case ']':
466bafcd 6665 if (contextclass) {
0bd48802 6666 /* XXX We shouldn't be modifying proto, so we can const proto */
6867be6d
AL		 6667 char *p = proto;
6668 const char s = *p;
466bafcd
RGS		 6669 contextclass = 0;
6670 *p = '\0';
6671 while (*--p != '[');
1eb1540c 6672 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6673 gv_ename(namegv), o2);
6674 *proto = s;
6675 } else
5b794e05
JH		 6676 goto oops;
6677 break;
4633a7c4 6678 case '*':
5b794e05
JH		 6679 if (o2->op_type == OP_RV2GV)
6680 goto wrapref;
6681 if (!contextclass)
6682 bad_type(arg, "symbol", gv_ename(namegv), o2);
6683 break;
4633a7c4 6684 case '&':
5b794e05
JH		 6685 if (o2->op_type == OP_ENTERSUB)
6686 goto wrapref;
6687 if (!contextclass)
6688 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6689 break;
4633a7c4 6690 case '$':
5b794e05
JH		 6691 if (o2->op_type == OP_RV2SV ||
6692 o2->op_type == OP_PADSV ||
6693 o2->op_type == OP_HELEM ||
6694 o2->op_type == OP_AELEM ||
6695 o2->op_type == OP_THREADSV)
6696 goto wrapref;
6697 if (!contextclass)
5dc0d613 6698 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6699 break;
4633a7c4 6700 case '@':
5b794e05
JH		 6701 if (o2->op_type == OP_RV2AV ||
6702 o2->op_type == OP_PADAV)
6703 goto wrapref;
6704 if (!contextclass)
5dc0d613 6705 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6706 break;
4633a7c4 6707 case '%':
5b794e05
JH		 6708 if (o2->op_type == OP_RV2HV ||
6709 o2->op_type == OP_PADHV)
6710 goto wrapref;
6711 if (!contextclass)
6712 bad_type(arg, "hash", gv_ename(namegv), o2);
6713 break;
6714 wrapref:
4633a7c4 6715 {
551405c4
AL		 6716 OP* const kid = o2;
6717 OP* const sib = kid->op_sibling;
4633a7c4 6718 kid->op_sibling = 0;
6fa846a0
GS		 6719 o2 = newUNOP(OP_REFGEN, 0, kid);
6720 o2->op_sibling = sib;
e858de61 6721 prev->op_sibling = o2;
4633a7c4 6722 }
841d93c8 6723 if (contextclass && e) {
5b794e05
JH		 6724 proto = e + 1;
6725 contextclass = 0;
6726 }
4633a7c4
LW		 6727 break;
6728 default: goto oops;
6729 }
5b794e05
JH		 6730 if (contextclass)
6731 goto again;
4633a7c4 6732 break;
b1cb66bf 6733 case ' ':
6734 proto++;
6735 continue;
4633a7c4
LW		 6736 default:
6737 oops:
35c1215d
NC		 6738 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6739 gv_ename(namegv), cv);
4633a7c4
LW		 6740 }
6741 }
6742 else
11343788
MB		 6743 list(o2);
6744 mod(o2, OP_ENTERSUB);
6745 prev = o2;
6746 o2 = o2->op_sibling;
551405c4 6747 } /* while */
fb73857a 6748 if (proto && !optional &&
6749 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6750 return too_few_arguments(o, gv_ename(namegv));
0723351e 6751 if(delete_op) {
06492da6
SF		 6752 op_free(o);
6753 o=newSVOP(OP_CONST, 0, newSViv(0));
6754 }
11343788 6755 return o;
79072805
LW		 6756}
6757
6758OP *
cea2e8a9 6759Perl_ck_svconst(pTHX_ OP *o)
8990e307 6760{
11343788
MB		 6761 SvREADONLY_on(cSVOPo->op_sv);
6762 return o;
8990e307
LW		 6763}
6764
6765OP *
cea2e8a9 6766Perl_ck_trunc(pTHX_ OP *o)
79072805 6767{
11343788
MB		 6768 if (o->op_flags & OPf_KIDS) {
6769 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6770
a0d0e21e
LW		 6771 if (kid->op_type == OP_NULL)
6772 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6773 if (kid && kid->op_type == OP_CONST &&
6774 (kid->op_private & OPpCONST_BARE))
6775 {
11343788 6776 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6777 kid->op_private &= ~OPpCONST_STRICT;
6778 }
79072805 6779 }
11343788 6780 return ck_fun(o);
79072805
LW		 6781}
6782
35fba0d9 6783OP *
bab9c0ac
RGS		 6784Perl_ck_unpack(pTHX_ OP *o)
6785{
6786 OP *kid = cLISTOPo->op_first;
6787 if (kid->op_sibling) {
6788 kid = kid->op_sibling;
6789 if (!kid->op_sibling)
6790 kid->op_sibling = newDEFSVOP();
6791 }
6792 return ck_fun(o);
6793}
6794
6795OP *
35fba0d9
RG		 6796Perl_ck_substr(pTHX_ OP *o)
6797{
6798 o = ck_fun(o);
6799 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6800 OP *kid = cLISTOPo->op_first;
6801
6802 if (kid->op_type == OP_NULL)
6803 kid = kid->op_sibling;
6804 if (kid)
6805 kid->op_flags |= OPf_MOD;
6806
6807 }
6808 return o;
6809}
6810
61b743bb
DM		 6811/* A peephole optimizer. We visit the ops in the order they're to execute.
6812 * See the comments at the top of this file for more details about when
6813 * peep() is called */
463ee0b2 6814
79072805 6815void
864dbfa3 6816Perl_peep(pTHX_ register OP *o)
79072805 6817{
27da23d5 6818 dVAR;
c445ea15 6819 register OP* oldop = NULL;
2d8e6c8d 6820
2814eb74 6821 if (!o || o->op_opt)
79072805 6822 return;
a0d0e21e 6823 ENTER;
462e5cf6 6824 SAVEOP();
7766f137 6825 SAVEVPTR(PL_curcop);
a0d0e21e 6826 for (; o; o = o->op_next) {
2814eb74 6827 if (o->op_opt)
a0d0e21e 6828 break;
533c011a 6829 PL_op = o;
a0d0e21e 6830 switch (o->op_type) {
acb36ea4 6831 case OP_SETSTATE:
a0d0e21e
LW		 6832 case OP_NEXTSTATE:
6833 case OP_DBSTATE:
3280af22 6834 PL_curcop = ((COP*)o); /* for warnings */
2814eb74 6835 o->op_opt = 1;
a0d0e21e
LW		 6836 break;
6837
a0d0e21e 6838 case OP_CONST:
7a52d87a
GS		 6839 if (cSVOPo->op_private & OPpCONST_STRICT)
6840 no_bareword_allowed(o);
7766f137 6841#ifdef USE_ITHREADS
3848b962 6842 case OP_METHOD_NAMED:
7766f137
GS		 6843 /* Relocate sv to the pad for thread safety.
6844 * Despite being a "constant", the SV is written to,
6845 * for reference counts, sv_upgrade() etc. */
6846 if (cSVOP->op_sv) {
6867be6d 6847 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6848 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6849 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6850 * some pad, so make a copy. */
dd2155a4
DM		 6851 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6852 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6853 SvREFCNT_dec(cSVOPo->op_sv);
6854 }
052ca17e
NC		 6855 else if (o->op_type == OP_CONST
6856 && cSVOPo->op_sv == &PL_sv_undef) {
6857 /* PL_sv_undef is hack - it's unsafe to store it in the
6858 AV that is the pad, because av_fetch treats values of
6859 PL_sv_undef as a "free" AV entry and will merrily
6860 replace them with a new SV, causing pad_alloc to think
6861 that this pad slot is free. (When, clearly, it is not)
6862 */
6863 SvOK_off(PAD_SVl(ix));
6864 SvPADTMP_on(PAD_SVl(ix));
6865 SvREADONLY_on(PAD_SVl(ix));
6866 }
6a7129a1 6867 else {
dd2155a4 6868 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6869 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6870 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6871 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6872 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6873 }
7766f137
GS		 6874 cSVOPo->op_sv = Nullsv;
6875 o->op_targ = ix;
6876 }
6877#endif
2814eb74 6878 o->op_opt = 1;
07447971
GS		 6879 break;
6880
df91b2c5
AE		 6881 case OP_CONCAT:
6882 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6883 if (o->op_next->op_private & OPpTARGET_MY) {
6884 if (o->op_flags & OPf_STACKED) /* chained concats */
6885 goto ignore_optimization;
6886 else {
6887 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6888 o->op_targ = o->op_next->op_targ;
6889 o->op_next->op_targ = 0;
6890 o->op_private |= OPpTARGET_MY;
6891 }
6892 }
6893 op_null(o->op_next);
6894 }
6895 ignore_optimization:
2814eb74 6896 o->op_opt = 1;
df91b2c5 6897 break;
8990e307 6898 case OP_STUB:
54310121 6899 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
2814eb74 6900 o->op_opt = 1;
54310121 6901 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6902 }
748a9306 6903 goto nothin;
79072805 6904 case OP_NULL:
acb36ea4
GS		 6905 if (o->op_targ == OP_NEXTSTATE
6906 || o->op_targ == OP_DBSTATE
6907 || o->op_targ == OP_SETSTATE)
6908 {
3280af22 6909 PL_curcop = ((COP*)o);
acb36ea4 6910 }
dad75012
AMS		 6911 /* XXX: We avoid setting op_seq here to prevent later calls
6912 to peep() from mistakenly concluding that optimisation
6913 has already occurred. This doesn't fix the real problem,
6914 though (See 20010220.007). AMS 20010719 */
2814eb74 6915 /* op_seq functionality is now replaced by op_opt */
dad75012
AMS		 6916 if (oldop && o->op_next) {
6917 oldop->op_next = o->op_next;
6918 continue;
6919 }
6920 break;
79072805 6921 case OP_SCALAR:
93a17b20 6922 case OP_LINESEQ:
463ee0b2 6923 case OP_SCOPE:
748a9306 6924 nothin:
a0d0e21e
LW		 6925 if (oldop && o->op_next) {
6926 oldop->op_next = o->op_next;
79072805
LW		 6927 continue;
6928 }
2814eb74 6929 o->op_opt = 1;
79072805
LW		 6930 break;
6931
6a077020 6932 case OP_PADAV:
79072805 6933 case OP_GV:
6a077020 6934 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 6935 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 6936 o->op_next : o->op_next->op_next;
a0d0e21e 6937 IV i;
f9dc862f 6938 if (pop && pop->op_type == OP_CONST &&
af5acbb4 6939 ((PL_op = pop->op_next)) &&
8990e307 6940 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6941 !(pop->op_next->op_private &
78f9721b 6942 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6943 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6944 <= 255 &&
8990e307
LW		 6945 i >= 0)
6946 {
350de78d 6947 GV *gv;
af5acbb4
DM		 6948 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6949 no_bareword_allowed(pop);
6a077020
DM		 6950 if (o->op_type == OP_GV)
6951 op_null(o->op_next);
93c66552
DM		 6952 op_null(pop->op_next);
6953 op_null(pop);
a0d0e21e
LW		 6954 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6955 o->op_next = pop->op_next->op_next;
22c35a8c 6956 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6957 o->op_private = (U8)i;
6a077020
DM		 6958 if (o->op_type == OP_GV) {
6959 gv = cGVOPo_gv;
6960 GvAVn(gv);
6961 }
6962 else
6963 o->op_flags |= OPf_SPECIAL;
6964 o->op_type = OP_AELEMFAST;
6965 }
6966 o->op_opt = 1;
6967 break;
6968 }
6969
6970 if (o->op_next->op_type == OP_RV2SV) {
6971 if (!(o->op_next->op_private & OPpDEREF)) {
6972 op_null(o->op_next);
6973 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6974 | OPpOUR_INTRO);
6975 o->op_next = o->op_next->op_next;
6976 o->op_type = OP_GVSV;
6977 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 6978 }
79072805 6979 }
e476b1b5 6980 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 6981 GV * const gv = cGVOPo_gv;
b15aece3 6982 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 6983 /* XXX could check prototype here instead of just carping */
551405c4 6984 SV * const sv = sv_newmortal();
76cd736e 6985 gv_efullname3(sv, gv, Nullch);
9014280d 6986 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6987 "%"SVf"() called too early to check prototype",
6988 sv);
76cd736e
GS		 6989 }
6990 }
89de2904
AMS		 6991 else if (o->op_next->op_type == OP_READLINE
6992 && o->op_next->op_next->op_type == OP_CONCAT
6993 && (o->op_next->op_next->op_flags & OPf_STACKED))
6994 {
d2c45030
AMS		 6995 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6996 o->op_type = OP_RCATLINE;
6997 o->op_flags |= OPf_STACKED;
6998 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6999 op_null(o->op_next->op_next);
d2c45030 7000 op_null(o->op_next);
89de2904 7001 }
76cd736e 7002
2814eb74 7003 o->op_opt = 1;
79072805
LW		 7004 break;
7005
a0d0e21e 7006 case OP_MAPWHILE:
79072805
LW		 7007 case OP_GREPWHILE:
7008 case OP_AND:
7009 case OP_OR:
c963b151 7010 case OP_DOR:
2c2d71f5
JH		 7011 case OP_ANDASSIGN:
7012 case OP_ORASSIGN:
c963b151 7013 case OP_DORASSIGN:
1a67a97c
SM		 7014 case OP_COND_EXPR:
7015 case OP_RANGE:
2814eb74 7016 o->op_opt = 1;
fd4d1407
IZ		 7017 while (cLOGOP->op_other->op_type == OP_NULL)
7018 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 7019 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 7020 break;
7021
79072805 7022 case OP_ENTERLOOP:
9c2ca71a 7023 case OP_ENTERITER:
2814eb74 7024 o->op_opt = 1;
58cccf98
SM		 7025 while (cLOOP->op_redoop->op_type == OP_NULL)
7026 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 7027 peep(cLOOP->op_redoop);
58cccf98
SM		 7028 while (cLOOP->op_nextop->op_type == OP_NULL)
7029 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 7030 peep(cLOOP->op_nextop);
58cccf98
SM		 7031 while (cLOOP->op_lastop->op_type == OP_NULL)
7032 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 7033 peep(cLOOP->op_lastop);
7034 break;
7035
8782bef2 7036 case OP_QR:
79072805
LW		 7037 case OP_MATCH:
7038 case OP_SUBST:
2814eb74 7039 o->op_opt = 1;
9041c2e3 7040 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 7041 cPMOP->op_pmreplstart->op_type == OP_NULL)
7042 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 7043 peep(cPMOP->op_pmreplstart);
79072805
LW		 7044 break;
7045
a0d0e21e 7046 case OP_EXEC:
2814eb74 7047 o->op_opt = 1;
041457d9
DM		 7048 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7049 && ckWARN(WARN_SYNTAX))
7050 {
a0d0e21e 7051 if (o->op_next->op_sibling &&
20408e3c
GS		 7052 o->op_next->op_sibling->op_type != OP_EXIT &&
7053 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 7054 o->op_next->op_sibling->op_type != OP_DIE) {
6867be6d 7055 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 7056
57843af0 7057 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 7058 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 7059 "Statement unlikely to be reached");
9014280d 7060 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 7061 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 7062 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 7063 }
7064 }
7065 break;
b2ffa427 7066
c750a3ec 7067 case OP_HELEM: {
e75d1f10 7068 UNOP *rop;
6d822dc4 7069 SV *lexname;
e75d1f10 7070 GV **fields;
6d822dc4 7071 SV **svp, *sv;
d5263905 7072 const char *key = NULL;
c750a3ec 7073 STRLEN keylen;
b2ffa427 7074
2814eb74 7075 o->op_opt = 1;
1c846c1f
NIS		 7076
7077 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 7078 break;
1c846c1f
NIS		 7079
7080 /* Make the CONST have a shared SV */
7081 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 7082 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
d5263905 7083 key = SvPV_const(sv, keylen);
25716404
GS		 7084 lexname = newSVpvn_share(key,
7085 SvUTF8(sv) ? -(I32)keylen : keylen,
7086 0);
1c846c1f
NIS		 7087 SvREFCNT_dec(sv);
7088 *svp = lexname;
7089 }
e75d1f10
RD		 7090
7091 if ((o->op_private & (OPpLVAL_INTRO)))
7092 break;
7093
7094 rop = (UNOP*)((BINOP*)o)->op_first;
7095 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7096 break;
7097 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7098 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7099 break;
a4fc7abc 7100 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 7101 if (!fields || !GvHV(*fields))
7102 break;
93524f2b 7103 key = SvPV_const(*svp, keylen);
e75d1f10
RD		 7104 if (!hv_fetch(GvHV(*fields), key,
7105 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7106 {
7107 Perl_croak(aTHX_ "No such class field \"%s\" "
7108 "in variable %s of type %s",
93524f2b 7109 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 7110 }
7111
6d822dc4
MS		 7112 break;
7113 }
c750a3ec 7114
e75d1f10
RD		 7115 case OP_HSLICE: {
7116 UNOP *rop;
7117 SV *lexname;
7118 GV **fields;
7119 SV **svp;
93524f2b 7120 const char *key;
e75d1f10
RD		 7121 STRLEN keylen;
7122 SVOP *first_key_op, *key_op;
7123
7124 if ((o->op_private & (OPpLVAL_INTRO))
7125 /* I bet there's always a pushmark... */
7126 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7127 /* hmmm, no optimization if list contains only one key. */
7128 break;
7129 rop = (UNOP*)((LISTOP*)o)->op_last;
7130 if (rop->op_type != OP_RV2HV)
7131 break;
7132 if (rop->op_first->op_type == OP_PADSV)
7133 /* @$hash{qw(keys here)} */
7134 rop = (UNOP*)rop->op_first;
7135 else {
7136 /* @{$hash}{qw(keys here)} */
7137 if (rop->op_first->op_type == OP_SCOPE
7138 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7139 {
7140 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7141 }
7142 else
7143 break;
7144 }
7145
7146 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7147 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7148 break;
a4fc7abc 7149 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 7150 if (!fields || !GvHV(*fields))
7151 break;
7152 /* Again guessing that the pushmark can be jumped over.... */
7153 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7154 ->op_first->op_sibling;
7155 for (key_op = first_key_op; key_op;
7156 key_op = (SVOP*)key_op->op_sibling) {
7157 if (key_op->op_type != OP_CONST)
7158 continue;
7159 svp = cSVOPx_svp(key_op);
93524f2b 7160 key = SvPV_const(*svp, keylen);
e75d1f10
RD		 7161 if (!hv_fetch(GvHV(*fields), key,
7162 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7163 {
7164 Perl_croak(aTHX_ "No such class field \"%s\" "
7165 "in variable %s of type %s",
bfcb3514 7166 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 7167 }
7168 }
7169 break;
7170 }
7171
fe1bc4cf 7172 case OP_SORT: {
fe1bc4cf 7173 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 7174 OP *oleft;
fe1bc4cf
DM		 7175 OP *o2;
7176
fe1bc4cf 7177 /* check that RHS of sort is a single plain array */
551405c4 7178 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 7179 if (!oright || oright->op_type != OP_PUSHMARK)
7180 break;
471178c0
NC		 7181
7182 /* reverse sort ... can be optimised. */
7183 if (!cUNOPo->op_sibling) {
7184 /* Nothing follows us on the list. */
551405c4 7185 OP * const reverse = o->op_next;
471178c0
NC		 7186
7187 if (reverse->op_type == OP_REVERSE &&
7188 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 7189 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 7190 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7191 && (cUNOPx(pushmark)->op_sibling == o)) {
7192 /* reverse -> pushmark -> sort */
7193 o->op_private |= OPpSORT_REVERSE;
7194 op_null(reverse);
7195 pushmark->op_next = oright->op_next;
7196 op_null(oright);
7197 }
7198 }
7199 }
7200
7201 /* make @a = sort @a act in-place */
7202
7203 o->op_opt = 1;
7204
fe1bc4cf
DM		 7205 oright = cUNOPx(oright)->op_sibling;
7206 if (!oright)
7207 break;
7208 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7209 oright = cUNOPx(oright)->op_sibling;
7210 }
7211
7212 if (!oright ||
7213 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7214 || oright->op_next != o
7215 || (oright->op_private & OPpLVAL_INTRO)
7216 )
7217 break;
7218
7219 /* o2 follows the chain of op_nexts through the LHS of the
7220 * assign (if any) to the aassign op itself */
7221 o2 = o->op_next;
7222 if (!o2 || o2->op_type != OP_NULL)
7223 break;
7224 o2 = o2->op_next;
7225 if (!o2 || o2->op_type != OP_PUSHMARK)
7226 break;
7227 o2 = o2->op_next;
7228 if (o2 && o2->op_type == OP_GV)
7229 o2 = o2->op_next;
7230 if (!o2
7231 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7232 || (o2->op_private & OPpLVAL_INTRO)
7233 )
7234 break;
7235 oleft = o2;
7236 o2 = o2->op_next;
7237 if (!o2 || o2->op_type != OP_NULL)
7238 break;
7239 o2 = o2->op_next;
7240 if (!o2 || o2->op_type != OP_AASSIGN
7241 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7242 break;
7243
db7511db
DM		 7244 /* check that the sort is the first arg on RHS of assign */
7245
7246 o2 = cUNOPx(o2)->op_first;
7247 if (!o2 || o2->op_type != OP_NULL)
7248 break;
7249 o2 = cUNOPx(o2)->op_first;
7250 if (!o2 || o2->op_type != OP_PUSHMARK)
7251 break;
7252 if (o2->op_sibling != o)
7253 break;
7254
fe1bc4cf
DM		 7255 /* check the array is the same on both sides */
7256 if (oleft->op_type == OP_RV2AV) {
7257 if (oright->op_type != OP_RV2AV
7258 || !cUNOPx(oright)->op_first
7259 || cUNOPx(oright)->op_first->op_type != OP_GV
7260 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7261 cGVOPx_gv(cUNOPx(oright)->op_first)
7262 )
7263 break;
7264 }
7265 else if (oright->op_type != OP_PADAV
7266 || oright->op_targ != oleft->op_targ
7267 )
7268 break;
7269
7270 /* transfer MODishness etc from LHS arg to RHS arg */
7271 oright->op_flags = oleft->op_flags;
7272 o->op_private |= OPpSORT_INPLACE;
7273
7274 /* excise push->gv->rv2av->null->aassign */
7275 o2 = o->op_next->op_next;
7276 op_null(o2); /* PUSHMARK */
7277 o2 = o2->op_next;
7278 if (o2->op_type == OP_GV) {
7279 op_null(o2); /* GV */
7280 o2 = o2->op_next;
7281 }
7282 op_null(o2); /* RV2AV or PADAV */
7283 o2 = o2->op_next->op_next;
7284 op_null(o2); /* AASSIGN */
7285
7286 o->op_next = o2->op_next;
7287
7288 break;
7289 }
ef3e5ea9
NC		 7290
7291 case OP_REVERSE: {
e682d7b7 7292 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 7293 OP *gvop = NULL;
ef3e5ea9
NC		 7294 LISTOP *enter, *exlist;
7295 o->op_opt = 1;
7296
7297 enter = (LISTOP *) o->op_next;
7298 if (!enter)
7299 break;
7300 if (enter->op_type == OP_NULL) {
7301 enter = (LISTOP *) enter->op_next;
7302 if (!enter)
7303 break;
7304 }
d46f46af
NC		 7305 /* for $a (...) will have OP_GV then OP_RV2GV here.
7306 for (...) just has an OP_GV. */
ce335f37
NC		 7307 if (enter->op_type == OP_GV) {
7308 gvop = (OP *) enter;
7309 enter = (LISTOP *) enter->op_next;
7310 if (!enter)
7311 break;
d46f46af
NC		 7312 if (enter->op_type == OP_RV2GV) {
7313 enter = (LISTOP *) enter->op_next;
7314 if (!enter)
ce335f37 7315 break;
d46f46af 7316 }
ce335f37
NC		 7317 }
7318
ef3e5ea9
NC		 7319 if (enter->op_type != OP_ENTERITER)
7320 break;
7321
7322 iter = enter->op_next;
7323 if (!iter || iter->op_type != OP_ITER)
7324 break;
7325
ce335f37
NC		 7326 expushmark = enter->op_first;
7327 if (!expushmark || expushmark->op_type != OP_NULL
7328 || expushmark->op_targ != OP_PUSHMARK)
7329 break;
7330
7331 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 7332 if (!exlist || exlist->op_type != OP_NULL
7333 || exlist->op_targ != OP_LIST)
7334 break;
7335
7336 if (exlist->op_last != o) {
7337 /* Mmm. Was expecting to point back to this op. */
7338 break;
7339 }
7340 theirmark = exlist->op_first;
7341 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7342 break;
7343
c491ecac 7344 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 7345 /* There's something between the mark and the reverse, eg
7346 for (1, reverse (...))
7347 so no go. */
7348 break;
7349 }
7350
c491ecac
NC		 7351 ourmark = ((LISTOP *)o)->op_first;
7352 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7353 break;
7354
ef3e5ea9
NC		 7355 ourlast = ((LISTOP *)o)->op_last;
7356 if (!ourlast || ourlast->op_next != o)
7357 break;
7358
e682d7b7
NC		 7359 rv2av = ourmark->op_sibling;
7360 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7361 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7362 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7363 /* We're just reversing a single array. */
7364 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7365 enter->op_flags |= OPf_STACKED;
7366 }
7367
ef3e5ea9
NC		 7368 /* We don't have control over who points to theirmark, so sacrifice
7369 ours. */
7370 theirmark->op_next = ourmark->op_next;
7371 theirmark->op_flags = ourmark->op_flags;
ce335f37 7372 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 7373 op_null(ourmark);
7374 op_null(o);
7375 enter->op_private |= OPpITER_REVERSED;
7376 iter->op_private |= OPpITER_REVERSED;
7377
7378 break;
7379 }
e26df76a
NC		 7380
7381 case OP_SASSIGN: {
7382 OP *rv2gv;
7383 UNOP *refgen, *rv2cv;
7384 LISTOP *exlist;
7385
7386 /* I do not understand this, but if o->op_opt isn't set to 1,
7387 various tests in ext/B/t/bytecode.t fail with no readily
7388 apparent cause. */
7389
7390 o->op_opt = 1;
7391
de3370bc
NC		 7392
7393 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7394 break;
7395
e26df76a
NC		 7396 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7397 break;
7398
7399 rv2gv = ((BINOP *)o)->op_last;
7400 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7401 break;
7402
7403 refgen = (UNOP *)((BINOP *)o)->op_first;
7404
7405 if (!refgen || refgen->op_type != OP_REFGEN)
7406 break;
7407
7408 exlist = (LISTOP *)refgen->op_first;
7409 if (!exlist || exlist->op_type != OP_NULL
7410 || exlist->op_targ != OP_LIST)
7411 break;
7412
7413 if (exlist->op_first->op_type != OP_PUSHMARK)
7414 break;
7415
7416 rv2cv = (UNOP*)exlist->op_last;
7417
7418 if (rv2cv->op_type != OP_RV2CV)
7419 break;
7420
7421 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7422 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7423 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7424
7425 o->op_private |= OPpASSIGN_CV_TO_GV;
7426 rv2gv->op_private |= OPpDONT_INIT_GV;
7427 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7428
7429 break;
7430 }
7431
fe1bc4cf 7432
79072805 7433 default:
2814eb74 7434 o->op_opt = 1;
79072805
LW		 7435 break;
7436 }
a0d0e21e 7437 oldop = o;
79072805 7438 }
a0d0e21e 7439 LEAVE;
79072805 7440}
beab0874 7441
1cb0ed9b
RGS		 7442char*
7443Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 7444{
97aff369 7445 dVAR;
e1ec3a88 7446 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 7447 SV* keysv;
7448 HE* he;
7449
7450 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 7451 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 7452
7453 keysv = sv_2mortal(newSViv(index));
7454
7455 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7456 if (!he)
27da23d5 7457 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 7458
7459 return SvPV_nolen(HeVAL(he));
7460}
7461
1cb0ed9b
RGS		 7462char*
7463Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 7464{
97aff369 7465 dVAR;
e1ec3a88 7466 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 7467 SV* keysv;
7468 HE* he;
7469
7470 if (!PL_custom_op_descs)
27da23d5 7471 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 7472
7473 keysv = sv_2mortal(newSViv(index));
7474
7475 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7476 if (!he)
27da23d5 7477 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 7478
7479 return SvPV_nolen(HeVAL(he));
7480}
19e8ce8e 7481
beab0874
JT		 7482#include "XSUB.h"
7483
7484/* Efficient sub that returns a constant scalar value. */
7485static void
acfe0abc 7486const_sv_xsub(pTHX_ CV* cv)
beab0874 7487{
97aff369 7488 dVAR;
beab0874 7489 dXSARGS;
9cbac4c7
DM		 7490 if (items != 0) {
7491#if 0
7492 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 7493 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 7494#endif
7495 }
9a049f1c 7496 EXTEND(sp, 1);
0768512c 7497 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7498 XSRETURN(1);
7499}
4946a0fa
NC		 7500
7501/*
7502 * Local variables:
7503 * c-indentation-style: bsd
7504 * c-basic-offset: 4
7505 * indent-tabs-mode: t
7506 * End:
7507 *
37442d52
RGS		 7508 * ex: set ts=8 sts=4 sw=4 noet:
7509 */
Unnamed repository; edit this file 'description' to name the repository.