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