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
C compilers don't let you return void. Pay attention gcc, and
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
acde74e1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 17 */
18
166f8a29
DM		 19/* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
21 *
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
28 * stack.
29 *
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
34 *
35 * newBINOP(OP_ADD, flags,
36 * newSVREF($a),
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
38 * )
39 *
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
42 */
ccfc67b7 43
61b743bb
DM		 44/*
45Perl's compiler is essentially a 3-pass compiler with interleaved phases:
46
47 A bottom-up pass
48 A top-down pass
49 An execution-order pass
50
51The bottom-up pass is represented by all the "newOP" routines and
52the ck_ routines. The bottom-upness is actually driven by yacc.
53So at the point that a ck_ routine fires, we have no idea what the
54context is, either upward in the syntax tree, or either forward or
55backward in the execution order. (The bottom-up parser builds that
56part of the execution order it knows about, but if you follow the "next"
57links around, you'll find it's actually a closed loop through the
58top level node.
59
60Whenever the bottom-up parser gets to a node that supplies context to
61its components, it invokes that portion of the top-down pass that applies
62to that part of the subtree (and marks the top node as processed, so
63if a node further up supplies context, it doesn't have to take the
64plunge again). As a particular subcase of this, as the new node is
65built, it takes all the closed execution loops of its subcomponents
66and links them into a new closed loop for the higher level node. But
67it's still not the real execution order.
68
69The actual execution order is not known till we get a grammar reduction
70to a top-level unit like a subroutine or file that will be called by
71"name" rather than via a "next" pointer. At that point, we can call
72into peep() to do that code's portion of the 3rd pass. It has to be
73recursive, but it's recursive on basic blocks, not on tree nodes.
74*/
75
79072805 76#include "EXTERN.h"
864dbfa3 77#define PERL_IN_OP_C
79072805 78#include "perl.h"
77ca0c92 79#include "keywords.h"
79072805 80
a07e034d 81#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 82
238a4c30
NIS		 83#if defined(PL_OP_SLAB_ALLOC)
84
85#ifndef PERL_SLAB_SIZE
86#define PERL_SLAB_SIZE 2048
87#endif
88
c7e45529
AE		 89void *
90Perl_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 91{
5a8e194f
NIS		 92 /*
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
97 */
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 99 if ((PL_OpSpace -= sz) < 0) {
083fcd59
JH		 100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
101 if (!PL_OpPtr) {
238a4c30
NIS		 102 return NULL;
103 }
5a8e194f
NIS		 104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
109 */
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
114 */
5a8e194f 115 PL_OpPtr += PERL_SLAB_SIZE;
238a4c30
NIS		 116 }
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
119 PL_OpPtr -= sz;
5a8e194f 120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
126}
127
c7e45529
AE		 128void
129Perl_Slab_Free(pTHX_ void *op)
238a4c30 130{
551405c4 131 I32 * const * const ptr = (I32 **) op;
aec46f14 132 I32 * const slab = ptr[-1];
5a8e194f
NIS		 133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30
NIS		 135 assert( *slab > 0 );
136 if (--(*slab) == 0) {
7e4e8c89
NC		 137# ifdef NETWARE
138# define PerlMemShared PerlMem
139# endif
083fcd59
JH		 140
141 PerlMemShared_free(slab);
238a4c30
NIS		 142 if (slab == PL_OpSlab) {
143 PL_OpSpace = 0;
144 }
145 }
b7dc083c 146}
b7dc083c 147#endif
e50aee73 148/*
5dc0d613 149 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 150 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 151 */
11343788 152#define CHECKOP(type,o) \
3280af22 153 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 154 ? ( op_free((OP*)o), \
cb77fdf0 155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
28757baa 156 Nullop ) \
fc0dc3b3 157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 158
e6438c1a 159#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 160
8b6b16e7 161STATIC const char*
cea2e8a9 162S_gv_ename(pTHX_ GV *gv)
4633a7c4 163{
46c461b5 164 SV* const tmpsv = sv_newmortal();
46fc3d4c 165 gv_efullname3(tmpsv, gv, Nullch);
8b6b16e7 166 return SvPV_nolen_const(tmpsv);
4633a7c4
LW		 167}
168
76e3520e 169STATIC OP *
cea2e8a9 170S_no_fh_allowed(pTHX_ OP *o)
79072805 171{
cea2e8a9 172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 173 OP_DESC(o)));
11343788 174 return o;
79072805
LW		 175}
176
76e3520e 177STATIC OP *
bfed75c6 178S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 179{
cea2e8a9 180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 181 return o;
79072805
LW		 182}
183
76e3520e 184STATIC OP *
bfed75c6 185S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 186{
cea2e8a9 187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 188 return o;
79072805
LW		 189}
190
76e3520e 191STATIC void
6867be6d 192S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 193{
cea2e8a9 194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 195 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 196}
197
7a52d87a 198STATIC void
6867be6d 199S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 200{
5a844595 201 qerror(Perl_mess(aTHX_
35c1215d
NC		 202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
203 cSVOPo_sv));
7a52d87a
GS		 204}
205
79072805
LW		 206/* "register" allocation */
207
208PADOFFSET
dd2155a4 209Perl_allocmy(pTHX_ char *name)
93a17b20 210{
97aff369 211 dVAR;
a0d0e21e 212 PADOFFSET off;
3edf23ff 213 const bool is_our = (PL_in_my == KEY_our);
a0d0e21e 214
59f00321 215 /* complain about "my $<special_var>" etc etc */
6b58708b 216 if (*name &&
3edf23ff 217 !(is_our ||
155aba94 218 isALPHA(name[1]) ||
39e02b42 219 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
6b58708b 220 (name[1] == '_' && (*name == '$' || name[2]))))
834a4ddd 221 {
6b58708b 222 /* name[2] is true if strlen(name) > 2 */
c4d0567e 223 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS		 224 /* 1999-02-27 mjd@plover.com */
225 char *p;
226 p = strchr(name, '\0');
227 /* The next block assumes the buffer is at least 205 chars
228 long. At present, it's always at least 256 chars. */
229 if (p-name > 200) {
230 strcpy(name+200, "...");
231 p = name+199;
232 }
233 else {
234 p[1] = '\0';
235 }
236 /* Move everything else down one character */
237 for (; p-name > 2; p--)
238 *p = *(p-1);
46fc3d4c 239 name[2] = toCTRL(name[1]);
240 name[1] = '^';
241 }
cea2e8a9 242 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 243 }
748a9306 244
dd2155a4 245 /* check for duplicate declaration */
3edf23ff 246 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
33b8ce05 247
dd2155a4
DM		 248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
3edf23ff 251 name, is_our ? "our" : "my"));
6b35e009
GS		 252 }
253
dd2155a4 254 /* allocate a spare slot and store the name in that slot */
93a17b20 255
dd2155a4
DM		 256 off = pad_add_name(name,
257 PL_in_my_stash,
3edf23ff 258 (is_our
133706a6
RGS		 259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 261 : NULL
dd2155a4
DM		 262 ),
263 0 /* not fake */
264 );
265 return off;
79072805
LW		 266}
267
79072805
LW		 268/* Destructor */
269
270void
864dbfa3 271Perl_op_free(pTHX_ OP *o)
79072805 272{
27da23d5 273 dVAR;
acb36ea4 274 OPCODE type;
4026c95a 275 PADOFFSET refcnt;
79072805 276
2814eb74 277 if (!o || o->op_static)
79072805
LW		 278 return;
279
7934575e
GS		 280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
282 case OP_LEAVESUB:
283 case OP_LEAVESUBLV:
284 case OP_LEAVEEVAL:
285 case OP_LEAVE:
286 case OP_SCOPE:
287 case OP_LEAVEWRITE:
288 OP_REFCNT_LOCK;
4026c95a 289 refcnt = OpREFCNT_dec(o);
7934575e 290 OP_REFCNT_UNLOCK;
4026c95a
SH		 291 if (refcnt)
292 return;
7934575e
GS		 293 break;
294 default:
295 break;
296 }
297 }
298
11343788 299 if (o->op_flags & OPf_KIDS) {
6867be6d 300 register OP *kid, *nextkid;
11343788 301 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 302 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 303 op_free(kid);
85e6fe83 304 }
79072805 305 }
acb36ea4
GS		 306 type = o->op_type;
307 if (type == OP_NULL)
eb160463 308 type = (OPCODE)o->op_targ;
acb36ea4
GS		 309
310 /* COP* is not cleared by op_clear() so that we may track line
311 * numbers etc even after null() */
312 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
313 cop_free((COP*)o);
314
315 op_clear(o);
238a4c30 316 FreeOp(o);
4d494880
DM		 317#ifdef DEBUG_LEAKING_SCALARS
318 if (PL_op == o)
319 PL_op = Nullop;
320#endif
acb36ea4 321}
79072805 322
93c66552
DM		 323void
324Perl_op_clear(pTHX_ OP *o)
acb36ea4 325{
13137afc 326
27da23d5 327 dVAR;
11343788 328 switch (o->op_type) {
acb36ea4
GS		 329 case OP_NULL: /* Was holding old type, if any. */
330 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 331 o->op_targ = 0;
a0d0e21e 332 break;
a6006777 333 default:
ac4c12e7 334 if (!(o->op_flags & OPf_REF)
0b94c7bb 335 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 336 break;
337 /* FALL THROUGH */
463ee0b2 338 case OP_GVSV:
79072805 339 case OP_GV:
a6006777 340 case OP_AELEMFAST:
6a077020
DM		 341 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
342 /* not an OP_PADAV replacement */
350de78d 343#ifdef USE_ITHREADS
6a077020
DM		 344 if (cPADOPo->op_padix > 0) {
345 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
346 * may still exist on the pad */
347 pad_swipe(cPADOPo->op_padix, TRUE);
348 cPADOPo->op_padix = 0;
349 }
350de78d 350#else
6a077020
DM		 351 SvREFCNT_dec(cSVOPo->op_sv);
352 cSVOPo->op_sv = Nullsv;
350de78d 353#endif
6a077020 354 }
79072805 355 break;
a1ae71d2 356 case OP_METHOD_NAMED:
79072805 357 case OP_CONST:
11343788 358 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 359 cSVOPo->op_sv = Nullsv;
3b1c21fa
AB		 360#ifdef USE_ITHREADS
361 /** Bug #15654
362 Even if op_clear does a pad_free for the target of the op,
6a077020 363 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 364 instead it lives on. This results in that it could be reused as
365 a target later on when the pad was reallocated.
366 **/
367 if(o->op_targ) {
368 pad_swipe(o->op_targ,1);
369 o->op_targ = 0;
370 }
371#endif
79072805 372 break;
748a9306
LW		 373 case OP_GOTO:
374 case OP_NEXT:
375 case OP_LAST:
376 case OP_REDO:
11343788 377 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 378 break;
379 /* FALL THROUGH */
a0d0e21e 380 case OP_TRANS:
acb36ea4 381 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 382 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS		 383 cSVOPo->op_sv = Nullsv;
384 }
385 else {
a0ed51b3 386 Safefree(cPVOPo->op_pv);
acb36ea4
GS		 387 cPVOPo->op_pv = Nullch;
388 }
a0d0e21e
LW		 389 break;
390 case OP_SUBST:
11343788 391 op_free(cPMOPo->op_pmreplroot);
971a9dd3 392 goto clear_pmop;
748a9306 393 case OP_PUSHRE:
971a9dd3 394#ifdef USE_ITHREADS
ba89bb6e 395 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM		 396 /* No GvIN_PAD_off here, because other references may still
397 * exist on the pad */
398 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS		 399 }
400#else
401 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
402#endif
403 /* FALL THROUGH */
a0d0e21e 404 case OP_MATCH:
8782bef2 405 case OP_QR:
971a9dd3 406clear_pmop:
cb55de95 407 {
551405c4 408 HV * const pmstash = PmopSTASH(cPMOPo);
0565a181 409 if (pmstash && !SvIS_FREED(pmstash)) {
551405c4 410 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
8d2f4536
NC		 411 if (mg) {
412 PMOP *pmop = (PMOP*) mg->mg_obj;
413 PMOP *lastpmop = NULL;
414 while (pmop) {
415 if (cPMOPo == pmop) {
416 if (lastpmop)
417 lastpmop->op_pmnext = pmop->op_pmnext;
418 else
419 mg->mg_obj = (SV*) pmop->op_pmnext;
420 break;
421 }
422 lastpmop = pmop;
423 pmop = pmop->op_pmnext;
cb55de95 424 }
cb55de95 425 }
83da49e6 426 }
05ec9bb3 427 PmopSTASH_free(cPMOPo);
cb55de95 428 }
971a9dd3 429 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM		 430 /* we use the "SAFE" version of the PM_ macros here
431 * since sv_clean_all might release some PMOPs
432 * after PL_regex_padav has been cleared
433 * and the clearing of PL_regex_padav needs to
434 * happen before sv_clean_all
435 */
436 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
437 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB		 438#ifdef USE_ITHREADS
439 if(PL_regex_pad) { /* We could be in destruction */
440 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 441 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 442 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
443 }
1eb1540c 444#endif
13137afc 445
a0d0e21e 446 break;
79072805
LW		 447 }
448
743e66e6 449 if (o->op_targ > 0) {
11343788 450 pad_free(o->op_targ);
743e66e6
GS		 451 o->op_targ = 0;
452 }
79072805
LW		 453}
454
76e3520e 455STATIC void
3eb57f73
HS		 456S_cop_free(pTHX_ COP* cop)
457{
05ec9bb3
NIS		 458 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
459 CopFILE_free(cop);
460 CopSTASH_free(cop);
0453d815 461 if (! specialWARN(cop->cop_warnings))
3eb57f73 462 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS		 463 if (! specialCopIO(cop->cop_io)) {
464#ifdef USE_ITHREADS
042f6df8 465#if 0
05ec9bb3
NIS		 466 STRLEN len;
467 char *s = SvPV(cop->cop_io,len);
b178108d
JH		 468 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
469#endif
05ec9bb3 470#else
ac27b0f5 471 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS		 472#endif
473 }
3eb57f73
HS		 474}
475
93c66552
DM		 476void
477Perl_op_null(pTHX_ OP *o)
8990e307 478{
27da23d5 479 dVAR;
acb36ea4
GS		 480 if (o->op_type == OP_NULL)
481 return;
482 op_clear(o);
11343788
MB		 483 o->op_targ = o->op_type;
484 o->op_type = OP_NULL;
22c35a8c 485 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 486}
487
4026c95a
SH		 488void
489Perl_op_refcnt_lock(pTHX)
490{
27da23d5 491 dVAR;
4026c95a
SH		 492 OP_REFCNT_LOCK;
493}
494
495void
496Perl_op_refcnt_unlock(pTHX)
497{
27da23d5 498 dVAR;
4026c95a
SH		 499 OP_REFCNT_UNLOCK;
500}
501
79072805
LW		 502/* Contextualizers */
503
463ee0b2 504#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 505
506OP *
864dbfa3 507Perl_linklist(pTHX_ OP *o)
79072805 508{
3edf23ff 509 OP *first;
79072805 510
11343788
MB		 511 if (o->op_next)
512 return o->op_next;
79072805
LW		 513
514 /* establish postfix order */
3edf23ff
AL		 515 first = cUNOPo->op_first;
516 if (first) {
6867be6d 517 register OP *kid;
3edf23ff
AL		 518 o->op_next = LINKLIST(first);
519 kid = first;
520 for (;;) {
521 if (kid->op_sibling) {
79072805 522 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 523 kid = kid->op_sibling;
524 } else {
11343788 525 kid->op_next = o;
3edf23ff
AL		 526 break;
527 }
79072805
LW		 528 }
529 }
530 else
11343788 531 o->op_next = o;
79072805 532
11343788 533 return o->op_next;
79072805
LW		 534}
535
536OP *
864dbfa3 537Perl_scalarkids(pTHX_ OP *o)
79072805 538{
11343788 539 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 540 OP *kid;
11343788 541 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 542 scalar(kid);
543 }
11343788 544 return o;
79072805
LW		 545}
546
76e3520e 547STATIC OP *
cea2e8a9 548S_scalarboolean(pTHX_ OP *o)
8990e307 549{
97aff369 550 dVAR;
d008e5eb 551 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 552 if (ckWARN(WARN_SYNTAX)) {
6867be6d 553 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 554
d008e5eb 555 if (PL_copline != NOLINE)
57843af0 556 CopLINE_set(PL_curcop, PL_copline);
9014280d 557 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 558 CopLINE_set(PL_curcop, oldline);
d008e5eb 559 }
a0d0e21e 560 }
11343788 561 return scalar(o);
8990e307
LW		 562}
563
564OP *
864dbfa3 565Perl_scalar(pTHX_ OP *o)
79072805 566{
27da23d5 567 dVAR;
79072805
LW		 568 OP *kid;
569
a0d0e21e 570 /* assumes no premature commitment */
551405c4 571 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
5dc0d613 572 || o->op_type == OP_RETURN)
7e363e51 573 {
11343788 574 return o;
7e363e51 575 }
79072805 576
5dc0d613 577 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 578
11343788 579 switch (o->op_type) {
79072805 580 case OP_REPEAT:
11343788 581 scalar(cBINOPo->op_first);
8990e307 582 break;
79072805
LW		 583 case OP_OR:
584 case OP_AND:
585 case OP_COND_EXPR:
11343788 586 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 587 scalar(kid);
79072805 588 break;
a0d0e21e 589 case OP_SPLIT:
11343788 590 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 591 if (!kPMOP->op_pmreplroot)
12bcd1a6 592 deprecate_old("implicit split to @_");
a0d0e21e
LW		 593 }
594 /* FALL THROUGH */
79072805 595 case OP_MATCH:
8782bef2 596 case OP_QR:
79072805
LW		 597 case OP_SUBST:
598 case OP_NULL:
8990e307 599 default:
11343788
MB		 600 if (o->op_flags & OPf_KIDS) {
601 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 602 scalar(kid);
603 }
79072805
LW		 604 break;
605 case OP_LEAVE:
606 case OP_LEAVETRY:
5dc0d613 607 kid = cLISTOPo->op_first;
54310121 608 scalar(kid);
155aba94 609 while ((kid = kid->op_sibling)) {
54310121 610 if (kid->op_sibling)
611 scalarvoid(kid);
612 else
613 scalar(kid);
614 }
3280af22 615 WITH_THR(PL_curcop = &PL_compiling);
54310121 616 break;
748a9306 617 case OP_SCOPE:
79072805 618 case OP_LINESEQ:
8990e307 619 case OP_LIST:
11343788 620 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 621 if (kid->op_sibling)
622 scalarvoid(kid);
623 else
624 scalar(kid);
625 }
3280af22 626 WITH_THR(PL_curcop = &PL_compiling);
79072805 627 break;
a801c63c
RGS		 628 case OP_SORT:
629 if (ckWARN(WARN_VOID))
9014280d 630 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 631 }
11343788 632 return o;
79072805
LW		 633}
634
635OP *
864dbfa3 636Perl_scalarvoid(pTHX_ OP *o)
79072805 637{
27da23d5 638 dVAR;
79072805 639 OP *kid;
c445ea15 640 const char* useless = NULL;
8990e307 641 SV* sv;
2ebea0a1
GS		 642 U8 want;
643
acb36ea4
GS		 644 if (o->op_type == OP_NEXTSTATE
645 || o->op_type == OP_SETSTATE
646 || o->op_type == OP_DBSTATE
647 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
648 || o->op_targ == OP_SETSTATE
649 || o->op_targ == OP_DBSTATE)))
2ebea0a1 650 PL_curcop = (COP*)o; /* for warning below */
79072805 651
54310121 652 /* assumes no premature commitment */
2ebea0a1
GS		 653 want = o->op_flags & OPf_WANT;
654 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 655 || o->op_type == OP_RETURN)
7e363e51 656 {
11343788 657 return o;
7e363e51 658 }
79072805 659
b162f9ea 660 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 661 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
662 {
b162f9ea 663 return scalar(o); /* As if inside SASSIGN */
7e363e51 664 }
1c846c1f 665
5dc0d613 666 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 667
11343788 668 switch (o->op_type) {
79072805 669 default:
22c35a8c 670 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 671 break;
36477c24 672 /* FALL THROUGH */
673 case OP_REPEAT:
11343788 674 if (o->op_flags & OPf_STACKED)
8990e307 675 break;
5d82c453
GA		 676 goto func_ops;
677 case OP_SUBSTR:
678 if (o->op_private == 4)
679 break;
8990e307
LW		 680 /* FALL THROUGH */
681 case OP_GVSV:
682 case OP_WANTARRAY:
683 case OP_GV:
684 case OP_PADSV:
685 case OP_PADAV:
686 case OP_PADHV:
687 case OP_PADANY:
688 case OP_AV2ARYLEN:
8990e307 689 case OP_REF:
a0d0e21e
LW		 690 case OP_REFGEN:
691 case OP_SREFGEN:
8990e307
LW		 692 case OP_DEFINED:
693 case OP_HEX:
694 case OP_OCT:
695 case OP_LENGTH:
8990e307
LW		 696 case OP_VEC:
697 case OP_INDEX:
698 case OP_RINDEX:
699 case OP_SPRINTF:
700 case OP_AELEM:
701 case OP_AELEMFAST:
702 case OP_ASLICE:
8990e307
LW		 703 case OP_HELEM:
704 case OP_HSLICE:
705 case OP_UNPACK:
706 case OP_PACK:
8990e307
LW		 707 case OP_JOIN:
708 case OP_LSLICE:
709 case OP_ANONLIST:
710 case OP_ANONHASH:
711 case OP_SORT:
712 case OP_REVERSE:
713 case OP_RANGE:
714 case OP_FLIP:
715 case OP_FLOP:
716 case OP_CALLER:
717 case OP_FILENO:
718 case OP_EOF:
719 case OP_TELL:
720 case OP_GETSOCKNAME:
721 case OP_GETPEERNAME:
722 case OP_READLINK:
723 case OP_TELLDIR:
724 case OP_GETPPID:
725 case OP_GETPGRP:
726 case OP_GETPRIORITY:
727 case OP_TIME:
728 case OP_TMS:
729 case OP_LOCALTIME:
730 case OP_GMTIME:
731 case OP_GHBYNAME:
732 case OP_GHBYADDR:
733 case OP_GHOSTENT:
734 case OP_GNBYNAME:
735 case OP_GNBYADDR:
736 case OP_GNETENT:
737 case OP_GPBYNAME:
738 case OP_GPBYNUMBER:
739 case OP_GPROTOENT:
740 case OP_GSBYNAME:
741 case OP_GSBYPORT:
742 case OP_GSERVENT:
743 case OP_GPWNAM:
744 case OP_GPWUID:
745 case OP_GGRNAM:
746 case OP_GGRGID:
747 case OP_GETLOGIN:
78e1b766 748 case OP_PROTOTYPE:
5d82c453 749 func_ops:
64aac5a9 750 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 751 useless = OP_DESC(o);
8990e307
LW		 752 break;
753
9f82cd5f
YST		 754 case OP_NOT:
755 kid = cUNOPo->op_first;
756 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
757 kid->op_type != OP_TRANS) {
758 goto func_ops;
759 }
760 useless = "negative pattern binding (!~)";
761 break;
762
8990e307
LW		 763 case OP_RV2GV:
764 case OP_RV2SV:
765 case OP_RV2AV:
766 case OP_RV2HV:
192587c2 767 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 768 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 769 useless = "a variable";
770 break;
79072805
LW		 771
772 case OP_CONST:
7766f137 773 sv = cSVOPo_sv;
7a52d87a
GS		 774 if (cSVOPo->op_private & OPpCONST_STRICT)
775 no_bareword_allowed(o);
776 else {
d008e5eb
GS		 777 if (ckWARN(WARN_VOID)) {
778 useless = "a constant";
e7fec78e 779 /* don't warn on optimised away booleans, eg
b5a930ec 780 * use constant Foo, 5; Foo || print; */
e7fec78e
DM		 781 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
782 useless = 0;
960b4253
MG		 783 /* the constants 0 and 1 are permitted as they are
784 conventionally used as dummies in constructs like
785 1 while some_condition_with_side_effects; */
e7fec78e 786 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d008e5eb
GS		 787 useless = 0;
788 else if (SvPOK(sv)) {
a52fe3ac
A		 789 /* perl4's way of mixing documentation and code
790 (before the invention of POD) was based on a
791 trick to mix nroff and perl code. The trick was
792 built upon these three nroff macros being used in
793 void context. The pink camel has the details in
794 the script wrapman near page 319. */
6136c704
AL		 795 const char * const maybe_macro = SvPVX_const(sv);
796 if (strnEQ(maybe_macro, "di", 2) ||
797 strnEQ(maybe_macro, "ds", 2) ||
798 strnEQ(maybe_macro, "ig", 2))
d008e5eb
GS		 799 useless = 0;
800 }
8990e307
LW		 801 }
802 }
93c66552 803 op_null(o); /* don't execute or even remember it */
79072805
LW		 804 break;
805
806 case OP_POSTINC:
11343788 807 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 808 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 809 break;
810
811 case OP_POSTDEC:
11343788 812 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 813 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 814 break;
815
679d6c4e
HS		 816 case OP_I_POSTINC:
817 o->op_type = OP_I_PREINC; /* pre-increment is faster */
818 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
819 break;
820
821 case OP_I_POSTDEC:
822 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
823 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
824 break;
825
79072805
LW		 826 case OP_OR:
827 case OP_AND:
c963b151 828 case OP_DOR:
79072805 829 case OP_COND_EXPR:
0d863452
RH		 830 case OP_ENTERGIVEN:
831 case OP_ENTERWHEN:
11343788 832 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 833 scalarvoid(kid);
834 break;
5aabfad6 835
a0d0e21e 836 case OP_NULL:
11343788 837 if (o->op_flags & OPf_STACKED)
a0d0e21e 838 break;
5aabfad6 839 /* FALL THROUGH */
2ebea0a1
GS		 840 case OP_NEXTSTATE:
841 case OP_DBSTATE:
79072805
LW		 842 case OP_ENTERTRY:
843 case OP_ENTER:
11343788 844 if (!(o->op_flags & OPf_KIDS))
79072805 845 break;
54310121 846 /* FALL THROUGH */
463ee0b2 847 case OP_SCOPE:
79072805
LW		 848 case OP_LEAVE:
849 case OP_LEAVETRY:
a0d0e21e 850 case OP_LEAVELOOP:
79072805 851 case OP_LINESEQ:
79072805 852 case OP_LIST:
0d863452
RH		 853 case OP_LEAVEGIVEN:
854 case OP_LEAVEWHEN:
11343788 855 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 856 scalarvoid(kid);
857 break;
c90c0ff4 858 case OP_ENTEREVAL:
5196be3e 859 scalarkids(o);
c90c0ff4 860 break;
5aabfad6 861 case OP_REQUIRE:
c90c0ff4 862 /* all requires must return a boolean value */
5196be3e 863 o->op_flags &= ~OPf_WANT;
d6483035
GS		 864 /* FALL THROUGH */
865 case OP_SCALAR:
5196be3e 866 return scalar(o);
a0d0e21e 867 case OP_SPLIT:
11343788 868 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 869 if (!kPMOP->op_pmreplroot)
12bcd1a6 870 deprecate_old("implicit split to @_");
a0d0e21e
LW		 871 }
872 break;
79072805 873 }
411caa50 874 if (useless && ckWARN(WARN_VOID))
9014280d 875 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 876 return o;
79072805
LW		 877}
878
879OP *
864dbfa3 880Perl_listkids(pTHX_ OP *o)
79072805 881{
11343788 882 if (o && o->op_flags & OPf_KIDS) {
6867be6d 883 OP *kid;
11343788 884 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 885 list(kid);
886 }
11343788 887 return o;
79072805
LW		 888}
889
890OP *
864dbfa3 891Perl_list(pTHX_ OP *o)
79072805 892{
27da23d5 893 dVAR;
79072805
LW		 894 OP *kid;
895
a0d0e21e 896 /* assumes no premature commitment */
3280af22 897 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 898 || o->op_type == OP_RETURN)
7e363e51 899 {
11343788 900 return o;
7e363e51 901 }
79072805 902
b162f9ea 903 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 904 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
905 {
b162f9ea 906 return o; /* As if inside SASSIGN */
7e363e51 907 }
1c846c1f 908
5dc0d613 909 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 910
11343788 911 switch (o->op_type) {
79072805
LW		 912 case OP_FLOP:
913 case OP_REPEAT:
11343788 914 list(cBINOPo->op_first);
79072805
LW		 915 break;
916 case OP_OR:
917 case OP_AND:
918 case OP_COND_EXPR:
11343788 919 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 920 list(kid);
921 break;
922 default:
923 case OP_MATCH:
8782bef2 924 case OP_QR:
79072805
LW		 925 case OP_SUBST:
926 case OP_NULL:
11343788 927 if (!(o->op_flags & OPf_KIDS))
79072805 928 break;
11343788
MB		 929 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
930 list(cBINOPo->op_first);
931 return gen_constant_list(o);
79072805
LW		 932 }
933 case OP_LIST:
11343788 934 listkids(o);
79072805
LW		 935 break;
936 case OP_LEAVE:
937 case OP_LEAVETRY:
5dc0d613 938 kid = cLISTOPo->op_first;
54310121 939 list(kid);
155aba94 940 while ((kid = kid->op_sibling)) {
54310121 941 if (kid->op_sibling)
942 scalarvoid(kid);
943 else
944 list(kid);
945 }
3280af22 946 WITH_THR(PL_curcop = &PL_compiling);
54310121 947 break;
748a9306 948 case OP_SCOPE:
79072805 949 case OP_LINESEQ:
11343788 950 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 951 if (kid->op_sibling)
952 scalarvoid(kid);
953 else
954 list(kid);
955 }
3280af22 956 WITH_THR(PL_curcop = &PL_compiling);
79072805 957 break;
c90c0ff4 958 case OP_REQUIRE:
959 /* all requires must return a boolean value */
5196be3e
MB		 960 o->op_flags &= ~OPf_WANT;
961 return scalar(o);
79072805 962 }
11343788 963 return o;
79072805
LW		 964}
965
966OP *
864dbfa3 967Perl_scalarseq(pTHX_ OP *o)
79072805 968{
97aff369 969 dVAR;
11343788
MB		 970 if (o) {
971 if (o->op_type == OP_LINESEQ ||
972 o->op_type == OP_SCOPE ||
973 o->op_type == OP_LEAVE ||
974 o->op_type == OP_LEAVETRY)
463ee0b2 975 {
6867be6d 976 OP *kid;
11343788 977 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 978 if (kid->op_sibling) {
463ee0b2 979 scalarvoid(kid);
ed6116ce 980 }
463ee0b2 981 }
3280af22 982 PL_curcop = &PL_compiling;
79072805 983 }
11343788 984 o->op_flags &= ~OPf_PARENS;
3280af22 985 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 986 o->op_flags |= OPf_PARENS;
79072805 987 }
8990e307 988 else
11343788
MB		 989 o = newOP(OP_STUB, 0);
990 return o;
79072805
LW		 991}
992
76e3520e 993STATIC OP *
cea2e8a9 994S_modkids(pTHX_ OP *o, I32 type)
79072805 995{
11343788 996 if (o && o->op_flags & OPf_KIDS) {
6867be6d 997 OP *kid;
11343788 998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 999 mod(kid, type);
79072805 1000 }
11343788 1001 return o;
79072805
LW		 1002}
1003
ff7298cb 1004/* Propagate lvalue ("modifiable") context to an op and its children.
ddeae0f1
DM		 1005 * 'type' represents the context type, roughly based on the type of op that
1006 * would do the modifying, although local() is represented by OP_NULL.
1007 * It's responsible for detecting things that can't be modified, flag
1008 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1009 * might have to vivify a reference in $x), and so on.
1010 *
1011 * For example, "$a+1 = 2" would cause mod() to be called with o being
1012 * OP_ADD and type being OP_SASSIGN, and would output an error.
1013 */
1014
79072805 1015OP *
864dbfa3 1016Perl_mod(pTHX_ OP *o, I32 type)
79072805 1017{
27da23d5 1018 dVAR;
79072805 1019 OP *kid;
ddeae0f1
DM		 1020 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1021 int localize = -1;
79072805 1022
3280af22 1023 if (!o || PL_error_count)
11343788 1024 return o;
79072805 1025
b162f9ea 1026 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1028 {
b162f9ea 1029 return o;
7e363e51 1030 }
1c846c1f 1031
11343788 1032 switch (o->op_type) {
68dc0745 1033 case OP_UNDEF:
ddeae0f1 1034 localize = 0;
3280af22 1035 PL_modcount++;
5dc0d613 1036 return o;
a0d0e21e 1037 case OP_CONST:
11343788 1038 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1039 goto nomod;
54dc0f91 1040 localize = 0;
3280af22 1041 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1042 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1043 PL_eval_start = 0;
a0d0e21e
LW		 1044 }
1045 else if (!type) {
3280af22
NIS		 1046 SAVEI32(PL_compiling.cop_arybase);
1047 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 1048 }
1049 else if (type == OP_REFGEN)
1050 goto nomod;
1051 else
cea2e8a9 1052 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1053 break;
5f05dabc 1054 case OP_STUB:
5196be3e 1055 if (o->op_flags & OPf_PARENS)
5f05dabc 1056 break;
1057 goto nomod;
a0d0e21e
LW		 1058 case OP_ENTERSUB:
1059 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1060 !(o->op_flags & OPf_STACKED)) {
1061 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC		 1062 /* The default is to set op_private to the number of children,
1063 which for a UNOP such as RV2CV is always 1. And w're using
1064 the bit for a flag in RV2CV, so we need it clear. */
1065 o->op_private &= ~1;
22c35a8c 1066 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1067 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1068 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1069 break;
1070 }
95f0a2f1
SB		 1071 else if (o->op_private & OPpENTERSUB_NOMOD)
1072 return o;
cd06dffe
GS		 1073 else { /* lvalue subroutine call */
1074 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1075 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1076 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1077 /* Backward compatibility mode: */
1078 o->op_private |= OPpENTERSUB_INARGS;
1079 break;
1080 }
1081 else { /* Compile-time error message: */
1082 OP *kid = cUNOPo->op_first;
1083 CV *cv;
1084 OP *okid;
1085
1086 if (kid->op_type == OP_PUSHMARK)
1087 goto skip_kids;
1088 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1089 Perl_croak(aTHX_
1090 "panic: unexpected lvalue entersub "
55140b79 1091 "args: type/targ %ld:%"UVuf,
3d811634 1092 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1093 kid = kLISTOP->op_first;
1094 skip_kids:
1095 while (kid->op_sibling)
1096 kid = kid->op_sibling;
1097 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1098 /* Indirect call */
1099 if (kid->op_type == OP_METHOD_NAMED
1100 || kid->op_type == OP_METHOD)
1101 {
87d7fd28 1102 UNOP *newop;
b2ffa427 1103
87d7fd28 1104 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1105 newop->op_type = OP_RV2CV;
1106 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 1107 newop->op_first = Nullop;
1108 newop->op_next = (OP*)newop;
1109 kid->op_sibling = (OP*)newop;
349fd7b7 1110 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1111 newop->op_private &= ~1;
cd06dffe
GS		 1112 break;
1113 }
b2ffa427 1114
cd06dffe
GS		 1115 if (kid->op_type != OP_RV2CV)
1116 Perl_croak(aTHX_
1117 "panic: unexpected lvalue entersub "
55140b79 1118 "entry via type/targ %ld:%"UVuf,
3d811634 1119 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1120 kid->op_private |= OPpLVAL_INTRO;
1121 break; /* Postpone until runtime */
1122 }
b2ffa427
NIS		 1123
1124 okid = kid;
cd06dffe
GS		 1125 kid = kUNOP->op_first;
1126 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1127 kid = kUNOP->op_first;
b2ffa427 1128 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1129 Perl_croak(aTHX_
1130 "Unexpected constant lvalue entersub "
55140b79 1131 "entry via type/targ %ld:%"UVuf,
3d811634 1132 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1133 if (kid->op_type != OP_GV) {
1134 /* Restore RV2CV to check lvalueness */
1135 restore_2cv:
1136 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1137 okid->op_next = kid->op_next;
1138 kid->op_next = okid;
1139 }
1140 else
1141 okid->op_next = Nullop;
1142 okid->op_type = OP_RV2CV;
1143 okid->op_targ = 0;
1144 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1145 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1146 okid->op_private &= ~1;
cd06dffe
GS		 1147 break;
1148 }
b2ffa427 1149
638eceb6 1150 cv = GvCV(kGVOP_gv);
1c846c1f 1151 if (!cv)
cd06dffe
GS		 1152 goto restore_2cv;
1153 if (CvLVALUE(cv))
1154 break;
1155 }
1156 }
79072805
LW		 1157 /* FALL THROUGH */
1158 default:
a0d0e21e 1159 nomod:
6fbb66d6
NC		 1160 /* grep, foreach, subcalls, refgen */
1161 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1162 break;
cea2e8a9 1163 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1164 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1165 ? "do block"
1166 : (o->op_type == OP_ENTERSUB
1167 ? "non-lvalue subroutine call"
53e06cf0 1168 : OP_DESC(o))),
22c35a8c 1169 type ? PL_op_desc[type] : "local"));
11343788 1170 return o;
79072805 1171
a0d0e21e
LW		 1172 case OP_PREINC:
1173 case OP_PREDEC:
1174 case OP_POW:
1175 case OP_MULTIPLY:
1176 case OP_DIVIDE:
1177 case OP_MODULO:
1178 case OP_REPEAT:
1179 case OP_ADD:
1180 case OP_SUBTRACT:
1181 case OP_CONCAT:
1182 case OP_LEFT_SHIFT:
1183 case OP_RIGHT_SHIFT:
1184 case OP_BIT_AND:
1185 case OP_BIT_XOR:
1186 case OP_BIT_OR:
1187 case OP_I_MULTIPLY:
1188 case OP_I_DIVIDE:
1189 case OP_I_MODULO:
1190 case OP_I_ADD:
1191 case OP_I_SUBTRACT:
11343788 1192 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1193 goto nomod;
3280af22 1194 PL_modcount++;
a0d0e21e 1195 break;
b2ffa427 1196
79072805 1197 case OP_COND_EXPR:
ddeae0f1 1198 localize = 1;
11343788 1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1200 mod(kid, type);
79072805
LW		 1201 break;
1202
1203 case OP_RV2AV:
1204 case OP_RV2HV:
11343788 1205 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1206 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1207 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1208 }
1209 /* FALL THROUGH */
79072805 1210 case OP_RV2GV:
5dc0d613 1211 if (scalar_mod_type(o, type))
3fe9a6f1 1212 goto nomod;
11343788 1213 ref(cUNOPo->op_first, o->op_type);
79072805 1214 /* FALL THROUGH */
79072805
LW		 1215 case OP_ASLICE:
1216 case OP_HSLICE:
78f9721b
SM		 1217 if (type == OP_LEAVESUBLV)
1218 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1219 localize = 1;
78f9721b
SM		 1220 /* FALL THROUGH */
1221 case OP_AASSIGN:
93a17b20
LW		 1222 case OP_NEXTSTATE:
1223 case OP_DBSTATE:
e6438c1a 1224 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1225 break;
463ee0b2 1226 case OP_RV2SV:
aeea060c 1227 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1228 localize = 1;
463ee0b2 1229 /* FALL THROUGH */
79072805 1230 case OP_GV:
463ee0b2 1231 case OP_AV2ARYLEN:
3280af22 1232 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1233 case OP_SASSIGN:
bf4b1e52
GS		 1234 case OP_ANDASSIGN:
1235 case OP_ORASSIGN:
c963b151 1236 case OP_DORASSIGN:
ddeae0f1
DM		 1237 PL_modcount++;
1238 break;
1239
8990e307 1240 case OP_AELEMFAST:
6a077020 1241 localize = -1;
3280af22 1242 PL_modcount++;
8990e307
LW		 1243 break;
1244
748a9306
LW		 1245 case OP_PADAV:
1246 case OP_PADHV:
e6438c1a 1247 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1248 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1249 return o; /* Treat \(@foo) like ordinary list. */
1250 if (scalar_mod_type(o, type))
3fe9a6f1 1251 goto nomod;
78f9721b
SM		 1252 if (type == OP_LEAVESUBLV)
1253 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1254 /* FALL THROUGH */
1255 case OP_PADSV:
3280af22 1256 PL_modcount++;
ddeae0f1 1257 if (!type) /* local() */
cea2e8a9 1258 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1259 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1260 break;
1261
748a9306 1262 case OP_PUSHMARK:
ddeae0f1 1263 localize = 0;
748a9306 1264 break;
b2ffa427 1265
69969c6f
SB		 1266 case OP_KEYS:
1267 if (type != OP_SASSIGN)
1268 goto nomod;
5d82c453
GA		 1269 goto lvalue_func;
1270 case OP_SUBSTR:
1271 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1272 goto nomod;
5f05dabc 1273 /* FALL THROUGH */
a0d0e21e 1274 case OP_POS:
463ee0b2 1275 case OP_VEC:
78f9721b
SM		 1276 if (type == OP_LEAVESUBLV)
1277 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1278 lvalue_func:
11343788
MB		 1279 pad_free(o->op_targ);
1280 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1281 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1282 if (o->op_flags & OPf_KIDS)
1283 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1284 break;
a0d0e21e 1285
463ee0b2
LW		 1286 case OP_AELEM:
1287 case OP_HELEM:
11343788 1288 ref(cBINOPo->op_first, o->op_type);
68dc0745 1289 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1290 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1291 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1292 if (type == OP_LEAVESUBLV)
1293 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1294 localize = 1;
3280af22 1295 PL_modcount++;
463ee0b2
LW		 1296 break;
1297
1298 case OP_SCOPE:
1299 case OP_LEAVE:
1300 case OP_ENTER:
78f9721b 1301 case OP_LINESEQ:
ddeae0f1 1302 localize = 0;
11343788
MB		 1303 if (o->op_flags & OPf_KIDS)
1304 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1305 break;
1306
1307 case OP_NULL:
ddeae0f1 1308 localize = 0;
638bc118
GS		 1309 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1310 goto nomod;
1311 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1312 break;
11343788
MB		 1313 if (o->op_targ != OP_LIST) {
1314 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1315 break;
1316 }
1317 /* FALL THROUGH */
463ee0b2 1318 case OP_LIST:
ddeae0f1 1319 localize = 0;
11343788 1320 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1321 mod(kid, type);
1322 break;
78f9721b
SM		 1323
1324 case OP_RETURN:
1325 if (type != OP_LEAVESUBLV)
1326 goto nomod;
1327 break; /* mod()ing was handled by ck_return() */
463ee0b2 1328 }
58d95175 1329
8be1be90
AMS		 1330 /* [20011101.069] File test operators interpret OPf_REF to mean that
1331 their argument is a filehandle; thus \stat(".") should not set
1332 it. AMS 20011102 */
1333 if (type == OP_REFGEN &&
1334 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1335 return o;
1336
1337 if (type != OP_LEAVESUBLV)
1338 o->op_flags |= OPf_MOD;
1339
1340 if (type == OP_AASSIGN || type == OP_SASSIGN)
1341 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1342 else if (!type) { /* local() */
1343 switch (localize) {
1344 case 1:
1345 o->op_private |= OPpLVAL_INTRO;
1346 o->op_flags &= ~OPf_SPECIAL;
1347 PL_hints |= HINT_BLOCK_SCOPE;
1348 break;
1349 case 0:
1350 break;
1351 case -1:
1352 if (ckWARN(WARN_SYNTAX)) {
1353 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1354 "Useless localization of %s", OP_DESC(o));
1355 }
1356 }
463ee0b2 1357 }
8be1be90
AMS		 1358 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1359 && type != OP_LEAVESUBLV)
1360 o->op_flags |= OPf_REF;
11343788 1361 return o;
463ee0b2
LW		 1362}
1363
864dbfa3 1364STATIC bool
6867be6d 1365S_scalar_mod_type(pTHX_ const OP *o, I32 type)
3fe9a6f1 1366{
1367 switch (type) {
1368 case OP_SASSIGN:
5196be3e 1369 if (o->op_type == OP_RV2GV)
3fe9a6f1 1370 return FALSE;
1371 /* FALL THROUGH */
1372 case OP_PREINC:
1373 case OP_PREDEC:
1374 case OP_POSTINC:
1375 case OP_POSTDEC:
1376 case OP_I_PREINC:
1377 case OP_I_PREDEC:
1378 case OP_I_POSTINC:
1379 case OP_I_POSTDEC:
1380 case OP_POW:
1381 case OP_MULTIPLY:
1382 case OP_DIVIDE:
1383 case OP_MODULO:
1384 case OP_REPEAT:
1385 case OP_ADD:
1386 case OP_SUBTRACT:
1387 case OP_I_MULTIPLY:
1388 case OP_I_DIVIDE:
1389 case OP_I_MODULO:
1390 case OP_I_ADD:
1391 case OP_I_SUBTRACT:
1392 case OP_LEFT_SHIFT:
1393 case OP_RIGHT_SHIFT:
1394 case OP_BIT_AND:
1395 case OP_BIT_XOR:
1396 case OP_BIT_OR:
1397 case OP_CONCAT:
1398 case OP_SUBST:
1399 case OP_TRANS:
49e9fbe6
GS		 1400 case OP_READ:
1401 case OP_SYSREAD:
1402 case OP_RECV:
bf4b1e52
GS		 1403 case OP_ANDASSIGN:
1404 case OP_ORASSIGN:
3fe9a6f1 1405 return TRUE;
1406 default:
1407 return FALSE;
1408 }
1409}
1410
35cd451c 1411STATIC bool
504618e9 1412S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
35cd451c
GS		 1413{
1414 switch (o->op_type) {
1415 case OP_PIPE_OP:
1416 case OP_SOCKPAIR:
504618e9 1417 if (numargs == 2)
35cd451c
GS		 1418 return TRUE;
1419 /* FALL THROUGH */
1420 case OP_SYSOPEN:
1421 case OP_OPEN:
ded8aa31 1422 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1423 case OP_SOCKET:
1424 case OP_OPEN_DIR:
1425 case OP_ACCEPT:
504618e9 1426 if (numargs == 1)
35cd451c
GS		 1427 return TRUE;
1428 /* FALL THROUGH */
1429 default:
1430 return FALSE;
1431 }
1432}
1433
463ee0b2 1434OP *
864dbfa3 1435Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1436{
11343788 1437 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1438 OP *kid;
11343788 1439 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1440 ref(kid, type);
1441 }
11343788 1442 return o;
463ee0b2
LW		 1443}
1444
1445OP *
e4c5ccf3 1446Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1447{
27da23d5 1448 dVAR;
463ee0b2 1449 OP *kid;
463ee0b2 1450
3280af22 1451 if (!o || PL_error_count)
11343788 1452 return o;
463ee0b2 1453
11343788 1454 switch (o->op_type) {
a0d0e21e 1455 case OP_ENTERSUB:
afebc493 1456 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1457 !(o->op_flags & OPf_STACKED)) {
1458 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1459 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1460 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1461 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1462 o->op_flags |= OPf_SPECIAL;
e26df76a 1463 o->op_private &= ~1;
8990e307
LW		 1464 }
1465 break;
aeea060c 1466
463ee0b2 1467 case OP_COND_EXPR:
11343788 1468 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1469 doref(kid, type, set_op_ref);
463ee0b2 1470 break;
8990e307 1471 case OP_RV2SV:
35cd451c
GS		 1472 if (type == OP_DEFINED)
1473 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1474 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1475 /* FALL THROUGH */
1476 case OP_PADSV:
5f05dabc 1477 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1478 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1479 : type == OP_RV2HV ? OPpDEREF_HV
1480 : OPpDEREF_SV);
11343788 1481 o->op_flags |= OPf_MOD;
a0d0e21e 1482 }
8990e307 1483 break;
1c846c1f 1484
2faa37cc 1485 case OP_THREADSV:
a863c7d1
MB		 1486 o->op_flags |= OPf_MOD; /* XXX ??? */
1487 break;
1488
463ee0b2
LW		 1489 case OP_RV2AV:
1490 case OP_RV2HV:
e4c5ccf3
RH		 1491 if (set_op_ref)
1492 o->op_flags |= OPf_REF;
8990e307 1493 /* FALL THROUGH */
463ee0b2 1494 case OP_RV2GV:
35cd451c
GS		 1495 if (type == OP_DEFINED)
1496 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1497 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1498 break;
8990e307 1499
463ee0b2
LW		 1500 case OP_PADAV:
1501 case OP_PADHV:
e4c5ccf3
RH		 1502 if (set_op_ref)
1503 o->op_flags |= OPf_REF;
79072805 1504 break;
aeea060c 1505
8990e307 1506 case OP_SCALAR:
79072805 1507 case OP_NULL:
11343788 1508 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1509 break;
e4c5ccf3 1510 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1511 break;
1512 case OP_AELEM:
1513 case OP_HELEM:
e4c5ccf3 1514 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1515 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1516 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1517 : type == OP_RV2HV ? OPpDEREF_HV
1518 : OPpDEREF_SV);
11343788 1519 o->op_flags |= OPf_MOD;
8990e307 1520 }
79072805
LW		 1521 break;
1522
463ee0b2 1523 case OP_SCOPE:
79072805 1524 case OP_LEAVE:
e4c5ccf3
RH		 1525 set_op_ref = FALSE;
1526 /* FALL THROUGH */
79072805 1527 case OP_ENTER:
8990e307 1528 case OP_LIST:
11343788 1529 if (!(o->op_flags & OPf_KIDS))
79072805 1530 break;
e4c5ccf3 1531 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1532 break;
a0d0e21e
LW		 1533 default:
1534 break;
79072805 1535 }
11343788 1536 return scalar(o);
8990e307 1537
79072805
LW		 1538}
1539
09bef843
SB		 1540STATIC OP *
1541S_dup_attrlist(pTHX_ OP *o)
1542{
97aff369 1543 dVAR;
0bd48802 1544 OP *rop;
09bef843
SB		 1545
1546 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1547 * where the first kid is OP_PUSHMARK and the remaining ones
1548 * are OP_CONST. We need to push the OP_CONST values.
1549 */
1550 if (o->op_type == OP_CONST)
1551 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1552 else {
1553 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
0bd48802 1554 rop = Nullop;
09bef843
SB		 1555 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1556 if (o->op_type == OP_CONST)
1557 rop = append_elem(OP_LIST, rop,
1558 newSVOP(OP_CONST, o->op_flags,
1559 SvREFCNT_inc(cSVOPo->op_sv)));
1560 }
1561 }
1562 return rop;
1563}
1564
1565STATIC void
95f0a2f1 1566S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1567{
27da23d5 1568 dVAR;
09bef843
SB		 1569 SV *stashsv;
1570
1571 /* fake up C<use attributes $pkg,$rv,@attrs> */
1572 ENTER; /* need to protect against side-effects of 'use' */
1573 SAVEINT(PL_expect);
5aaec2b4 1574 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1575
09bef843 1576#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1577#define ATTRSMODULE_PM "attributes.pm"
1578
1579 if (for_my) {
95f0a2f1 1580 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1581 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1
SB		 1582 if (svp && *svp != &PL_sv_undef)
1583 ; /* already in %INC */
1584 else
1585 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1586 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1587 }
1588 else {
1589 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 1590 newSVpvs(ATTRSMODULE),
1591 NULL,
95f0a2f1
SB		 1592 prepend_elem(OP_LIST,
1593 newSVOP(OP_CONST, 0, stashsv),
1594 prepend_elem(OP_LIST,
1595 newSVOP(OP_CONST, 0,
1596 newRV(target)),
1597 dup_attrlist(attrs))));
1598 }
09bef843
SB		 1599 LEAVE;
1600}
1601
95f0a2f1
SB		 1602STATIC void
1603S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1604{
97aff369 1605 dVAR;
95f0a2f1
SB		 1606 OP *pack, *imop, *arg;
1607 SV *meth, *stashsv;
1608
1609 if (!attrs)
1610 return;
1611
1612 assert(target->op_type == OP_PADSV ||
1613 target->op_type == OP_PADHV ||
1614 target->op_type == OP_PADAV);
1615
1616 /* Ensure that attributes.pm is loaded. */
dd2155a4 1617 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1618
1619 /* Need package name for method call. */
6136c704 1620 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1621
1622 /* Build up the real arg-list. */
5aaec2b4
NC		 1623 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1624
95f0a2f1
SB		 1625 arg = newOP(OP_PADSV, 0);
1626 arg->op_targ = target->op_targ;
1627 arg = prepend_elem(OP_LIST,
1628 newSVOP(OP_CONST, 0, stashsv),
1629 prepend_elem(OP_LIST,
1630 newUNOP(OP_REFGEN, 0,
1631 mod(arg, OP_REFGEN)),
1632 dup_attrlist(attrs)));
1633
1634 /* Fake up a method call to import */
18916d0d 1635 meth = newSVpvs_share("import");
95f0a2f1
SB		 1636 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1637 append_elem(OP_LIST,
1638 prepend_elem(OP_LIST, pack, list(arg)),
1639 newSVOP(OP_METHOD_NAMED, 0, meth)));
1640 imop->op_private |= OPpENTERSUB_NOMOD;
1641
1642 /* Combine the ops. */
1643 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1644}
1645
1646/*
1647=notfor apidoc apply_attrs_string
1648
1649Attempts to apply a list of attributes specified by the C<attrstr> and
1650C<len> arguments to the subroutine identified by the C<cv> argument which
1651is expected to be associated with the package identified by the C<stashpv>
1652argument (see L<attributes>). It gets this wrong, though, in that it
1653does not correctly identify the boundaries of the individual attribute
1654specifications within C<attrstr>. This is not really intended for the
1655public API, but has to be listed here for systems such as AIX which
1656need an explicit export list for symbols. (It's called from XS code
1657in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1658to respect attribute syntax properly would be welcome.
1659
1660=cut
1661*/
1662
be3174d2 1663void
6867be6d
AL		 1664Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1665 const char *attrstr, STRLEN len)
be3174d2
GS		 1666{
1667 OP *attrs = Nullop;
1668
1669 if (!len) {
1670 len = strlen(attrstr);
1671 }
1672
1673 while (len) {
1674 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1675 if (len) {
890ce7af 1676 const char * const sstr = attrstr;
be3174d2
GS		 1677 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1678 attrs = append_elem(OP_LIST, attrs,
1679 newSVOP(OP_CONST, 0,
1680 newSVpvn(sstr, attrstr-sstr)));
1681 }
1682 }
1683
1684 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 1685 newSVpvs(ATTRSMODULE),
be3174d2
GS		 1686 Nullsv, prepend_elem(OP_LIST,
1687 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1688 prepend_elem(OP_LIST,
1689 newSVOP(OP_CONST, 0,
1690 newRV((SV*)cv)),
1691 attrs)));
1692}
1693
09bef843 1694STATIC OP *
95f0a2f1 1695S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1696{
97aff369 1697 dVAR;
93a17b20
LW		 1698 I32 type;
1699
3280af22 1700 if (!o || PL_error_count)
11343788 1701 return o;
93a17b20 1702
11343788 1703 type = o->op_type;
93a17b20 1704 if (type == OP_LIST) {
6867be6d 1705 OP *kid;
11343788 1706 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1707 my_kid(kid, attrs, imopsp);
dab48698 1708 } else if (type == OP_UNDEF) {
7766148a 1709 return o;
77ca0c92
LW		 1710 } else if (type == OP_RV2SV || /* "our" declaration */
1711 type == OP_RV2AV ||
1712 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS		 1713 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1714 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1715 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1716 } else if (attrs) {
551405c4 1717 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1ce0b88c 1718 PL_in_my = FALSE;
5c284bb0 1719 PL_in_my_stash = NULL;
1ce0b88c
RGS		 1720 apply_attrs(GvSTASH(gv),
1721 (type == OP_RV2SV ? GvSV(gv) :
1722 type == OP_RV2AV ? (SV*)GvAV(gv) :
1723 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1724 attrs, FALSE);
1725 }
192587c2 1726 o->op_private |= OPpOUR_INTRO;
77ca0c92 1727 return o;
95f0a2f1
SB		 1728 }
1729 else if (type != OP_PADSV &&
93a17b20
LW		 1730 type != OP_PADAV &&
1731 type != OP_PADHV &&
1732 type != OP_PUSHMARK)
1733 {
eb64745e 1734 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1735 OP_DESC(o),
eb64745e 1736 PL_in_my == KEY_our ? "our" : "my"));
11343788 1737 return o;
93a17b20 1738 }
09bef843
SB		 1739 else if (attrs && type != OP_PUSHMARK) {
1740 HV *stash;
09bef843 1741
eb64745e 1742 PL_in_my = FALSE;
5c284bb0 1743 PL_in_my_stash = NULL;
eb64745e 1744
09bef843 1745 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1746 stash = PAD_COMPNAME_TYPE(o->op_targ);
1747 if (!stash)
09bef843 1748 stash = PL_curstash;
95f0a2f1 1749 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1750 }
11343788
MB		 1751 o->op_flags |= OPf_MOD;
1752 o->op_private |= OPpLVAL_INTRO;
1753 return o;
93a17b20
LW		 1754}
1755
1756OP *
09bef843
SB		 1757Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1758{
97aff369 1759 dVAR;
0bd48802 1760 OP *rops;
95f0a2f1
SB		 1761 int maybe_scalar = 0;
1762
d2be0de5 1763/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1764 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1765#if 0
09bef843
SB		 1766 if (o->op_flags & OPf_PARENS)
1767 list(o);
95f0a2f1
SB		 1768 else
1769 maybe_scalar = 1;
d2be0de5
YST		 1770#else
1771 maybe_scalar = 1;
1772#endif
09bef843
SB		 1773 if (attrs)
1774 SAVEFREEOP(attrs);
0bd48802 1775 rops = Nullop;
95f0a2f1
SB		 1776 o = my_kid(o, attrs, &rops);
1777 if (rops) {
1778 if (maybe_scalar && o->op_type == OP_PADSV) {
1779 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1780 o->op_private |= OPpLVAL_INTRO;
1781 }
1782 else
1783 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1784 }
eb64745e 1785 PL_in_my = FALSE;
5c284bb0 1786 PL_in_my_stash = NULL;
eb64745e 1787 return o;
09bef843
SB		 1788}
1789
1790OP *
1791Perl_my(pTHX_ OP *o)
1792{
95f0a2f1 1793 return my_attrs(o, Nullop);
09bef843
SB		 1794}
1795
1796OP *
864dbfa3 1797Perl_sawparens(pTHX_ OP *o)
79072805
LW		 1798{
1799 if (o)
1800 o->op_flags |= OPf_PARENS;
1801 return o;
1802}
1803
1804OP *
864dbfa3 1805Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1806{
11343788 1807 OP *o;
59f00321 1808 bool ismatchop = 0;
79072805 1809
041457d9 1810 if ( (left->op_type == OP_RV2AV ||
599cee73
PM		 1811 left->op_type == OP_RV2HV ||
1812 left->op_type == OP_PADAV ||
041457d9
DM		 1813 left->op_type == OP_PADHV)
1814 && ckWARN(WARN_MISC))
1815 {
551405c4 1816 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 1817 right->op_type == OP_TRANS)
1818 ? right->op_type : OP_MATCH];
551405c4 1819 const char * const sample = ((left->op_type == OP_RV2AV ||
dff6d3cd
GS		 1820 left->op_type == OP_PADAV)
1821 ? "@array" : "%hash");
9014280d 1822 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1823 "Applying %s to %s will act on scalar(%s)",
599cee73 1824 desc, sample, sample);
2ae324a7 1825 }
1826
5cc9e5c9
RH		 1827 if (right->op_type == OP_CONST &&
1828 cSVOPx(right)->op_private & OPpCONST_BARE &&
1829 cSVOPx(right)->op_private & OPpCONST_STRICT)
1830 {
1831 no_bareword_allowed(right);
1832 }
1833
59f00321
RGS		 1834 ismatchop = right->op_type == OP_MATCH ||
1835 right->op_type == OP_SUBST ||
1836 right->op_type == OP_TRANS;
1837 if (ismatchop && right->op_private & OPpTARGET_MY) {
1838 right->op_targ = 0;
1839 right->op_private &= ~OPpTARGET_MY;
1840 }
1841 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1842 right->op_flags |= OPf_STACKED;
6fbb66d6
NC		 1843 if (right->op_type != OP_MATCH &&
1844 ! (right->op_type == OP_TRANS &&
1845 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1846 left = mod(left, right->op_type);
79072805 1847 if (right->op_type == OP_TRANS)
11343788 1848 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1849 else
11343788 1850 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1851 if (type == OP_NOT)
11343788
MB		 1852 return newUNOP(OP_NOT, 0, scalar(o));
1853 return o;
79072805
LW		 1854 }
1855 else
1856 return bind_match(type, left,
131b3ad0 1857 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 1858}
1859
1860OP *
864dbfa3 1861Perl_invert(pTHX_ OP *o)
79072805 1862{
11343788
MB		 1863 if (!o)
1864 return o;
79072805 1865 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1866 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1867}
1868
1869OP *
864dbfa3 1870Perl_scope(pTHX_ OP *o)
79072805 1871{
27da23d5 1872 dVAR;
79072805 1873 if (o) {
3280af22 1874 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1875 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1876 o->op_type = OP_LEAVE;
22c35a8c 1877 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1878 }
fdb22418
HS		 1879 else if (o->op_type == OP_LINESEQ) {
1880 OP *kid;
1881 o->op_type = OP_SCOPE;
1882 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1883 kid = ((LISTOP*)o)->op_first;
59110972 1884 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 1885 op_null(kid);
59110972
RH		 1886
1887 /* The following deals with things like 'do {1 for 1}' */
1888 kid = kid->op_sibling;
1889 if (kid &&
1890 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1891 op_null(kid);
1892 }
463ee0b2 1893 }
fdb22418
HS		 1894 else
1895 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
79072805
LW		 1896 }
1897 return o;
1898}
1899
a0d0e21e 1900int
864dbfa3 1901Perl_block_start(pTHX_ int full)
79072805 1902{
97aff369 1903 dVAR;
73d840c0 1904 const int retval = PL_savestack_ix;
dd2155a4 1905 pad_block_start(full);
b3ac6de7 1906 SAVEHINTS();
3280af22 1907 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1908 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1909 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 1910 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1911 SAVEFREESV(PL_compiling.cop_warnings) ;
1912 }
ac27b0f5
NIS		 1913 SAVESPTR(PL_compiling.cop_io);
1914 if (! specialCopIO(PL_compiling.cop_io)) {
1915 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1916 SAVEFREESV(PL_compiling.cop_io) ;
1917 }
a0d0e21e
LW		 1918 return retval;
1919}
1920
1921OP*
864dbfa3 1922Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1923{
97aff369 1924 dVAR;
6867be6d 1925 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 1926 OP* const retval = scalarseq(seq);
e9818f4e 1927 LEAVE_SCOPE(floor);
eb160463 1928 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1929 if (needblockscope)
3280af22 1930 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1931 pad_leavemy();
a0d0e21e
LW		 1932 return retval;
1933}
1934
76e3520e 1935STATIC OP *
cea2e8a9 1936S_newDEFSVOP(pTHX)
54b9620d 1937{
97aff369 1938 dVAR;
6867be6d 1939 const I32 offset = pad_findmy("$_");
59f00321
RGS		 1940 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1941 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1942 }
1943 else {
551405c4 1944 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 1945 o->op_targ = offset;
1946 return o;
1947 }
54b9620d
MB		 1948}
1949
a0d0e21e 1950void
864dbfa3 1951Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1952{
97aff369 1953 dVAR;
3280af22 1954 if (PL_in_eval) {
b295d113
TH		 1955 if (PL_eval_root)
1956 return;
faef0170
HS		 1957 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1958 ((PL_in_eval & EVAL_KEEPERR)
1959 ? OPf_SPECIAL : 0), o);
3280af22 1960 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 1961 PL_eval_root->op_private |= OPpREFCOUNTED;
1962 OpREFCNT_set(PL_eval_root, 1);
3280af22 1963 PL_eval_root->op_next = 0;
a2efc822 1964 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 1965 }
1966 else {
6be89cf9
AE		 1967 if (o->op_type == OP_STUB) {
1968 PL_comppad_name = 0;
1969 PL_compcv = 0;
2a4f803a 1970 FreeOp(o);
a0d0e21e 1971 return;
6be89cf9 1972 }
3280af22
NIS		 1973 PL_main_root = scope(sawparens(scalarvoid(o)));
1974 PL_curcop = &PL_compiling;
1975 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 1976 PL_main_root->op_private |= OPpREFCOUNTED;
1977 OpREFCNT_set(PL_main_root, 1);
3280af22 1978 PL_main_root->op_next = 0;
a2efc822 1979 CALL_PEEP(PL_main_start);
3280af22 1980 PL_compcv = 0;
3841441e 1981
4fdae800 1982 /* Register with debugger */
84902520 1983 if (PERLDB_INTER) {
551405c4 1984 CV * const cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 1985 if (cv) {
1986 dSP;
924508f0 1987 PUSHMARK(SP);
cc49e20b 1988 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1989 PUTBACK;
864dbfa3 1990 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 1991 }
1992 }
79072805 1993 }
79072805
LW		 1994}
1995
1996OP *
864dbfa3 1997Perl_localize(pTHX_ OP *o, I32 lex)
79072805 1998{
97aff369 1999 dVAR;
79072805 2000 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2001/* [perl #17376]: this appears to be premature, and results in code such as
2002 C< our(%x); > executing in list mode rather than void mode */
2003#if 0
79072805 2004 list(o);
d2be0de5
YST		 2005#else
2006 ;
2007#endif
8990e307 2008 else {
041457d9
DM		 2009 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2010 && ckWARN(WARN_PARENTHESIS))
64420d0d
JH		 2011 {
2012 char *s = PL_bufptr;
bac662ee 2013 bool sigil = FALSE;
64420d0d 2014
8473848f 2015 /* some heuristics to detect a potential error */
bac662ee 2016 while (*s && (strchr(", \t\n", *s)))
64420d0d 2017 s++;
8473848f 2018
bac662ee
TS		 2019 while (1) {
2020 if (*s && strchr("@$%*", *s) && *++s
2021 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2022 s++;
2023 sigil = TRUE;
2024 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2025 s++;
2026 while (*s && (strchr(", \t\n", *s)))
2027 s++;
2028 }
2029 else
2030 break;
2031 }
2032 if (sigil && (*s == ';' || *s == '=')) {
2033 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS		 2034 "Parentheses missing around \"%s\" list",
2035 lex ? (PL_in_my == KEY_our ? "our" : "my")
2036 : "local");
2037 }
8990e307
LW		 2038 }
2039 }
93a17b20 2040 if (lex)
eb64745e 2041 o = my(o);
93a17b20 2042 else
eb64745e
GS		 2043 o = mod(o, OP_NULL); /* a bit kludgey */
2044 PL_in_my = FALSE;
5c284bb0 2045 PL_in_my_stash = NULL;
eb64745e 2046 return o;
79072805
LW		 2047}
2048
2049OP *
864dbfa3 2050Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2051{
2052 if (o->op_type == OP_LIST) {
5c1737d1
NC		 2053 OP * const o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD,
2054 SVt_PV)));
554b3eca 2055 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2056 }
2057 return o;
2058}
2059
2060OP *
864dbfa3 2061Perl_fold_constants(pTHX_ register OP *o)
79072805 2062{
27da23d5 2063 dVAR;
79072805
LW		 2064 register OP *curop;
2065 I32 type = o->op_type;
748a9306 2066 SV *sv;
79072805 2067
22c35a8c 2068 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2069 scalar(o);
b162f9ea 2070 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2071 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2072
eac055e9
GS		 2073 /* integerize op, unless it happens to be C<-foo>.
2074 * XXX should pp_i_negate() do magic string negation instead? */
2075 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2076 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2077 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2078 {
22c35a8c 2079 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2080 }
85e6fe83 2081
22c35a8c 2082 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2083 goto nope;
2084
de939608 2085 switch (type) {
7a52d87a
GS		 2086 case OP_NEGATE:
2087 /* XXX might want a ck_negate() for this */
2088 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2089 break;
de939608
CS		 2090 case OP_UCFIRST:
2091 case OP_LCFIRST:
2092 case OP_UC:
2093 case OP_LC:
69dcf70c
MB		 2094 case OP_SLT:
2095 case OP_SGT:
2096 case OP_SLE:
2097 case OP_SGE:
2098 case OP_SCMP:
2de3dbcc
JH		 2099 /* XXX what about the numeric ops? */
2100 if (PL_hints & HINT_LOCALE)
de939608
CS		 2101 goto nope;
2102 }
2103
3280af22 2104 if (PL_error_count)
a0d0e21e
LW		 2105 goto nope; /* Don't try to run w/ errors */
2106
79072805 2107 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 2108 if ((curop->op_type != OP_CONST ||
2109 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 2110 curop->op_type != OP_LIST &&
2111 curop->op_type != OP_SCALAR &&
2112 curop->op_type != OP_NULL &&
2113 curop->op_type != OP_PUSHMARK)
2114 {
79072805
LW		 2115 goto nope;
2116 }
2117 }
2118
2119 curop = LINKLIST(o);
2120 o->op_next = 0;
533c011a 2121 PL_op = curop;
cea2e8a9 2122 CALLRUNOPS(aTHX);
3280af22 2123 sv = *(PL_stack_sp--);
748a9306 2124 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 2125 pad_swipe(o->op_targ, FALSE);
748a9306
LW		 2126 else if (SvTEMP(sv)) { /* grab mortal temp? */
2127 (void)SvREFCNT_inc(sv);
2128 SvTEMP_off(sv);
85e6fe83 2129 }
79072805
LW		 2130 op_free(o);
2131 if (type == OP_RV2GV)
b1cb66bf 2132 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 2133 return newSVOP(OP_CONST, 0, sv);
aeea060c 2134
79072805 2135 nope:
79072805
LW		 2136 return o;
2137}
2138
2139OP *
864dbfa3 2140Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2141{
27da23d5 2142 dVAR;
79072805 2143 register OP *curop;
6867be6d 2144 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2145
a0d0e21e 2146 list(o);
3280af22 2147 if (PL_error_count)
a0d0e21e
LW		 2148 return o; /* Don't attempt to run with errors */
2149
533c011a 2150 PL_op = curop = LINKLIST(o);
a0d0e21e 2151 o->op_next = 0;
a2efc822 2152 CALL_PEEP(curop);
cea2e8a9
GS		 2153 pp_pushmark();
2154 CALLRUNOPS(aTHX);
533c011a 2155 PL_op = curop;
cea2e8a9 2156 pp_anonlist();
3280af22 2157 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2158
2159 o->op_type = OP_RV2AV;
22c35a8c 2160 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2161 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2162 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2163 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2164 curop = ((UNOP*)o)->op_first;
3280af22 2165 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2166 op_free(curop);
79072805
LW		 2167 linklist(o);
2168 return list(o);
2169}
2170
2171OP *
864dbfa3 2172Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2173{
27da23d5 2174 dVAR;
11343788
MB		 2175 if (!o || o->op_type != OP_LIST)
2176 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2177 else
5dc0d613 2178 o->op_flags &= ~OPf_WANT;
79072805 2179
22c35a8c 2180 if (!(PL_opargs[type] & OA_MARK))
93c66552 2181 op_null(cLISTOPo->op_first);
8990e307 2182
eb160463 2183 o->op_type = (OPCODE)type;
22c35a8c 2184 o->op_ppaddr = PL_ppaddr[type];
11343788 2185 o->op_flags |= flags;
79072805 2186
11343788 2187 o = CHECKOP(type, o);
fe2774ed 2188 if (o->op_type != (unsigned)type)
11343788 2189 return o;
79072805 2190
11343788 2191 return fold_constants(o);
79072805
LW		 2192}
2193
2194/* List constructors */
2195
2196OP *
864dbfa3 2197Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2198{
2199 if (!first)
2200 return last;
8990e307
LW		 2201
2202 if (!last)
79072805 2203 return first;
8990e307 2204
fe2774ed 2205 if (first->op_type != (unsigned)type
155aba94
GS		 2206 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2207 {
2208 return newLISTOP(type, 0, first, last);
2209 }
79072805 2210
a0d0e21e
LW		 2211 if (first->op_flags & OPf_KIDS)
2212 ((LISTOP*)first)->op_last->op_sibling = last;
2213 else {
2214 first->op_flags |= OPf_KIDS;
2215 ((LISTOP*)first)->op_first = last;
2216 }
2217 ((LISTOP*)first)->op_last = last;
a0d0e21e 2218 return first;
79072805
LW		 2219}
2220
2221OP *
864dbfa3 2222Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2223{
2224 if (!first)
2225 return (OP*)last;
8990e307
LW		 2226
2227 if (!last)
79072805 2228 return (OP*)first;
8990e307 2229
fe2774ed 2230 if (first->op_type != (unsigned)type)
79072805 2231 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2232
fe2774ed 2233 if (last->op_type != (unsigned)type)
79072805
LW		 2234 return append_elem(type, (OP*)first, (OP*)last);
2235
2236 first->op_last->op_sibling = last->op_first;
2237 first->op_last = last->op_last;
117dada2 2238 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2239
238a4c30
NIS		 2240 FreeOp(last);
2241
79072805
LW		 2242 return (OP*)first;
2243}
2244
2245OP *
864dbfa3 2246Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2247{
2248 if (!first)
2249 return last;
8990e307
LW		 2250
2251 if (!last)
79072805 2252 return first;
8990e307 2253
fe2774ed 2254 if (last->op_type == (unsigned)type) {
8990e307
LW		 2255 if (type == OP_LIST) { /* already a PUSHMARK there */
2256 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2257 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2258 if (!(first->op_flags & OPf_PARENS))
2259 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2260 }
2261 else {
2262 if (!(last->op_flags & OPf_KIDS)) {
2263 ((LISTOP*)last)->op_last = first;
2264 last->op_flags |= OPf_KIDS;
2265 }
2266 first->op_sibling = ((LISTOP*)last)->op_first;
2267 ((LISTOP*)last)->op_first = first;
79072805 2268 }
117dada2 2269 last->op_flags |= OPf_KIDS;
79072805
LW		 2270 return last;
2271 }
2272
2273 return newLISTOP(type, 0, first, last);
2274}
2275
2276/* Constructors */
2277
2278OP *
864dbfa3 2279Perl_newNULLLIST(pTHX)
79072805 2280{
8990e307
LW		 2281 return newOP(OP_STUB, 0);
2282}
2283
2284OP *
864dbfa3 2285Perl_force_list(pTHX_ OP *o)
8990e307 2286{
11343788
MB		 2287 if (!o || o->op_type != OP_LIST)
2288 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2289 op_null(o);
11343788 2290 return o;
79072805
LW		 2291}
2292
2293OP *
864dbfa3 2294Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2295{
27da23d5 2296 dVAR;
79072805
LW		 2297 LISTOP *listop;
2298
b7dc083c 2299 NewOp(1101, listop, 1, LISTOP);
79072805 2300
eb160463 2301 listop->op_type = (OPCODE)type;
22c35a8c 2302 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2303 if (first || last)
2304 flags |= OPf_KIDS;
eb160463 2305 listop->op_flags = (U8)flags;
79072805
LW		 2306
2307 if (!last && first)
2308 last = first;
2309 else if (!first && last)
2310 first = last;
8990e307
LW		 2311 else if (first)
2312 first->op_sibling = last;
79072805
LW		 2313 listop->op_first = first;
2314 listop->op_last = last;
8990e307 2315 if (type == OP_LIST) {
551405c4 2316 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2317 pushop->op_sibling = first;
2318 listop->op_first = pushop;
2319 listop->op_flags |= OPf_KIDS;
2320 if (!last)
2321 listop->op_last = pushop;
2322 }
79072805 2323
463d09e6 2324 return CHECKOP(type, listop);
79072805
LW		 2325}
2326
2327OP *
864dbfa3 2328Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2329{
27da23d5 2330 dVAR;
11343788 2331 OP *o;
b7dc083c 2332 NewOp(1101, o, 1, OP);
eb160463 2333 o->op_type = (OPCODE)type;
22c35a8c 2334 o->op_ppaddr = PL_ppaddr[type];
eb160463 2335 o->op_flags = (U8)flags;
79072805 2336
11343788 2337 o->op_next = o;
eb160463 2338 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2339 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2340 scalar(o);
22c35a8c 2341 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2342 o->op_targ = pad_alloc(type, SVs_PADTMP);
2343 return CHECKOP(type, o);
79072805
LW		 2344}
2345
2346OP *
864dbfa3 2347Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2348{
27da23d5 2349 dVAR;
79072805
LW		 2350 UNOP *unop;
2351
93a17b20 2352 if (!first)
aeea060c 2353 first = newOP(OP_STUB, 0);
22c35a8c 2354 if (PL_opargs[type] & OA_MARK)
8990e307 2355 first = force_list(first);
93a17b20 2356
b7dc083c 2357 NewOp(1101, unop, 1, UNOP);
eb160463 2358 unop->op_type = (OPCODE)type;
22c35a8c 2359 unop->op_ppaddr = PL_ppaddr[type];
79072805 2360 unop->op_first = first;
585ec06d 2361 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2362 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2363 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2364 if (unop->op_next)
2365 return (OP*)unop;
2366
a0d0e21e 2367 return fold_constants((OP *) unop);
79072805
LW		 2368}
2369
2370OP *
864dbfa3 2371Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2372{
27da23d5 2373 dVAR;
79072805 2374 BINOP *binop;
b7dc083c 2375 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2376
2377 if (!first)
2378 first = newOP(OP_NULL, 0);
2379
eb160463 2380 binop->op_type = (OPCODE)type;
22c35a8c 2381 binop->op_ppaddr = PL_ppaddr[type];
79072805 2382 binop->op_first = first;
585ec06d 2383 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2384 if (!last) {
2385 last = first;
eb160463 2386 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2387 }
2388 else {
eb160463 2389 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2390 first->op_sibling = last;
2391 }
2392
e50aee73 2393 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2394 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2395 return (OP*)binop;
2396
7284ab6f 2397 binop->op_last = binop->op_first->op_sibling;
79072805 2398
a0d0e21e 2399 return fold_constants((OP *)binop);
79072805
LW		 2400}
2401
abb2c242
JH		 2402static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
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;
131b3ad0
DM		 2787 OP* repl = Nullop;
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;
2797 kid->op_sibling = Nullop;
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
DM		 2806 expr = cLISTOPx(oe)->op_first->op_sibling;
2807 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2808 cLISTOPx(oe)->op_last = Nullop;
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
SM		 2924 else if (curop->op_type == OP_PUSHRE)
2925 ; /* 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
b1cb66bf 3068 veop = Nullop;
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)) {
b1cb66bf 3099 imop = Nullop; /* 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")),
4633a7c4 3121 Nullop,
09bef843 3122 Nullop,
a0d0e21e 3123 append_elem(OP_LINESEQ,
b1cb66bf 3124 append_elem(OP_LINESEQ,
88d95a4d 3125 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 3126 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3127 newSTATEOP(0, Nullch, 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
3201 veop = Nullop;
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;
3210 imop = Nullop;
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;
850e8516 3235 GV *gv = Nullgv;
78ca652e 3236
850e8516 3237 if (!force_builtin) {
5c1737d1 3238 gv = gv_fetchpvs("do", 0, SVt_PVCV);
850e8516 3239 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 3240 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
551405c4 3241 gv = gvp ? *gvp : Nullgv;
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;
3424 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
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 */
3429 tmpop->op_sibling = Nullop; /* don't free split */
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;
3565 cUNOPo->op_first = Nullop;
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);
883ffac3 3578 *firstp = Nullop;
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);
883ffac3 3602 *otherp = Nullop;
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);
883ffac3 3907 return Nullop; /* 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
LW		 3962 op_free(sv);
3963 sv = Nullop;
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);
3970 sv = Nullop;
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("$_");
aabe9514
RGS		 3979 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
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;
4006 range->op_first = Nullop;
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
35f1c1c7
SB		 4264 if (CvFILE(cv) && !CvXSUB(cv)) {
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
a0d0e21e
LW		 4271 if (!CvXSUB(cv) && CvROOT(cv)) {
4272 if (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));
79072805 4279 CvROOT(cv) = Nullop;
8f476eee 4280 CvSTART(cv) = Nullop;
8990e307 4281 LEAVE;
79072805 4282 }
1d5db326 4283 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 4284 CvGV(cv) = Nullgv;
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));
4292 CvOUTSIDE(cv) = Nullcv;
4293 }
beab0874
JT		 4294 if (CvCONST(cv)) {
4295 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4296 CvCONST_off(cv);
4297 }
50762d59
DM		 4298 if (CvXSUB(cv)) {
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();
3fe9a6f1 4310 SV* name = Nullsv;
4311
4312 if (gv)
46fc3d4c 4313 gv_efullname3(name = sv_newmortal(), gv, Nullch);
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;
fe5e78ed
GS		 4380 SV *sv = Nullsv;
4381
0f79a09d 4382 if (!o)
fe5e78ed 4383 return Nullsv;
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)
4402 return Nullsv;
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
JT		 4407 if (!sv)
4408 return Nullsv;
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)
4416 return Nullsv;
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 {
54310121 4427 return Nullsv;
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{
09bef843
SB		 4452 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
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;
8b6b16e7 4473 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
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
4480 ps = Nullch;
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
4490 aname = Nullch;
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
beab0874
JT		 4524 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
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))
beab0874
JT		 4533 const_sv = Nullsv;
4534 else
4535 const_sv = op_const_sv(block, Nullcv);
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);
4577 cv = Nullcv;
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);
beab0874
JT		 4589 }
4590 else {
4591 GvCV(gv) = Nullcv;
4592 cv = newCONSTSUB(NULL, name, const_sv);
4593 }
4594 op_free(block);
4595 SvREFCNT_dec(PL_compcv);
4596 PL_compcv = NULL;
4597 PL_sub_generation++;
4598 goto done;
4599 }
09bef843
SB		 4600 if (attrs) {
4601 HV *stash;
4602 SV *rcv;
4603
4604 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4605 * before we clobber PL_compcv.
4606 */
4607 if (cv && !block) {
4608 rcv = (SV*)cv;
020f0e03
SB		 4609 /* Might have had built-in attributes applied -- propagate them. */
4610 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4611 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4612 stash = GvSTASH(CvGV(cv));
a9164de8 4613 else if (CvSTASH(cv))
09bef843
SB		 4614 stash = CvSTASH(cv);
4615 else
4616 stash = PL_curstash;
4617 }
4618 else {
4619 /* possibly about to re-define existing subr -- ignore old cv */
4620 rcv = (SV*)PL_compcv;
a9164de8 4621 if (name && GvSTASH(gv))
09bef843
SB		 4622 stash = GvSTASH(gv);
4623 else
4624 stash = PL_curstash;
4625 }
95f0a2f1 4626 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4627 }
a0d0e21e 4628 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4629 if (!block) {
4630 /* got here with just attrs -- work done, so bug out */
4631 SAVEFREESV(PL_compcv);
4632 goto done;
4633 }
a3985cdc 4634 /* transfer PL_compcv to cv */
4633a7c4 4635 cv_undef(cv);
3280af22 4636 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 4637 if (!CvWEAKOUTSIDE(cv))
4638 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 4639 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4640 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4641 CvOUTSIDE(PL_compcv) = 0;
4642 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4643 CvPADLIST(PL_compcv) = 0;
282f25c9 4644 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4645 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4646 /* ... before we throw it away */
3280af22 4647 SvREFCNT_dec(PL_compcv);
b5c19bd7 4648 PL_compcv = cv;
a933f601
IZ		 4649 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4650 ++PL_sub_generation;
a0d0e21e
LW		 4651 }
4652 else {
3280af22 4653 cv = PL_compcv;
44a8e56a 4654 if (name) {
4655 GvCV(gv) = cv;
4656 GvCVGEN(gv) = 0;
3280af22 4657 PL_sub_generation++;
44a8e56a 4658 }
a0d0e21e 4659 }
65c50114 4660 CvGV(cv) = gv;
a636914a 4661 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4662 CvSTASH(cv) = PL_curstash;
8990e307 4663
3fe9a6f1 4664 if (ps)
ea6e9374 4665 sv_setpvn((SV*)cv, ps, ps_len);
4633a7c4 4666
3280af22 4667 if (PL_error_count) {
c07a80fd 4668 op_free(block);
4669 block = Nullop;
68dc0745 4670 if (name) {
6867be6d 4671 const char *s = strrchr(name, ':');
68dc0745 4672 s = s ? s+1 : name;
6d4c2119 4673 if (strEQ(s, "BEGIN")) {
e1ec3a88 4674 const char not_safe[] =
6d4c2119 4675 "BEGIN not safe after errors--compilation aborted";
faef0170 4676 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4677 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4678 else {
4679 /* force display of errors found but not reported */
38a03e6e 4680 sv_catpv(ERRSV, not_safe);
35c1215d 4681 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4682 }
4683 }
68dc0745 4684 }
c07a80fd 4685 }
beab0874
JT		 4686 if (!block)
4687 goto done;
a0d0e21e 4688
7766f137 4689 if (CvLVALUE(cv)) {
78f9721b
SM		 4690 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4691 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4692 }
4693 else {
09c2fd24
AE		 4694 /* This makes sub {}; work as expected. */
4695 if (block->op_type == OP_STUB) {
4696 op_free(block);
4697 block = newSTATEOP(0, Nullch, 0);
4698 }
7766f137
GS		 4699 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4700 }
4701 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4702 OpREFCNT_set(CvROOT(cv), 1);
4703 CvSTART(cv) = LINKLIST(CvROOT(cv));
4704 CvROOT(cv)->op_next = 0;
a2efc822 4705 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4706
4707 /* now that optimizer has done its work, adjust pad values */
54310121 4708
dd2155a4
DM		 4709 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4710
4711 if (CvCLONE(cv)) {
beab0874
JT		 4712 assert(!CvCONST(cv));
4713 if (ps && !*ps && op_const_sv(block, cv))
4714 CvCONST_on(cv);
a0d0e21e 4715 }
79072805 4716
83ee9e09 4717 if (name || aname) {
6867be6d 4718 const char *s;
0bd48802 4719 const char * const tname = (name ? name : aname);
44a8e56a 4720
3280af22 4721 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 4722 SV * const sv = newSV(0);
c4420975 4723 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 4724 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4725 GV_ADDMULTI, SVt_PVHV);
44a8e56a 4726 HV *hv;
4727
ed094faf
GS		 4728 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4729 CopFILE(PL_curcop),
cc49e20b 4730 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4731 gv_efullname3(tmpstr, gv, Nullch);
b15aece3 4732 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4733 hv = GvHVn(db_postponed);
551405c4
AL		 4734 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4735 CV * const pcv = GvCV(db_postponed);
4736 if (pcv) {
4737 dSP;
4738 PUSHMARK(SP);
4739 XPUSHs(tmpstr);
4740 PUTBACK;
4741 call_sv((SV*)pcv, G_DISCARD);
4742 }
44a8e56a 4743 }
4744 }
79072805 4745
83ee9e09 4746 if ((s = strrchr(tname,':')))
28757baa 4747 s++;
4748 else
83ee9e09 4749 s = tname;
ed094faf 4750
7d30b5c4 4751 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4752 goto done;
4753
7678c486 4754 if (strEQ(s, "BEGIN") && !PL_error_count) {
6867be6d 4755 const I32 oldscope = PL_scopestack_ix;
28757baa 4756 ENTER;
57843af0
GS		 4757 SAVECOPFILE(&PL_compiling);
4758 SAVECOPLINE(&PL_compiling);
28757baa 4759
3280af22
NIS		 4760 if (!PL_beginav)
4761 PL_beginav = newAV();
28757baa 4762 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4763 av_push(PL_beginav, (SV*)cv);
4764 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4765 call_list(oldscope, PL_beginav);
a6006777 4766
3280af22 4767 PL_curcop = &PL_compiling;
eb160463 4768 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4769 LEAVE;
4770 }
3280af22
NIS		 4771 else if (strEQ(s, "END") && !PL_error_count) {
4772 if (!PL_endav)
4773 PL_endav = newAV();
ed094faf 4774 DEBUG_x( dump_sub(gv) );
3280af22 4775 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4776 av_store(PL_endav, 0, (SV*)cv);
4777 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4778 }
7d30b5c4
GS		 4779 else if (strEQ(s, "CHECK") && !PL_error_count) {
4780 if (!PL_checkav)
4781 PL_checkav = newAV();
ed094faf 4782 DEBUG_x( dump_sub(gv) );
ddda08b7 4783 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4784 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4785 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4786 av_store(PL_checkav, 0, (SV*)cv);
4787 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4788 }
3280af22
NIS		 4789 else if (strEQ(s, "INIT") && !PL_error_count) {
4790 if (!PL_initav)
4791 PL_initav = newAV();
ed094faf 4792 DEBUG_x( dump_sub(gv) );
ddda08b7 4793 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4794 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4795 av_push(PL_initav, (SV*)cv);
4796 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4797 }
79072805 4798 }
a6006777 4799
aa689395 4800 done:
3280af22 4801 PL_copline = NOLINE;
8990e307 4802 LEAVE_SCOPE(floor);
a0d0e21e 4803 return cv;
79072805
LW		 4804}
4805
b099ddc0 4806/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4807/*
4808=for apidoc newCONSTSUB
4809
4810Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4811eligible for inlining at compile-time.
4812
4813=cut
4814*/
4815
beab0874 4816CV *
e1ec3a88 4817Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 4818{
27da23d5 4819 dVAR;
beab0874 4820 CV* cv;
5476c433 4821
11faa288 4822 ENTER;
11faa288 4823
f4dd75d9 4824 SAVECOPLINE(PL_curcop);
11faa288 4825 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4826
4827 SAVEHINTS();
3280af22 4828 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4829
4830 if (stash) {
4831 SAVESPTR(PL_curstash);
4832 SAVECOPSTASH(PL_curcop);
4833 PL_curstash = stash;
05ec9bb3 4834 CopSTASH_set(PL_curcop,stash);
11faa288 4835 }
5476c433 4836
91a15d0d 4837 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4838 CvXSUBANY(cv).any_ptr = sv;
4839 CvCONST_on(cv);
c69006e4 4840 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5476c433 4841
65e66c80 4842#ifdef USE_ITHREADS
02f28d44
MHM		 4843 if (stash)
4844 CopSTASH_free(PL_curcop);
65e66c80 4845#endif
11faa288 4846 LEAVE;
beab0874
JT		 4847
4848 return cv;
5476c433
JD		 4849}
4850
954c1994
GS		 4851/*
4852=for apidoc U||newXS
4853
4854Used by C<xsubpp> to hook up XSUBs as Perl subs.
4855
4856=cut
4857*/
4858
57d3b86d 4859CV *
bfed75c6 4860Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 4861{
97aff369 4862 dVAR;
9a957fbc 4863 GV * const gv = gv_fetchpv(name ? name :
c99da370
JH		 4864 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4865 GV_ADDMULTI, SVt_PVCV);
79072805 4866 register CV *cv;
44a8e56a 4867
1ecdd9a8
HS		 4868 if (!subaddr)
4869 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4870
155aba94 4871 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4872 if (GvCVGEN(gv)) {
4873 /* just a cached method */
4874 SvREFCNT_dec(cv);
66a1b24b 4875 cv = Nullcv;
44a8e56a 4876 }
4877 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4878 /* already defined (or promised) */
1df70142 4879 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 4880 if (ckWARN(WARN_REDEFINE)) {
4881 GV * const gvcv = CvGV(cv);
4882 if (gvcv) {
4883 HV * const stash = GvSTASH(gvcv);
4884 if (stash) {
4885 const char *name = HvNAME_get(stash);
4886 if ( strEQ(name,"autouse") ) {
4887 const line_t oldline = CopLINE(PL_curcop);
4888 if (PL_copline != NOLINE)
4889 CopLINE_set(PL_curcop, PL_copline);
4890 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4891 CvCONST(cv) ? "Constant subroutine %s redefined"
4892 : "Subroutine %s redefined"
4893 ,name);
4894 CopLINE_set(PL_curcop, oldline);
4895 }
4896 }
4897 }
a0d0e21e
LW		 4898 }
4899 SvREFCNT_dec(cv);
66a1b24b 4900 cv = Nullcv;
79072805 4901 }
79072805 4902 }
44a8e56a 4903
4904 if (cv) /* must reuse cv if autoloaded */
4905 cv_undef(cv);
a0d0e21e 4906 else {
561b68a9 4907 cv = (CV*)newSV(0);
a0d0e21e 4908 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4909 if (name) {
4910 GvCV(gv) = cv;
4911 GvCVGEN(gv) = 0;
3280af22 4912 PL_sub_generation++;
44a8e56a 4913 }
a0d0e21e 4914 }
65c50114 4915 CvGV(cv) = gv;
b195d487 4916 (void)gv_fetchfile(filename);
dd374669 4917 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 4918 an external constant string */
a0d0e21e 4919 CvXSUB(cv) = subaddr;
44a8e56a 4920
28757baa 4921 if (name) {
e1ec3a88 4922 const char *s = strrchr(name,':');
28757baa 4923 if (s)
4924 s++;
4925 else
4926 s = name;
ed094faf 4927
7d30b5c4 4928 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4929 goto done;
4930
28757baa 4931 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4932 if (!PL_beginav)
4933 PL_beginav = newAV();
ea2f84a3
GS		 4934 av_push(PL_beginav, (SV*)cv);
4935 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4936 }
4937 else if (strEQ(s, "END")) {
3280af22
NIS		 4938 if (!PL_endav)
4939 PL_endav = newAV();
4940 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4941 av_store(PL_endav, 0, (SV*)cv);
4942 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4943 }
7d30b5c4
GS		 4944 else if (strEQ(s, "CHECK")) {
4945 if (!PL_checkav)
4946 PL_checkav = newAV();
ddda08b7 4947 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4948 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4949 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4950 av_store(PL_checkav, 0, (SV*)cv);
4951 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4952 }
7d07dbc2 4953 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4954 if (!PL_initav)
4955 PL_initav = newAV();
ddda08b7 4956 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4957 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4958 av_push(PL_initav, (SV*)cv);
4959 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4960 }
28757baa 4961 }
8990e307 4962 else
a5f75d66 4963 CvANON_on(cv);
44a8e56a 4964
ed094faf 4965done:
a0d0e21e 4966 return cv;
79072805
LW		 4967}
4968
4969void
864dbfa3 4970Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 4971{
97aff369 4972 dVAR;
79072805 4973 register CV *cv;
79072805 4974
0bd48802 4975 GV * const gv = o
f776e3cd 4976 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5c1737d1 4977 : gv_fetchpvs("STDOUT", GV_ADD, SVt_PVFM);
0bd48802 4978
7fb37951
AMS		 4979#ifdef GV_UNIQUE_CHECK
4980 if (GvUNIQUE(gv)) {
4981 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4982 }
4983#endif
a5f75d66 4984 GvMULTI_on(gv);
155aba94 4985 if ((cv = GvFORM(gv))) {
599cee73 4986 if (ckWARN(WARN_REDEFINE)) {
6867be6d 4987 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4988 if (PL_copline != NOLINE)
4989 CopLINE_set(PL_curcop, PL_copline);
7a5fd60d
NC		 4990 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4991 o ? "Format %"SVf" redefined"
4992 : "Format STDOUT redefined" ,cSVOPo->op_sv);
57843af0 4993 CopLINE_set(PL_curcop, oldline);
79072805 4994 }
8990e307 4995 SvREFCNT_dec(cv);
79072805 4996 }
3280af22 4997 cv = PL_compcv;
79072805 4998 GvFORM(gv) = cv;
65c50114 4999 CvGV(cv) = gv;
a636914a 5000 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5001
a0d0e21e 5002
dd2155a4 5003 pad_tidy(padtidy_FORMAT);
79072805 5004 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5005 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5006 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5007 CvSTART(cv) = LINKLIST(CvROOT(cv));
5008 CvROOT(cv)->op_next = 0;
a2efc822 5009 CALL_PEEP(CvSTART(cv));
11343788 5010 op_free(o);
3280af22 5011 PL_copline = NOLINE;
8990e307 5012 LEAVE_SCOPE(floor);
79072805
LW		 5013}
5014
5015OP *
864dbfa3 5016Perl_newANONLIST(pTHX_ OP *o)
79072805 5017{
93a17b20 5018 return newUNOP(OP_REFGEN, 0,
11343788 5019 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 5020}
5021
5022OP *
864dbfa3 5023Perl_newANONHASH(pTHX_ OP *o)
79072805 5024{
93a17b20 5025 return newUNOP(OP_REFGEN, 0,
11343788 5026 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 5027}
5028
5029OP *
864dbfa3 5030Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5031{
09bef843
SB		 5032 return newANONATTRSUB(floor, proto, Nullop, block);
5033}
5034
5035OP *
5036Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5037{
a0d0e21e 5038 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5039 newSVOP(OP_ANONCODE, 0,
5040 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5041}
5042
5043OP *
864dbfa3 5044Perl_oopsAV(pTHX_ OP *o)
79072805 5045{
27da23d5 5046 dVAR;
ed6116ce
LW		 5047 switch (o->op_type) {
5048 case OP_PADSV:
5049 o->op_type = OP_PADAV;
22c35a8c 5050 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5051 return ref(o, OP_RV2AV);
b2ffa427 5052
ed6116ce 5053 case OP_RV2SV:
79072805 5054 o->op_type = OP_RV2AV;
22c35a8c 5055 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5056 ref(o, OP_RV2AV);
ed6116ce
LW		 5057 break;
5058
5059 default:
0453d815 5060 if (ckWARN_d(WARN_INTERNAL))
9014280d 5061 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 5062 break;
5063 }
79072805
LW		 5064 return o;
5065}
5066
5067OP *
864dbfa3 5068Perl_oopsHV(pTHX_ OP *o)
79072805 5069{
27da23d5 5070 dVAR;
ed6116ce
LW		 5071 switch (o->op_type) {
5072 case OP_PADSV:
5073 case OP_PADAV:
5074 o->op_type = OP_PADHV;
22c35a8c 5075 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5076 return ref(o, OP_RV2HV);
ed6116ce
LW		 5077
5078 case OP_RV2SV:
5079 case OP_RV2AV:
79072805 5080 o->op_type = OP_RV2HV;
22c35a8c 5081 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5082 ref(o, OP_RV2HV);
ed6116ce
LW		 5083 break;
5084
5085 default:
0453d815 5086 if (ckWARN_d(WARN_INTERNAL))
9014280d 5087 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 5088 break;
5089 }
79072805
LW		 5090 return o;
5091}
5092
5093OP *
864dbfa3 5094Perl_newAVREF(pTHX_ OP *o)
79072805 5095{
27da23d5 5096 dVAR;
ed6116ce
LW		 5097 if (o->op_type == OP_PADANY) {
5098 o->op_type = OP_PADAV;
22c35a8c 5099 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5100 return o;
ed6116ce 5101 }
a1063b2d 5102 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 5103 && ckWARN(WARN_DEPRECATED)) {
5104 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5105 "Using an array as a reference is deprecated");
5106 }
79072805
LW		 5107 return newUNOP(OP_RV2AV, 0, scalar(o));
5108}
5109
5110OP *
864dbfa3 5111Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5112{
82092f1d 5113 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5114 return newUNOP(OP_NULL, 0, o);
748a9306 5115 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5116}
5117
5118OP *
864dbfa3 5119Perl_newHVREF(pTHX_ OP *o)
79072805 5120{
27da23d5 5121 dVAR;
ed6116ce
LW		 5122 if (o->op_type == OP_PADANY) {
5123 o->op_type = OP_PADHV;
22c35a8c 5124 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5125 return o;
ed6116ce 5126 }
a1063b2d 5127 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 5128 && ckWARN(WARN_DEPRECATED)) {
5129 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5130 "Using a hash as a reference is deprecated");
5131 }
79072805
LW		 5132 return newUNOP(OP_RV2HV, 0, scalar(o));
5133}
5134
5135OP *
864dbfa3 5136Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5137{
c07a80fd 5138 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5139}
5140
5141OP *
864dbfa3 5142Perl_newSVREF(pTHX_ OP *o)
79072805 5143{
27da23d5 5144 dVAR;
ed6116ce
LW		 5145 if (o->op_type == OP_PADANY) {
5146 o->op_type = OP_PADSV;
22c35a8c 5147 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5148 return o;
ed6116ce 5149 }
224a4551
MB		 5150 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5151 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5152 return o;
224a4551 5153 }
79072805
LW		 5154 return newUNOP(OP_RV2SV, 0, scalar(o));
5155}
5156
61b743bb
DM		 5157/* Check routines. See the comments at the top of this file for details
5158 * on when these are called */
79072805
LW		 5159
5160OP *
cea2e8a9 5161Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5162{
dd2155a4 5163 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 5164 cSVOPo->op_sv = Nullsv;
5dc0d613 5165 return o;
5f05dabc 5166}
5167
5168OP *
cea2e8a9 5169Perl_ck_bitop(pTHX_ OP *o)
55497cff 5170{
97aff369 5171 dVAR;
276b2a0c
RGS		 5172#define OP_IS_NUMCOMPARE(op) \
5173 ((op) == OP_LT || (op) == OP_I_LT || \
5174 (op) == OP_GT || (op) == OP_I_GT || \
5175 (op) == OP_LE || (op) == OP_I_LE || \
5176 (op) == OP_GE || (op) == OP_I_GE || \
5177 (op) == OP_EQ || (op) == OP_I_EQ || \
5178 (op) == OP_NE || (op) == OP_I_NE || \
5179 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 5180 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 5181 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5182 && (o->op_type == OP_BIT_OR
5183 || o->op_type == OP_BIT_AND
5184 || o->op_type == OP_BIT_XOR))
276b2a0c 5185 {
1df70142
AL		 5186 const OP * const left = cBINOPo->op_first;
5187 const OP * const right = left->op_sibling;
96a925ab
YST		 5188 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5189 (left->op_flags & OPf_PARENS) == 0) ||
5190 (OP_IS_NUMCOMPARE(right->op_type) &&
5191 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 5192 if (ckWARN(WARN_PRECEDENCE))
5193 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5194 "Possible precedence problem on bitwise %c operator",
5195 o->op_type == OP_BIT_OR ? '|'
5196 : o->op_type == OP_BIT_AND ? '&' : '^'
5197 );
5198 }
5dc0d613 5199 return o;
55497cff 5200}
5201
5202OP *
cea2e8a9 5203Perl_ck_concat(pTHX_ OP *o)
79072805 5204{
0bd48802 5205 const OP * const kid = cUNOPo->op_first;
df91b2c5
AE		 5206 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5207 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 5208 o->op_flags |= OPf_STACKED;
11343788 5209 return o;
79072805
LW		 5210}
5211
5212OP *
cea2e8a9 5213Perl_ck_spair(pTHX_ OP *o)
79072805 5214{
27da23d5 5215 dVAR;
11343788 5216 if (o->op_flags & OPf_KIDS) {
79072805 5217 OP* newop;
a0d0e21e 5218 OP* kid;
6867be6d 5219 const OPCODE type = o->op_type;
5dc0d613 5220 o = modkids(ck_fun(o), type);
11343788 5221 kid = cUNOPo->op_first;
a0d0e21e
LW		 5222 newop = kUNOP->op_first->op_sibling;
5223 if (newop &&
5224 (newop->op_sibling ||
22c35a8c 5225 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5226 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5227 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 5228
11343788 5229 return o;
a0d0e21e
LW		 5230 }
5231 op_free(kUNOP->op_first);
5232 kUNOP->op_first = newop;
5233 }
22c35a8c 5234 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5235 return ck_fun(o);
a0d0e21e
LW		 5236}
5237
5238OP *
cea2e8a9 5239Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5240{
11343788 5241 o = ck_fun(o);
5dc0d613 5242 o->op_private = 0;
11343788 5243 if (o->op_flags & OPf_KIDS) {
551405c4 5244 OP * const kid = cUNOPo->op_first;
01020589
GS		 5245 switch (kid->op_type) {
5246 case OP_ASLICE:
5247 o->op_flags |= OPf_SPECIAL;
5248 /* FALL THROUGH */
5249 case OP_HSLICE:
5dc0d613 5250 o->op_private |= OPpSLICE;
01020589
GS		 5251 break;
5252 case OP_AELEM:
5253 o->op_flags |= OPf_SPECIAL;
5254 /* FALL THROUGH */
5255 case OP_HELEM:
5256 break;
5257 default:
5258 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5259 OP_DESC(o));
01020589 5260 }
93c66552 5261 op_null(kid);
79072805 5262 }
11343788 5263 return o;
79072805
LW		 5264}
5265
5266OP *
96e176bf
CL		 5267Perl_ck_die(pTHX_ OP *o)
5268{
5269#ifdef VMS
5270 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5271#endif
5272 return ck_fun(o);
5273}
5274
5275OP *
cea2e8a9 5276Perl_ck_eof(pTHX_ OP *o)
79072805 5277{
97aff369 5278 dVAR;
6867be6d 5279 const I32 type = o->op_type;
79072805 5280
11343788
MB		 5281 if (o->op_flags & OPf_KIDS) {
5282 if (cLISTOPo->op_first->op_type == OP_STUB) {
5283 op_free(o);
8fde6460 5284 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 5285 }
11343788 5286 return ck_fun(o);
79072805 5287 }
11343788 5288 return o;
79072805
LW		 5289}
5290
5291OP *
cea2e8a9 5292Perl_ck_eval(pTHX_ OP *o)
79072805 5293{
27da23d5 5294 dVAR;
3280af22 5295 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5296 if (o->op_flags & OPf_KIDS) {
46c461b5 5297 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 5298
93a17b20 5299 if (!kid) {
11343788 5300 o->op_flags &= ~OPf_KIDS;
93c66552 5301 op_null(o);
79072805 5302 }
b14574b4 5303 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 5304 LOGOP *enter;
5305
11343788
MB		 5306 cUNOPo->op_first = 0;
5307 op_free(o);
79072805 5308
b7dc083c 5309 NewOp(1101, enter, 1, LOGOP);
79072805 5310 enter->op_type = OP_ENTERTRY;
22c35a8c 5311 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5312 enter->op_private = 0;
5313
5314 /* establish postfix order */
5315 enter->op_next = (OP*)enter;
5316
11343788
MB		 5317 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5318 o->op_type = OP_LEAVETRY;
22c35a8c 5319 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5320 enter->op_other = o;
5321 return o;
79072805 5322 }
b5c19bd7 5323 else {
473986ff 5324 scalar((OP*)kid);
b5c19bd7
DM		 5325 PL_cv_has_eval = 1;
5326 }
79072805
LW		 5327 }
5328 else {
11343788 5329 op_free(o);
54b9620d 5330 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5331 }
3280af22 5332 o->op_targ = (PADOFFSET)PL_hints;
7168684c 5333 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
0d863452
RH		 5334 /* Store a copy of %^H that pp_entereval can pick up */
5335 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5336 cUNOPo->op_first->op_sibling = hhop;
5337 o->op_private |= OPpEVAL_HAS_HH;
5338 }
11343788 5339 return o;
79072805
LW		 5340}
5341
5342OP *
d98f61e7
GS		 5343Perl_ck_exit(pTHX_ OP *o)
5344{
5345#ifdef VMS
551405c4 5346 HV * const table = GvHV(PL_hintgv);
d98f61e7 5347 if (table) {
a4fc7abc 5348 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 5349 if (svp && *svp && SvTRUE(*svp))
5350 o->op_private |= OPpEXIT_VMSISH;
5351 }
96e176bf 5352 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 5353#endif
5354 return ck_fun(o);
5355}
5356
5357OP *
cea2e8a9 5358Perl_ck_exec(pTHX_ OP *o)
79072805 5359{
11343788 5360 if (o->op_flags & OPf_STACKED) {
6867be6d 5361 OP *kid;
11343788
MB		 5362 o = ck_fun(o);
5363 kid = cUNOPo->op_first->op_sibling;
8990e307 5364 if (kid->op_type == OP_RV2GV)
93c66552 5365 op_null(kid);
79072805 5366 }
463ee0b2 5367 else
11343788
MB		 5368 o = listkids(o);
5369 return o;
79072805
LW		 5370}
5371
5372OP *
cea2e8a9 5373Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5374{
97aff369 5375 dVAR;
5196be3e
MB		 5376 o = ck_fun(o);
5377 if (o->op_flags & OPf_KIDS) {
46c461b5 5378 OP * const kid = cUNOPo->op_first;
afebc493
GS		 5379 if (kid->op_type == OP_ENTERSUB) {
5380 (void) ref(kid, o->op_type);
5381 if (kid->op_type != OP_RV2CV && !PL_error_count)
5382 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 5383 OP_DESC(o));
afebc493
GS		 5384 o->op_private |= OPpEXISTS_SUB;
5385 }
5386 else if (kid->op_type == OP_AELEM)
01020589
GS		 5387 o->op_flags |= OPf_SPECIAL;
5388 else if (kid->op_type != OP_HELEM)
5389 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 5390 OP_DESC(o));
93c66552 5391 op_null(kid);
5f05dabc 5392 }
5196be3e 5393 return o;
5f05dabc 5394}
5395
79072805 5396OP *
cea2e8a9 5397Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5398{
27da23d5 5399 dVAR;
0bd48802 5400 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5401
3280af22 5402 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 5403 if (o->op_type == OP_RV2CV)
5404 o->op_private &= ~1;
5405
79072805 5406 if (kid->op_type == OP_CONST) {
44a8e56a 5407 int iscv;
5408 GV *gv;
504618e9 5409 SV * const kidsv = kid->op_sv;
44a8e56a 5410
779c5bc9
GS		 5411 /* Is it a constant from cv_const_sv()? */
5412 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 5413 SV * const rsv = SvRV(kidsv);
504618e9 5414 const int svtype = SvTYPE(rsv);
e1ec3a88 5415 const char *badtype = Nullch;
779c5bc9
GS		 5416
5417 switch (o->op_type) {
5418 case OP_RV2SV:
5419 if (svtype > SVt_PVMG)
5420 badtype = "a SCALAR";
5421 break;
5422 case OP_RV2AV:
5423 if (svtype != SVt_PVAV)
5424 badtype = "an ARRAY";
5425 break;
5426 case OP_RV2HV:
6d822dc4 5427 if (svtype != SVt_PVHV)
779c5bc9 5428 badtype = "a HASH";
779c5bc9
GS		 5429 break;
5430 case OP_RV2CV:
5431 if (svtype != SVt_PVCV)
5432 badtype = "a CODE";
5433 break;
5434 }
5435 if (badtype)
cea2e8a9 5436 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5437 return o;
5438 }
ce10b5d1
RGS		 5439 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5440 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5441 /* If this is an access to a stash, disable "strict refs", because
5442 * stashes aren't auto-vivified at compile-time (unless we store
5443 * symbols in them), and we don't want to produce a run-time
5444 * stricture error when auto-vivifying the stash. */
5445 const char *s = SvPV_nolen(kidsv);
5446 const STRLEN l = SvCUR(kidsv);
5447 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5448 o->op_private &= ~HINT_STRICT_REFS;
5449 }
5450 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
e1ec3a88 5451 const char *badthing = Nullch;
5dc0d613 5452 switch (o->op_type) {
44a8e56a 5453 case OP_RV2SV:
5454 badthing = "a SCALAR";
5455 break;
5456 case OP_RV2AV:
5457 badthing = "an ARRAY";
5458 break;
5459 case OP_RV2HV:
5460 badthing = "a HASH";
5461 break;
5462 }
5463 if (badthing)
1c846c1f 5464 Perl_croak(aTHX_
7a5fd60d
NC		 5465 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5466 kidsv, badthing);
44a8e56a 5467 }
93233ece
CS		 5468 /*
5469 * This is a little tricky. We only want to add the symbol if we
5470 * didn't add it in the lexer. Otherwise we get duplicate strict
5471 * warnings. But if we didn't add it in the lexer, we must at
5472 * least pretend like we wanted to add it even if it existed before,
5473 * or we get possible typo warnings. OPpCONST_ENTERED says
5474 * whether the lexer already added THIS instance of this symbol.
5475 */
5196be3e 5476 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5477 do {
7a5fd60d 5478 gv = gv_fetchsv(kidsv,
748a9306 5479 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5480 iscv
5481 ? SVt_PVCV
11343788 5482 : o->op_type == OP_RV2SV
a0d0e21e 5483 ? SVt_PV
11343788 5484 : o->op_type == OP_RV2AV
a0d0e21e 5485 ? SVt_PVAV
11343788 5486 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5487 ? SVt_PVHV
5488 : SVt_PVGV);
93233ece
CS		 5489 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5490 if (gv) {
5491 kid->op_type = OP_GV;
5492 SvREFCNT_dec(kid->op_sv);
350de78d 5493#ifdef USE_ITHREADS
638eceb6 5494 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5495 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 5496 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 5497 GvIN_PAD_on(gv);
dd2155a4 5498 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 5499#else
93233ece 5500 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5501#endif
23f1ca44 5502 kid->op_private = 0;
76cd736e 5503 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5504 }
79072805 5505 }
11343788 5506 return o;
79072805
LW		 5507}
5508
5509OP *
cea2e8a9 5510Perl_ck_ftst(pTHX_ OP *o)
79072805 5511{
27da23d5 5512 dVAR;
6867be6d 5513 const I32 type = o->op_type;
79072805 5514
d0dca557
JD		 5515 if (o->op_flags & OPf_REF) {
5516 /* nothing */
5517 }
5518 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 5519 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5520
5521 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 5522 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 5523 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11343788 5524 op_free(o);
d0dca557 5525 o = newop;
181bc48d 5526 return o;
79072805 5527 }
1af34c76
JH		 5528 else {
5529 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5530 OP_IS_FILETEST_ACCESS(o))
5531 o->op_private |= OPpFT_ACCESS;
5532 }
fbb0b3b3
RGS		 5533 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5534 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5535 o->op_private |= OPpFT_STACKED;
79072805
LW		 5536 }
5537 else {
11343788 5538 op_free(o);
79072805 5539 if (type == OP_FTTTY)
8fde6460 5540 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5541 else
d0dca557 5542 o = newUNOP(type, 0, newDEFSVOP());
79072805 5543 }
11343788 5544 return o;
79072805
LW		 5545}
5546
5547OP *
cea2e8a9 5548Perl_ck_fun(pTHX_ OP *o)
79072805 5549{
97aff369 5550 dVAR;
6867be6d 5551 const int type = o->op_type;
22c35a8c 5552 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5553
11343788 5554 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5555 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5556 oa &= ~OA_OPTIONAL;
5557 else
11343788 5558 return no_fh_allowed(o);
79072805
LW		 5559 }
5560
11343788 5561 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 5562 OP **tokid = &cLISTOPo->op_first;
5563 register OP *kid = cLISTOPo->op_first;
5564 OP *sibl;
5565 I32 numargs = 0;
5566
8990e307 5567 if (kid->op_type == OP_PUSHMARK ||
155aba94 5568 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5569 {
79072805
LW		 5570 tokid = &kid->op_sibling;
5571 kid = kid->op_sibling;
5572 }
22c35a8c 5573 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5574 *tokid = kid = newDEFSVOP();
79072805
LW		 5575
5576 while (oa && kid) {
5577 numargs++;
5578 sibl = kid->op_sibling;
5579 switch (oa & 7) {
5580 case OA_SCALAR:
62c18ce2
GS		 5581 /* list seen where single (scalar) arg expected? */
5582 if (numargs == 1 && !(oa >> 4)
5583 && kid->op_type == OP_LIST && type != OP_SCALAR)
5584 {
5585 return too_many_arguments(o,PL_op_desc[type]);
5586 }
79072805
LW		 5587 scalar(kid);
5588 break;
5589 case OA_LIST:
5590 if (oa < 16) {
5591 kid = 0;
5592 continue;
5593 }
5594 else
5595 list(kid);
5596 break;
5597 case OA_AVREF:
936edb8b 5598 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5599 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5600 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5601 "Useless use of %s with no values",
936edb8b 5602 PL_op_desc[type]);
b2ffa427 5603
79072805 5604 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5605 (kid->op_private & OPpCONST_BARE))
5606 {
551405c4 5607 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 5608 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 5609 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5610 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d
NC		 5611 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5612 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5613 op_free(kid);
5614 kid = newop;
5615 kid->op_sibling = sibl;
5616 *tokid = kid;
5617 }
8990e307 5618 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5619 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5620 mod(kid, type);
79072805
LW		 5621 break;
5622 case OA_HVREF:
5623 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5624 (kid->op_private & OPpCONST_BARE))
5625 {
551405c4 5626 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 5627 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 5628 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5629 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d
NC		 5630 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5631 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5632 op_free(kid);
5633 kid = newop;
5634 kid->op_sibling = sibl;
5635 *tokid = kid;
5636 }
8990e307 5637 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5638 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5639 mod(kid, type);
79072805
LW		 5640 break;
5641 case OA_CVREF:
5642 {
551405c4 5643 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5644 kid->op_sibling = 0;
5645 linklist(kid);
5646 newop->op_next = newop;
5647 kid = newop;
5648 kid->op_sibling = sibl;
5649 *tokid = kid;
5650 }
5651 break;
5652 case OA_FILEREF:
c340be78 5653 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5654 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5655 (kid->op_private & OPpCONST_BARE))
5656 {
0bd48802 5657 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 5658 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 5659 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5660 kid == cLISTOPo->op_last)
364daeac 5661 cLISTOPo->op_last = newop;
79072805
LW		 5662 op_free(kid);
5663 kid = newop;
5664 }
1ea32a52
GS		 5665 else if (kid->op_type == OP_READLINE) {
5666 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5667 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5668 }
79072805 5669 else {
35cd451c 5670 I32 flags = OPf_SPECIAL;
a6c40364 5671 I32 priv = 0;
2c8ac474
GS		 5672 PADOFFSET targ = 0;
5673
35cd451c 5674 /* is this op a FH constructor? */
853846ea 5675 if (is_handle_constructor(o,numargs)) {
e1ec3a88 5676 const char *name = Nullch;
dd2155a4 5677 STRLEN len = 0;
2c8ac474
GS		 5678
5679 flags = 0;
5680 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5681 * need to "prove" flag does not mean something
5682 * else already - NI-S 1999/05/07
2c8ac474
GS		 5683 */
5684 priv = OPpDEREF;
5685 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5686 name = PAD_COMPNAME_PV(kid->op_targ);
5687 /* SvCUR of a pad namesv can't be trusted
5688 * (see PL_generation), so calc its length
5689 * manually */
5690 if (name)
5691 len = strlen(name);
5692
2c8ac474
GS		 5693 }
5694 else if (kid->op_type == OP_RV2SV
5695 && kUNOP->op_first->op_type == OP_GV)
5696 {
0bd48802 5697 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 5698 name = GvNAME(gv);
5699 len = GvNAMELEN(gv);
5700 }
afd1915d
GS		 5701 else if (kid->op_type == OP_AELEM
5702 || kid->op_type == OP_HELEM)
5703 {
551405c4 5704 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 5705 name = NULL;
551405c4 5706 if (op) {
0c4b0a3f 5707 SV *tmpstr = Nullsv;
551405c4 5708 const char * const a =
0c4b0a3f
JH		 5709 kid->op_type == OP_AELEM ?
5710 "[]" : "{}";
5711 if (((op->op_type == OP_RV2AV) ||
5712 (op->op_type == OP_RV2HV)) &&
5713 (op = ((UNOP*)op)->op_first) &&
5714 (op->op_type == OP_GV)) {
5715 /* packagevar $a[] or $h{} */
551405c4 5716 GV * const gv = cGVOPx_gv(op);
0c4b0a3f
JH		 5717 if (gv)
5718 tmpstr =
5719 Perl_newSVpvf(aTHX_
5720 "%s%c...%c",
5721 GvNAME(gv),
5722 a[0], a[1]);
5723 }
5724 else if (op->op_type == OP_PADAV
5725 || op->op_type == OP_PADHV) {
5726 /* lexicalvar $a[] or $h{} */
551405c4 5727 const char * const padname =
0c4b0a3f
JH		 5728 PAD_COMPNAME_PV(op->op_targ);
5729 if (padname)
5730 tmpstr =
5731 Perl_newSVpvf(aTHX_
5732 "%s%c...%c",
5733 padname + 1,
5734 a[0], a[1]);
0c4b0a3f
JH		 5735 }
5736 if (tmpstr) {
93524f2b 5737 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 5738 sv_2mortal(tmpstr);
5739 }
5740 }
5741 if (!name) {
5742 name = "__ANONIO__";
5743 len = 10;
5744 }
5745 mod(kid, type);
afd1915d 5746 }
2c8ac474
GS		 5747 if (name) {
5748 SV *namesv;
5749 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5750 namesv = PAD_SVl(targ);
862a34c6 5751 SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5752 if (*name != '$')
5753 sv_setpvn(namesv, "$", 1);
5754 sv_catpvn(namesv, name, len);
5755 }
853846ea 5756 }
79072805 5757 kid->op_sibling = 0;
35cd451c 5758 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5759 kid->op_targ = targ;
5760 kid->op_private |= priv;
79072805
LW		 5761 }
5762 kid->op_sibling = sibl;
5763 *tokid = kid;
5764 }
5765 scalar(kid);
5766 break;
5767 case OA_SCALARREF:
a0d0e21e 5768 mod(scalar(kid), type);
79072805
LW		 5769 break;
5770 }
5771 oa >>= 4;
5772 tokid = &kid->op_sibling;
5773 kid = kid->op_sibling;
5774 }
11343788 5775 o->op_private |= numargs;
79072805 5776 if (kid)
53e06cf0 5777 return too_many_arguments(o,OP_DESC(o));
11343788 5778 listkids(o);
79072805 5779 }
22c35a8c 5780 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5781 op_free(o);
54b9620d 5782 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5783 }
5784
79072805
LW		 5785 if (oa) {
5786 while (oa & OA_OPTIONAL)
5787 oa >>= 4;
5788 if (oa && oa != OA_LIST)
53e06cf0 5789 return too_few_arguments(o,OP_DESC(o));
79072805 5790 }
11343788 5791 return o;
79072805
LW		 5792}
5793
5794OP *
cea2e8a9 5795Perl_ck_glob(pTHX_ OP *o)
79072805 5796{
27da23d5 5797 dVAR;
fb73857a 5798 GV *gv;
5799
649da076 5800 o = ck_fun(o);
1f2bfc8a 5801 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5802 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5803
5c1737d1 5804 if (!((gv = gv_fetchpvs("glob", 0, SVt_PVCV))
b9f751c0
GS		 5805 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5806 {
5c1737d1 5807 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 5808 }
b1cb66bf 5809
52bb0670 5810#if !defined(PERL_EXTERNAL_GLOB)
72b16652 5811 /* XXX this can be tightened up and made more failsafe. */
f444d496 5812 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 5813 GV *glob_gv;
72b16652 5814 ENTER;
00ca71c1 5815 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
396482e1 5816 newSVpvs("File::Glob"), Nullsv, Nullsv, Nullsv);
5c1737d1
NC		 5817 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5818 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 5819 GvCV(gv) = GvCV(glob_gv);
7fc63493 5820 (void)SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5821 GvIMPORTED_CV_on(gv);
72b16652
GS		 5822 LEAVE;
5823 }
52bb0670 5824#endif /* PERL_EXTERNAL_GLOB */
72b16652 5825
b9f751c0 5826 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5827 append_elem(OP_GLOB, o,
80252599 5828 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5829 o->op_type = OP_LIST;
22c35a8c 5830 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5831 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5832 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 5833 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 5834 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5835 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5836 scalar(newUNOP(OP_RV2CV, 0,
5837 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5838 o = newUNOP(OP_NULL, 0, ck_subr(o));
5839 o->op_targ = OP_GLOB; /* hint at what it used to be */
5840 return o;
b1cb66bf 5841 }
5842 gv = newGVgen("main");
a0d0e21e 5843 gv_IOadd(gv);
11343788
MB		 5844 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5845 scalarkids(o);
649da076 5846 return o;
79072805
LW		 5847}
5848
5849OP *
cea2e8a9 5850Perl_ck_grep(pTHX_ OP *o)
79072805 5851{
27da23d5 5852 dVAR;
79072805
LW		 5853 LOGOP *gwop;
5854 OP *kid;
6867be6d 5855 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
59f00321 5856 I32 offset;
79072805 5857
22c35a8c 5858 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5859 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5860
11343788 5861 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5862 OP* k;
11343788
MB		 5863 o = ck_sort(o);
5864 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 5865 if (!cUNOPx(kid)->op_next)
5866 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 5867 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 5868 kid = k;
5869 }
5870 kid->op_next = (OP*)gwop;
11343788 5871 o->op_flags &= ~OPf_STACKED;
93a17b20 5872 }
11343788 5873 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5874 if (type == OP_MAPWHILE)
5875 list(kid);
5876 else
5877 scalar(kid);
11343788 5878 o = ck_fun(o);
3280af22 5879 if (PL_error_count)
11343788 5880 return o;
aeea060c 5881 kid = cLISTOPo->op_first->op_sibling;
79072805 5882 if (kid->op_type != OP_NULL)
cea2e8a9 5883 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5884 kid = kUNOP->op_first;
5885
a0d0e21e 5886 gwop->op_type = type;
22c35a8c 5887 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5888 gwop->op_first = listkids(o);
79072805 5889 gwop->op_flags |= OPf_KIDS;
79072805 5890 gwop->op_other = LINKLIST(kid);
79072805 5891 kid->op_next = (OP*)gwop;
59f00321
RGS		 5892 offset = pad_findmy("$_");
5893 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5894 o->op_private = gwop->op_private = 0;
5895 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5896 }
5897 else {
5898 o->op_private = gwop->op_private = OPpGREP_LEX;
5899 gwop->op_targ = o->op_targ = offset;
5900 }
79072805 5901
11343788 5902 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5903 if (!kid || !kid->op_sibling)
53e06cf0 5904 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5905 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5906 mod(kid, OP_GREPSTART);
5907
79072805
LW		 5908 return (OP*)gwop;
5909}
5910
5911OP *
cea2e8a9 5912Perl_ck_index(pTHX_ OP *o)
79072805 5913{
11343788
MB		 5914 if (o->op_flags & OPf_KIDS) {
5915 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5916 if (kid)
5917 kid = kid->op_sibling; /* get past "big" */
79072805 5918 if (kid && kid->op_type == OP_CONST)
2779dcf1 5919 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5920 }
11343788 5921 return ck_fun(o);
79072805
LW		 5922}
5923
5924OP *
cea2e8a9 5925Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5926{
5927 /* XXX length optimization goes here */
11343788 5928 return ck_fun(o);
79072805
LW		 5929}
5930
5931OP *
cea2e8a9 5932Perl_ck_lfun(pTHX_ OP *o)
79072805 5933{
6867be6d 5934 const OPCODE type = o->op_type;
5dc0d613 5935 return modkids(ck_fun(o), type);
79072805
LW		 5936}
5937
5938OP *
cea2e8a9 5939Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5940{
12bcd1a6 5941 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5942 switch (cUNOPo->op_first->op_type) {
5943 case OP_RV2AV:
a8739d98
JH		 5944 /* This is needed for
5945 if (defined %stash::)
5946 to work. Do not break Tk.
5947 */
1c846c1f 5948 break; /* Globals via GV can be undef */
d0334bed
GS		 5949 case OP_PADAV:
5950 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5951 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5952 "defined(@array) is deprecated");
12bcd1a6 5953 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5954 "\t(Maybe you should just omit the defined()?)\n");
69794302 5955 break;
d0334bed 5956 case OP_RV2HV:
a8739d98
JH		 5957 /* This is needed for
5958 if (defined %stash::)
5959 to work. Do not break Tk.
5960 */
1c846c1f 5961 break; /* Globals via GV can be undef */
d0334bed 5962 case OP_PADHV:
12bcd1a6 5963 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5964 "defined(%%hash) is deprecated");
12bcd1a6 5965 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5966 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5967 break;
5968 default:
5969 /* no warning */
5970 break;
5971 }
69794302
MJD		 5972 }
5973 return ck_rfun(o);
5974}
5975
5976OP *
cea2e8a9 5977Perl_ck_rfun(pTHX_ OP *o)
8990e307 5978{
6867be6d 5979 const OPCODE type = o->op_type;
5dc0d613 5980 return refkids(ck_fun(o), type);
8990e307
LW		 5981}
5982
5983OP *
cea2e8a9 5984Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5985{
5986 register OP *kid;
aeea060c 5987
11343788 5988 kid = cLISTOPo->op_first;
79072805 5989 if (!kid) {
11343788
MB		 5990 o = force_list(o);
5991 kid = cLISTOPo->op_first;
79072805
LW		 5992 }
5993 if (kid->op_type == OP_PUSHMARK)
5994 kid = kid->op_sibling;
11343788 5995 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5996 kid = kid->op_sibling;
5997 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5998 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5999 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6000 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6001 cLISTOPo->op_first->op_sibling = kid;
6002 cLISTOPo->op_last = kid;
79072805
LW		 6003 kid = kid->op_sibling;
6004 }
6005 }
b2ffa427 6006
79072805 6007 if (!kid)
54b9620d 6008 append_elem(o->op_type, o, newDEFSVOP());
79072805 6009
2de3dbcc 6010 return listkids(o);
bbce6d69 6011}
6012
6013OP *
0d863452
RH		 6014Perl_ck_say(pTHX_ OP *o)
6015{
6016 o = ck_listiob(o);
6017 o->op_type = OP_PRINT;
6018 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
396482e1 6019 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
0d863452
RH		 6020 return o;
6021}
6022
6023OP *
6024Perl_ck_smartmatch(pTHX_ OP *o)
6025{
97aff369 6026 dVAR;
0d863452
RH		 6027 if (0 == (o->op_flags & OPf_SPECIAL)) {
6028 OP *first = cBINOPo->op_first;
6029 OP *second = first->op_sibling;
6030
6031 /* Implicitly take a reference to an array or hash */
6032 first->op_sibling = Nullop;
6033 first = cBINOPo->op_first = ref_array_or_hash(first);
6034 second = first->op_sibling = ref_array_or_hash(second);
6035
6036 /* Implicitly take a reference to a regular expression */
6037 if (first->op_type == OP_MATCH) {
6038 first->op_type = OP_QR;
6039 first->op_ppaddr = PL_ppaddr[OP_QR];
6040 }
6041 if (second->op_type == OP_MATCH) {
6042 second->op_type = OP_QR;
6043 second->op_ppaddr = PL_ppaddr[OP_QR];
6044 }
6045 }
6046
6047 return o;
6048}
6049
6050
6051OP *
b162f9ea
IZ		 6052Perl_ck_sassign(pTHX_ OP *o)
6053{
6054 OP *kid = cLISTOPo->op_first;
6055 /* has a disposable target? */
6056 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6057 && !(kid->op_flags & OPf_STACKED)
6058 /* Cannot steal the second time! */
6059 && !(kid->op_private & OPpTARGET_MY))
b162f9ea 6060 {
551405c4 6061 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 6062
6063 /* Can just relocate the target. */
2c2d71f5
JH		 6064 if (kkid && kkid->op_type == OP_PADSV
6065 && !(kkid->op_private & OPpLVAL_INTRO))
6066 {
b162f9ea 6067 kid->op_targ = kkid->op_targ;
743e66e6 6068 kkid->op_targ = 0;
b162f9ea
IZ		 6069 /* Now we do not need PADSV and SASSIGN. */
6070 kid->op_sibling = o->op_sibling; /* NULL */
6071 cLISTOPo->op_first = NULL;
6072 op_free(o);
6073 op_free(kkid);
6074 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6075 return kid;
6076 }
6077 }
6078 return o;
6079}
6080
6081OP *
cea2e8a9 6082Perl_ck_match(pTHX_ OP *o)
79072805 6083{
97aff369 6084 dVAR;
0d863452 6085 if (o->op_type != OP_QR && PL_compcv) {
6867be6d 6086 const I32 offset = pad_findmy("$_");
59f00321
RGS		 6087 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6088 o->op_targ = offset;
6089 o->op_private |= OPpTARGET_MY;
6090 }
6091 }
6092 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6093 o->op_private |= OPpRUNTIME;
11343788 6094 return o;
79072805
LW		 6095}
6096
6097OP *
f5d5a27c
CS		 6098Perl_ck_method(pTHX_ OP *o)
6099{
551405c4 6100 OP * const kid = cUNOPo->op_first;
f5d5a27c
CS		 6101 if (kid->op_type == OP_CONST) {
6102 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 6103 const char * const method = SvPVX_const(sv);
6104 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 6105 OP *cmop;
1c846c1f 6106 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 6107 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 6108 }
6109 else {
6110 kSVOP->op_sv = Nullsv;
6111 }
f5d5a27c 6112 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 6113 op_free(o);
6114 return cmop;
6115 }
6116 }
6117 return o;
6118}
6119
6120OP *
cea2e8a9 6121Perl_ck_null(pTHX_ OP *o)
79072805 6122{
11343788 6123 return o;
79072805
LW		 6124}
6125
6126OP *
16fe6d59
GS		 6127Perl_ck_open(pTHX_ OP *o)
6128{
97aff369 6129 dVAR;
551405c4 6130 HV * const table = GvHV(PL_hintgv);
16fe6d59 6131 if (table) {
a4fc7abc 6132 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 6133 if (svp && *svp) {
551405c4 6134 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6135 if (mode & O_BINARY)
6136 o->op_private |= OPpOPEN_IN_RAW;
6137 else if (mode & O_TEXT)
6138 o->op_private |= OPpOPEN_IN_CRLF;
6139 }
6140
a4fc7abc 6141 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 6142 if (svp && *svp) {
551405c4 6143 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6144 if (mode & O_BINARY)
6145 o->op_private |= OPpOPEN_OUT_RAW;
6146 else if (mode & O_TEXT)
6147 o->op_private |= OPpOPEN_OUT_CRLF;
6148 }
6149 }
6150 if (o->op_type == OP_BACKTICK)
6151 return o;
3b82e551
JH		 6152 {
6153 /* In case of three-arg dup open remove strictness
6154 * from the last arg if it is a bareword. */
551405c4
AL		 6155 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6156 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 6157 OP *oa;
b15aece3 6158 const char *mode;
3b82e551
JH		 6159
6160 if ((last->op_type == OP_CONST) && /* The bareword. */
6161 (last->op_private & OPpCONST_BARE) &&
6162 (last->op_private & OPpCONST_STRICT) &&
6163 (oa = first->op_sibling) && /* The fh. */
6164 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 6165 (oa->op_type == OP_CONST) &&
3b82e551 6166 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 6167 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 6168 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6169 (last == oa->op_sibling)) /* The bareword. */
6170 last->op_private &= ~OPpCONST_STRICT;
6171 }
16fe6d59
GS		 6172 return ck_fun(o);
6173}
6174
6175OP *
cea2e8a9 6176Perl_ck_repeat(pTHX_ OP *o)
79072805 6177{
11343788
MB		 6178 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6179 o->op_private |= OPpREPEAT_DOLIST;
6180 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6181 }
6182 else
11343788
MB		 6183 scalar(o);
6184 return o;
79072805
LW		 6185}
6186
6187OP *
cea2e8a9 6188Perl_ck_require(pTHX_ OP *o)
8990e307 6189{
97aff369 6190 dVAR;
a72a1c8b 6191 GV* gv = Nullgv;
ec4ab249 6192
11343788 6193 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 6194 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6195
6196 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6197 SV * const sv = kid->op_sv;
5c144d81 6198 U32 was_readonly = SvREADONLY(sv);
8990e307 6199 char *s;
5c144d81
NC		 6200
6201 if (was_readonly) {
6202 if (SvFAKE(sv)) {
6203 sv_force_normal_flags(sv, 0);
6204 assert(!SvREADONLY(sv));
6205 was_readonly = 0;
6206 } else {
6207 SvREADONLY_off(sv);
6208 }
6209 }
6210
6211 for (s = SvPVX(sv); *s; s++) {
a0d0e21e 6212 if (*s == ':' && s[1] == ':') {
42d9b98d 6213 const STRLEN len = strlen(s+2)+1;
a0d0e21e 6214 *s = '/';
42d9b98d 6215 Move(s+2, s+1, len, char);
5c144d81 6216 SvCUR_set(sv, SvCUR(sv) - 1);
a0d0e21e 6217 }
8990e307 6218 }
396482e1 6219 sv_catpvs(sv, ".pm");
5c144d81 6220 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 6221 }
6222 }
ec4ab249 6223
a72a1c8b
RGS		 6224 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6225 /* handle override, if any */
5c1737d1 6226 gv = gv_fetchpvs("require", 0, SVt_PVCV);
d6a985f2 6227 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 6228 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
551405c4 6229 gv = gvp ? *gvp : Nullgv;
d6a985f2 6230 }
a72a1c8b 6231 }
ec4ab249 6232
b9f751c0 6233 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 6234 OP * const kid = cUNOPo->op_first;
ec4ab249
GA		 6235 cUNOPo->op_first = 0;
6236 op_free(o);
6237 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6238 append_elem(OP_LIST, kid,
6239 scalar(newUNOP(OP_RV2CV, 0,
6240 newGVOP(OP_GV, 0,
6241 gv))))));
6242 }
6243
11343788 6244 return ck_fun(o);
8990e307
LW		 6245}
6246
78f9721b
SM		 6247OP *
6248Perl_ck_return(pTHX_ OP *o)
6249{
97aff369 6250 dVAR;
78f9721b 6251 if (CvLVALUE(PL_compcv)) {
6867be6d 6252 OP *kid;
78f9721b
SM		 6253 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6254 mod(kid, OP_LEAVESUBLV);
6255 }
6256 return o;
6257}
6258
79072805 6259OP *
cea2e8a9 6260Perl_ck_select(pTHX_ OP *o)
79072805 6261{
27da23d5 6262 dVAR;
c07a80fd 6263 OP* kid;
11343788
MB		 6264 if (o->op_flags & OPf_KIDS) {
6265 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6266 if (kid && kid->op_sibling) {
11343788 6267 o->op_type = OP_SSELECT;
22c35a8c 6268 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6269 o = ck_fun(o);
6270 return fold_constants(o);
79072805
LW		 6271 }
6272 }
11343788
MB		 6273 o = ck_fun(o);
6274 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6275 if (kid && kid->op_type == OP_RV2GV)
6276 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6277 return o;
79072805
LW		 6278}
6279
6280OP *
cea2e8a9 6281Perl_ck_shift(pTHX_ OP *o)
79072805 6282{
97aff369 6283 dVAR;
6867be6d 6284 const I32 type = o->op_type;
79072805 6285
11343788 6286 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 6287 OP *argop;
b2ffa427 6288
11343788 6289 op_free(o);
6d4ff0d2 6290 argop = newUNOP(OP_RV2AV, 0,
8fde6460 6291 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 6292 return newUNOP(type, 0, scalar(argop));
79072805 6293 }
11343788 6294 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6295}
6296
6297OP *
cea2e8a9 6298Perl_ck_sort(pTHX_ OP *o)
79072805 6299{
97aff369 6300 dVAR;
8e3f9bdf 6301 OP *firstkid;
bbce6d69 6302
7b9ef140
RH		 6303 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6304 {
a4fc7abc 6305 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 6306 if (hinthv) {
a4fc7abc 6307 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 6308 if (svp) {
a4fc7abc 6309 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 6310 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6311 o->op_private |= OPpSORT_QSORT;
6312 if ((sorthints & HINT_SORT_STABLE) != 0)
6313 o->op_private |= OPpSORT_STABLE;
6314 }
6315 }
6316 }
6317
9ea6e965 6318 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6319 simplify_sort(o);
8e3f9bdf
GS		 6320 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6321 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 6322 OP *k = NULL;
8e3f9bdf 6323 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6324
463ee0b2 6325 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6326 linklist(kid);
463ee0b2
LW		 6327 if (kid->op_type == OP_SCOPE) {
6328 k = kid->op_next;
6329 kid->op_next = 0;
79072805 6330 }
463ee0b2 6331 else if (kid->op_type == OP_LEAVE) {
11343788 6332 if (o->op_type == OP_SORT) {
93c66552 6333 op_null(kid); /* wipe out leave */
748a9306 6334 kid->op_next = kid;
463ee0b2 6335
748a9306
LW		 6336 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6337 if (k->op_next == kid)
6338 k->op_next = 0;
71a29c3c
GS		 6339 /* don't descend into loops */
6340 else if (k->op_type == OP_ENTERLOOP
6341 || k->op_type == OP_ENTERITER)
6342 {
6343 k = cLOOPx(k)->op_lastop;
6344 }
748a9306 6345 }
463ee0b2 6346 }
748a9306
LW		 6347 else
6348 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6349 k = kLISTOP->op_first;
463ee0b2 6350 }
a2efc822 6351 CALL_PEEP(k);
a0d0e21e 6352
8e3f9bdf
GS		 6353 kid = firstkid;
6354 if (o->op_type == OP_SORT) {
6355 /* provide scalar context for comparison function/block */
6356 kid = scalar(kid);
a0d0e21e 6357 kid->op_next = kid;
8e3f9bdf 6358 }
a0d0e21e
LW		 6359 else
6360 kid->op_next = k;
11343788 6361 o->op_flags |= OPf_SPECIAL;
79072805 6362 }
c6e96bcb 6363 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6364 op_null(firstkid);
8e3f9bdf
GS		 6365
6366 firstkid = firstkid->op_sibling;
79072805 6367 }
bbce6d69 6368
8e3f9bdf
GS		 6369 /* provide list context for arguments */
6370 if (o->op_type == OP_SORT)
6371 list(firstkid);
6372
11343788 6373 return o;
79072805 6374}
bda4119b
GS		 6375
6376STATIC void
cea2e8a9 6377S_simplify_sort(pTHX_ OP *o)
9c007264 6378{
97aff369 6379 dVAR;
9c007264
JH		 6380 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6381 OP *k;
eb209983 6382 int descending;
350de78d 6383 GV *gv;
770526c1 6384 const char *gvname;
9c007264
JH		 6385 if (!(o->op_flags & OPf_STACKED))
6386 return;
5c1737d1
NC		 6387 GvMULTI_on(gv_fetchpvs("a", GV_ADD, SVt_PV));
6388 GvMULTI_on(gv_fetchpvs("b", GV_ADD, SVt_PV));
82092f1d 6389 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6390 if (kid->op_type != OP_SCOPE)
6391 return;
6392 kid = kLISTOP->op_last; /* get past scope */
6393 switch(kid->op_type) {
6394 case OP_NCMP:
6395 case OP_I_NCMP:
6396 case OP_SCMP:
6397 break;
6398 default:
6399 return;
6400 }
6401 k = kid; /* remember this node*/
6402 if (kBINOP->op_first->op_type != OP_RV2SV)
6403 return;
6404 kid = kBINOP->op_first; /* get past cmp */
6405 if (kUNOP->op_first->op_type != OP_GV)
6406 return;
6407 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6408 gv = kGVOP_gv;
350de78d 6409 if (GvSTASH(gv) != PL_curstash)
9c007264 6410 return;
770526c1
NC		 6411 gvname = GvNAME(gv);
6412 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 6413 descending = 0;
770526c1 6414 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 6415 descending = 1;
9c007264
JH		 6416 else
6417 return;
eb209983 6418
9c007264
JH		 6419 kid = k; /* back to cmp */
6420 if (kBINOP->op_last->op_type != OP_RV2SV)
6421 return;
6422 kid = kBINOP->op_last; /* down to 2nd arg */
6423 if (kUNOP->op_first->op_type != OP_GV)
6424 return;
6425 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6426 gv = kGVOP_gv;
770526c1
NC		 6427 if (GvSTASH(gv) != PL_curstash)
6428 return;
6429 gvname = GvNAME(gv);
6430 if ( descending
6431 ? !(*gvname == 'a' && gvname[1] == '\0')
6432 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 6433 return;
6434 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 6435 if (descending)
6436 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 6437 if (k->op_type == OP_NCMP)
6438 o->op_private |= OPpSORT_NUMERIC;
6439 if (k->op_type == OP_I_NCMP)
6440 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6441 kid = cLISTOPo->op_first->op_sibling;
6442 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6443 op_free(kid); /* then delete it */
9c007264 6444}
79072805
LW		 6445
6446OP *
cea2e8a9 6447Perl_ck_split(pTHX_ OP *o)
79072805 6448{
27da23d5 6449 dVAR;
79072805 6450 register OP *kid;
aeea060c 6451
11343788
MB		 6452 if (o->op_flags & OPf_STACKED)
6453 return no_fh_allowed(o);
79072805 6454
11343788 6455 kid = cLISTOPo->op_first;
8990e307 6456 if (kid->op_type != OP_NULL)
cea2e8a9 6457 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6458 kid = kid->op_sibling;
11343788
MB		 6459 op_free(cLISTOPo->op_first);
6460 cLISTOPo->op_first = kid;
85e6fe83 6461 if (!kid) {
396482e1 6462 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 6463 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6464 }
79072805 6465
de4bf5b3 6466 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 6467 OP * const sibl = kid->op_sibling;
463ee0b2 6468 kid->op_sibling = 0;
131b3ad0 6469 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 6470 if (cLISTOPo->op_first == cLISTOPo->op_last)
6471 cLISTOPo->op_last = kid;
6472 cLISTOPo->op_first = kid;
79072805
LW		 6473 kid->op_sibling = sibl;
6474 }
6475
6476 kid->op_type = OP_PUSHRE;
22c35a8c 6477 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 6478 scalar(kid);
041457d9 6479 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 6480 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6481 "Use of /g modifier is meaningless in split");
6482 }
79072805
LW		 6483
6484 if (!kid->op_sibling)
54b9620d 6485 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6486
6487 kid = kid->op_sibling;
6488 scalar(kid);
6489
6490 if (!kid->op_sibling)
11343788 6491 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6492
6493 kid = kid->op_sibling;
6494 scalar(kid);
6495
6496 if (kid->op_sibling)
53e06cf0 6497 return too_many_arguments(o,OP_DESC(o));
79072805 6498
11343788 6499 return o;
79072805
LW		 6500}
6501
6502OP *
1c846c1f 6503Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 6504{
551405c4 6505 const OP * const kid = cLISTOPo->op_first->op_sibling;
041457d9
DM		 6506 if (kid && kid->op_type == OP_MATCH) {
6507 if (ckWARN(WARN_SYNTAX)) {
6867be6d
AL		 6508 const REGEXP *re = PM_GETRE(kPMOP);
6509 const char *pmstr = re ? re->precomp : "STRING";
9014280d 6510 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 6511 "/%s/ should probably be written as \"%s\"",
6512 pmstr, pmstr);
6513 }
6514 }
6515 return ck_fun(o);
6516}
6517
6518OP *
cea2e8a9 6519Perl_ck_subr(pTHX_ OP *o)
79072805 6520{
97aff369 6521 dVAR;
11343788
MB		 6522 OP *prev = ((cUNOPo->op_first->op_sibling)
6523 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6524 OP *o2 = prev->op_sibling;
4633a7c4 6525 OP *cvop;
c445ea15
AL		 6526 char *proto = NULL;
6527 CV *cv = NULL;
6528 GV *namegv = NULL;
4633a7c4
LW		 6529 int optional = 0;
6530 I32 arg = 0;
5b794e05 6531 I32 contextclass = 0;
c445ea15 6532 char *e = NULL;
0723351e 6533 bool delete_op = 0;
4633a7c4 6534
d3011074 6535 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6536 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6537 if (cvop->op_type == OP_RV2CV) {
6538 SVOP* tmpop;
11343788 6539 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6540 op_null(cvop); /* disable rv2cv */
4633a7c4 6541 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6542 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6543 GV *gv = cGVOPx_gv(tmpop);
350de78d 6544 cv = GvCVu(gv);
76cd736e
GS		 6545 if (!cv)
6546 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 6547 else {
6548 if (SvPOK(cv)) {
6549 namegv = CvANON(cv) ? gv : CvGV(cv);
8b6b16e7 6550 proto = SvPV_nolen((SV*)cv);
06492da6
SF		 6551 }
6552 if (CvASSERTION(cv)) {
6553 if (PL_hints & HINT_ASSERTING) {
6554 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6555 o->op_private |= OPpENTERSUB_DB;
6556 }
8fa7688f 6557 else {
0723351e 6558 delete_op = 1;
041457d9 6559 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
8fa7688f
SF		 6560 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6561 "Impossible to activate assertion call");
6562 }
6563 }
06492da6 6564 }
46fc3d4c 6565 }
4633a7c4
LW		 6566 }
6567 }
f5d5a27c 6568 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6569 if (o2->op_type == OP_CONST)
6570 o2->op_private &= ~OPpCONST_STRICT;
58a40671 6571 else if (o2->op_type == OP_LIST) {
551405c4 6572 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
58a40671
GS		 6573 if (o && o->op_type == OP_CONST)
6574 o->op_private &= ~OPpCONST_STRICT;
6575 }
7a52d87a 6576 }
3280af22
NIS		 6577 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6578 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6579 o->op_private |= OPpENTERSUB_DB;
6580 while (o2 != cvop) {
4633a7c4
LW		 6581 if (proto) {
6582 switch (*proto) {
6583 case '\0':
5dc0d613 6584 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6585 case ';':
6586 optional = 1;
6587 proto++;
6588 continue;
6589 case '$':
6590 proto++;
6591 arg++;
11343788 6592 scalar(o2);
4633a7c4
LW		 6593 break;
6594 case '%':
6595 case '@':
11343788 6596 list(o2);
4633a7c4
LW		 6597 arg++;
6598 break;
6599 case '&':
6600 proto++;
6601 arg++;
11343788 6602 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6603 bad_type(arg,
6604 arg == 1 ? "block or sub {}" : "sub {}",
6605 gv_ename(namegv), o2);
4633a7c4
LW		 6606 break;
6607 case '*':
2ba6ecf4 6608 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6609 proto++;
6610 arg++;
11343788 6611 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6612 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6613 else if (o2->op_type == OP_CONST)
6614 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6615 else if (o2->op_type == OP_ENTERSUB) {
6616 /* accidental subroutine, revert to bareword */
6617 OP *gvop = ((UNOP*)o2)->op_first;
6618 if (gvop && gvop->op_type == OP_NULL) {
6619 gvop = ((UNOP*)gvop)->op_first;
6620 if (gvop) {
6621 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6622 ;
6623 if (gvop &&
6624 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6625 (gvop = ((UNOP*)gvop)->op_first) &&
6626 gvop->op_type == OP_GV)
6627 {
551405c4
AL		 6628 GV * const gv = cGVOPx_gv(gvop);
6629 OP * const sibling = o2->op_sibling;
396482e1 6630 SV * const n = newSVpvs("");
9675f7ac 6631 op_free(o2);
2a797ae2 6632 gv_fullname4(n, gv, "", FALSE);
2692f720 6633 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6634 prev->op_sibling = o2;
6635 o2->op_sibling = sibling;
6636 }
6637 }
6638 }
6639 }
2ba6ecf4
GS		 6640 scalar(o2);
6641 break;
5b794e05
JH		 6642 case '[': case ']':
6643 goto oops;
6644 break;
4633a7c4
LW		 6645 case '\\':
6646 proto++;
6647 arg++;
5b794e05 6648 again:
4633a7c4 6649 switch (*proto++) {
5b794e05
JH		 6650 case '[':
6651 if (contextclass++ == 0) {
841d93c8 6652 e = strchr(proto, ']');
5b794e05
JH		 6653 if (!e || e == proto)
6654 goto oops;
6655 }
6656 else
6657 goto oops;
6658 goto again;
6659 break;
6660 case ']':
466bafcd 6661 if (contextclass) {
0bd48802 6662 /* XXX We shouldn't be modifying proto, so we can const proto */
6867be6d
AL		 6663 char *p = proto;
6664 const char s = *p;
466bafcd
RGS		 6665 contextclass = 0;
6666 *p = '\0';
6667 while (*--p != '[');
1eb1540c 6668 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6669 gv_ename(namegv), o2);
6670 *proto = s;
6671 } else
5b794e05
JH		 6672 goto oops;
6673 break;
4633a7c4 6674 case '*':
5b794e05
JH		 6675 if (o2->op_type == OP_RV2GV)
6676 goto wrapref;
6677 if (!contextclass)
6678 bad_type(arg, "symbol", gv_ename(namegv), o2);
6679 break;
4633a7c4 6680 case '&':
5b794e05
JH		 6681 if (o2->op_type == OP_ENTERSUB)
6682 goto wrapref;
6683 if (!contextclass)
6684 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6685 break;
4633a7c4 6686 case '$':
5b794e05
JH		 6687 if (o2->op_type == OP_RV2SV ||
6688 o2->op_type == OP_PADSV ||
6689 o2->op_type == OP_HELEM ||
6690 o2->op_type == OP_AELEM ||
6691 o2->op_type == OP_THREADSV)
6692 goto wrapref;
6693 if (!contextclass)
5dc0d613 6694 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6695 break;
4633a7c4 6696 case '@':
5b794e05
JH		 6697 if (o2->op_type == OP_RV2AV ||
6698 o2->op_type == OP_PADAV)
6699 goto wrapref;
6700 if (!contextclass)
5dc0d613 6701 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6702 break;
4633a7c4 6703 case '%':
5b794e05
JH		 6704 if (o2->op_type == OP_RV2HV ||
6705 o2->op_type == OP_PADHV)
6706 goto wrapref;
6707 if (!contextclass)
6708 bad_type(arg, "hash", gv_ename(namegv), o2);
6709 break;
6710 wrapref:
4633a7c4 6711 {
551405c4
AL		 6712 OP* const kid = o2;
6713 OP* const sib = kid->op_sibling;
4633a7c4 6714 kid->op_sibling = 0;
6fa846a0
GS		 6715 o2 = newUNOP(OP_REFGEN, 0, kid);
6716 o2->op_sibling = sib;
e858de61 6717 prev->op_sibling = o2;
4633a7c4 6718 }
841d93c8 6719 if (contextclass && e) {
5b794e05
JH		 6720 proto = e + 1;
6721 contextclass = 0;
6722 }
4633a7c4
LW		 6723 break;
6724 default: goto oops;
6725 }
5b794e05
JH		 6726 if (contextclass)
6727 goto again;
4633a7c4 6728 break;
b1cb66bf 6729 case ' ':
6730 proto++;
6731 continue;
4633a7c4
LW		 6732 default:
6733 oops:
35c1215d
NC		 6734 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6735 gv_ename(namegv), cv);
4633a7c4
LW		 6736 }
6737 }
6738 else
11343788
MB		 6739 list(o2);
6740 mod(o2, OP_ENTERSUB);
6741 prev = o2;
6742 o2 = o2->op_sibling;
551405c4 6743 } /* while */
fb73857a 6744 if (proto && !optional &&
6745 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6746 return too_few_arguments(o, gv_ename(namegv));
0723351e 6747 if(delete_op) {
06492da6
SF		 6748 op_free(o);
6749 o=newSVOP(OP_CONST, 0, newSViv(0));
6750 }
11343788 6751 return o;
79072805
LW		 6752}
6753
6754OP *
cea2e8a9 6755Perl_ck_svconst(pTHX_ OP *o)
8990e307 6756{
11343788
MB		 6757 SvREADONLY_on(cSVOPo->op_sv);
6758 return o;
8990e307
LW		 6759}
6760
6761OP *
cea2e8a9 6762Perl_ck_trunc(pTHX_ OP *o)
79072805 6763{
11343788
MB		 6764 if (o->op_flags & OPf_KIDS) {
6765 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6766
a0d0e21e
LW		 6767 if (kid->op_type == OP_NULL)
6768 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6769 if (kid && kid->op_type == OP_CONST &&
6770 (kid->op_private & OPpCONST_BARE))
6771 {
11343788 6772 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6773 kid->op_private &= ~OPpCONST_STRICT;
6774 }
79072805 6775 }
11343788 6776 return ck_fun(o);
79072805
LW		 6777}
6778
35fba0d9 6779OP *
bab9c0ac
RGS		 6780Perl_ck_unpack(pTHX_ OP *o)
6781{
6782 OP *kid = cLISTOPo->op_first;
6783 if (kid->op_sibling) {
6784 kid = kid->op_sibling;
6785 if (!kid->op_sibling)
6786 kid->op_sibling = newDEFSVOP();
6787 }
6788 return ck_fun(o);
6789}
6790
6791OP *
35fba0d9
RG		 6792Perl_ck_substr(pTHX_ OP *o)
6793{
6794 o = ck_fun(o);
6795 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6796 OP *kid = cLISTOPo->op_first;
6797
6798 if (kid->op_type == OP_NULL)
6799 kid = kid->op_sibling;
6800 if (kid)
6801 kid->op_flags |= OPf_MOD;
6802
6803 }
6804 return o;
6805}
6806
61b743bb
DM		 6807/* A peephole optimizer. We visit the ops in the order they're to execute.
6808 * See the comments at the top of this file for more details about when
6809 * peep() is called */
463ee0b2 6810
79072805 6811void
864dbfa3 6812Perl_peep(pTHX_ register OP *o)
79072805 6813{
27da23d5 6814 dVAR;
c445ea15 6815 register OP* oldop = NULL;
2d8e6c8d 6816
2814eb74 6817 if (!o || o->op_opt)
79072805 6818 return;
a0d0e21e 6819 ENTER;
462e5cf6 6820 SAVEOP();
7766f137 6821 SAVEVPTR(PL_curcop);
a0d0e21e 6822 for (; o; o = o->op_next) {
2814eb74 6823 if (o->op_opt)
a0d0e21e 6824 break;
533c011a 6825 PL_op = o;
a0d0e21e 6826 switch (o->op_type) {
acb36ea4 6827 case OP_SETSTATE:
a0d0e21e
LW		 6828 case OP_NEXTSTATE:
6829 case OP_DBSTATE:
3280af22 6830 PL_curcop = ((COP*)o); /* for warnings */
2814eb74 6831 o->op_opt = 1;
a0d0e21e
LW		 6832 break;
6833
a0d0e21e 6834 case OP_CONST:
7a52d87a
GS		 6835 if (cSVOPo->op_private & OPpCONST_STRICT)
6836 no_bareword_allowed(o);
7766f137 6837#ifdef USE_ITHREADS
3848b962 6838 case OP_METHOD_NAMED:
7766f137
GS		 6839 /* Relocate sv to the pad for thread safety.
6840 * Despite being a "constant", the SV is written to,
6841 * for reference counts, sv_upgrade() etc. */
6842 if (cSVOP->op_sv) {
6867be6d 6843 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6844 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6845 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6846 * some pad, so make a copy. */
dd2155a4
DM		 6847 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6848 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6849 SvREFCNT_dec(cSVOPo->op_sv);
6850 }
052ca17e
NC		 6851 else if (o->op_type == OP_CONST
6852 && cSVOPo->op_sv == &PL_sv_undef) {
6853 /* PL_sv_undef is hack - it's unsafe to store it in the
6854 AV that is the pad, because av_fetch treats values of
6855 PL_sv_undef as a "free" AV entry and will merrily
6856 replace them with a new SV, causing pad_alloc to think
6857 that this pad slot is free. (When, clearly, it is not)
6858 */
6859 SvOK_off(PAD_SVl(ix));
6860 SvPADTMP_on(PAD_SVl(ix));
6861 SvREADONLY_on(PAD_SVl(ix));
6862 }
6a7129a1 6863 else {
dd2155a4 6864 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6865 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6866 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6867 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6868 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6869 }
7766f137
GS		 6870 cSVOPo->op_sv = Nullsv;
6871 o->op_targ = ix;
6872 }
6873#endif
2814eb74 6874 o->op_opt = 1;
07447971
GS		 6875 break;
6876
df91b2c5
AE		 6877 case OP_CONCAT:
6878 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6879 if (o->op_next->op_private & OPpTARGET_MY) {
6880 if (o->op_flags & OPf_STACKED) /* chained concats */
6881 goto ignore_optimization;
6882 else {
6883 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6884 o->op_targ = o->op_next->op_targ;
6885 o->op_next->op_targ = 0;
6886 o->op_private |= OPpTARGET_MY;
6887 }
6888 }
6889 op_null(o->op_next);
6890 }
6891 ignore_optimization:
2814eb74 6892 o->op_opt = 1;
df91b2c5 6893 break;
8990e307 6894 case OP_STUB:
54310121 6895 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
2814eb74 6896 o->op_opt = 1;
54310121 6897 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6898 }
748a9306 6899 goto nothin;
79072805 6900 case OP_NULL:
acb36ea4
GS		 6901 if (o->op_targ == OP_NEXTSTATE
6902 || o->op_targ == OP_DBSTATE
6903 || o->op_targ == OP_SETSTATE)
6904 {
3280af22 6905 PL_curcop = ((COP*)o);
acb36ea4 6906 }
dad75012
AMS		 6907 /* XXX: We avoid setting op_seq here to prevent later calls
6908 to peep() from mistakenly concluding that optimisation
6909 has already occurred. This doesn't fix the real problem,
6910 though (See 20010220.007). AMS 20010719 */
2814eb74 6911 /* op_seq functionality is now replaced by op_opt */
dad75012
AMS		 6912 if (oldop && o->op_next) {
6913 oldop->op_next = o->op_next;
6914 continue;
6915 }
6916 break;
79072805 6917 case OP_SCALAR:
93a17b20 6918 case OP_LINESEQ:
463ee0b2 6919 case OP_SCOPE:
748a9306 6920 nothin:
a0d0e21e
LW		 6921 if (oldop && o->op_next) {
6922 oldop->op_next = o->op_next;
79072805
LW		 6923 continue;
6924 }
2814eb74 6925 o->op_opt = 1;
79072805
LW		 6926 break;
6927
6a077020 6928 case OP_PADAV:
79072805 6929 case OP_GV:
6a077020 6930 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 6931 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 6932 o->op_next : o->op_next->op_next;
a0d0e21e 6933 IV i;
f9dc862f 6934 if (pop && pop->op_type == OP_CONST &&
af5acbb4 6935 ((PL_op = pop->op_next)) &&
8990e307 6936 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6937 !(pop->op_next->op_private &
78f9721b 6938 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6939 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6940 <= 255 &&
8990e307
LW		 6941 i >= 0)
6942 {
350de78d 6943 GV *gv;
af5acbb4
DM		 6944 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6945 no_bareword_allowed(pop);
6a077020
DM		 6946 if (o->op_type == OP_GV)
6947 op_null(o->op_next);
93c66552
DM		 6948 op_null(pop->op_next);
6949 op_null(pop);
a0d0e21e
LW		 6950 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6951 o->op_next = pop->op_next->op_next;
22c35a8c 6952 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6953 o->op_private = (U8)i;
6a077020
DM		 6954 if (o->op_type == OP_GV) {
6955 gv = cGVOPo_gv;
6956 GvAVn(gv);
6957 }
6958 else
6959 o->op_flags |= OPf_SPECIAL;
6960 o->op_type = OP_AELEMFAST;
6961 }
6962 o->op_opt = 1;
6963 break;
6964 }
6965
6966 if (o->op_next->op_type == OP_RV2SV) {
6967 if (!(o->op_next->op_private & OPpDEREF)) {
6968 op_null(o->op_next);
6969 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6970 | OPpOUR_INTRO);
6971 o->op_next = o->op_next->op_next;
6972 o->op_type = OP_GVSV;
6973 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 6974 }
79072805 6975 }
e476b1b5 6976 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 6977 GV * const gv = cGVOPo_gv;
b15aece3 6978 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 6979 /* XXX could check prototype here instead of just carping */
551405c4 6980 SV * const sv = sv_newmortal();
76cd736e 6981 gv_efullname3(sv, gv, Nullch);
9014280d 6982 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6983 "%"SVf"() called too early to check prototype",
6984 sv);
76cd736e
GS		 6985 }
6986 }
89de2904
AMS		 6987 else if (o->op_next->op_type == OP_READLINE
6988 && o->op_next->op_next->op_type == OP_CONCAT
6989 && (o->op_next->op_next->op_flags & OPf_STACKED))
6990 {
d2c45030
AMS		 6991 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6992 o->op_type = OP_RCATLINE;
6993 o->op_flags |= OPf_STACKED;
6994 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6995 op_null(o->op_next->op_next);
d2c45030 6996 op_null(o->op_next);
89de2904 6997 }
76cd736e 6998
2814eb74 6999 o->op_opt = 1;
79072805
LW		 7000 break;
7001
a0d0e21e 7002 case OP_MAPWHILE:
79072805
LW		 7003 case OP_GREPWHILE:
7004 case OP_AND:
7005 case OP_OR:
c963b151 7006 case OP_DOR:
2c2d71f5
JH		 7007 case OP_ANDASSIGN:
7008 case OP_ORASSIGN:
c963b151 7009 case OP_DORASSIGN:
1a67a97c
SM		 7010 case OP_COND_EXPR:
7011 case OP_RANGE:
2814eb74 7012 o->op_opt = 1;
fd4d1407
IZ		 7013 while (cLOGOP->op_other->op_type == OP_NULL)
7014 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 7015 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 7016 break;
7017
79072805 7018 case OP_ENTERLOOP:
9c2ca71a 7019 case OP_ENTERITER:
2814eb74 7020 o->op_opt = 1;
58cccf98
SM		 7021 while (cLOOP->op_redoop->op_type == OP_NULL)
7022 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 7023 peep(cLOOP->op_redoop);
58cccf98
SM		 7024 while (cLOOP->op_nextop->op_type == OP_NULL)
7025 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 7026 peep(cLOOP->op_nextop);
58cccf98
SM		 7027 while (cLOOP->op_lastop->op_type == OP_NULL)
7028 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 7029 peep(cLOOP->op_lastop);
7030 break;
7031
8782bef2 7032 case OP_QR:
79072805
LW		 7033 case OP_MATCH:
7034 case OP_SUBST:
2814eb74 7035 o->op_opt = 1;
9041c2e3 7036 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 7037 cPMOP->op_pmreplstart->op_type == OP_NULL)
7038 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 7039 peep(cPMOP->op_pmreplstart);
79072805
LW		 7040 break;
7041
a0d0e21e 7042 case OP_EXEC:
2814eb74 7043 o->op_opt = 1;
041457d9
DM		 7044 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7045 && ckWARN(WARN_SYNTAX))
7046 {
a0d0e21e 7047 if (o->op_next->op_sibling &&
20408e3c
GS		 7048 o->op_next->op_sibling->op_type != OP_EXIT &&
7049 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 7050 o->op_next->op_sibling->op_type != OP_DIE) {
6867be6d 7051 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 7052
57843af0 7053 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 7054 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 7055 "Statement unlikely to be reached");
9014280d 7056 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 7057 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 7058 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 7059 }
7060 }
7061 break;
b2ffa427 7062
c750a3ec 7063 case OP_HELEM: {
e75d1f10 7064 UNOP *rop;
6d822dc4 7065 SV *lexname;
e75d1f10 7066 GV **fields;
6d822dc4 7067 SV **svp, *sv;
d5263905 7068 const char *key = NULL;
c750a3ec 7069 STRLEN keylen;
b2ffa427 7070
2814eb74 7071 o->op_opt = 1;
1c846c1f
NIS		 7072
7073 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 7074 break;
1c846c1f
NIS		 7075
7076 /* Make the CONST have a shared SV */
7077 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 7078 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
d5263905 7079 key = SvPV_const(sv, keylen);
25716404
GS		 7080 lexname = newSVpvn_share(key,
7081 SvUTF8(sv) ? -(I32)keylen : keylen,
7082 0);
1c846c1f
NIS		 7083 SvREFCNT_dec(sv);
7084 *svp = lexname;
7085 }
e75d1f10
RD		 7086
7087 if ((o->op_private & (OPpLVAL_INTRO)))
7088 break;
7089
7090 rop = (UNOP*)((BINOP*)o)->op_first;
7091 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7092 break;
7093 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7094 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7095 break;
a4fc7abc 7096 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 7097 if (!fields || !GvHV(*fields))
7098 break;
93524f2b 7099 key = SvPV_const(*svp, keylen);
e75d1f10
RD		 7100 if (!hv_fetch(GvHV(*fields), key,
7101 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7102 {
7103 Perl_croak(aTHX_ "No such class field \"%s\" "
7104 "in variable %s of type %s",
93524f2b 7105 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 7106 }
7107
6d822dc4
MS		 7108 break;
7109 }
c750a3ec 7110
e75d1f10
RD		 7111 case OP_HSLICE: {
7112 UNOP *rop;
7113 SV *lexname;
7114 GV **fields;
7115 SV **svp;
93524f2b 7116 const char *key;
e75d1f10
RD		 7117 STRLEN keylen;
7118 SVOP *first_key_op, *key_op;
7119
7120 if ((o->op_private & (OPpLVAL_INTRO))
7121 /* I bet there's always a pushmark... */
7122 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7123 /* hmmm, no optimization if list contains only one key. */
7124 break;
7125 rop = (UNOP*)((LISTOP*)o)->op_last;
7126 if (rop->op_type != OP_RV2HV)
7127 break;
7128 if (rop->op_first->op_type == OP_PADSV)
7129 /* @$hash{qw(keys here)} */
7130 rop = (UNOP*)rop->op_first;
7131 else {
7132 /* @{$hash}{qw(keys here)} */
7133 if (rop->op_first->op_type == OP_SCOPE
7134 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7135 {
7136 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7137 }
7138 else
7139 break;
7140 }
7141
7142 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7143 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7144 break;
a4fc7abc 7145 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 7146 if (!fields || !GvHV(*fields))
7147 break;
7148 /* Again guessing that the pushmark can be jumped over.... */
7149 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7150 ->op_first->op_sibling;
7151 for (key_op = first_key_op; key_op;
7152 key_op = (SVOP*)key_op->op_sibling) {
7153 if (key_op->op_type != OP_CONST)
7154 continue;
7155 svp = cSVOPx_svp(key_op);
93524f2b 7156 key = SvPV_const(*svp, keylen);
e75d1f10
RD		 7157 if (!hv_fetch(GvHV(*fields), key,
7158 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7159 {
7160 Perl_croak(aTHX_ "No such class field \"%s\" "
7161 "in variable %s of type %s",
bfcb3514 7162 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 7163 }
7164 }
7165 break;
7166 }
7167
fe1bc4cf 7168 case OP_SORT: {
fe1bc4cf 7169 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 7170 OP *oleft;
fe1bc4cf
DM		 7171 OP *o2;
7172
fe1bc4cf 7173 /* check that RHS of sort is a single plain array */
551405c4 7174 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 7175 if (!oright || oright->op_type != OP_PUSHMARK)
7176 break;
471178c0
NC		 7177
7178 /* reverse sort ... can be optimised. */
7179 if (!cUNOPo->op_sibling) {
7180 /* Nothing follows us on the list. */
551405c4 7181 OP * const reverse = o->op_next;
471178c0
NC		 7182
7183 if (reverse->op_type == OP_REVERSE &&
7184 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 7185 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 7186 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7187 && (cUNOPx(pushmark)->op_sibling == o)) {
7188 /* reverse -> pushmark -> sort */
7189 o->op_private |= OPpSORT_REVERSE;
7190 op_null(reverse);
7191 pushmark->op_next = oright->op_next;
7192 op_null(oright);
7193 }
7194 }
7195 }
7196
7197 /* make @a = sort @a act in-place */
7198
7199 o->op_opt = 1;
7200
fe1bc4cf
DM		 7201 oright = cUNOPx(oright)->op_sibling;
7202 if (!oright)
7203 break;
7204 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7205 oright = cUNOPx(oright)->op_sibling;
7206 }
7207
7208 if (!oright ||
7209 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7210 || oright->op_next != o
7211 || (oright->op_private & OPpLVAL_INTRO)
7212 )
7213 break;
7214
7215 /* o2 follows the chain of op_nexts through the LHS of the
7216 * assign (if any) to the aassign op itself */
7217 o2 = o->op_next;
7218 if (!o2 || o2->op_type != OP_NULL)
7219 break;
7220 o2 = o2->op_next;
7221 if (!o2 || o2->op_type != OP_PUSHMARK)
7222 break;
7223 o2 = o2->op_next;
7224 if (o2 && o2->op_type == OP_GV)
7225 o2 = o2->op_next;
7226 if (!o2
7227 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7228 || (o2->op_private & OPpLVAL_INTRO)
7229 )
7230 break;
7231 oleft = o2;
7232 o2 = o2->op_next;
7233 if (!o2 || o2->op_type != OP_NULL)
7234 break;
7235 o2 = o2->op_next;
7236 if (!o2 || o2->op_type != OP_AASSIGN
7237 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7238 break;
7239
db7511db
DM		 7240 /* check that the sort is the first arg on RHS of assign */
7241
7242 o2 = cUNOPx(o2)->op_first;
7243 if (!o2 || o2->op_type != OP_NULL)
7244 break;
7245 o2 = cUNOPx(o2)->op_first;
7246 if (!o2 || o2->op_type != OP_PUSHMARK)
7247 break;
7248 if (o2->op_sibling != o)
7249 break;
7250
fe1bc4cf
DM		 7251 /* check the array is the same on both sides */
7252 if (oleft->op_type == OP_RV2AV) {
7253 if (oright->op_type != OP_RV2AV
7254 || !cUNOPx(oright)->op_first
7255 || cUNOPx(oright)->op_first->op_type != OP_GV
7256 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7257 cGVOPx_gv(cUNOPx(oright)->op_first)
7258 )
7259 break;
7260 }
7261 else if (oright->op_type != OP_PADAV
7262 || oright->op_targ != oleft->op_targ
7263 )
7264 break;
7265
7266 /* transfer MODishness etc from LHS arg to RHS arg */
7267 oright->op_flags = oleft->op_flags;
7268 o->op_private |= OPpSORT_INPLACE;
7269
7270 /* excise push->gv->rv2av->null->aassign */
7271 o2 = o->op_next->op_next;
7272 op_null(o2); /* PUSHMARK */
7273 o2 = o2->op_next;
7274 if (o2->op_type == OP_GV) {
7275 op_null(o2); /* GV */
7276 o2 = o2->op_next;
7277 }
7278 op_null(o2); /* RV2AV or PADAV */
7279 o2 = o2->op_next->op_next;
7280 op_null(o2); /* AASSIGN */
7281
7282 o->op_next = o2->op_next;
7283
7284 break;
7285 }
ef3e5ea9
NC		 7286
7287 case OP_REVERSE: {
e682d7b7 7288 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 7289 OP *gvop = NULL;
ef3e5ea9
NC		 7290 LISTOP *enter, *exlist;
7291 o->op_opt = 1;
7292
7293 enter = (LISTOP *) o->op_next;
7294 if (!enter)
7295 break;
7296 if (enter->op_type == OP_NULL) {
7297 enter = (LISTOP *) enter->op_next;
7298 if (!enter)
7299 break;
7300 }
d46f46af
NC		 7301 /* for $a (...) will have OP_GV then OP_RV2GV here.
7302 for (...) just has an OP_GV. */
ce335f37
NC		 7303 if (enter->op_type == OP_GV) {
7304 gvop = (OP *) enter;
7305 enter = (LISTOP *) enter->op_next;
7306 if (!enter)
7307 break;
d46f46af
NC		 7308 if (enter->op_type == OP_RV2GV) {
7309 enter = (LISTOP *) enter->op_next;
7310 if (!enter)
ce335f37 7311 break;
d46f46af 7312 }
ce335f37
NC		 7313 }
7314
ef3e5ea9
NC		 7315 if (enter->op_type != OP_ENTERITER)
7316 break;
7317
7318 iter = enter->op_next;
7319 if (!iter || iter->op_type != OP_ITER)
7320 break;
7321
ce335f37
NC		 7322 expushmark = enter->op_first;
7323 if (!expushmark || expushmark->op_type != OP_NULL
7324 || expushmark->op_targ != OP_PUSHMARK)
7325 break;
7326
7327 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 7328 if (!exlist || exlist->op_type != OP_NULL
7329 || exlist->op_targ != OP_LIST)
7330 break;
7331
7332 if (exlist->op_last != o) {
7333 /* Mmm. Was expecting to point back to this op. */
7334 break;
7335 }
7336 theirmark = exlist->op_first;
7337 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7338 break;
7339
c491ecac 7340 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 7341 /* There's something between the mark and the reverse, eg
7342 for (1, reverse (...))
7343 so no go. */
7344 break;
7345 }
7346
c491ecac
NC		 7347 ourmark = ((LISTOP *)o)->op_first;
7348 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7349 break;
7350
ef3e5ea9
NC		 7351 ourlast = ((LISTOP *)o)->op_last;
7352 if (!ourlast || ourlast->op_next != o)
7353 break;
7354
e682d7b7
NC		 7355 rv2av = ourmark->op_sibling;
7356 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7357 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7358 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7359 /* We're just reversing a single array. */
7360 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7361 enter->op_flags |= OPf_STACKED;
7362 }
7363
ef3e5ea9
NC		 7364 /* We don't have control over who points to theirmark, so sacrifice
7365 ours. */
7366 theirmark->op_next = ourmark->op_next;
7367 theirmark->op_flags = ourmark->op_flags;
ce335f37 7368 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 7369 op_null(ourmark);
7370 op_null(o);
7371 enter->op_private |= OPpITER_REVERSED;
7372 iter->op_private |= OPpITER_REVERSED;
7373
7374 break;
7375 }
e26df76a
NC		 7376
7377 case OP_SASSIGN: {
7378 OP *rv2gv;
7379 UNOP *refgen, *rv2cv;
7380 LISTOP *exlist;
7381
7382 /* I do not understand this, but if o->op_opt isn't set to 1,
7383 various tests in ext/B/t/bytecode.t fail with no readily
7384 apparent cause. */
7385
7386 o->op_opt = 1;
7387
de3370bc
NC		 7388
7389 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7390 break;
7391
e26df76a
NC		 7392 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7393 break;
7394
7395 rv2gv = ((BINOP *)o)->op_last;
7396 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7397 break;
7398
7399 refgen = (UNOP *)((BINOP *)o)->op_first;
7400
7401 if (!refgen || refgen->op_type != OP_REFGEN)
7402 break;
7403
7404 exlist = (LISTOP *)refgen->op_first;
7405 if (!exlist || exlist->op_type != OP_NULL
7406 || exlist->op_targ != OP_LIST)
7407 break;
7408
7409 if (exlist->op_first->op_type != OP_PUSHMARK)
7410 break;
7411
7412 rv2cv = (UNOP*)exlist->op_last;
7413
7414 if (rv2cv->op_type != OP_RV2CV)
7415 break;
7416
7417 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7418 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7419 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7420
7421 o->op_private |= OPpASSIGN_CV_TO_GV;
7422 rv2gv->op_private |= OPpDONT_INIT_GV;
7423 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7424
7425 break;
7426 }
7427
fe1bc4cf 7428
79072805 7429 default:
2814eb74 7430 o->op_opt = 1;
79072805
LW		 7431 break;
7432 }
a0d0e21e 7433 oldop = o;
79072805 7434 }
a0d0e21e 7435 LEAVE;
79072805 7436}
beab0874 7437
1cb0ed9b
RGS		 7438char*
7439Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 7440{
97aff369 7441 dVAR;
e1ec3a88 7442 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 7443 SV* keysv;
7444 HE* he;
7445
7446 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 7447 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 7448
7449 keysv = sv_2mortal(newSViv(index));
7450
7451 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7452 if (!he)
27da23d5 7453 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 7454
7455 return SvPV_nolen(HeVAL(he));
7456}
7457
1cb0ed9b
RGS		 7458char*
7459Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 7460{
97aff369 7461 dVAR;
e1ec3a88 7462 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 7463 SV* keysv;
7464 HE* he;
7465
7466 if (!PL_custom_op_descs)
27da23d5 7467 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 7468
7469 keysv = sv_2mortal(newSViv(index));
7470
7471 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7472 if (!he)
27da23d5 7473 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 7474
7475 return SvPV_nolen(HeVAL(he));
7476}
19e8ce8e 7477
beab0874
JT		 7478#include "XSUB.h"
7479
7480/* Efficient sub that returns a constant scalar value. */
7481static void
acfe0abc 7482const_sv_xsub(pTHX_ CV* cv)
beab0874 7483{
97aff369 7484 dVAR;
beab0874 7485 dXSARGS;
9cbac4c7
DM		 7486 if (items != 0) {
7487#if 0
7488 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 7489 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 7490#endif
7491 }
9a049f1c 7492 EXTEND(sp, 1);
0768512c 7493 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7494 XSRETURN(1);
7495}
4946a0fa
NC		 7496
7497/*
7498 * Local variables:
7499 * c-indentation-style: bsd
7500 * c-basic-offset: 4
7501 * indent-tabs-mode: t
7502 * End:
7503 *
37442d52
RGS		 7504 * ex: set ts=8 sts=4 sw=4 noet:
7505 */
Unnamed repository; edit this file 'description' to name the repository.