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