This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refactoring to Sv*_set() macros - patch #5
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
cbdf9ef8 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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{
5a8e194f
NIS
131 I32 **ptr = (I32 **) op;
132 I32 *slab = ptr[-1];
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
76e3520e 161STATIC char*
cea2e8a9 162S_gv_ename(pTHX_ GV *gv)
4633a7c4 163{
2d8e6c8d 164 STRLEN n_a;
4633a7c4 165 SV* tmpsv = sv_newmortal();
46fc3d4c 166 gv_efullname3(tmpsv, gv, Nullch);
2d8e6c8d 167 return SvPV(tmpsv,n_a);
4633a7c4
LW
168}
169
76e3520e 170STATIC OP *
cea2e8a9 171S_no_fh_allowed(pTHX_ OP *o)
79072805 172{
cea2e8a9 173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 174 OP_DESC(o)));
11343788 175 return o;
79072805
LW
176}
177
76e3520e 178STATIC OP *
bfed75c6 179S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 180{
cea2e8a9 181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 182 return o;
79072805
LW
183}
184
76e3520e 185STATIC OP *
bfed75c6 186S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 187{
cea2e8a9 188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 189 return o;
79072805
LW
190}
191
76e3520e 192STATIC void
6867be6d 193S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 194{
cea2e8a9 195 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 196 (int)n, name, t, OP_DESC(kid)));
8990e307
LW
197}
198
7a52d87a 199STATIC void
6867be6d 200S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 201{
5a844595 202 qerror(Perl_mess(aTHX_
35c1215d
NC
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
204 cSVOPo_sv));
7a52d87a
GS
205}
206
79072805
LW
207/* "register" allocation */
208
209PADOFFSET
dd2155a4 210Perl_allocmy(pTHX_ char *name)
93a17b20 211{
a0d0e21e 212 PADOFFSET off;
a0d0e21e 213
59f00321 214 /* complain about "my $<special_var>" etc etc */
155aba94
GS
215 if (!(PL_in_my == KEY_our ||
216 isALPHA(name[1]) ||
39e02b42 217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
59f00321 218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
834a4ddd 219 {
c4d0567e 220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS
221 /* 1999-02-27 mjd@plover.com */
222 char *p;
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
226 if (p-name > 200) {
227 strcpy(name+200, "...");
228 p = name+199;
229 }
230 else {
231 p[1] = '\0';
232 }
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
235 *p = *(p-1);
46fc3d4c
PP
236 name[2] = toCTRL(name[1]);
237 name[1] = '^';
238 }
cea2e8a9 239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 240 }
748a9306 241
dd2155a4
DM
242 /* check for duplicate declaration */
243 pad_check_dup(name,
c5661c80 244 (bool)(PL_in_my == KEY_our),
dd2155a4
DM
245 (PL_curstash ? PL_curstash : PL_defstash)
246 );
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\"",
251 name, PL_in_my == KEY_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,
258 (PL_in_my == KEY_our
133706a6
RGS
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
dd2155a4
DM
261 : Nullhv
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{
acb36ea4 273 OPCODE type;
4026c95a 274 PADOFFSET refcnt;
79072805 275
2814eb74 276 if (!o || o->op_static)
79072805
LW
277 return;
278
7934575e
GS
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
281 case OP_LEAVESUB:
282 case OP_LEAVESUBLV:
283 case OP_LEAVEEVAL:
284 case OP_LEAVE:
285 case OP_SCOPE:
286 case OP_LEAVEWRITE:
287 OP_REFCNT_LOCK;
4026c95a 288 refcnt = OpREFCNT_dec(o);
7934575e 289 OP_REFCNT_UNLOCK;
4026c95a
SH
290 if (refcnt)
291 return;
7934575e
GS
292 break;
293 default:
294 break;
295 }
296 }
297
11343788 298 if (o->op_flags & OPf_KIDS) {
6867be6d 299 register OP *kid, *nextkid;
11343788 300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 301 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 302 op_free(kid);
85e6fe83 303 }
79072805 304 }
acb36ea4
GS
305 type = o->op_type;
306 if (type == OP_NULL)
eb160463 307 type = (OPCODE)o->op_targ;
acb36ea4
GS
308
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
312 cop_free((COP*)o);
313
314 op_clear(o);
238a4c30 315 FreeOp(o);
acb36ea4 316}
79072805 317
93c66552
DM
318void
319Perl_op_clear(pTHX_ OP *o)
acb36ea4 320{
13137afc 321
11343788 322 switch (o->op_type) {
acb36ea4
GS
323 case OP_NULL: /* Was holding old type, if any. */
324 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 325 o->op_targ = 0;
a0d0e21e 326 break;
a6006777 327 default:
ac4c12e7 328 if (!(o->op_flags & OPf_REF)
0b94c7bb 329 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777
PP
330 break;
331 /* FALL THROUGH */
463ee0b2 332 case OP_GVSV:
79072805 333 case OP_GV:
a6006777 334 case OP_AELEMFAST:
6a077020
DM
335 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
336 /* not an OP_PADAV replacement */
350de78d 337#ifdef USE_ITHREADS
6a077020
DM
338 if (cPADOPo->op_padix > 0) {
339 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
340 * may still exist on the pad */
341 pad_swipe(cPADOPo->op_padix, TRUE);
342 cPADOPo->op_padix = 0;
343 }
350de78d 344#else
6a077020
DM
345 SvREFCNT_dec(cSVOPo->op_sv);
346 cSVOPo->op_sv = Nullsv;
350de78d 347#endif
6a077020 348 }
79072805 349 break;
a1ae71d2 350 case OP_METHOD_NAMED:
79072805 351 case OP_CONST:
11343788 352 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 353 cSVOPo->op_sv = Nullsv;
3b1c21fa
AB
354#ifdef USE_ITHREADS
355 /** Bug #15654
356 Even if op_clear does a pad_free for the target of the op,
6a077020 357 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB
358 instead it lives on. This results in that it could be reused as
359 a target later on when the pad was reallocated.
360 **/
361 if(o->op_targ) {
362 pad_swipe(o->op_targ,1);
363 o->op_targ = 0;
364 }
365#endif
79072805 366 break;
748a9306
LW
367 case OP_GOTO:
368 case OP_NEXT:
369 case OP_LAST:
370 case OP_REDO:
11343788 371 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW
372 break;
373 /* FALL THROUGH */
a0d0e21e 374 case OP_TRANS:
acb36ea4 375 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 376 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS
377 cSVOPo->op_sv = Nullsv;
378 }
379 else {
a0ed51b3 380 Safefree(cPVOPo->op_pv);
acb36ea4
GS
381 cPVOPo->op_pv = Nullch;
382 }
a0d0e21e
LW
383 break;
384 case OP_SUBST:
11343788 385 op_free(cPMOPo->op_pmreplroot);
971a9dd3 386 goto clear_pmop;
748a9306 387 case OP_PUSHRE:
971a9dd3 388#ifdef USE_ITHREADS
ba89bb6e 389 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM
390 /* No GvIN_PAD_off here, because other references may still
391 * exist on the pad */
392 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS
393 }
394#else
395 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
396#endif
397 /* FALL THROUGH */
a0d0e21e 398 case OP_MATCH:
8782bef2 399 case OP_QR:
971a9dd3 400clear_pmop:
cb55de95
JH
401 {
402 HV *pmstash = PmopSTASH(cPMOPo);
403 if (pmstash && SvREFCNT(pmstash)) {
404 PMOP *pmop = HvPMROOT(pmstash);
405 PMOP *lastpmop = NULL;
406 while (pmop) {
407 if (cPMOPo == pmop) {
408 if (lastpmop)
409 lastpmop->op_pmnext = pmop->op_pmnext;
410 else
411 HvPMROOT(pmstash) = pmop->op_pmnext;
412 break;
413 }
414 lastpmop = pmop;
415 pmop = pmop->op_pmnext;
416 }
83da49e6 417 }
05ec9bb3 418 PmopSTASH_free(cPMOPo);
cb55de95 419 }
971a9dd3 420 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM
421 /* we use the "SAFE" version of the PM_ macros here
422 * since sv_clean_all might release some PMOPs
423 * after PL_regex_padav has been cleared
424 * and the clearing of PL_regex_padav needs to
425 * happen before sv_clean_all
426 */
427 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
428 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB
429#ifdef USE_ITHREADS
430 if(PL_regex_pad) { /* We could be in destruction */
431 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 432 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB
433 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
434 }
1eb1540c 435#endif
13137afc 436
a0d0e21e 437 break;
79072805
LW
438 }
439
743e66e6 440 if (o->op_targ > 0) {
11343788 441 pad_free(o->op_targ);
743e66e6
GS
442 o->op_targ = 0;
443 }
79072805
LW
444}
445
76e3520e 446STATIC void
3eb57f73
HS
447S_cop_free(pTHX_ COP* cop)
448{
05ec9bb3
NIS
449 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
450 CopFILE_free(cop);
451 CopSTASH_free(cop);
0453d815 452 if (! specialWARN(cop->cop_warnings))
3eb57f73 453 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS
454 if (! specialCopIO(cop->cop_io)) {
455#ifdef USE_ITHREADS
042f6df8 456#if 0
05ec9bb3
NIS
457 STRLEN len;
458 char *s = SvPV(cop->cop_io,len);
b178108d
JH
459 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
460#endif
05ec9bb3 461#else
ac27b0f5 462 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS
463#endif
464 }
3eb57f73
HS
465}
466
93c66552
DM
467void
468Perl_op_null(pTHX_ OP *o)
8990e307 469{
acb36ea4
GS
470 if (o->op_type == OP_NULL)
471 return;
472 op_clear(o);
11343788
MB
473 o->op_targ = o->op_type;
474 o->op_type = OP_NULL;
22c35a8c 475 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW
476}
477
4026c95a
SH
478void
479Perl_op_refcnt_lock(pTHX)
480{
481 OP_REFCNT_LOCK;
482}
483
484void
485Perl_op_refcnt_unlock(pTHX)
486{
487 OP_REFCNT_UNLOCK;
488}
489
79072805
LW
490/* Contextualizers */
491
463ee0b2 492#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW
493
494OP *
864dbfa3 495Perl_linklist(pTHX_ OP *o)
79072805 496{
79072805 497
11343788
MB
498 if (o->op_next)
499 return o->op_next;
79072805
LW
500
501 /* establish postfix order */
11343788 502 if (cUNOPo->op_first) {
6867be6d 503 register OP *kid;
11343788
MB
504 o->op_next = LINKLIST(cUNOPo->op_first);
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
506 if (kid->op_sibling)
507 kid->op_next = LINKLIST(kid->op_sibling);
508 else
11343788 509 kid->op_next = o;
79072805
LW
510 }
511 }
512 else
11343788 513 o->op_next = o;
79072805 514
11343788 515 return o->op_next;
79072805
LW
516}
517
518OP *
864dbfa3 519Perl_scalarkids(pTHX_ OP *o)
79072805 520{
11343788 521 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 522 OP *kid;
11343788 523 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
524 scalar(kid);
525 }
11343788 526 return o;
79072805
LW
527}
528
76e3520e 529STATIC OP *
cea2e8a9 530S_scalarboolean(pTHX_ OP *o)
8990e307 531{
d008e5eb 532 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 533 if (ckWARN(WARN_SYNTAX)) {
6867be6d 534 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 535
d008e5eb 536 if (PL_copline != NOLINE)
57843af0 537 CopLINE_set(PL_curcop, PL_copline);
9014280d 538 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 539 CopLINE_set(PL_curcop, oldline);
d008e5eb 540 }
a0d0e21e 541 }
11343788 542 return scalar(o);
8990e307
LW
543}
544
545OP *
864dbfa3 546Perl_scalar(pTHX_ OP *o)
79072805
LW
547{
548 OP *kid;
549
a0d0e21e 550 /* assumes no premature commitment */
3280af22 551 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 552 || o->op_type == OP_RETURN)
7e363e51 553 {
11343788 554 return o;
7e363e51 555 }
79072805 556
5dc0d613 557 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 558
11343788 559 switch (o->op_type) {
79072805 560 case OP_REPEAT:
11343788 561 scalar(cBINOPo->op_first);
8990e307 562 break;
79072805
LW
563 case OP_OR:
564 case OP_AND:
565 case OP_COND_EXPR:
11343788 566 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 567 scalar(kid);
79072805 568 break;
a0d0e21e 569 case OP_SPLIT:
11343788 570 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 571 if (!kPMOP->op_pmreplroot)
12bcd1a6 572 deprecate_old("implicit split to @_");
a0d0e21e
LW
573 }
574 /* FALL THROUGH */
79072805 575 case OP_MATCH:
8782bef2 576 case OP_QR:
79072805
LW
577 case OP_SUBST:
578 case OP_NULL:
8990e307 579 default:
11343788
MB
580 if (o->op_flags & OPf_KIDS) {
581 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW
582 scalar(kid);
583 }
79072805
LW
584 break;
585 case OP_LEAVE:
586 case OP_LEAVETRY:
5dc0d613 587 kid = cLISTOPo->op_first;
54310121 588 scalar(kid);
155aba94 589 while ((kid = kid->op_sibling)) {
54310121
PP
590 if (kid->op_sibling)
591 scalarvoid(kid);
592 else
593 scalar(kid);
594 }
3280af22 595 WITH_THR(PL_curcop = &PL_compiling);
54310121 596 break;
748a9306 597 case OP_SCOPE:
79072805 598 case OP_LINESEQ:
8990e307 599 case OP_LIST:
11343788 600 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
601 if (kid->op_sibling)
602 scalarvoid(kid);
603 else
604 scalar(kid);
605 }
3280af22 606 WITH_THR(PL_curcop = &PL_compiling);
79072805 607 break;
a801c63c
RGS
608 case OP_SORT:
609 if (ckWARN(WARN_VOID))
9014280d 610 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 611 }
11343788 612 return o;
79072805
LW
613}
614
615OP *
864dbfa3 616Perl_scalarvoid(pTHX_ OP *o)
79072805
LW
617{
618 OP *kid;
e1ec3a88 619 const char* useless = 0;
8990e307 620 SV* sv;
2ebea0a1
GS
621 U8 want;
622
acb36ea4
GS
623 if (o->op_type == OP_NEXTSTATE
624 || o->op_type == OP_SETSTATE
625 || o->op_type == OP_DBSTATE
626 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
627 || o->op_targ == OP_SETSTATE
628 || o->op_targ == OP_DBSTATE)))
2ebea0a1 629 PL_curcop = (COP*)o; /* for warning below */
79072805 630
54310121 631 /* assumes no premature commitment */
2ebea0a1
GS
632 want = o->op_flags & OPf_WANT;
633 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 634 || o->op_type == OP_RETURN)
7e363e51 635 {
11343788 636 return o;
7e363e51 637 }
79072805 638
b162f9ea 639 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
640 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
641 {
b162f9ea 642 return scalar(o); /* As if inside SASSIGN */
7e363e51 643 }
1c846c1f 644
5dc0d613 645 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 646
11343788 647 switch (o->op_type) {
79072805 648 default:
22c35a8c 649 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 650 break;
36477c24
PP
651 /* FALL THROUGH */
652 case OP_REPEAT:
11343788 653 if (o->op_flags & OPf_STACKED)
8990e307 654 break;
5d82c453
GA
655 goto func_ops;
656 case OP_SUBSTR:
657 if (o->op_private == 4)
658 break;
8990e307
LW
659 /* FALL THROUGH */
660 case OP_GVSV:
661 case OP_WANTARRAY:
662 case OP_GV:
663 case OP_PADSV:
664 case OP_PADAV:
665 case OP_PADHV:
666 case OP_PADANY:
667 case OP_AV2ARYLEN:
8990e307 668 case OP_REF:
a0d0e21e
LW
669 case OP_REFGEN:
670 case OP_SREFGEN:
8990e307
LW
671 case OP_DEFINED:
672 case OP_HEX:
673 case OP_OCT:
674 case OP_LENGTH:
8990e307
LW
675 case OP_VEC:
676 case OP_INDEX:
677 case OP_RINDEX:
678 case OP_SPRINTF:
679 case OP_AELEM:
680 case OP_AELEMFAST:
681 case OP_ASLICE:
8990e307
LW
682 case OP_HELEM:
683 case OP_HSLICE:
684 case OP_UNPACK:
685 case OP_PACK:
8990e307
LW
686 case OP_JOIN:
687 case OP_LSLICE:
688 case OP_ANONLIST:
689 case OP_ANONHASH:
690 case OP_SORT:
691 case OP_REVERSE:
692 case OP_RANGE:
693 case OP_FLIP:
694 case OP_FLOP:
695 case OP_CALLER:
696 case OP_FILENO:
697 case OP_EOF:
698 case OP_TELL:
699 case OP_GETSOCKNAME:
700 case OP_GETPEERNAME:
701 case OP_READLINK:
702 case OP_TELLDIR:
703 case OP_GETPPID:
704 case OP_GETPGRP:
705 case OP_GETPRIORITY:
706 case OP_TIME:
707 case OP_TMS:
708 case OP_LOCALTIME:
709 case OP_GMTIME:
710 case OP_GHBYNAME:
711 case OP_GHBYADDR:
712 case OP_GHOSTENT:
713 case OP_GNBYNAME:
714 case OP_GNBYADDR:
715 case OP_GNETENT:
716 case OP_GPBYNAME:
717 case OP_GPBYNUMBER:
718 case OP_GPROTOENT:
719 case OP_GSBYNAME:
720 case OP_GSBYPORT:
721 case OP_GSERVENT:
722 case OP_GPWNAM:
723 case OP_GPWUID:
724 case OP_GGRNAM:
725 case OP_GGRGID:
726 case OP_GETLOGIN:
78e1b766 727 case OP_PROTOTYPE:
5d82c453 728 func_ops:
64aac5a9 729 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 730 useless = OP_DESC(o);
8990e307
LW
731 break;
732
9f82cd5f
YST
733 case OP_NOT:
734 kid = cUNOPo->op_first;
735 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
736 kid->op_type != OP_TRANS) {
737 goto func_ops;
738 }
739 useless = "negative pattern binding (!~)";
740 break;
741
8990e307
LW
742 case OP_RV2GV:
743 case OP_RV2SV:
744 case OP_RV2AV:
745 case OP_RV2HV:
192587c2 746 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 747 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW
748 useless = "a variable";
749 break;
79072805
LW
750
751 case OP_CONST:
7766f137 752 sv = cSVOPo_sv;
7a52d87a
GS
753 if (cSVOPo->op_private & OPpCONST_STRICT)
754 no_bareword_allowed(o);
755 else {
d008e5eb
GS
756 if (ckWARN(WARN_VOID)) {
757 useless = "a constant";
e7fec78e 758 /* don't warn on optimised away booleans, eg
b5a930ec 759 * use constant Foo, 5; Foo || print; */
e7fec78e
DM
760 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
761 useless = 0;
960b4253
MG
762 /* the constants 0 and 1 are permitted as they are
763 conventionally used as dummies in constructs like
764 1 while some_condition_with_side_effects; */
e7fec78e 765 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d008e5eb
GS
766 useless = 0;
767 else if (SvPOK(sv)) {
a52fe3ac
A
768 /* perl4's way of mixing documentation and code
769 (before the invention of POD) was based on a
770 trick to mix nroff and perl code. The trick was
771 built upon these three nroff macros being used in
772 void context. The pink camel has the details in
773 the script wrapman near page 319. */
d008e5eb
GS
774 if (strnEQ(SvPVX(sv), "di", 2) ||
775 strnEQ(SvPVX(sv), "ds", 2) ||
776 strnEQ(SvPVX(sv), "ig", 2))
777 useless = 0;
778 }
8990e307
LW
779 }
780 }
93c66552 781 op_null(o); /* don't execute or even remember it */
79072805
LW
782 break;
783
784 case OP_POSTINC:
11343788 785 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 786 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
787 break;
788
789 case OP_POSTDEC:
11343788 790 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 791 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
792 break;
793
79072805
LW
794 case OP_OR:
795 case OP_AND:
c963b151 796 case OP_DOR:
79072805 797 case OP_COND_EXPR:
11343788 798 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
799 scalarvoid(kid);
800 break;
5aabfad6 801
a0d0e21e 802 case OP_NULL:
11343788 803 if (o->op_flags & OPf_STACKED)
a0d0e21e 804 break;
5aabfad6 805 /* FALL THROUGH */
2ebea0a1
GS
806 case OP_NEXTSTATE:
807 case OP_DBSTATE:
79072805
LW
808 case OP_ENTERTRY:
809 case OP_ENTER:
11343788 810 if (!(o->op_flags & OPf_KIDS))
79072805 811 break;
54310121 812 /* FALL THROUGH */
463ee0b2 813 case OP_SCOPE:
79072805
LW
814 case OP_LEAVE:
815 case OP_LEAVETRY:
a0d0e21e 816 case OP_LEAVELOOP:
79072805 817 case OP_LINESEQ:
79072805 818 case OP_LIST:
11343788 819 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
820 scalarvoid(kid);
821 break;
c90c0ff4 822 case OP_ENTEREVAL:
5196be3e 823 scalarkids(o);
c90c0ff4 824 break;
5aabfad6 825 case OP_REQUIRE:
c90c0ff4 826 /* all requires must return a boolean value */
5196be3e 827 o->op_flags &= ~OPf_WANT;
d6483035
GS
828 /* FALL THROUGH */
829 case OP_SCALAR:
5196be3e 830 return scalar(o);
a0d0e21e 831 case OP_SPLIT:
11343788 832 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 833 if (!kPMOP->op_pmreplroot)
12bcd1a6 834 deprecate_old("implicit split to @_");
a0d0e21e
LW
835 }
836 break;
79072805 837 }
411caa50 838 if (useless && ckWARN(WARN_VOID))
9014280d 839 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 840 return o;
79072805
LW
841}
842
843OP *
864dbfa3 844Perl_listkids(pTHX_ OP *o)
79072805 845{
11343788 846 if (o && o->op_flags & OPf_KIDS) {
6867be6d 847 OP *kid;
11343788 848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
849 list(kid);
850 }
11343788 851 return o;
79072805
LW
852}
853
854OP *
864dbfa3 855Perl_list(pTHX_ OP *o)
79072805
LW
856{
857 OP *kid;
858
a0d0e21e 859 /* assumes no premature commitment */
3280af22 860 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 861 || o->op_type == OP_RETURN)
7e363e51 862 {
11343788 863 return o;
7e363e51 864 }
79072805 865
b162f9ea 866 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
867 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
868 {
b162f9ea 869 return o; /* As if inside SASSIGN */
7e363e51 870 }
1c846c1f 871
5dc0d613 872 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 873
11343788 874 switch (o->op_type) {
79072805
LW
875 case OP_FLOP:
876 case OP_REPEAT:
11343788 877 list(cBINOPo->op_first);
79072805
LW
878 break;
879 case OP_OR:
880 case OP_AND:
881 case OP_COND_EXPR:
11343788 882 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
883 list(kid);
884 break;
885 default:
886 case OP_MATCH:
8782bef2 887 case OP_QR:
79072805
LW
888 case OP_SUBST:
889 case OP_NULL:
11343788 890 if (!(o->op_flags & OPf_KIDS))
79072805 891 break;
11343788
MB
892 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
893 list(cBINOPo->op_first);
894 return gen_constant_list(o);
79072805
LW
895 }
896 case OP_LIST:
11343788 897 listkids(o);
79072805
LW
898 break;
899 case OP_LEAVE:
900 case OP_LEAVETRY:
5dc0d613 901 kid = cLISTOPo->op_first;
54310121 902 list(kid);
155aba94 903 while ((kid = kid->op_sibling)) {
54310121
PP
904 if (kid->op_sibling)
905 scalarvoid(kid);
906 else
907 list(kid);
908 }
3280af22 909 WITH_THR(PL_curcop = &PL_compiling);
54310121 910 break;
748a9306 911 case OP_SCOPE:
79072805 912 case OP_LINESEQ:
11343788 913 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
914 if (kid->op_sibling)
915 scalarvoid(kid);
916 else
917 list(kid);
918 }
3280af22 919 WITH_THR(PL_curcop = &PL_compiling);
79072805 920 break;
c90c0ff4
PP
921 case OP_REQUIRE:
922 /* all requires must return a boolean value */
5196be3e
MB
923 o->op_flags &= ~OPf_WANT;
924 return scalar(o);
79072805 925 }
11343788 926 return o;
79072805
LW
927}
928
929OP *
864dbfa3 930Perl_scalarseq(pTHX_ OP *o)
79072805 931{
11343788
MB
932 if (o) {
933 if (o->op_type == OP_LINESEQ ||
934 o->op_type == OP_SCOPE ||
935 o->op_type == OP_LEAVE ||
936 o->op_type == OP_LEAVETRY)
463ee0b2 937 {
6867be6d 938 OP *kid;
11343788 939 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 940 if (kid->op_sibling) {
463ee0b2 941 scalarvoid(kid);
ed6116ce 942 }
463ee0b2 943 }
3280af22 944 PL_curcop = &PL_compiling;
79072805 945 }
11343788 946 o->op_flags &= ~OPf_PARENS;
3280af22 947 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 948 o->op_flags |= OPf_PARENS;
79072805 949 }
8990e307 950 else
11343788
MB
951 o = newOP(OP_STUB, 0);
952 return o;
79072805
LW
953}
954
76e3520e 955STATIC OP *
cea2e8a9 956S_modkids(pTHX_ OP *o, I32 type)
79072805 957{
11343788 958 if (o && o->op_flags & OPf_KIDS) {
6867be6d 959 OP *kid;
11343788 960 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 961 mod(kid, type);
79072805 962 }
11343788 963 return o;
79072805
LW
964}
965
ddeae0f1
DM
966/* Propagate lvalue ("modifiable") context to an op and it's children.
967 * 'type' represents the context type, roughly based on the type of op that
968 * would do the modifying, although local() is represented by OP_NULL.
969 * It's responsible for detecting things that can't be modified, flag
970 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
971 * might have to vivify a reference in $x), and so on.
972 *
973 * For example, "$a+1 = 2" would cause mod() to be called with o being
974 * OP_ADD and type being OP_SASSIGN, and would output an error.
975 */
976
79072805 977OP *
864dbfa3 978Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW
979{
980 OP *kid;
ddeae0f1
DM
981 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
982 int localize = -1;
79072805 983
3280af22 984 if (!o || PL_error_count)
11343788 985 return o;
79072805 986
b162f9ea 987 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
988 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
989 {
b162f9ea 990 return o;
7e363e51 991 }
1c846c1f 992
11343788 993 switch (o->op_type) {
68dc0745 994 case OP_UNDEF:
ddeae0f1 995 localize = 0;
3280af22 996 PL_modcount++;
5dc0d613 997 return o;
a0d0e21e 998 case OP_CONST:
11343788 999 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1000 goto nomod;
3280af22 1001 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1002 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1003 PL_eval_start = 0;
a0d0e21e
LW
1004 }
1005 else if (!type) {
3280af22
NIS
1006 SAVEI32(PL_compiling.cop_arybase);
1007 PL_compiling.cop_arybase = 0;
a0d0e21e
LW
1008 }
1009 else if (type == OP_REFGEN)
1010 goto nomod;
1011 else
cea2e8a9 1012 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1013 break;
5f05dabc 1014 case OP_STUB:
5196be3e 1015 if (o->op_flags & OPf_PARENS)
5f05dabc
PP
1016 break;
1017 goto nomod;
a0d0e21e
LW
1018 case OP_ENTERSUB:
1019 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB
1020 !(o->op_flags & OPf_STACKED)) {
1021 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1022 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1023 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1024 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1025 break;
1026 }
95f0a2f1
SB
1027 else if (o->op_private & OPpENTERSUB_NOMOD)
1028 return o;
cd06dffe
GS
1029 else { /* lvalue subroutine call */
1030 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1031 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1032 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS
1033 /* Backward compatibility mode: */
1034 o->op_private |= OPpENTERSUB_INARGS;
1035 break;
1036 }
1037 else { /* Compile-time error message: */
1038 OP *kid = cUNOPo->op_first;
1039 CV *cv;
1040 OP *okid;
1041
1042 if (kid->op_type == OP_PUSHMARK)
1043 goto skip_kids;
1044 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1045 Perl_croak(aTHX_
1046 "panic: unexpected lvalue entersub "
55140b79 1047 "args: type/targ %ld:%"UVuf,
3d811634 1048 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1049 kid = kLISTOP->op_first;
1050 skip_kids:
1051 while (kid->op_sibling)
1052 kid = kid->op_sibling;
1053 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1054 /* Indirect call */
1055 if (kid->op_type == OP_METHOD_NAMED
1056 || kid->op_type == OP_METHOD)
1057 {
87d7fd28 1058 UNOP *newop;
b2ffa427 1059
87d7fd28 1060 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS
1061 newop->op_type = OP_RV2CV;
1062 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS
1063 newop->op_first = Nullop;
1064 newop->op_next = (OP*)newop;
1065 kid->op_sibling = (OP*)newop;
349fd7b7 1066 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS
1067 break;
1068 }
b2ffa427 1069
cd06dffe
GS
1070 if (kid->op_type != OP_RV2CV)
1071 Perl_croak(aTHX_
1072 "panic: unexpected lvalue entersub "
55140b79 1073 "entry via type/targ %ld:%"UVuf,
3d811634 1074 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1075 kid->op_private |= OPpLVAL_INTRO;
1076 break; /* Postpone until runtime */
1077 }
b2ffa427
NIS
1078
1079 okid = kid;
cd06dffe
GS
1080 kid = kUNOP->op_first;
1081 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1082 kid = kUNOP->op_first;
b2ffa427 1083 if (kid->op_type == OP_NULL)
cd06dffe
GS
1084 Perl_croak(aTHX_
1085 "Unexpected constant lvalue entersub "
55140b79 1086 "entry via type/targ %ld:%"UVuf,
3d811634 1087 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1088 if (kid->op_type != OP_GV) {
1089 /* Restore RV2CV to check lvalueness */
1090 restore_2cv:
1091 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1092 okid->op_next = kid->op_next;
1093 kid->op_next = okid;
1094 }
1095 else
1096 okid->op_next = Nullop;
1097 okid->op_type = OP_RV2CV;
1098 okid->op_targ = 0;
1099 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1100 okid->op_private |= OPpLVAL_INTRO;
1101 break;
1102 }
b2ffa427 1103
638eceb6 1104 cv = GvCV(kGVOP_gv);
1c846c1f 1105 if (!cv)
cd06dffe
GS
1106 goto restore_2cv;
1107 if (CvLVALUE(cv))
1108 break;
1109 }
1110 }
79072805
LW
1111 /* FALL THROUGH */
1112 default:
a0d0e21e
LW
1113 nomod:
1114 /* grep, foreach, subcalls, refgen */
1115 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1116 break;
cea2e8a9 1117 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1118 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
1119 ? "do block"
1120 : (o->op_type == OP_ENTERSUB
1121 ? "non-lvalue subroutine call"
53e06cf0 1122 : OP_DESC(o))),
22c35a8c 1123 type ? PL_op_desc[type] : "local"));
11343788 1124 return o;
79072805 1125
a0d0e21e
LW
1126 case OP_PREINC:
1127 case OP_PREDEC:
1128 case OP_POW:
1129 case OP_MULTIPLY:
1130 case OP_DIVIDE:
1131 case OP_MODULO:
1132 case OP_REPEAT:
1133 case OP_ADD:
1134 case OP_SUBTRACT:
1135 case OP_CONCAT:
1136 case OP_LEFT_SHIFT:
1137 case OP_RIGHT_SHIFT:
1138 case OP_BIT_AND:
1139 case OP_BIT_XOR:
1140 case OP_BIT_OR:
1141 case OP_I_MULTIPLY:
1142 case OP_I_DIVIDE:
1143 case OP_I_MODULO:
1144 case OP_I_ADD:
1145 case OP_I_SUBTRACT:
11343788 1146 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1147 goto nomod;
3280af22 1148 PL_modcount++;
a0d0e21e 1149 break;
b2ffa427 1150
79072805 1151 case OP_COND_EXPR:
ddeae0f1 1152 localize = 1;
11343788 1153 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1154 mod(kid, type);
79072805
LW
1155 break;
1156
1157 case OP_RV2AV:
1158 case OP_RV2HV:
11343788 1159 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1160 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1161 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
1162 }
1163 /* FALL THROUGH */
79072805 1164 case OP_RV2GV:
5dc0d613 1165 if (scalar_mod_type(o, type))
3fe9a6f1 1166 goto nomod;
11343788 1167 ref(cUNOPo->op_first, o->op_type);
79072805 1168 /* FALL THROUGH */
79072805
LW
1169 case OP_ASLICE:
1170 case OP_HSLICE:
78f9721b
SM
1171 if (type == OP_LEAVESUBLV)
1172 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1173 localize = 1;
78f9721b
SM
1174 /* FALL THROUGH */
1175 case OP_AASSIGN:
93a17b20
LW
1176 case OP_NEXTSTATE:
1177 case OP_DBSTATE:
e6438c1a 1178 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1179 break;
463ee0b2 1180 case OP_RV2SV:
aeea060c 1181 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1182 localize = 1;
463ee0b2 1183 /* FALL THROUGH */
79072805 1184 case OP_GV:
463ee0b2 1185 case OP_AV2ARYLEN:
3280af22 1186 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1187 case OP_SASSIGN:
bf4b1e52
GS
1188 case OP_ANDASSIGN:
1189 case OP_ORASSIGN:
c963b151 1190 case OP_DORASSIGN:
ddeae0f1
DM
1191 PL_modcount++;
1192 break;
1193
8990e307 1194 case OP_AELEMFAST:
6a077020 1195 localize = -1;
3280af22 1196 PL_modcount++;
8990e307
LW
1197 break;
1198
748a9306
LW
1199 case OP_PADAV:
1200 case OP_PADHV:
e6438c1a 1201 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
1202 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1203 return o; /* Treat \(@foo) like ordinary list. */
1204 if (scalar_mod_type(o, type))
3fe9a6f1 1205 goto nomod;
78f9721b
SM
1206 if (type == OP_LEAVESUBLV)
1207 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
1208 /* FALL THROUGH */
1209 case OP_PADSV:
3280af22 1210 PL_modcount++;
ddeae0f1 1211 if (!type) /* local() */
cea2e8a9 1212 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1213 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW
1214 break;
1215
748a9306 1216 case OP_PUSHMARK:
ddeae0f1 1217 localize = 0;
748a9306 1218 break;
b2ffa427 1219
69969c6f
SB
1220 case OP_KEYS:
1221 if (type != OP_SASSIGN)
1222 goto nomod;
5d82c453
GA
1223 goto lvalue_func;
1224 case OP_SUBSTR:
1225 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1226 goto nomod;
5f05dabc 1227 /* FALL THROUGH */
a0d0e21e 1228 case OP_POS:
463ee0b2 1229 case OP_VEC:
78f9721b
SM
1230 if (type == OP_LEAVESUBLV)
1231 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1232 lvalue_func:
11343788
MB
1233 pad_free(o->op_targ);
1234 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1235 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB
1236 if (o->op_flags & OPf_KIDS)
1237 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1238 break;
a0d0e21e 1239
463ee0b2
LW
1240 case OP_AELEM:
1241 case OP_HELEM:
11343788 1242 ref(cBINOPo->op_first, o->op_type);
68dc0745 1243 if (type == OP_ENTERSUB &&
5dc0d613
MB
1244 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1245 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
1246 if (type == OP_LEAVESUBLV)
1247 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1248 localize = 1;
3280af22 1249 PL_modcount++;
463ee0b2
LW
1250 break;
1251
1252 case OP_SCOPE:
1253 case OP_LEAVE:
1254 case OP_ENTER:
78f9721b 1255 case OP_LINESEQ:
ddeae0f1 1256 localize = 0;
11343788
MB
1257 if (o->op_flags & OPf_KIDS)
1258 mod(cLISTOPo->op_last, type);
a0d0e21e
LW
1259 break;
1260
1261 case OP_NULL:
ddeae0f1 1262 localize = 0;
638bc118
GS
1263 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1264 goto nomod;
1265 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1266 break;
11343788
MB
1267 if (o->op_targ != OP_LIST) {
1268 mod(cBINOPo->op_first, type);
a0d0e21e
LW
1269 break;
1270 }
1271 /* FALL THROUGH */
463ee0b2 1272 case OP_LIST:
ddeae0f1 1273 localize = 0;
11343788 1274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1275 mod(kid, type);
1276 break;
78f9721b
SM
1277
1278 case OP_RETURN:
1279 if (type != OP_LEAVESUBLV)
1280 goto nomod;
1281 break; /* mod()ing was handled by ck_return() */
463ee0b2 1282 }
58d95175 1283
8be1be90
AMS
1284 /* [20011101.069] File test operators interpret OPf_REF to mean that
1285 their argument is a filehandle; thus \stat(".") should not set
1286 it. AMS 20011102 */
1287 if (type == OP_REFGEN &&
1288 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1289 return o;
1290
1291 if (type != OP_LEAVESUBLV)
1292 o->op_flags |= OPf_MOD;
1293
1294 if (type == OP_AASSIGN || type == OP_SASSIGN)
1295 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM
1296 else if (!type) { /* local() */
1297 switch (localize) {
1298 case 1:
1299 o->op_private |= OPpLVAL_INTRO;
1300 o->op_flags &= ~OPf_SPECIAL;
1301 PL_hints |= HINT_BLOCK_SCOPE;
1302 break;
1303 case 0:
1304 break;
1305 case -1:
1306 if (ckWARN(WARN_SYNTAX)) {
1307 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1308 "Useless localization of %s", OP_DESC(o));
1309 }
1310 }
463ee0b2 1311 }
8be1be90
AMS
1312 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1313 && type != OP_LEAVESUBLV)
1314 o->op_flags |= OPf_REF;
11343788 1315 return o;
463ee0b2
LW
1316}
1317
864dbfa3 1318STATIC bool
6867be6d 1319S_scalar_mod_type(pTHX_ const OP *o, I32 type)
3fe9a6f1
PP
1320{
1321 switch (type) {
1322 case OP_SASSIGN:
5196be3e 1323 if (o->op_type == OP_RV2GV)
3fe9a6f1
PP
1324 return FALSE;
1325 /* FALL THROUGH */
1326 case OP_PREINC:
1327 case OP_PREDEC:
1328 case OP_POSTINC:
1329 case OP_POSTDEC:
1330 case OP_I_PREINC:
1331 case OP_I_PREDEC:
1332 case OP_I_POSTINC:
1333 case OP_I_POSTDEC:
1334 case OP_POW:
1335 case OP_MULTIPLY:
1336 case OP_DIVIDE:
1337 case OP_MODULO:
1338 case OP_REPEAT:
1339 case OP_ADD:
1340 case OP_SUBTRACT:
1341 case OP_I_MULTIPLY:
1342 case OP_I_DIVIDE:
1343 case OP_I_MODULO:
1344 case OP_I_ADD:
1345 case OP_I_SUBTRACT:
1346 case OP_LEFT_SHIFT:
1347 case OP_RIGHT_SHIFT:
1348 case OP_BIT_AND:
1349 case OP_BIT_XOR:
1350 case OP_BIT_OR:
1351 case OP_CONCAT:
1352 case OP_SUBST:
1353 case OP_TRANS:
49e9fbe6
GS
1354 case OP_READ:
1355 case OP_SYSREAD:
1356 case OP_RECV:
bf4b1e52
GS
1357 case OP_ANDASSIGN:
1358 case OP_ORASSIGN:
3fe9a6f1
PP
1359 return TRUE;
1360 default:
1361 return FALSE;
1362 }
1363}
1364
35cd451c 1365STATIC bool
6867be6d 1366S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
35cd451c
GS
1367{
1368 switch (o->op_type) {
1369 case OP_PIPE_OP:
1370 case OP_SOCKPAIR:
1371 if (argnum == 2)
1372 return TRUE;
1373 /* FALL THROUGH */
1374 case OP_SYSOPEN:
1375 case OP_OPEN:
ded8aa31 1376 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
1377 case OP_SOCKET:
1378 case OP_OPEN_DIR:
1379 case OP_ACCEPT:
1380 if (argnum == 1)
1381 return TRUE;
1382 /* FALL THROUGH */
1383 default:
1384 return FALSE;
1385 }
1386}
1387
463ee0b2 1388OP *
864dbfa3 1389Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1390{
11343788 1391 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1392 OP *kid;
11343788 1393 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1394 ref(kid, type);
1395 }
11343788 1396 return o;
463ee0b2
LW
1397}
1398
1399OP *
864dbfa3 1400Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW
1401{
1402 OP *kid;
463ee0b2 1403
3280af22 1404 if (!o || PL_error_count)
11343788 1405 return o;
463ee0b2 1406
11343788 1407 switch (o->op_type) {
a0d0e21e 1408 case OP_ENTERSUB:
afebc493 1409 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB
1410 !(o->op_flags & OPf_STACKED)) {
1411 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1412 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1413 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1414 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1415 o->op_flags |= OPf_SPECIAL;
8990e307
LW
1416 }
1417 break;
aeea060c 1418
463ee0b2 1419 case OP_COND_EXPR:
11343788 1420 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW
1421 ref(kid, type);
1422 break;
8990e307 1423 case OP_RV2SV:
35cd451c
GS
1424 if (type == OP_DEFINED)
1425 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1426 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW
1427 /* FALL THROUGH */
1428 case OP_PADSV:
5f05dabc 1429 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1430 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1431 : type == OP_RV2HV ? OPpDEREF_HV
1432 : OPpDEREF_SV);
11343788 1433 o->op_flags |= OPf_MOD;
a0d0e21e 1434 }
8990e307 1435 break;
1c846c1f 1436
2faa37cc 1437 case OP_THREADSV:
a863c7d1
MB
1438 o->op_flags |= OPf_MOD; /* XXX ??? */
1439 break;
1440
463ee0b2
LW
1441 case OP_RV2AV:
1442 case OP_RV2HV:
aeea060c 1443 o->op_flags |= OPf_REF;
8990e307 1444 /* FALL THROUGH */
463ee0b2 1445 case OP_RV2GV:
35cd451c
GS
1446 if (type == OP_DEFINED)
1447 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1448 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1449 break;
8990e307 1450
463ee0b2
LW
1451 case OP_PADAV:
1452 case OP_PADHV:
aeea060c 1453 o->op_flags |= OPf_REF;
79072805 1454 break;
aeea060c 1455
8990e307 1456 case OP_SCALAR:
79072805 1457 case OP_NULL:
11343788 1458 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1459 break;
11343788 1460 ref(cBINOPo->op_first, type);
79072805
LW
1461 break;
1462 case OP_AELEM:
1463 case OP_HELEM:
11343788 1464 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1465 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1466 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1467 : type == OP_RV2HV ? OPpDEREF_HV
1468 : OPpDEREF_SV);
11343788 1469 o->op_flags |= OPf_MOD;
8990e307 1470 }
79072805
LW
1471 break;
1472
463ee0b2 1473 case OP_SCOPE:
79072805
LW
1474 case OP_LEAVE:
1475 case OP_ENTER:
8990e307 1476 case OP_LIST:
11343788 1477 if (!(o->op_flags & OPf_KIDS))
79072805 1478 break;
11343788 1479 ref(cLISTOPo->op_last, type);
79072805 1480 break;
a0d0e21e
LW
1481 default:
1482 break;
79072805 1483 }
11343788 1484 return scalar(o);
8990e307 1485
79072805
LW
1486}
1487
09bef843
SB
1488STATIC OP *
1489S_dup_attrlist(pTHX_ OP *o)
1490{
1491 OP *rop = Nullop;
1492
1493 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1494 * where the first kid is OP_PUSHMARK and the remaining ones
1495 * are OP_CONST. We need to push the OP_CONST values.
1496 */
1497 if (o->op_type == OP_CONST)
1498 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1499 else {
1500 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1501 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1502 if (o->op_type == OP_CONST)
1503 rop = append_elem(OP_LIST, rop,
1504 newSVOP(OP_CONST, o->op_flags,
1505 SvREFCNT_inc(cSVOPo->op_sv)));
1506 }
1507 }
1508 return rop;
1509}
1510
1511STATIC void
95f0a2f1 1512S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1513{
09bef843
SB
1514 SV *stashsv;
1515
1516 /* fake up C<use attributes $pkg,$rv,@attrs> */
1517 ENTER; /* need to protect against side-effects of 'use' */
1518 SAVEINT(PL_expect);
a9164de8 1519 if (stash)
09bef843
SB
1520 stashsv = newSVpv(HvNAME(stash), 0);
1521 else
1522 stashsv = &PL_sv_no;
e4783991 1523
09bef843 1524#define ATTRSMODULE "attributes"
95f0a2f1
SB
1525#define ATTRSMODULE_PM "attributes.pm"
1526
1527 if (for_my) {
1528 SV **svp;
1529 /* Don't force the C<use> if we don't need it. */
1530 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1531 sizeof(ATTRSMODULE_PM)-1, 0);
1532 if (svp && *svp != &PL_sv_undef)
1533 ; /* already in %INC */
1534 else
1535 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1536 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1537 Nullsv);
1538 }
1539 else {
1540 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1541 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1542 Nullsv,
1543 prepend_elem(OP_LIST,
1544 newSVOP(OP_CONST, 0, stashsv),
1545 prepend_elem(OP_LIST,
1546 newSVOP(OP_CONST, 0,
1547 newRV(target)),
1548 dup_attrlist(attrs))));
1549 }
09bef843
SB
1550 LEAVE;
1551}
1552
95f0a2f1
SB
1553STATIC void
1554S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1555{
1556 OP *pack, *imop, *arg;
1557 SV *meth, *stashsv;
1558
1559 if (!attrs)
1560 return;
1561
1562 assert(target->op_type == OP_PADSV ||
1563 target->op_type == OP_PADHV ||
1564 target->op_type == OP_PADAV);
1565
1566 /* Ensure that attributes.pm is loaded. */
dd2155a4 1567 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB
1568
1569 /* Need package name for method call. */
1570 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1571
1572 /* Build up the real arg-list. */
1573 if (stash)
1574 stashsv = newSVpv(HvNAME(stash), 0);
1575 else
1576 stashsv = &PL_sv_no;
1577 arg = newOP(OP_PADSV, 0);
1578 arg->op_targ = target->op_targ;
1579 arg = prepend_elem(OP_LIST,
1580 newSVOP(OP_CONST, 0, stashsv),
1581 prepend_elem(OP_LIST,
1582 newUNOP(OP_REFGEN, 0,
1583 mod(arg, OP_REFGEN)),
1584 dup_attrlist(attrs)));
1585
1586 /* Fake up a method call to import */
1587 meth = newSVpvn("import", 6);
1588 (void)SvUPGRADE(meth, SVt_PVIV);
1589 (void)SvIOK_on(meth);
4946a0fa
NC
1590 {
1591 U32 hash;
1592 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
1593 SvUV_set(meth, hash);
1594 }
95f0a2f1
SB
1595 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1596 append_elem(OP_LIST,
1597 prepend_elem(OP_LIST, pack, list(arg)),
1598 newSVOP(OP_METHOD_NAMED, 0, meth)));
1599 imop->op_private |= OPpENTERSUB_NOMOD;
1600
1601 /* Combine the ops. */
1602 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1603}
1604
1605/*
1606=notfor apidoc apply_attrs_string
1607
1608Attempts to apply a list of attributes specified by the C<attrstr> and
1609C<len> arguments to the subroutine identified by the C<cv> argument which
1610is expected to be associated with the package identified by the C<stashpv>
1611argument (see L<attributes>). It gets this wrong, though, in that it
1612does not correctly identify the boundaries of the individual attribute
1613specifications within C<attrstr>. This is not really intended for the
1614public API, but has to be listed here for systems such as AIX which
1615need an explicit export list for symbols. (It's called from XS code
1616in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1617to respect attribute syntax properly would be welcome.
1618
1619=cut
1620*/
1621
be3174d2 1622void
6867be6d
AL
1623Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1624 const char *attrstr, STRLEN len)
be3174d2
GS
1625{
1626 OP *attrs = Nullop;
1627
1628 if (!len) {
1629 len = strlen(attrstr);
1630 }
1631
1632 while (len) {
1633 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1634 if (len) {
6867be6d 1635 const char *sstr = attrstr;
be3174d2
GS
1636 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1637 attrs = append_elem(OP_LIST, attrs,
1638 newSVOP(OP_CONST, 0,
1639 newSVpvn(sstr, attrstr-sstr)));
1640 }
1641 }
1642
1643 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1644 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1645 Nullsv, prepend_elem(OP_LIST,
1646 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1647 prepend_elem(OP_LIST,
1648 newSVOP(OP_CONST, 0,
1649 newRV((SV*)cv)),
1650 attrs)));
1651}
1652
09bef843 1653STATIC OP *
95f0a2f1 1654S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1655{
93a17b20
LW
1656 I32 type;
1657
3280af22 1658 if (!o || PL_error_count)
11343788 1659 return o;
93a17b20 1660
11343788 1661 type = o->op_type;
93a17b20 1662 if (type == OP_LIST) {
6867be6d 1663 OP *kid;
11343788 1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1665 my_kid(kid, attrs, imopsp);
dab48698 1666 } else if (type == OP_UNDEF) {
7766148a 1667 return o;
77ca0c92
LW
1668 } else if (type == OP_RV2SV || /* "our" declaration */
1669 type == OP_RV2AV ||
1670 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS
1671 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1672 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1673 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1674 } else if (attrs) {
1675 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1676 PL_in_my = FALSE;
1677 PL_in_my_stash = Nullhv;
1678 apply_attrs(GvSTASH(gv),
1679 (type == OP_RV2SV ? GvSV(gv) :
1680 type == OP_RV2AV ? (SV*)GvAV(gv) :
1681 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1682 attrs, FALSE);
1683 }
192587c2 1684 o->op_private |= OPpOUR_INTRO;
77ca0c92 1685 return o;
95f0a2f1
SB
1686 }
1687 else if (type != OP_PADSV &&
93a17b20
LW
1688 type != OP_PADAV &&
1689 type != OP_PADHV &&
1690 type != OP_PUSHMARK)
1691 {
eb64745e 1692 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1693 OP_DESC(o),
eb64745e 1694 PL_in_my == KEY_our ? "our" : "my"));
11343788 1695 return o;
93a17b20 1696 }
09bef843
SB
1697 else if (attrs && type != OP_PUSHMARK) {
1698 HV *stash;
09bef843 1699
eb64745e
GS
1700 PL_in_my = FALSE;
1701 PL_in_my_stash = Nullhv;
1702
09bef843 1703 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM
1704 stash = PAD_COMPNAME_TYPE(o->op_targ);
1705 if (!stash)
09bef843 1706 stash = PL_curstash;
95f0a2f1 1707 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1708 }
11343788
MB
1709 o->op_flags |= OPf_MOD;
1710 o->op_private |= OPpLVAL_INTRO;
1711 return o;
93a17b20
LW
1712}
1713
1714OP *
09bef843
SB
1715Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1716{
95f0a2f1
SB
1717 OP *rops = Nullop;
1718 int maybe_scalar = 0;
1719
d2be0de5 1720/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1721 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1722#if 0
09bef843
SB
1723 if (o->op_flags & OPf_PARENS)
1724 list(o);
95f0a2f1
SB
1725 else
1726 maybe_scalar = 1;
d2be0de5
YST
1727#else
1728 maybe_scalar = 1;
1729#endif
09bef843
SB
1730 if (attrs)
1731 SAVEFREEOP(attrs);
95f0a2f1
SB
1732 o = my_kid(o, attrs, &rops);
1733 if (rops) {
1734 if (maybe_scalar && o->op_type == OP_PADSV) {
1735 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1736 o->op_private |= OPpLVAL_INTRO;
1737 }
1738 else
1739 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1740 }
eb64745e
GS
1741 PL_in_my = FALSE;
1742 PL_in_my_stash = Nullhv;
1743 return o;
09bef843
SB
1744}
1745
1746OP *
1747Perl_my(pTHX_ OP *o)
1748{
95f0a2f1 1749 return my_attrs(o, Nullop);
09bef843
SB
1750}
1751
1752OP *
864dbfa3 1753Perl_sawparens(pTHX_ OP *o)
79072805
LW
1754{
1755 if (o)
1756 o->op_flags |= OPf_PARENS;
1757 return o;
1758}
1759
1760OP *
864dbfa3 1761Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1762{
11343788 1763 OP *o;
59f00321 1764 bool ismatchop = 0;
79072805 1765
e476b1b5 1766 if (ckWARN(WARN_MISC) &&
599cee73
PM
1767 (left->op_type == OP_RV2AV ||
1768 left->op_type == OP_RV2HV ||
1769 left->op_type == OP_PADAV ||
1770 left->op_type == OP_PADHV)) {
e1ec3a88 1771 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM
1772 right->op_type == OP_TRANS)
1773 ? right->op_type : OP_MATCH];
dff6d3cd
GS
1774 const char *sample = ((left->op_type == OP_RV2AV ||
1775 left->op_type == OP_PADAV)
1776 ? "@array" : "%hash");
9014280d 1777 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1778 "Applying %s to %s will act on scalar(%s)",
599cee73 1779 desc, sample, sample);
2ae324a7
PP
1780 }
1781
5cc9e5c9
RH
1782 if (right->op_type == OP_CONST &&
1783 cSVOPx(right)->op_private & OPpCONST_BARE &&
1784 cSVOPx(right)->op_private & OPpCONST_STRICT)
1785 {
1786 no_bareword_allowed(right);
1787 }
1788
59f00321
RGS
1789 ismatchop = right->op_type == OP_MATCH ||
1790 right->op_type == OP_SUBST ||
1791 right->op_type == OP_TRANS;
1792 if (ismatchop && right->op_private & OPpTARGET_MY) {
1793 right->op_targ = 0;
1794 right->op_private &= ~OPpTARGET_MY;
1795 }
1796 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1797 right->op_flags |= OPf_STACKED;
18808301
JH
1798 if (right->op_type != OP_MATCH &&
1799 ! (right->op_type == OP_TRANS &&
1800 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1801 left = mod(left, right->op_type);
79072805 1802 if (right->op_type == OP_TRANS)
11343788 1803 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1804 else
11343788 1805 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1806 if (type == OP_NOT)
11343788
MB
1807 return newUNOP(OP_NOT, 0, scalar(o));
1808 return o;
79072805
LW
1809 }
1810 else
1811 return bind_match(type, left,
131b3ad0 1812 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW
1813}
1814
1815OP *
864dbfa3 1816Perl_invert(pTHX_ OP *o)
79072805 1817{
11343788
MB
1818 if (!o)
1819 return o;
79072805 1820 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1821 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
1822}
1823
1824OP *
864dbfa3 1825Perl_scope(pTHX_ OP *o)
79072805
LW
1826{
1827 if (o) {
3280af22 1828 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW
1829 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1830 o->op_type = OP_LEAVE;
22c35a8c 1831 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1832 }
fdb22418
HS
1833 else if (o->op_type == OP_LINESEQ) {
1834 OP *kid;
1835 o->op_type = OP_SCOPE;
1836 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1837 kid = ((LISTOP*)o)->op_first;
1838 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1839 op_null(kid);
463ee0b2 1840 }
fdb22418
HS
1841 else
1842 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
79072805
LW
1843 }
1844 return o;
1845}
1846
dfa41748 1847/* XXX kept for BINCOMPAT only */
b3ac6de7 1848void
864dbfa3 1849Perl_save_hints(pTHX)
b3ac6de7 1850{
dfa41748 1851 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
b3ac6de7
IZ
1852}
1853
a0d0e21e 1854int
864dbfa3 1855Perl_block_start(pTHX_ int full)
79072805 1856{
73d840c0 1857 const int retval = PL_savestack_ix;
dd2155a4 1858 pad_block_start(full);
b3ac6de7 1859 SAVEHINTS();
3280af22 1860 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1861 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1862 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
1863 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1864 SAVEFREESV(PL_compiling.cop_warnings) ;
1865 }
ac27b0f5
NIS
1866 SAVESPTR(PL_compiling.cop_io);
1867 if (! specialCopIO(PL_compiling.cop_io)) {
1868 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1869 SAVEFREESV(PL_compiling.cop_io) ;
1870 }
a0d0e21e
LW
1871 return retval;
1872}
1873
1874OP*
864dbfa3 1875Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1876{
6867be6d 1877 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
e9f19e3c 1878 OP* retval = scalarseq(seq);
e9818f4e 1879 LEAVE_SCOPE(floor);
eb160463 1880 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1881 if (needblockscope)
3280af22 1882 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1883 pad_leavemy();
a0d0e21e
LW
1884 return retval;
1885}
1886
76e3520e 1887STATIC OP *
cea2e8a9 1888S_newDEFSVOP(pTHX)
54b9620d 1889{
6867be6d 1890 const I32 offset = pad_findmy("$_");
59f00321
RGS
1891 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1892 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1893 }
1894 else {
1895 OP *o = newOP(OP_PADSV, 0);
1896 o->op_targ = offset;
1897 return o;
1898 }
54b9620d
MB
1899}
1900
a0d0e21e 1901void
864dbfa3 1902Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1903{
3280af22 1904 if (PL_in_eval) {
b295d113
TH
1905 if (PL_eval_root)
1906 return;
faef0170
HS
1907 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1908 ((PL_in_eval & EVAL_KEEPERR)
1909 ? OPf_SPECIAL : 0), o);
3280af22 1910 PL_eval_start = linklist(PL_eval_root);
7934575e
GS
1911 PL_eval_root->op_private |= OPpREFCOUNTED;
1912 OpREFCNT_set(PL_eval_root, 1);
3280af22 1913 PL_eval_root->op_next = 0;
a2efc822 1914 CALL_PEEP(PL_eval_start);
a0d0e21e
LW
1915 }
1916 else {
6be89cf9
AE
1917 if (o->op_type == OP_STUB) {
1918 PL_comppad_name = 0;
1919 PL_compcv = 0;
2a4f803a 1920 FreeOp(o);
a0d0e21e 1921 return;
6be89cf9 1922 }
3280af22
NIS
1923 PL_main_root = scope(sawparens(scalarvoid(o)));
1924 PL_curcop = &PL_compiling;
1925 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
1926 PL_main_root->op_private |= OPpREFCOUNTED;
1927 OpREFCNT_set(PL_main_root, 1);
3280af22 1928 PL_main_root->op_next = 0;
a2efc822 1929 CALL_PEEP(PL_main_start);
3280af22 1930 PL_compcv = 0;
3841441e 1931
4fdae800 1932 /* Register with debugger */
84902520 1933 if (PERLDB_INTER) {
864dbfa3 1934 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS
1935 if (cv) {
1936 dSP;
924508f0 1937 PUSHMARK(SP);
cc49e20b 1938 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1939 PUTBACK;
864dbfa3 1940 call_sv((SV*)cv, G_DISCARD);
3841441e
CS
1941 }
1942 }
79072805 1943 }
79072805
LW
1944}
1945
1946OP *
864dbfa3 1947Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW
1948{
1949 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
1950/* [perl #17376]: this appears to be premature, and results in code such as
1951 C< our(%x); > executing in list mode rather than void mode */
1952#if 0
79072805 1953 list(o);
d2be0de5
YST
1954#else
1955 ;
1956#endif
8990e307 1957 else {
64420d0d
JH
1958 if (ckWARN(WARN_PARENTHESIS)
1959 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1960 {
1961 char *s = PL_bufptr;
bac662ee 1962 bool sigil = FALSE;
64420d0d 1963
8473848f 1964 /* some heuristics to detect a potential error */
bac662ee 1965 while (*s && (strchr(", \t\n", *s)))
64420d0d 1966 s++;
8473848f 1967
bac662ee
ST
1968 while (1) {
1969 if (*s && strchr("@$%*", *s) && *++s
1970 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1971 s++;
1972 sigil = TRUE;
1973 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1974 s++;
1975 while (*s && (strchr(", \t\n", *s)))
1976 s++;
1977 }
1978 else
1979 break;
1980 }
1981 if (sigil && (*s == ';' || *s == '=')) {
1982 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS
1983 "Parentheses missing around \"%s\" list",
1984 lex ? (PL_in_my == KEY_our ? "our" : "my")
1985 : "local");
1986 }
8990e307
LW
1987 }
1988 }
93a17b20 1989 if (lex)
eb64745e 1990 o = my(o);
93a17b20 1991 else
eb64745e
GS
1992 o = mod(o, OP_NULL); /* a bit kludgey */
1993 PL_in_my = FALSE;
1994 PL_in_my_stash = Nullhv;
1995 return o;
79072805
LW
1996}
1997
1998OP *
864dbfa3 1999Perl_jmaybe(pTHX_ OP *o)
79072805
LW
2000{
2001 if (o->op_type == OP_LIST) {
554b3eca 2002 OP *o2;
554b3eca 2003 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
554b3eca 2004 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW
2005 }
2006 return o;
2007}
2008
2009OP *
864dbfa3 2010Perl_fold_constants(pTHX_ register OP *o)
79072805
LW
2011{
2012 register OP *curop;
2013 I32 type = o->op_type;
748a9306 2014 SV *sv;
79072805 2015
22c35a8c 2016 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2017 scalar(o);
b162f9ea 2018 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2019 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2020
eac055e9
GS
2021 /* integerize op, unless it happens to be C<-foo>.
2022 * XXX should pp_i_negate() do magic string negation instead? */
2023 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2024 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2025 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2026 {
22c35a8c 2027 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2028 }
85e6fe83 2029
22c35a8c 2030 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
2031 goto nope;
2032
de939608 2033 switch (type) {
7a52d87a
GS
2034 case OP_NEGATE:
2035 /* XXX might want a ck_negate() for this */
2036 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2037 break;
de939608
CS
2038 case OP_SPRINTF:
2039 case OP_UCFIRST:
2040 case OP_LCFIRST:
2041 case OP_UC:
2042 case OP_LC:
69dcf70c
MB
2043 case OP_SLT:
2044 case OP_SGT:
2045 case OP_SLE:
2046 case OP_SGE:
2047 case OP_SCMP:
2de3dbcc
JH
2048 /* XXX what about the numeric ops? */
2049 if (PL_hints & HINT_LOCALE)
de939608
CS
2050 goto nope;
2051 }
2052
3280af22 2053 if (PL_error_count)
a0d0e21e
LW
2054 goto nope; /* Don't try to run w/ errors */
2055
79072805 2056 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS
2057 if ((curop->op_type != OP_CONST ||
2058 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS
2059 curop->op_type != OP_LIST &&
2060 curop->op_type != OP_SCALAR &&
2061 curop->op_type != OP_NULL &&
2062 curop->op_type != OP_PUSHMARK)
2063 {
79072805
LW
2064 goto nope;
2065 }
2066 }
2067
2068 curop = LINKLIST(o);
2069 o->op_next = 0;
533c011a 2070 PL_op = curop;
cea2e8a9 2071 CALLRUNOPS(aTHX);
3280af22 2072 sv = *(PL_stack_sp--);
748a9306 2073 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 2074 pad_swipe(o->op_targ, FALSE);
748a9306
LW
2075 else if (SvTEMP(sv)) { /* grab mortal temp? */
2076 (void)SvREFCNT_inc(sv);
2077 SvTEMP_off(sv);
85e6fe83 2078 }
79072805
LW
2079 op_free(o);
2080 if (type == OP_RV2GV)
b1cb66bf 2081 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 2082 return newSVOP(OP_CONST, 0, sv);
aeea060c 2083
79072805 2084 nope:
79072805
LW
2085 return o;
2086}
2087
2088OP *
864dbfa3 2089Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW
2090{
2091 register OP *curop;
6867be6d 2092 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2093
a0d0e21e 2094 list(o);
3280af22 2095 if (PL_error_count)
a0d0e21e
LW
2096 return o; /* Don't attempt to run with errors */
2097
533c011a 2098 PL_op = curop = LINKLIST(o);
a0d0e21e 2099 o->op_next = 0;
a2efc822 2100 CALL_PEEP(curop);
cea2e8a9
GS
2101 pp_pushmark();
2102 CALLRUNOPS(aTHX);
533c011a 2103 PL_op = curop;
cea2e8a9 2104 pp_anonlist();
3280af22 2105 PL_tmps_floor = oldtmps_floor;
79072805
LW
2106
2107 o->op_type = OP_RV2AV;
22c35a8c 2108 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
2109 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2110 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2111 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2112 curop = ((UNOP*)o)->op_first;
3280af22 2113 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2114 op_free(curop);
79072805
LW
2115 linklist(o);
2116 return list(o);
2117}
2118
2119OP *
864dbfa3 2120Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2121{
11343788
MB
2122 if (!o || o->op_type != OP_LIST)
2123 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2124 else
5dc0d613 2125 o->op_flags &= ~OPf_WANT;
79072805 2126
22c35a8c 2127 if (!(PL_opargs[type] & OA_MARK))
93c66552 2128 op_null(cLISTOPo->op_first);
8990e307 2129
eb160463 2130 o->op_type = (OPCODE)type;
22c35a8c 2131 o->op_ppaddr = PL_ppaddr[type];
11343788 2132 o->op_flags |= flags;
79072805 2133
11343788 2134 o = CHECKOP(type, o);
fe2774ed 2135 if (o->op_type != (unsigned)type)
11343788 2136 return o;
79072805 2137
11343788 2138 return fold_constants(o);
79072805
LW
2139}
2140
2141/* List constructors */
2142
2143OP *
864dbfa3 2144Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2145{
2146 if (!first)
2147 return last;
8990e307
LW
2148
2149 if (!last)
79072805 2150 return first;
8990e307 2151
fe2774ed 2152 if (first->op_type != (unsigned)type
155aba94
GS
2153 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2154 {
2155 return newLISTOP(type, 0, first, last);
2156 }
79072805 2157
a0d0e21e
LW
2158 if (first->op_flags & OPf_KIDS)
2159 ((LISTOP*)first)->op_last->op_sibling = last;
2160 else {
2161 first->op_flags |= OPf_KIDS;
2162 ((LISTOP*)first)->op_first = last;
2163 }
2164 ((LISTOP*)first)->op_last = last;
a0d0e21e 2165 return first;
79072805
LW
2166}
2167
2168OP *
864dbfa3 2169Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW
2170{
2171 if (!first)
2172 return (OP*)last;
8990e307
LW
2173
2174 if (!last)
79072805 2175 return (OP*)first;
8990e307 2176
fe2774ed 2177 if (first->op_type != (unsigned)type)
79072805 2178 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2179
fe2774ed 2180 if (last->op_type != (unsigned)type)
79072805
LW
2181 return append_elem(type, (OP*)first, (OP*)last);
2182
2183 first->op_last->op_sibling = last->op_first;
2184 first->op_last = last->op_last;
117dada2 2185 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2186
238a4c30
NIS
2187 FreeOp(last);
2188
79072805
LW
2189 return (OP*)first;
2190}
2191
2192OP *
864dbfa3 2193Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2194{
2195 if (!first)
2196 return last;
8990e307
LW
2197
2198 if (!last)
79072805 2199 return first;
8990e307 2200
fe2774ed 2201 if (last->op_type == (unsigned)type) {
8990e307
LW
2202 if (type == OP_LIST) { /* already a PUSHMARK there */
2203 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2204 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
2205 if (!(first->op_flags & OPf_PARENS))
2206 last->op_flags &= ~OPf_PARENS;
8990e307
LW
2207 }
2208 else {
2209 if (!(last->op_flags & OPf_KIDS)) {
2210 ((LISTOP*)last)->op_last = first;
2211 last->op_flags |= OPf_KIDS;
2212 }
2213 first->op_sibling = ((LISTOP*)last)->op_first;
2214 ((LISTOP*)last)->op_first = first;
79072805 2215 }
117dada2 2216 last->op_flags |= OPf_KIDS;
79072805
LW
2217 return last;
2218 }
2219
2220 return newLISTOP(type, 0, first, last);
2221}
2222
2223/* Constructors */
2224
2225OP *
864dbfa3 2226Perl_newNULLLIST(pTHX)
79072805 2227{
8990e307
LW
2228 return newOP(OP_STUB, 0);
2229}
2230
2231OP *
864dbfa3 2232Perl_force_list(pTHX_ OP *o)
8990e307 2233{
11343788
MB
2234 if (!o || o->op_type != OP_LIST)
2235 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2236 op_null(o);
11343788 2237 return o;
79072805
LW
2238}
2239
2240OP *
864dbfa3 2241Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2242{
2243 LISTOP *listop;
2244
b7dc083c 2245 NewOp(1101, listop, 1, LISTOP);
79072805 2246
eb160463 2247 listop->op_type = (OPCODE)type;
22c35a8c 2248 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
2249 if (first || last)
2250 flags |= OPf_KIDS;
eb160463 2251 listop->op_flags = (U8)flags;
79072805
LW
2252
2253 if (!last && first)
2254 last = first;
2255 else if (!first && last)
2256 first = last;
8990e307
LW
2257 else if (first)
2258 first->op_sibling = last;
79072805
LW
2259 listop->op_first = first;
2260 listop->op_last = last;
8990e307
LW
2261 if (type == OP_LIST) {
2262 OP* pushop;
2263 pushop = newOP(OP_PUSHMARK, 0);
2264 pushop->op_sibling = first;
2265 listop->op_first = pushop;
2266 listop->op_flags |= OPf_KIDS;
2267 if (!last)
2268 listop->op_last = pushop;
2269 }
79072805 2270
463d09e6 2271 return CHECKOP(type, listop);
79072805
LW
2272}
2273
2274OP *
864dbfa3 2275Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2276{
11343788 2277 OP *o;
b7dc083c 2278 NewOp(1101, o, 1, OP);
eb160463 2279 o->op_type = (OPCODE)type;
22c35a8c 2280 o->op_ppaddr = PL_ppaddr[type];
eb160463 2281 o->op_flags = (U8)flags;
79072805 2282
11343788 2283 o->op_next = o;
eb160463 2284 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2285 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2286 scalar(o);
22c35a8c 2287 if (PL_opargs[type] & OA_TARGET)
11343788
MB
2288 o->op_targ = pad_alloc(type, SVs_PADTMP);
2289 return CHECKOP(type, o);
79072805
LW
2290}
2291
2292OP *
864dbfa3 2293Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW
2294{
2295 UNOP *unop;
2296
93a17b20 2297 if (!first)
aeea060c 2298 first = newOP(OP_STUB, 0);
22c35a8c 2299 if (PL_opargs[type] & OA_MARK)
8990e307 2300 first = force_list(first);
93a17b20 2301
b7dc083c 2302 NewOp(1101, unop, 1, UNOP);
eb160463 2303 unop->op_type = (OPCODE)type;
22c35a8c 2304 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2305 unop->op_first = first;
2306 unop->op_flags = flags | OPf_KIDS;
eb160463 2307 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2308 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
2309 if (unop->op_next)
2310 return (OP*)unop;
2311
a0d0e21e 2312 return fold_constants((OP *) unop);
79072805
LW
2313}
2314
2315OP *
864dbfa3 2316Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2317{
2318 BINOP *binop;
b7dc083c 2319 NewOp(1101, binop, 1, BINOP);
79072805
LW
2320
2321 if (!first)
2322 first = newOP(OP_NULL, 0);
2323
eb160463 2324 binop->op_type = (OPCODE)type;
22c35a8c 2325 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2326 binop->op_first = first;
2327 binop->op_flags = flags | OPf_KIDS;
2328 if (!last) {
2329 last = first;
eb160463 2330 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW
2331 }
2332 else {
eb160463 2333 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW
2334 first->op_sibling = last;
2335 }
2336
e50aee73 2337 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2338 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW
2339 return (OP*)binop;
2340
7284ab6f 2341 binop->op_last = binop->op_first->op_sibling;
79072805 2342
a0d0e21e 2343 return fold_constants((OP *)binop);
79072805
LW
2344}
2345
a0ed51b3 2346static int
2b9d42f0
NIS
2347uvcompare(const void *a, const void *b)
2348{
e1ec3a88 2349 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2350 return -1;
e1ec3a88 2351 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2352 return 1;
e1ec3a88 2353 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2354 return -1;
e1ec3a88 2355 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2356 return 1;
a0ed51b3
LW
2357 return 0;
2358}
2359
79072805 2360OP *
864dbfa3 2361Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2362{
79072805
LW
2363 SV *tstr = ((SVOP*)expr)->op_sv;
2364 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW
2365 STRLEN tlen;
2366 STRLEN rlen;
9b877dbb
IH
2367 U8 *t = (U8*)SvPV(tstr, tlen);
2368 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW
2369 register I32 i;
2370 register I32 j;
a0ed51b3 2371 I32 del;
79072805 2372 I32 complement;
5d06d08e 2373 I32 squash;
9b877dbb 2374 I32 grows = 0;
79072805
LW
2375 register short *tbl;
2376
800b4dc4 2377 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2378 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2379 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2380 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2381
036b4402
GS
2382 if (SvUTF8(tstr))
2383 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS
2384
2385 if (SvUTF8(rstr))
036b4402 2386 o->op_private |= OPpTRANS_TO_UTF;
79072805 2387
a0ed51b3 2388 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2389 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW
2390 SV* transv = 0;
2391 U8* tend = t + tlen;
2392 U8* rend = r + rlen;
ba210ebe 2393 STRLEN ulen;
84c133a0
RB
2394 UV tfirst = 1;
2395 UV tlast = 0;
2396 IV tdiff;
2397 UV rfirst = 1;
2398 UV rlast = 0;
2399 IV rdiff;
2400 IV diff;
a0ed51b3
LW
2401 I32 none = 0;
2402 U32 max = 0;
2403 I32 bits;
a0ed51b3 2404 I32 havefinal = 0;
9c5ffd7c 2405 U32 final = 0;
a0ed51b3
LW
2406 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2407 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH
2408 U8* tsave = NULL;
2409 U8* rsave = NULL;
2410
2411 if (!from_utf) {
2412 STRLEN len = tlen;
2413 tsave = t = bytes_to_utf8(t, &len);
2414 tend = t + len;
2415 }
2416 if (!to_utf && rlen) {
2417 STRLEN len = rlen;
2418 rsave = r = bytes_to_utf8(r, &len);
2419 rend = r + len;
2420 }
a0ed51b3 2421
2b9d42f0
NIS
2422/* There are several snags with this code on EBCDIC:
2423 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2424 2. scan_const() in toke.c has encoded chars in native encoding which makes
2425 ranges at least in EBCDIC 0..255 range the bottom odd.
2426*/
2427
a0ed51b3 2428 if (complement) {
89ebb4a3 2429 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2430 UV *cp;
a0ed51b3 2431 UV nextmin = 0;
2b9d42f0 2432 New(1109, cp, 2*tlen, UV);
a0ed51b3 2433 i = 0;
79cb57f6 2434 transv = newSVpvn("",0);
a0ed51b3 2435 while (t < tend) {
2b9d42f0
NIS
2436 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2437 t += ulen;
2438 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2439 t++;
2b9d42f0
NIS
2440 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2441 t += ulen;
a0ed51b3 2442 }
2b9d42f0
NIS
2443 else {
2444 cp[2*i+1] = cp[2*i];
2445 }
2446 i++;
a0ed51b3 2447 }
2b9d42f0 2448 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2449 for (j = 0; j < i; j++) {
2b9d42f0 2450 UV val = cp[2*j];
a0ed51b3
LW
2451 diff = val - nextmin;
2452 if (diff > 0) {
9041c2e3 2453 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2454 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2455 if (diff > 1) {
2b9d42f0 2456 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2457 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2458 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2459 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW
2460 }
2461 }
2b9d42f0 2462 val = cp[2*j+1];
a0ed51b3
LW
2463 if (val >= nextmin)
2464 nextmin = val + 1;
2465 }
9041c2e3 2466 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS
2468 {
2469 U8 range_mark = UTF_TO_NATIVE(0xff);
2470 sv_catpvn(transv, (char *)&range_mark, 1);
2471 }
b851fbc1
JH
2472 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2473 UNICODE_ALLOW_SUPER);
dfe13c55
GS
2474 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2475 t = (U8*)SvPVX(transv);
a0ed51b3
LW
2476 tlen = SvCUR(transv);
2477 tend = t + tlen;
455d824a 2478 Safefree(cp);
a0ed51b3
LW
2479 }
2480 else if (!rlen && !del) {
2481 r = t; rlen = tlen; rend = tend;
4757a243
LW
2482 }
2483 if (!squash) {
05d340b8 2484 if ((!rlen && !del) || t == r ||
12ae5dfc 2485 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2486 {
4757a243 2487 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2488 }
a0ed51b3
LW
2489 }
2490
2491 while (t < tend || tfirst <= tlast) {
2492 /* see if we need more "t" chars */
2493 if (tfirst > tlast) {
9041c2e3 2494 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2495 t += ulen;
2b9d42f0 2496 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2497 t++;
9041c2e3 2498 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW
2499 t += ulen;
2500 }
2501 else
2502 tlast = tfirst;
2503 }
2504
2505 /* now see if we need more "r" chars */
2506 if (rfirst > rlast) {
2507 if (r < rend) {
9041c2e3 2508 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2509 r += ulen;
2b9d42f0 2510 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2511 r++;
9041c2e3 2512 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW
2513 r += ulen;
2514 }
2515 else
2516 rlast = rfirst;
2517 }
2518 else {
2519 if (!havefinal++)
2520 final = rlast;
2521 rfirst = rlast = 0xffffffff;
2522 }
2523 }
2524
2525 /* now see which range will peter our first, if either. */
2526 tdiff = tlast - tfirst;
2527 rdiff = rlast - rfirst;
2528
2529 if (tdiff <= rdiff)
2530 diff = tdiff;
2531 else
2532 diff = rdiff;
2533
2534 if (rfirst == 0xffffffff) {
2535 diff = tdiff; /* oops, pretend rdiff is infinite */
2536 if (diff > 0)
894356b3
GS
2537 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2538 (long)tfirst, (long)tlast);
a0ed51b3 2539 else
894356b3 2540 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW
2541 }
2542 else {
2543 if (diff > 0)
894356b3
GS
2544 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2545 (long)tfirst, (long)(tfirst + diff),
2546 (long)rfirst);
a0ed51b3 2547 else
894356b3
GS
2548 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2549 (long)tfirst, (long)rfirst);
a0ed51b3
LW
2550
2551 if (rfirst + diff > max)
2552 max = rfirst + diff;
9b877dbb 2553 if (!grows)
45005bfb
JH
2554 grows = (tfirst < rfirst &&
2555 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2556 rfirst += diff + 1;
a0ed51b3
LW
2557 }
2558 tfirst += diff + 1;
2559 }
2560
2561 none = ++max;
2562 if (del)
2563 del = ++max;
2564
2565 if (max > 0xffff)
2566 bits = 32;
2567 else if (max > 0xff)
2568 bits = 16;
2569 else
2570 bits = 8;
2571
455d824a 2572 Safefree(cPVOPo->op_pv);
a0ed51b3
LW
2573 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2574 SvREFCNT_dec(listsv);
2575 if (transv)
2576 SvREFCNT_dec(transv);
2577
45005bfb 2578 if (!del && havefinal && rlen)
b448e4fe
JH
2579 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2580 newSVuv((UV)final), 0);
a0ed51b3 2581
9b877dbb 2582 if (grows)
a0ed51b3
LW
2583 o->op_private |= OPpTRANS_GROWS;
2584
9b877dbb
IH
2585 if (tsave)
2586 Safefree(tsave);
2587 if (rsave)
2588 Safefree(rsave);
2589
a0ed51b3
LW
2590 op_free(expr);
2591 op_free(repl);
2592 return o;
2593 }
2594
2595 tbl = (short*)cPVOPo->op_pv;
79072805
LW
2596 if (complement) {
2597 Zero(tbl, 256, short);
eb160463 2598 for (i = 0; i < (I32)tlen; i++)
ec49126f 2599 tbl[t[i]] = -1;
79072805
LW
2600 for (i = 0, j = 0; i < 256; i++) {
2601 if (!tbl[i]) {
eb160463 2602 if (j >= (I32)rlen) {
a0ed51b3 2603 if (del)
79072805
LW
2604 tbl[i] = -2;
2605 else if (rlen)
ec49126f 2606 tbl[i] = r[j-1];
79072805 2607 else
eb160463 2608 tbl[i] = (short)i;
79072805 2609 }
9b877dbb
IH
2610 else {
2611 if (i < 128 && r[j] >= 128)
2612 grows = 1;
ec49126f 2613 tbl[i] = r[j++];
9b877dbb 2614 }
79072805
LW
2615 }
2616 }
05d340b8
JH
2617 if (!del) {
2618 if (!rlen) {
2619 j = rlen;
2620 if (!squash)
2621 o->op_private |= OPpTRANS_IDENTICAL;
2622 }
eb160463 2623 else if (j >= (I32)rlen)
05d340b8
JH
2624 j = rlen - 1;
2625 else
2626 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 2627 tbl[0x100] = rlen - j;
eb160463 2628 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH
2629 tbl[0x101+i] = r[j+i];
2630 }
79072805
LW
2631 }
2632 else {
a0ed51b3 2633 if (!rlen && !del) {
79072805 2634 r = t; rlen = tlen;
5d06d08e 2635 if (!squash)
4757a243 2636 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2637 }
94bfe852
RGS
2638 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2639 o->op_private |= OPpTRANS_IDENTICAL;
2640 }
79072805
LW
2641 for (i = 0; i < 256; i++)
2642 tbl[i] = -1;
eb160463
GS
2643 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2644 if (j >= (I32)rlen) {
a0ed51b3 2645 if (del) {
ec49126f
PP
2646 if (tbl[t[i]] == -1)
2647 tbl[t[i]] = -2;
79072805
LW
2648 continue;
2649 }
2650 --j;
2651 }
9b877dbb
IH
2652 if (tbl[t[i]] == -1) {
2653 if (t[i] < 128 && r[j] >= 128)
2654 grows = 1;
ec49126f 2655 tbl[t[i]] = r[j];
9b877dbb 2656 }
79072805
LW
2657 }
2658 }
9b877dbb
IH
2659 if (grows)
2660 o->op_private |= OPpTRANS_GROWS;
79072805
LW
2661 op_free(expr);
2662 op_free(repl);
2663
11343788 2664 return o;
79072805
LW
2665}
2666
2667OP *
864dbfa3 2668Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW
2669{
2670 PMOP *pmop;
2671
b7dc083c 2672 NewOp(1101, pmop, 1, PMOP);
eb160463 2673 pmop->op_type = (OPCODE)type;
22c35a8c 2674 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS
2675 pmop->op_flags = (U8)flags;
2676 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2677
3280af22 2678 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2679 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2680 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS
2681 pmop->op_pmpermflags |= PMf_LOCALE;
2682 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2683
debc9467 2684#ifdef USE_ITHREADS
13137afc
AB
2685 {
2686 SV* repointer;
2687 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2688 repointer = av_pop((AV*)PL_regex_pad[0]);
2689 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2690 SvREPADTMP_off(repointer);
13137afc 2691 sv_setiv(repointer,0);
1eb1540c 2692 } else {
13137afc
AB
2693 repointer = newSViv(0);
2694 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2695 pmop->op_pmoffset = av_len(PL_regex_padav);
2696 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2697 }
13137afc 2698 }
debc9467 2699#endif
1eb1540c 2700
1fcf4c12 2701 /* link into pm list */
3280af22
NIS
2702 if (type != OP_TRANS && PL_curstash) {
2703 pmop->op_pmnext = HvPMROOT(PL_curstash);
2704 HvPMROOT(PL_curstash) = pmop;
cb55de95 2705 PmopSTASH_set(pmop,PL_curstash);
79072805
LW
2706 }
2707
463d09e6 2708 return CHECKOP(type, pmop);
79072805
LW
2709}
2710
131b3ad0
DM
2711/* Given some sort of match op o, and an expression expr containing a
2712 * pattern, either compile expr into a regex and attach it to o (if it's
2713 * constant), or convert expr into a runtime regcomp op sequence (if it's
2714 * not)
2715 *
2716 * isreg indicates that the pattern is part of a regex construct, eg
2717 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2718 * split "pattern", which aren't. In the former case, expr will be a list
2719 * if the pattern contains more than one term (eg /a$b/) or if it contains
2720 * a replacement, ie s/// or tr///.
2721 */
2722
79072805 2723OP *
131b3ad0 2724Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805
LW
2725{
2726 PMOP *pm;
2727 LOGOP *rcop;
ce862d02 2728 I32 repl_has_vars = 0;
131b3ad0
DM
2729 OP* repl = Nullop;
2730 bool reglist;
2731
2732 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2733 /* last element in list is the replacement; pop it */
2734 OP* kid;
2735 repl = cLISTOPx(expr)->op_last;
2736 kid = cLISTOPx(expr)->op_first;
2737 while (kid->op_sibling != repl)
2738 kid = kid->op_sibling;
2739 kid->op_sibling = Nullop;
2740 cLISTOPx(expr)->op_last = kid;
2741 }
79072805 2742
131b3ad0
DM
2743 if (isreg && expr->op_type == OP_LIST &&
2744 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2745 {
2746 /* convert single element list to element */
2747 OP* oe = expr;
2748 expr = cLISTOPx(oe)->op_first->op_sibling;
2749 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2750 cLISTOPx(oe)->op_last = Nullop;
2751 op_free(oe);
2752 }
2753
2754 if (o->op_type == OP_TRANS) {
11343788 2755 return pmtrans(o, expr, repl);
131b3ad0
DM
2756 }
2757
2758 reglist = isreg && expr->op_type == OP_LIST;
2759 if (reglist)
2760 op_null(expr);
79072805 2761
3280af22 2762 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2763 pm = (PMOP*)o;
79072805
LW
2764
2765 if (expr->op_type == OP_CONST) {
463ee0b2 2766 STRLEN plen;
79072805 2767 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2768 char *p = SvPV(pat, plen);
770526c1 2769 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
93a17b20 2770 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2771 p = SvPV(pat, plen);
79072805
LW
2772 pm->op_pmflags |= PMf_SKIPWHITE;
2773 }
5b71a6a7 2774 if (DO_UTF8(pat))
a5961de5 2775 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS
2776 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2777 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2778 pm->op_pmflags |= PMf_WHITE;
79072805
LW
2779 op_free(expr);
2780 }
2781 else {
3280af22 2782 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2783 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
2784 ? OP_REGCRESET
2785 : OP_REGCMAYBE),0,expr);
463ee0b2 2786
b7dc083c 2787 NewOp(1101, rcop, 1, LOGOP);
79072805 2788 rcop->op_type = OP_REGCOMP;
22c35a8c 2789 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2790 rcop->op_first = scalar(expr);
131b3ad0
DM
2791 rcop->op_flags |= OPf_KIDS
2792 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2793 | (reglist ? OPf_STACKED : 0);
79072805 2794 rcop->op_private = 1;
11343788 2795 rcop->op_other = o;
131b3ad0
DM
2796 if (reglist)
2797 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2798
b5c19bd7
DM
2799 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2800 PL_cv_has_eval = 1;
79072805
LW
2801
2802 /* establish postfix order */
3280af22 2803 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW
2804 LINKLIST(expr);
2805 rcop->op_next = expr;
2806 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2807 }
2808 else {
2809 rcop->op_next = LINKLIST(expr);
2810 expr->op_next = (OP*)rcop;
2811 }
79072805 2812
11343788 2813 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW
2814 }
2815
2816 if (repl) {
748a9306 2817 OP *curop;
0244c3a4 2818 if (pm->op_pmflags & PMf_EVAL) {
748a9306 2819 curop = 0;
8bafa735 2820 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2821 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2822 }
748a9306
LW
2823 else if (repl->op_type == OP_CONST)
2824 curop = repl;
79072805 2825 else {
79072805
LW
2826 OP *lastop = 0;
2827 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2828 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2829 if (curop->op_type == OP_GV) {
638eceb6 2830 GV *gv = cGVOPx_gv(curop);
ce862d02 2831 repl_has_vars = 1;
f702bf4a 2832 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW
2833 break;
2834 }
2835 else if (curop->op_type == OP_RV2CV)
2836 break;
2837 else if (curop->op_type == OP_RV2SV ||
2838 curop->op_type == OP_RV2AV ||
2839 curop->op_type == OP_RV2HV ||
2840 curop->op_type == OP_RV2GV) {
2841 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2842 break;
2843 }
748a9306
LW
2844 else if (curop->op_type == OP_PADSV ||
2845 curop->op_type == OP_PADAV ||
2846 curop->op_type == OP_PADHV ||
554b3eca 2847 curop->op_type == OP_PADANY) {
ce862d02 2848 repl_has_vars = 1;
748a9306 2849 }
1167e5da
SM
2850 else if (curop->op_type == OP_PUSHRE)
2851 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW
2852 else
2853 break;
2854 }
2855 lastop = curop;
2856 }
748a9306 2857 }
ce862d02 2858 if (curop == repl
1c846c1f 2859 && !(repl_has_vars
aaa362c4
RS
2860 && (!PM_GETRE(pm)
2861 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2862 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2863 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2864 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW
2865 }
2866 else {
aaa362c4 2867 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ
2868 pm->op_pmflags |= PMf_MAYBE_CONST;
2869 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2870 }
b7dc083c 2871 NewOp(1101, rcop, 1, LOGOP);
748a9306 2872 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2873 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW
2874 rcop->op_first = scalar(repl);
2875 rcop->op_flags |= OPf_KIDS;
2876 rcop->op_private = 1;
11343788 2877 rcop->op_other = o;
748a9306
LW
2878
2879 /* establish postfix order */
2880 rcop->op_next = LINKLIST(repl);
2881 repl->op_next = (OP*)rcop;
2882
2883 pm->op_pmreplroot = scalar((OP*)rcop);
2884 pm->op_pmreplstart = LINKLIST(rcop);
2885 rcop->op_next = 0;
79072805
LW
2886 }
2887 }
2888
2889 return (OP*)pm;
2890}
2891
2892OP *
864dbfa3 2893Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW
2894{
2895 SVOP *svop;
b7dc083c 2896 NewOp(1101, svop, 1, SVOP);
eb160463 2897 svop->op_type = (OPCODE)type;
22c35a8c 2898 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2899 svop->op_sv = sv;
2900 svop->op_next = (OP*)svop;
eb160463 2901 svop->op_flags = (U8)flags;
22c35a8c 2902 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2903 scalar((OP*)svop);
22c35a8c 2904 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2905 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2906 return CHECKOP(type, svop);
79072805
LW
2907}
2908
2909OP *
350de78d
GS
2910Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2911{
2912 PADOP *padop;
2913 NewOp(1101, padop, 1, PADOP);
eb160463 2914 padop->op_type = (OPCODE)type;
350de78d
GS
2915 padop->op_ppaddr = PL_ppaddr[type];
2916 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM
2917 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2918 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS
2919 if (sv)
2920 SvPADTMP_on(sv);
350de78d 2921 padop->op_next = (OP*)padop;
eb160463 2922 padop->op_flags = (U8)flags;
350de78d
GS
2923 if (PL_opargs[type] & OA_RETSCALAR)
2924 scalar((OP*)padop);
2925 if (PL_opargs[type] & OA_TARGET)
2926 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2927 return CHECKOP(type, padop);
2928}
2929
2930OP *
864dbfa3 2931Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 2932{
350de78d 2933#ifdef USE_ITHREADS
ce50c033
AMS
2934 if (gv)
2935 GvIN_PAD_on(gv);
350de78d
GS
2936 return newPADOP(type, flags, SvREFCNT_inc(gv));
2937#else
7934575e 2938 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 2939#endif
79072805
LW
2940}
2941
2942OP *
864dbfa3 2943Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW
2944{
2945 PVOP *pvop;
b7dc083c 2946 NewOp(1101, pvop, 1, PVOP);
eb160463 2947 pvop->op_type = (OPCODE)type;
22c35a8c 2948 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2949 pvop->op_pv = pv;
2950 pvop->op_next = (OP*)pvop;
eb160463 2951 pvop->op_flags = (U8)flags;
22c35a8c 2952 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2953 scalar((OP*)pvop);
22c35a8c 2954 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2955 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2956 return CHECKOP(type, pvop);
79072805
LW
2957}
2958
79072805 2959void
864dbfa3 2960Perl_package(pTHX_ OP *o)
79072805 2961{
6867be6d 2962 const char *name;
de11ba31 2963 STRLEN len;
79072805 2964
3280af22
NIS
2965 save_hptr(&PL_curstash);
2966 save_item(PL_curstname);
de11ba31
AMS
2967
2968 name = SvPV(cSVOPo->op_sv, len);
2969 PL_curstash = gv_stashpvn(name, len, TRUE);
2970 sv_setpvn(PL_curstname, name, len);
2971 op_free(o);
2972
7ad382f4 2973 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
2974 PL_copline = NOLINE;
2975 PL_expect = XSTATE;
79072805
LW
2976}
2977
85e6fe83 2978void
88d95a4d 2979Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 2980{
a0d0e21e 2981 OP *pack;
a0d0e21e 2982 OP *imop;
b1cb66bf 2983 OP *veop;
85e6fe83 2984
88d95a4d 2985 if (idop->op_type != OP_CONST)
cea2e8a9 2986 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 2987
b1cb66bf
PP
2988 veop = Nullop;
2989
0f79a09d 2990 if (version != Nullop) {
b1cb66bf
PP
2991 SV *vesv = ((SVOP*)version)->op_sv;
2992
44dcb63b 2993 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf
PP
2994 arg = version;
2995 }
2996 else {
2997 OP *pack;
0f79a09d 2998 SV *meth;
b1cb66bf 2999
44dcb63b 3000 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3001 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3002
88d95a4d
JH
3003 /* Make copy of idop so we don't free it twice */
3004 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf
PP
3005
3006 /* Fake up a method call to VERSION */
0f79a09d
GS
3007 meth = newSVpvn("VERSION",7);
3008 sv_upgrade(meth, SVt_PVIV);
155aba94 3009 (void)SvIOK_on(meth);
4946a0fa
NC
3010 {
3011 U32 hash;
3012 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3013 SvUV_set(meth, hash);
3014 }
b1cb66bf
PP
3015 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3016 append_elem(OP_LIST,
0f79a09d
GS
3017 prepend_elem(OP_LIST, pack, list(version)),
3018 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf
PP
3019 }
3020 }
aeea060c 3021
a0d0e21e 3022 /* Fake up an import/unimport */
4633a7c4
LW
3023 if (arg && arg->op_type == OP_STUB)
3024 imop = arg; /* no import on explicit () */
88d95a4d 3025 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf
PP
3026 imop = Nullop; /* use 5.0; */
3027 }
4633a7c4 3028 else {
0f79a09d
GS
3029 SV *meth;
3030
88d95a4d
JH
3031 /* Make copy of idop so we don't free it twice */
3032 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS
3033
3034 /* Fake up a method call to import/unimport */
b47cad08 3035 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 3036 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3037 (void)SvIOK_on(meth);
4946a0fa
NC
3038 {
3039 U32 hash;
3040 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3041 SvUV_set(meth, hash);
3042 }
4633a7c4 3043 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS
3044 append_elem(OP_LIST,
3045 prepend_elem(OP_LIST, pack, list(arg)),
3046 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW
3047 }
3048
a0d0e21e 3049 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3050 newATTRSUB(floor,
79cb57f6 3051 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3052 Nullop,
09bef843 3053 Nullop,
a0d0e21e 3054 append_elem(OP_LINESEQ,
b1cb66bf 3055 append_elem(OP_LINESEQ,
88d95a4d 3056 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 3057 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3058 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3059
70f5e4ed
JH
3060 /* The "did you use incorrect case?" warning used to be here.
3061 * The problem is that on case-insensitive filesystems one
3062 * might get false positives for "use" (and "require"):
3063 * "use Strict" or "require CARP" will work. This causes
3064 * portability problems for the script: in case-strict
3065 * filesystems the script will stop working.
3066 *
3067 * The "incorrect case" warning checked whether "use Foo"
3068 * imported "Foo" to your namespace, but that is wrong, too:
3069 * there is no requirement nor promise in the language that
3070 * a Foo.pm should or would contain anything in package "Foo".
3071 *
3072 * There is very little Configure-wise that can be done, either:
3073 * the case-sensitivity of the build filesystem of Perl does not
3074 * help in guessing the case-sensitivity of the runtime environment.
3075 */
18fc9488 3076
c305c6a0 3077 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3078 PL_copline = NOLINE;
3079 PL_expect = XSTATE;
8ec8fbef 3080 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW
3081}
3082
7d3fb230 3083/*
ccfc67b7
JH
3084=head1 Embedding Functions
3085
7d3fb230
BS
3086=for apidoc load_module
3087
3088Loads the module whose name is pointed to by the string part of name.
3089Note that the actual module name, not its filename, should be given.
3090Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3091PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3092(or 0 for no flags). ver, if specified, provides version semantics
3093similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3094arguments can be used to specify arguments to the module's import()
3095method, similar to C<use Foo::Bar VERSION LIST>.
3096
3097=cut */
3098
e4783991
GS
3099void
3100Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3101{
3102 va_list args;
3103 va_start(args, ver);
3104 vload_module(flags, name, ver, &args);
3105 va_end(args);
3106}
3107
3108#ifdef PERL_IMPLICIT_CONTEXT
3109void
3110Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3111{
3112 dTHX;
3113 va_list args;
3114 va_start(args, ver);
3115 vload_module(flags, name, ver, &args);
3116 va_end(args);
3117}
3118#endif
3119
3120void
3121Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3122{
3123 OP *modname, *veop, *imop;
3124
3125 modname = newSVOP(OP_CONST, 0, name);
3126 modname->op_private |= OPpCONST_BARE;
3127 if (ver) {
3128 veop = newSVOP(OP_CONST, 0, ver);
3129 }
3130 else
3131 veop = Nullop;
3132 if (flags & PERL_LOADMOD_NOIMPORT) {
3133 imop = sawparens(newNULLLIST());
3134 }
3135 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3136 imop = va_arg(*args, OP*);
3137 }
3138 else {
3139 SV *sv;
3140 imop = Nullop;
3141 sv = va_arg(*args, SV*);
3142 while (sv) {
3143 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3144 sv = va_arg(*args, SV*);
3145 }
3146 }
81885997 3147 {
6867be6d
AL
3148 const line_t ocopline = PL_copline;
3149 COP * const ocurcop = PL_curcop;
3150 const int oexpect = PL_expect;
81885997
GS
3151
3152 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3153 veop, modname, imop);
3154 PL_expect = oexpect;
3155 PL_copline = ocopline;
834a3ffa 3156 PL_curcop = ocurcop;
81885997 3157 }
e4783991
GS
3158}
3159
79072805 3160OP *
864dbfa3 3161Perl_dofile(pTHX_ OP *term)
78ca652e
GS
3162{
3163 OP *doop;
3164 GV *gv;
3165
3166 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3167 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS
3168 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3169
b9f751c0 3170 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS
3171 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3172 append_elem(OP_LIST, term,
3173 scalar(newUNOP(OP_RV2CV, 0,
3174 newGVOP(OP_GV, 0,
3175 gv))))));
3176 }
3177 else {
3178 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3179 }
3180 return doop;
3181}
3182
3183OP *
864dbfa3 3184Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW
3185{
3186 return newBINOP(OP_LSLICE, flags,
8990e307
LW
3187 list(force_list(subscript)),
3188 list(force_list(listval)) );
79072805
LW
3189}
3190
76e3520e 3191STATIC I32
6867be6d 3192S_list_assignment(pTHX_ register const OP *o)
79072805 3193{
11343788 3194 if (!o)
79072805
LW
3195 return TRUE;
3196
11343788
MB
3197 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3198 o = cUNOPo->op_first;
79072805 3199
11343788 3200 if (o->op_type == OP_COND_EXPR) {
6867be6d
AL
3201 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3202 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW
3203
3204 if (t && f)
3205 return TRUE;
3206 if (t || f)
3207 yyerror("Assignment to both a list and a scalar");
3208 return FALSE;
3209 }
3210
95f0a2f1
SB
3211 if (o->op_type == OP_LIST &&
3212 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3213 o->op_private & OPpLVAL_INTRO)
3214 return FALSE;
3215
11343788
MB
3216 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3217 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3218 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW
3219 return TRUE;
3220
11343788 3221 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW
3222 return TRUE;
3223
11343788 3224 if (o->op_type == OP_RV2SV)
79072805
LW
3225 return FALSE;
3226
3227 return FALSE;
3228}
3229
3230OP *
864dbfa3 3231Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3232{
11343788 3233 OP *o;
79072805 3234
a0d0e21e 3235 if (optype) {
c963b151 3236 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW
3237 return newLOGOP(optype, 0,
3238 mod(scalar(left), optype),
3239 newUNOP(OP_SASSIGN, 0, scalar(right)));
3240 }
3241 else {
3242 return newBINOP(optype, OPf_STACKED,
3243 mod(scalar(left), optype), scalar(right));
3244 }
3245 }
3246
79072805 3247 if (list_assignment(left)) {
10c8fecd
GS
3248 OP *curop;
3249
3280af22
NIS
3250 PL_modcount = 0;
3251 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3252 left = mod(left, OP_AASSIGN);
3280af22
NIS
3253 if (PL_eval_start)
3254 PL_eval_start = 0;
748a9306 3255 else {
a0d0e21e
LW
3256 op_free(left);
3257 op_free(right);
3258 return Nullop;
3259 }
b9d46b39
RGS
3260 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3261 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3262 && right->op_type == OP_STUB
3263 && (left->op_private & OPpLVAL_INTRO))
3264 {
3265 op_free(right);
9ff53bc9 3266 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
b9d46b39
RGS
3267 return left;
3268 }
10c8fecd
GS
3269 curop = list(force_list(left));
3270 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3271 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM
3272
3273 /* PL_generation sorcery:
3274 * an assignment like ($a,$b) = ($c,$d) is easier than
3275 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3276 * To detect whether there are common vars, the global var
3277 * PL_generation is incremented for each assign op we compile.
3278 * Then, while compiling the assign op, we run through all the
3279 * variables on both sides of the assignment, setting a spare slot
3280 * in each of them to PL_generation. If any of them already have
3281 * that value, we know we've got commonality. We could use a
3282 * single bit marker, but then we'd have to make 2 passes, first
3283 * to clear the flag, then to test and set it. To find somewhere
3284 * to store these values, evil chicanery is done with SvCUR().
3285 */
3286
a0d0e21e 3287 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3288 OP *lastop = o;
3280af22 3289 PL_generation++;
11343788 3290 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3291 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3292 if (curop->op_type == OP_GV) {
638eceb6 3293 GV *gv = cGVOPx_gv(curop);
eb160463 3294 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3295 break;
b162af07 3296 SvCUR_set(gv, PL_generation);
79072805 3297 }
748a9306
LW
3298 else if (curop->op_type == OP_PADSV ||
3299 curop->op_type == OP_PADAV ||
3300 curop->op_type == OP_PADHV ||
dd2155a4
DM
3301 curop->op_type == OP_PADANY)
3302 {
3303 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3304 == (STRLEN)PL_generation)
748a9306 3305 break;
b162af07 3306 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 3307
748a9306 3308 }
79072805
LW
3309 else if (curop->op_type == OP_RV2CV)
3310 break;
3311 else if (curop->op_type == OP_RV2SV ||
3312 curop->op_type == OP_RV2AV ||
3313 curop->op_type == OP_RV2HV ||
3314 curop->op_type == OP_RV2GV) {
3315 if (lastop->op_type != OP_GV) /* funny deref? */
3316 break;
3317 }
1167e5da
SM
3318 else if (curop->op_type == OP_PUSHRE) {
3319 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3320#ifdef USE_ITHREADS
dd2155a4
DM
3321 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3322 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3323#else
1167e5da 3324 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3325#endif
eb160463 3326 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3327 break;
b162af07 3328 SvCUR_set(gv, PL_generation);
b2ffa427 3329 }
1167e5da 3330 }
79072805
LW
3331 else
3332 break;
3333 }
3334 lastop = curop;
3335 }
11343788 3336 if (curop != o)
10c8fecd 3337 o->op_private |= OPpASSIGN_COMMON;
79072805 3338 }
c07a80fd
PP
3339 if (right && right->op_type == OP_SPLIT) {
3340 OP* tmpop;
3341 if ((tmpop = ((LISTOP*)right)->op_first) &&
3342 tmpop->op_type == OP_PUSHRE)
3343 {
3344 PMOP *pm = (PMOP*)tmpop;
3345 if (left->op_type == OP_RV2AV &&
3346 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3347 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd
PP
3348 {
3349 tmpop = ((UNOP*)left)->op_first;
3350 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3351#ifdef USE_ITHREADS
ba89bb6e 3352 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS
3353 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3354#else
3355 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3356 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3357#endif
c07a80fd 3358 pm->op_pmflags |= PMf_ONCE;
11343788 3359 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd
PP
3360 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3361 tmpop->op_sibling = Nullop; /* don't free split */
3362 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3363 op_free(o); /* blow off assign */
54310121 3364 right->op_flags &= ~OPf_WANT;
a5f75d66 3365 /* "I don't know and I don't care." */
c07a80fd
PP
3366 return right;
3367 }
3368 }
3369 else {
e6438c1a 3370 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd
PP
3371 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3372 {
3373 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3374 if (SvIVX(sv) == 0)
3280af22 3375 sv_setiv(sv, PL_modcount+1);
c07a80fd
PP
3376 }
3377 }
3378 }
3379 }
11343788 3380 return o;
79072805
LW
3381 }
3382 if (!right)
3383 right = newOP(OP_UNDEF, 0);
3384 if (right->op_type == OP_READLINE) {
3385 right->op_flags |= OPf_STACKED;
463ee0b2 3386 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3387 }
a0d0e21e 3388 else {
3280af22 3389 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3390 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3391 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS
3392 if (PL_eval_start)
3393 PL_eval_start = 0;
748a9306 3394 else {
11343788 3395 op_free(o);
a0d0e21e
LW
3396 return Nullop;
3397 }
3398 }
11343788 3399 return o;
79072805
LW
3400}
3401
3402OP *
864dbfa3 3403Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3404{
e1ec3a88 3405 const U32 seq = intro_my();
79072805
LW
3406 register COP *cop;
3407
b7dc083c 3408 NewOp(1101, cop, 1, COP);
57843af0 3409 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3410 cop->op_type = OP_DBSTATE;
22c35a8c 3411 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW
3412 }
3413 else {
3414 cop->op_type = OP_NEXTSTATE;
22c35a8c 3415 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3416 }
eb160463
GS
3417 cop->op_flags = (U8)flags;
3418 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69
PP
3419#ifdef NATIVE_HINTS
3420 cop->op_private |= NATIVE_HINTS;
3421#endif
e24b16f9 3422 PL_compiling.op_private = cop->op_private;
79072805
LW
3423 cop->op_next = (OP*)cop;
3424
463ee0b2
LW
3425 if (label) {
3426 cop->cop_label = label;
3280af22 3427 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3428 }
bbce6d69 3429 cop->cop_seq = seq;
3280af22 3430 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3431 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3432 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3433 else
599cee73 3434 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS
3435 if (specialCopIO(PL_curcop->cop_io))
3436 cop->cop_io = PL_curcop->cop_io;
3437 else
3438 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3439
79072805 3440
3280af22 3441 if (PL_copline == NOLINE)
57843af0 3442 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3443 else {
57843af0 3444 CopLINE_set(cop, PL_copline);
3280af22 3445 PL_copline = NOLINE;
79072805 3446 }
57843af0 3447#ifdef USE_ITHREADS
f4dd75d9 3448 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3449#else
f4dd75d9 3450 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3451#endif
11faa288 3452 CopSTASH_set(cop, PL_curstash);
79072805 3453
3280af22 3454 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3455 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3456 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3457 (void)SvIOK_on(*svp);
45977657 3458 SvIV_set(*svp, PTR2IV(cop));
1eb1540c 3459 }
93a17b20
LW
3460 }
3461
722969e2 3462 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW
3463}
3464
bbce6d69 3465
79072805 3466OP *
864dbfa3 3467Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3468{
883ffac3
CS
3469 return new_logop(type, flags, &first, &other);
3470}
3471
3bd495df 3472STATIC OP *
cea2e8a9 3473S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3474{
79072805 3475 LOGOP *logop;
11343788 3476 OP *o;
883ffac3
CS
3477 OP *first = *firstp;
3478 OP *other = *otherp;
79072805 3479
a0d0e21e
LW
3480 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3481 return newBINOP(type, flags, scalar(first), scalar(other));
3482
8990e307 3483 scalarboolean(first);
79072805
LW
3484 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3485 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3486 if (type == OP_AND || type == OP_OR) {
3487 if (type == OP_AND)
3488 type = OP_OR;
3489 else
3490 type = OP_AND;
11343788 3491 o = first;
883ffac3 3492 first = *firstp = cUNOPo->op_first;
11343788
MB
3493 if (o->op_next)
3494 first->op_next = o->op_next;
3495 cUNOPo->op_first = Nullop;
3496 op_free(o);
79072805
LW
3497 }
3498 }
3499 if (first->op_type == OP_CONST) {
39a440a3
DM
3500 if (first->op_private & OPpCONST_STRICT)
3501 no_bareword_allowed(first);
3502 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
989dfb19 3503 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
75cc09e4
MHM
3504 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3505 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3506 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
79072805 3507 op_free(first);
883ffac3 3508 *firstp = Nullop;
d6fee5c7
DM
3509 if (other->op_type == OP_CONST)
3510 other->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW
3511 return other;
3512 }
3513 else {
7921d0f2 3514 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 3515 const OP *o2 = other;
7921d0f2
DM
3516 if ( ! (o2->op_type == OP_LIST
3517 && (( o2 = cUNOPx(o2)->op_first))
3518 && o2->op_type == OP_PUSHMARK
3519 && (( o2 = o2->op_sibling)) )
3520 )
3521 o2 = other;
3522 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3523 || o2->op_type == OP_PADHV)
3524 && o2->op_private & OPpLVAL_INTRO
3525 && ckWARN(WARN_DEPRECATED))
3526 {
3527 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3528 "Deprecated use of my() in false conditional");
3529 }
3530
79072805 3531 op_free(other);
883ffac3 3532 *otherp = Nullop;
d6fee5c7
DM
3533 if (first->op_type == OP_CONST)
3534 first->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW
3535 return first;
3536 }
3537 }
59e10468
RGS
3538 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3539 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */