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