This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
s/newSVpv_hek/newSVhek/g; # Lousy choice of name
[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 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 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 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 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. */
b15aece3
SP
788 if (strnEQ(SvPVX_const(sv), "di", 2) ||
789 strnEQ(SvPVX_const(sv), "ds", 2) ||
790 strnEQ(SvPVX_const(sv), "ig", 2))
d008e5eb
GS
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 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 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 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 1336{
1337 switch (type) {
1338 case OP_SASSIGN:
5196be3e 1339 if (o->op_type == OP_RV2GV)
3fe9a6f1 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 1375 return TRUE;
1376 default:
1377 return FALSE;
1378 }
1379}
1380
35cd451c 1381STATIC bool
504618e9 1382S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
35cd451c
GS
1383{
1384 switch (o->op_type) {
1385 case OP_PIPE_OP:
1386 case OP_SOCKPAIR:
504618e9 1387 if (numargs == 2)
35cd451c
GS
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:
504618e9 1396 if (numargs == 1)
35cd451c
GS
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)
7423f6db 1538 stashsv = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
09bef843
SB
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) {
95f0a2f1 1546 /* Don't force the C<use> if we don't need it. */
504618e9 1547 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
95f0a2f1
SB
1548 sizeof(ATTRSMODULE_PM)-1, 0);
1549 if (svp && *svp != &PL_sv_undef)
1550 ; /* already in %INC */
1551 else
1552 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1553 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1554 Nullsv);
1555 }
1556 else {
1557 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1558 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1559 Nullsv,
1560 prepend_elem(OP_LIST,
1561 newSVOP(OP_CONST, 0, stashsv),
1562 prepend_elem(OP_LIST,
1563 newSVOP(OP_CONST, 0,
1564 newRV(target)),
1565 dup_attrlist(attrs))));
1566 }
09bef843
SB
1567 LEAVE;
1568}
1569
95f0a2f1
SB
1570STATIC void
1571S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1572{
1573 OP *pack, *imop, *arg;
1574 SV *meth, *stashsv;
1575
1576 if (!attrs)
1577 return;
1578
1579 assert(target->op_type == OP_PADSV ||
1580 target->op_type == OP_PADHV ||
1581 target->op_type == OP_PADAV);
1582
1583 /* Ensure that attributes.pm is loaded. */
dd2155a4 1584 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB
1585
1586 /* Need package name for method call. */
1587 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1588
1589 /* Build up the real arg-list. */
1590 if (stash)
7423f6db 1591 stashsv = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
95f0a2f1
SB
1592 else
1593 stashsv = &PL_sv_no;
1594 arg = newOP(OP_PADSV, 0);
1595 arg->op_targ = target->op_targ;
1596 arg = prepend_elem(OP_LIST,
1597 newSVOP(OP_CONST, 0, stashsv),
1598 prepend_elem(OP_LIST,
1599 newUNOP(OP_REFGEN, 0,
1600 mod(arg, OP_REFGEN)),
1601 dup_attrlist(attrs)));
1602
1603 /* Fake up a method call to import */
1604 meth = newSVpvn("import", 6);
1605 (void)SvUPGRADE(meth, SVt_PVIV);
1606 (void)SvIOK_on(meth);
4946a0fa
NC
1607 {
1608 U32 hash;
b15aece3 1609 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
4946a0fa
NC
1610 SvUV_set(meth, hash);
1611 }
95f0a2f1
SB
1612 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1613 append_elem(OP_LIST,
1614 prepend_elem(OP_LIST, pack, list(arg)),
1615 newSVOP(OP_METHOD_NAMED, 0, meth)));
1616 imop->op_private |= OPpENTERSUB_NOMOD;
1617
1618 /* Combine the ops. */
1619 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1620}
1621
1622/*
1623=notfor apidoc apply_attrs_string
1624
1625Attempts to apply a list of attributes specified by the C<attrstr> and
1626C<len> arguments to the subroutine identified by the C<cv> argument which
1627is expected to be associated with the package identified by the C<stashpv>
1628argument (see L<attributes>). It gets this wrong, though, in that it
1629does not correctly identify the boundaries of the individual attribute
1630specifications within C<attrstr>. This is not really intended for the
1631public API, but has to be listed here for systems such as AIX which
1632need an explicit export list for symbols. (It's called from XS code
1633in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1634to respect attribute syntax properly would be welcome.
1635
1636=cut
1637*/
1638
be3174d2 1639void
6867be6d
AL
1640Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1641 const char *attrstr, STRLEN len)
be3174d2
GS
1642{
1643 OP *attrs = Nullop;
1644
1645 if (!len) {
1646 len = strlen(attrstr);
1647 }
1648
1649 while (len) {
1650 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1651 if (len) {
6867be6d 1652 const char *sstr = attrstr;
be3174d2
GS
1653 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1654 attrs = append_elem(OP_LIST, attrs,
1655 newSVOP(OP_CONST, 0,
1656 newSVpvn(sstr, attrstr-sstr)));
1657 }
1658 }
1659
1660 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1661 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1662 Nullsv, prepend_elem(OP_LIST,
1663 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1664 prepend_elem(OP_LIST,
1665 newSVOP(OP_CONST, 0,
1666 newRV((SV*)cv)),
1667 attrs)));
1668}
1669
09bef843 1670STATIC OP *
95f0a2f1 1671S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1672{
93a17b20
LW
1673 I32 type;
1674
3280af22 1675 if (!o || PL_error_count)
11343788 1676 return o;
93a17b20 1677
11343788 1678 type = o->op_type;
93a17b20 1679 if (type == OP_LIST) {
6867be6d 1680 OP *kid;
11343788 1681 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1682 my_kid(kid, attrs, imopsp);
dab48698 1683 } else if (type == OP_UNDEF) {
7766148a 1684 return o;
77ca0c92
LW
1685 } else if (type == OP_RV2SV || /* "our" declaration */
1686 type == OP_RV2AV ||
1687 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS
1688 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1689 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1690 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1691 } else if (attrs) {
1692 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1693 PL_in_my = FALSE;
1694 PL_in_my_stash = Nullhv;
1695 apply_attrs(GvSTASH(gv),
1696 (type == OP_RV2SV ? GvSV(gv) :
1697 type == OP_RV2AV ? (SV*)GvAV(gv) :
1698 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1699 attrs, FALSE);
1700 }
192587c2 1701 o->op_private |= OPpOUR_INTRO;
77ca0c92 1702 return o;
95f0a2f1
SB
1703 }
1704 else if (type != OP_PADSV &&
93a17b20
LW
1705 type != OP_PADAV &&
1706 type != OP_PADHV &&
1707 type != OP_PUSHMARK)
1708 {
eb64745e 1709 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1710 OP_DESC(o),
eb64745e 1711 PL_in_my == KEY_our ? "our" : "my"));
11343788 1712 return o;
93a17b20 1713 }
09bef843
SB
1714 else if (attrs && type != OP_PUSHMARK) {
1715 HV *stash;
09bef843 1716
eb64745e
GS
1717 PL_in_my = FALSE;
1718 PL_in_my_stash = Nullhv;
1719
09bef843 1720 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM
1721 stash = PAD_COMPNAME_TYPE(o->op_targ);
1722 if (!stash)
09bef843 1723 stash = PL_curstash;
95f0a2f1 1724 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1725 }
11343788
MB
1726 o->op_flags |= OPf_MOD;
1727 o->op_private |= OPpLVAL_INTRO;
1728 return o;
93a17b20
LW
1729}
1730
1731OP *
09bef843
SB
1732Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1733{
95f0a2f1
SB
1734 OP *rops = Nullop;
1735 int maybe_scalar = 0;
1736
d2be0de5 1737/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1738 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1739#if 0
09bef843
SB
1740 if (o->op_flags & OPf_PARENS)
1741 list(o);
95f0a2f1
SB
1742 else
1743 maybe_scalar = 1;
d2be0de5
YST
1744#else
1745 maybe_scalar = 1;
1746#endif
09bef843
SB
1747 if (attrs)
1748 SAVEFREEOP(attrs);
95f0a2f1
SB
1749 o = my_kid(o, attrs, &rops);
1750 if (rops) {
1751 if (maybe_scalar && o->op_type == OP_PADSV) {
1752 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1753 o->op_private |= OPpLVAL_INTRO;
1754 }
1755 else
1756 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1757 }
eb64745e
GS
1758 PL_in_my = FALSE;
1759 PL_in_my_stash = Nullhv;
1760 return o;
09bef843
SB
1761}
1762
1763OP *
1764Perl_my(pTHX_ OP *o)
1765{
95f0a2f1 1766 return my_attrs(o, Nullop);
09bef843
SB
1767}
1768
1769OP *
864dbfa3 1770Perl_sawparens(pTHX_ OP *o)
79072805
LW
1771{
1772 if (o)
1773 o->op_flags |= OPf_PARENS;
1774 return o;
1775}
1776
1777OP *
864dbfa3 1778Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1779{
11343788 1780 OP *o;
59f00321 1781 bool ismatchop = 0;
79072805 1782
e476b1b5 1783 if (ckWARN(WARN_MISC) &&
599cee73
PM
1784 (left->op_type == OP_RV2AV ||
1785 left->op_type == OP_RV2HV ||
1786 left->op_type == OP_PADAV ||
1787 left->op_type == OP_PADHV)) {
e1ec3a88 1788 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM
1789 right->op_type == OP_TRANS)
1790 ? right->op_type : OP_MATCH];
dff6d3cd
GS
1791 const char *sample = ((left->op_type == OP_RV2AV ||
1792 left->op_type == OP_PADAV)
1793 ? "@array" : "%hash");
9014280d 1794 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1795 "Applying %s to %s will act on scalar(%s)",
599cee73 1796 desc, sample, sample);
2ae324a7 1797 }
1798
5cc9e5c9
RH
1799 if (right->op_type == OP_CONST &&
1800 cSVOPx(right)->op_private & OPpCONST_BARE &&
1801 cSVOPx(right)->op_private & OPpCONST_STRICT)
1802 {
1803 no_bareword_allowed(right);
1804 }
1805
59f00321
RGS
1806 ismatchop = right->op_type == OP_MATCH ||
1807 right->op_type == OP_SUBST ||
1808 right->op_type == OP_TRANS;
1809 if (ismatchop && right->op_private & OPpTARGET_MY) {
1810 right->op_targ = 0;
1811 right->op_private &= ~OPpTARGET_MY;
1812 }
1813 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1814 right->op_flags |= OPf_STACKED;
18808301
JH
1815 if (right->op_type != OP_MATCH &&
1816 ! (right->op_type == OP_TRANS &&
1817 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1818 left = mod(left, right->op_type);
79072805 1819 if (right->op_type == OP_TRANS)
11343788 1820 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1821 else
11343788 1822 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1823 if (type == OP_NOT)
11343788
MB
1824 return newUNOP(OP_NOT, 0, scalar(o));
1825 return o;
79072805
LW
1826 }
1827 else
1828 return bind_match(type, left,
131b3ad0 1829 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW
1830}
1831
1832OP *
864dbfa3 1833Perl_invert(pTHX_ OP *o)
79072805 1834{
11343788
MB
1835 if (!o)
1836 return o;
79072805 1837 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1838 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
1839}
1840
1841OP *
864dbfa3 1842Perl_scope(pTHX_ OP *o)
79072805 1843{
27da23d5 1844 dVAR;
79072805 1845 if (o) {
3280af22 1846 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW
1847 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1848 o->op_type = OP_LEAVE;
22c35a8c 1849 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1850 }
fdb22418
HS
1851 else if (o->op_type == OP_LINESEQ) {
1852 OP *kid;
1853 o->op_type = OP_SCOPE;
1854 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1855 kid = ((LISTOP*)o)->op_first;
1856 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1857 op_null(kid);
463ee0b2 1858 }
fdb22418
HS
1859 else
1860 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
79072805
LW
1861 }
1862 return o;
1863}
1864
dfa41748 1865/* XXX kept for BINCOMPAT only */
b3ac6de7 1866void
864dbfa3 1867Perl_save_hints(pTHX)
b3ac6de7 1868{
dfa41748 1869 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
b3ac6de7
IZ
1870}
1871
a0d0e21e 1872int
864dbfa3 1873Perl_block_start(pTHX_ int full)
79072805 1874{
73d840c0 1875 const int retval = PL_savestack_ix;
dd2155a4 1876 pad_block_start(full);
b3ac6de7 1877 SAVEHINTS();
3280af22 1878 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1879 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1880 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
1881 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1882 SAVEFREESV(PL_compiling.cop_warnings) ;
1883 }
ac27b0f5
NIS
1884 SAVESPTR(PL_compiling.cop_io);
1885 if (! specialCopIO(PL_compiling.cop_io)) {
1886 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1887 SAVEFREESV(PL_compiling.cop_io) ;
1888 }
a0d0e21e
LW
1889 return retval;
1890}
1891
1892OP*
864dbfa3 1893Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1894{
6867be6d 1895 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
e9f19e3c 1896 OP* retval = scalarseq(seq);
e9818f4e 1897 LEAVE_SCOPE(floor);
eb160463 1898 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1899 if (needblockscope)
3280af22 1900 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1901 pad_leavemy();
a0d0e21e
LW
1902 return retval;
1903}
1904
76e3520e 1905STATIC OP *
cea2e8a9 1906S_newDEFSVOP(pTHX)
54b9620d 1907{
6867be6d 1908 const I32 offset = pad_findmy("$_");
59f00321
RGS
1909 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1910 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1911 }
1912 else {
1913 OP *o = newOP(OP_PADSV, 0);
1914 o->op_targ = offset;
1915 return o;
1916 }
54b9620d
MB
1917}
1918
a0d0e21e 1919void
864dbfa3 1920Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1921{
3280af22 1922 if (PL_in_eval) {
b295d113
TH
1923 if (PL_eval_root)
1924 return;
faef0170
HS
1925 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1926 ((PL_in_eval & EVAL_KEEPERR)
1927 ? OPf_SPECIAL : 0), o);
3280af22 1928 PL_eval_start = linklist(PL_eval_root);
7934575e
GS
1929 PL_eval_root->op_private |= OPpREFCOUNTED;
1930 OpREFCNT_set(PL_eval_root, 1);
3280af22 1931 PL_eval_root->op_next = 0;
a2efc822 1932 CALL_PEEP(PL_eval_start);
a0d0e21e
LW
1933 }
1934 else {
6be89cf9
AE
1935 if (o->op_type == OP_STUB) {
1936 PL_comppad_name = 0;
1937 PL_compcv = 0;
2a4f803a 1938 FreeOp(o);
a0d0e21e 1939 return;
6be89cf9 1940 }
3280af22
NIS
1941 PL_main_root = scope(sawparens(scalarvoid(o)));
1942 PL_curcop = &PL_compiling;
1943 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
1944 PL_main_root->op_private |= OPpREFCOUNTED;
1945 OpREFCNT_set(PL_main_root, 1);
3280af22 1946 PL_main_root->op_next = 0;
a2efc822 1947 CALL_PEEP(PL_main_start);
3280af22 1948 PL_compcv = 0;
3841441e 1949
4fdae800 1950 /* Register with debugger */
84902520 1951 if (PERLDB_INTER) {
864dbfa3 1952 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS
1953 if (cv) {
1954 dSP;
924508f0 1955 PUSHMARK(SP);
cc49e20b 1956 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1957 PUTBACK;
864dbfa3 1958 call_sv((SV*)cv, G_DISCARD);
3841441e
CS
1959 }
1960 }
79072805 1961 }
79072805
LW
1962}
1963
1964OP *
864dbfa3 1965Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW
1966{
1967 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
1968/* [perl #17376]: this appears to be premature, and results in code such as
1969 C< our(%x); > executing in list mode rather than void mode */
1970#if 0
79072805 1971 list(o);
d2be0de5
YST
1972#else
1973 ;
1974#endif
8990e307 1975 else {
64420d0d
JH
1976 if (ckWARN(WARN_PARENTHESIS)
1977 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1978 {
1979 char *s = PL_bufptr;
bac662ee 1980 bool sigil = FALSE;
64420d0d 1981
8473848f 1982 /* some heuristics to detect a potential error */
bac662ee 1983 while (*s && (strchr(", \t\n", *s)))
64420d0d 1984 s++;
8473848f 1985
bac662ee
TS
1986 while (1) {
1987 if (*s && strchr("@$%*", *s) && *++s
1988 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1989 s++;
1990 sigil = TRUE;
1991 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1992 s++;
1993 while (*s && (strchr(", \t\n", *s)))
1994 s++;
1995 }
1996 else
1997 break;
1998 }
1999 if (sigil && (*s == ';' || *s == '=')) {
2000 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS
2001 "Parentheses missing around \"%s\" list",
2002 lex ? (PL_in_my == KEY_our ? "our" : "my")
2003 : "local");
2004 }
8990e307
LW
2005 }
2006 }
93a17b20 2007 if (lex)
eb64745e 2008 o = my(o);
93a17b20 2009 else
eb64745e
GS
2010 o = mod(o, OP_NULL); /* a bit kludgey */
2011 PL_in_my = FALSE;
2012 PL_in_my_stash = Nullhv;
2013 return o;
79072805
LW
2014}
2015
2016OP *
864dbfa3 2017Perl_jmaybe(pTHX_ OP *o)
79072805
LW
2018{
2019 if (o->op_type == OP_LIST) {
554b3eca 2020 OP *o2;
554b3eca 2021 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
554b3eca 2022 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW
2023 }
2024 return o;
2025}
2026
2027OP *
864dbfa3 2028Perl_fold_constants(pTHX_ register OP *o)
79072805 2029{
27da23d5 2030 dVAR;
79072805
LW
2031 register OP *curop;
2032 I32 type = o->op_type;
748a9306 2033 SV *sv;
79072805 2034
22c35a8c 2035 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2036 scalar(o);
b162f9ea 2037 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2038 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2039
eac055e9
GS
2040 /* integerize op, unless it happens to be C<-foo>.
2041 * XXX should pp_i_negate() do magic string negation instead? */
2042 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2043 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2044 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2045 {
22c35a8c 2046 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2047 }
85e6fe83 2048
22c35a8c 2049 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
2050 goto nope;
2051
de939608 2052 switch (type) {
7a52d87a
GS
2053 case OP_NEGATE:
2054 /* XXX might want a ck_negate() for this */
2055 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2056 break;
de939608
CS
2057 case OP_SPRINTF:
2058 case OP_UCFIRST:
2059 case OP_LCFIRST:
2060 case OP_UC:
2061 case OP_LC:
69dcf70c
MB
2062 case OP_SLT:
2063 case OP_SGT:
2064 case OP_SLE:
2065 case OP_SGE:
2066 case OP_SCMP:
2de3dbcc
JH
2067 /* XXX what about the numeric ops? */
2068 if (PL_hints & HINT_LOCALE)
de939608
CS
2069 goto nope;
2070 }
2071
3280af22 2072 if (PL_error_count)
a0d0e21e
LW
2073 goto nope; /* Don't try to run w/ errors */
2074
79072805 2075 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS
2076 if ((curop->op_type != OP_CONST ||
2077 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS
2078 curop->op_type != OP_LIST &&
2079 curop->op_type != OP_SCALAR &&
2080 curop->op_type != OP_NULL &&
2081 curop->op_type != OP_PUSHMARK)
2082 {
79072805
LW
2083 goto nope;
2084 }
2085 }
2086
2087 curop = LINKLIST(o);
2088 o->op_next = 0;
533c011a 2089 PL_op = curop;
cea2e8a9 2090 CALLRUNOPS(aTHX);
3280af22 2091 sv = *(PL_stack_sp--);
748a9306 2092 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 2093 pad_swipe(o->op_targ, FALSE);
748a9306
LW
2094 else if (SvTEMP(sv)) { /* grab mortal temp? */
2095 (void)SvREFCNT_inc(sv);
2096 SvTEMP_off(sv);
85e6fe83 2097 }
79072805
LW
2098 op_free(o);
2099 if (type == OP_RV2GV)
b1cb66bf 2100 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 2101 return newSVOP(OP_CONST, 0, sv);
aeea060c 2102
79072805 2103 nope:
79072805
LW
2104 return o;
2105}
2106
2107OP *
864dbfa3 2108Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2109{
27da23d5 2110 dVAR;
79072805 2111 register OP *curop;
6867be6d 2112 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2113
a0d0e21e 2114 list(o);
3280af22 2115 if (PL_error_count)
a0d0e21e
LW
2116 return o; /* Don't attempt to run with errors */
2117
533c011a 2118 PL_op = curop = LINKLIST(o);
a0d0e21e 2119 o->op_next = 0;
a2efc822 2120 CALL_PEEP(curop);
cea2e8a9
GS
2121 pp_pushmark();
2122 CALLRUNOPS(aTHX);
533c011a 2123 PL_op = curop;
cea2e8a9 2124 pp_anonlist();
3280af22 2125 PL_tmps_floor = oldtmps_floor;
79072805
LW
2126
2127 o->op_type = OP_RV2AV;
22c35a8c 2128 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
2129 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2130 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2131 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2132 curop = ((UNOP*)o)->op_first;
3280af22 2133 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2134 op_free(curop);
79072805
LW
2135 linklist(o);
2136 return list(o);
2137}
2138
2139OP *
864dbfa3 2140Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2141{
27da23d5 2142 dVAR;
11343788
MB
2143 if (!o || o->op_type != OP_LIST)
2144 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2145 else
5dc0d613 2146 o->op_flags &= ~OPf_WANT;
79072805 2147
22c35a8c 2148 if (!(PL_opargs[type] & OA_MARK))
93c66552 2149 op_null(cLISTOPo->op_first);
8990e307 2150
eb160463 2151 o->op_type = (OPCODE)type;
22c35a8c 2152 o->op_ppaddr = PL_ppaddr[type];
11343788 2153 o->op_flags |= flags;
79072805 2154
11343788 2155 o = CHECKOP(type, o);
fe2774ed 2156 if (o->op_type != (unsigned)type)
11343788 2157 return o;
79072805 2158
11343788 2159 return fold_constants(o);
79072805
LW
2160}
2161
2162/* List constructors */
2163
2164OP *
864dbfa3 2165Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2166{
2167 if (!first)
2168 return last;
8990e307
LW
2169
2170 if (!last)
79072805 2171 return first;
8990e307 2172
fe2774ed 2173 if (first->op_type != (unsigned)type
155aba94
GS
2174 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2175 {
2176 return newLISTOP(type, 0, first, last);
2177 }
79072805 2178
a0d0e21e
LW
2179 if (first->op_flags & OPf_KIDS)
2180 ((LISTOP*)first)->op_last->op_sibling = last;
2181 else {
2182 first->op_flags |= OPf_KIDS;
2183 ((LISTOP*)first)->op_first = last;
2184 }
2185 ((LISTOP*)first)->op_last = last;
a0d0e21e 2186 return first;
79072805
LW
2187}
2188
2189OP *
864dbfa3 2190Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW
2191{
2192 if (!first)
2193 return (OP*)last;
8990e307
LW
2194
2195 if (!last)
79072805 2196 return (OP*)first;
8990e307 2197
fe2774ed 2198 if (first->op_type != (unsigned)type)
79072805 2199 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2200
fe2774ed 2201 if (last->op_type != (unsigned)type)
79072805
LW
2202 return append_elem(type, (OP*)first, (OP*)last);
2203
2204 first->op_last->op_sibling = last->op_first;
2205 first->op_last = last->op_last;
117dada2 2206 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2207
238a4c30
NIS
2208 FreeOp(last);
2209
79072805
LW
2210 return (OP*)first;
2211}
2212
2213OP *
864dbfa3 2214Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2215{
2216 if (!first)
2217 return last;
8990e307
LW
2218
2219 if (!last)
79072805 2220 return first;
8990e307 2221
fe2774ed 2222 if (last->op_type == (unsigned)type) {
8990e307
LW
2223 if (type == OP_LIST) { /* already a PUSHMARK there */
2224 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2225 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
2226 if (!(first->op_flags & OPf_PARENS))
2227 last->op_flags &= ~OPf_PARENS;
8990e307
LW
2228 }
2229 else {
2230 if (!(last->op_flags & OPf_KIDS)) {
2231 ((LISTOP*)last)->op_last = first;
2232 last->op_flags |= OPf_KIDS;
2233 }
2234 first->op_sibling = ((LISTOP*)last)->op_first;
2235 ((LISTOP*)last)->op_first = first;
79072805 2236 }
117dada2 2237 last->op_flags |= OPf_KIDS;
79072805
LW
2238 return last;
2239 }
2240
2241 return newLISTOP(type, 0, first, last);
2242}
2243
2244/* Constructors */
2245
2246OP *
864dbfa3 2247Perl_newNULLLIST(pTHX)
79072805 2248{
8990e307
LW
2249 return newOP(OP_STUB, 0);
2250}
2251
2252OP *
864dbfa3 2253Perl_force_list(pTHX_ OP *o)
8990e307 2254{
11343788
MB
2255 if (!o || o->op_type != OP_LIST)
2256 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2257 op_null(o);
11343788 2258 return o;
79072805
LW
2259}
2260
2261OP *
864dbfa3 2262Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2263{
27da23d5 2264 dVAR;
79072805
LW
2265 LISTOP *listop;
2266
b7dc083c 2267 NewOp(1101, listop, 1, LISTOP);
79072805 2268
eb160463 2269 listop->op_type = (OPCODE)type;
22c35a8c 2270 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
2271 if (first || last)
2272 flags |= OPf_KIDS;
eb160463 2273 listop->op_flags = (U8)flags;
79072805
LW
2274
2275 if (!last && first)
2276 last = first;
2277 else if (!first && last)
2278 first = last;
8990e307
LW
2279 else if (first)
2280 first->op_sibling = last;
79072805
LW
2281 listop->op_first = first;
2282 listop->op_last = last;
8990e307
LW
2283 if (type == OP_LIST) {
2284 OP* pushop;
2285 pushop = newOP(OP_PUSHMARK, 0);
2286 pushop->op_sibling = first;
2287 listop->op_first = pushop;
2288 listop->op_flags |= OPf_KIDS;
2289 if (!last)
2290 listop->op_last = pushop;
2291 }
79072805 2292
463d09e6 2293 return CHECKOP(type, listop);
79072805
LW
2294}
2295
2296OP *
864dbfa3 2297Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2298{
27da23d5 2299 dVAR;
11343788 2300 OP *o;
b7dc083c 2301 NewOp(1101, o, 1, OP);
eb160463 2302 o->op_type = (OPCODE)type;
22c35a8c 2303 o->op_ppaddr = PL_ppaddr[type];
eb160463 2304 o->op_flags = (U8)flags;
79072805 2305
11343788 2306 o->op_next = o;
eb160463 2307 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2308 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2309 scalar(o);
22c35a8c 2310 if (PL_opargs[type] & OA_TARGET)
11343788
MB
2311 o->op_targ = pad_alloc(type, SVs_PADTMP);
2312 return CHECKOP(type, o);
79072805
LW
2313}
2314
2315OP *
864dbfa3 2316Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2317{
27da23d5 2318 dVAR;
79072805
LW
2319 UNOP *unop;
2320
93a17b20 2321 if (!first)
aeea060c 2322 first = newOP(OP_STUB, 0);
22c35a8c 2323 if (PL_opargs[type] & OA_MARK)
8990e307 2324 first = force_list(first);
93a17b20 2325
b7dc083c 2326 NewOp(1101, unop, 1, UNOP);
eb160463 2327 unop->op_type = (OPCODE)type;
22c35a8c 2328 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2329 unop->op_first = first;
2330 unop->op_flags = flags | OPf_KIDS;
eb160463 2331 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2332 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
2333 if (unop->op_next)
2334 return (OP*)unop;
2335
a0d0e21e 2336 return fold_constants((OP *) unop);
79072805
LW
2337}
2338
2339OP *
864dbfa3 2340Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2341{
27da23d5 2342 dVAR;
79072805 2343 BINOP *binop;
b7dc083c 2344 NewOp(1101, binop, 1, BINOP);
79072805
LW
2345
2346 if (!first)
2347 first = newOP(OP_NULL, 0);
2348
eb160463 2349 binop->op_type = (OPCODE)type;
22c35a8c 2350 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2351 binop->op_first = first;
2352 binop->op_flags = flags | OPf_KIDS;
2353 if (!last) {
2354 last = first;
eb160463 2355 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW
2356 }
2357 else {
eb160463 2358 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW
2359 first->op_sibling = last;
2360 }
2361
e50aee73 2362 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2363 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW
2364 return (OP*)binop;
2365
7284ab6f 2366 binop->op_last = binop->op_first->op_sibling;
79072805 2367
a0d0e21e 2368 return fold_constants((OP *)binop);
79072805
LW
2369}
2370
abb2c242
JH
2371static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2372static int uvcompare(const void *a, const void *b)
2b9d42f0 2373{
e1ec3a88 2374 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2375 return -1;
e1ec3a88 2376 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2377 return 1;
e1ec3a88 2378 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2379 return -1;
e1ec3a88 2380 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2381 return 1;
a0ed51b3
LW
2382 return 0;
2383}
2384
79072805 2385OP *
864dbfa3 2386Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2387{
79072805
LW
2388 SV *tstr = ((SVOP*)expr)->op_sv;
2389 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW
2390 STRLEN tlen;
2391 STRLEN rlen;
9b877dbb
IH
2392 U8 *t = (U8*)SvPV(tstr, tlen);
2393 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW
2394 register I32 i;
2395 register I32 j;
a0ed51b3 2396 I32 del;
79072805 2397 I32 complement;
5d06d08e 2398 I32 squash;
9b877dbb 2399 I32 grows = 0;
79072805
LW
2400 register short *tbl;
2401
800b4dc4 2402 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2403 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2404 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2405 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2406
036b4402
GS
2407 if (SvUTF8(tstr))
2408 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS
2409
2410 if (SvUTF8(rstr))
036b4402 2411 o->op_private |= OPpTRANS_TO_UTF;
79072805 2412
a0ed51b3 2413 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2414 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW
2415 SV* transv = 0;
2416 U8* tend = t + tlen;
2417 U8* rend = r + rlen;
ba210ebe 2418 STRLEN ulen;
84c133a0
RB
2419 UV tfirst = 1;
2420 UV tlast = 0;
2421 IV tdiff;
2422 UV rfirst = 1;
2423 UV rlast = 0;
2424 IV rdiff;
2425 IV diff;
a0ed51b3
LW
2426 I32 none = 0;
2427 U32 max = 0;
2428 I32 bits;
a0ed51b3 2429 I32 havefinal = 0;
9c5ffd7c 2430 U32 final = 0;
a0ed51b3
LW
2431 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2432 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH
2433 U8* tsave = NULL;
2434 U8* rsave = NULL;
2435
2436 if (!from_utf) {
2437 STRLEN len = tlen;
2438 tsave = t = bytes_to_utf8(t, &len);
2439 tend = t + len;
2440 }
2441 if (!to_utf && rlen) {
2442 STRLEN len = rlen;
2443 rsave = r = bytes_to_utf8(r, &len);
2444 rend = r + len;
2445 }
a0ed51b3 2446
2b9d42f0
NIS
2447/* There are several snags with this code on EBCDIC:
2448 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2449 2. scan_const() in toke.c has encoded chars in native encoding which makes
2450 ranges at least in EBCDIC 0..255 range the bottom odd.
2451*/
2452
a0ed51b3 2453 if (complement) {
89ebb4a3 2454 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2455 UV *cp;
a0ed51b3 2456 UV nextmin = 0;
2b9d42f0 2457 New(1109, cp, 2*tlen, UV);
a0ed51b3 2458 i = 0;
79cb57f6 2459 transv = newSVpvn("",0);
a0ed51b3 2460 while (t < tend) {
2b9d42f0
NIS
2461 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2462 t += ulen;
2463 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2464 t++;
2b9d42f0
NIS
2465 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2466 t += ulen;
a0ed51b3 2467 }
2b9d42f0
NIS
2468 else {
2469 cp[2*i+1] = cp[2*i];
2470 }
2471 i++;
a0ed51b3 2472 }
2b9d42f0 2473 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2474 for (j = 0; j < i; j++) {
2b9d42f0 2475 UV val = cp[2*j];
a0ed51b3
LW
2476 diff = val - nextmin;
2477 if (diff > 0) {
9041c2e3 2478 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2479 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2480 if (diff > 1) {
2b9d42f0 2481 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2482 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2483 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2484 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW
2485 }
2486 }
2b9d42f0 2487 val = cp[2*j+1];
a0ed51b3
LW
2488 if (val >= nextmin)
2489 nextmin = val + 1;
2490 }
9041c2e3 2491 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2492 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS
2493 {
2494 U8 range_mark = UTF_TO_NATIVE(0xff);
2495 sv_catpvn(transv, (char *)&range_mark, 1);
2496 }
b851fbc1
JH
2497 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2498 UNICODE_ALLOW_SUPER);
dfe13c55
GS
2499 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2500 t = (U8*)SvPVX(transv);
a0ed51b3
LW
2501 tlen = SvCUR(transv);
2502 tend = t + tlen;
455d824a 2503 Safefree(cp);
a0ed51b3
LW
2504 }
2505 else if (!rlen && !del) {
2506 r = t; rlen = tlen; rend = tend;
4757a243
LW
2507 }
2508 if (!squash) {
05d340b8 2509 if ((!rlen && !del) || t == r ||
12ae5dfc 2510 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2511 {
4757a243 2512 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2513 }
a0ed51b3
LW
2514 }
2515
2516 while (t < tend || tfirst <= tlast) {
2517 /* see if we need more "t" chars */
2518 if (tfirst > tlast) {
9041c2e3 2519 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2520 t += ulen;
2b9d42f0 2521 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2522 t++;
9041c2e3 2523 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW
2524 t += ulen;
2525 }
2526 else
2527 tlast = tfirst;
2528 }
2529
2530 /* now see if we need more "r" chars */
2531 if (rfirst > rlast) {
2532 if (r < rend) {
9041c2e3 2533 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2534 r += ulen;
2b9d42f0 2535 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2536 r++;
9041c2e3 2537 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW
2538 r += ulen;
2539 }
2540 else
2541 rlast = rfirst;
2542 }
2543 else {
2544 if (!havefinal++)
2545 final = rlast;
2546 rfirst = rlast = 0xffffffff;
2547 }
2548 }
2549
2550 /* now see which range will peter our first, if either. */
2551 tdiff = tlast - tfirst;
2552 rdiff = rlast - rfirst;
2553
2554 if (tdiff <= rdiff)
2555 diff = tdiff;
2556 else
2557 diff = rdiff;
2558
2559 if (rfirst == 0xffffffff) {
2560 diff = tdiff; /* oops, pretend rdiff is infinite */
2561 if (diff > 0)
894356b3
GS
2562 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2563 (long)tfirst, (long)tlast);
a0ed51b3 2564 else
894356b3 2565 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW
2566 }
2567 else {
2568 if (diff > 0)
894356b3
GS
2569 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2570 (long)tfirst, (long)(tfirst + diff),
2571 (long)rfirst);
a0ed51b3 2572 else
894356b3
GS
2573 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2574 (long)tfirst, (long)rfirst);
a0ed51b3
LW
2575
2576 if (rfirst + diff > max)
2577 max = rfirst + diff;
9b877dbb 2578 if (!grows)
45005bfb
JH
2579 grows = (tfirst < rfirst &&
2580 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2581 rfirst += diff + 1;
a0ed51b3
LW
2582 }
2583 tfirst += diff + 1;
2584 }
2585
2586 none = ++max;
2587 if (del)
2588 del = ++max;
2589
2590 if (max > 0xffff)
2591 bits = 32;
2592 else if (max > 0xff)
2593 bits = 16;
2594 else
2595 bits = 8;
2596
455d824a 2597 Safefree(cPVOPo->op_pv);
a0ed51b3
LW
2598 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2599 SvREFCNT_dec(listsv);
2600 if (transv)
2601 SvREFCNT_dec(transv);
2602
45005bfb 2603 if (!del && havefinal && rlen)
b448e4fe
JH
2604 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2605 newSVuv((UV)final), 0);
a0ed51b3 2606
9b877dbb 2607 if (grows)
a0ed51b3
LW
2608 o->op_private |= OPpTRANS_GROWS;
2609
9b877dbb
IH
2610 if (tsave)
2611 Safefree(tsave);
2612 if (rsave)
2613 Safefree(rsave);
2614
a0ed51b3
LW
2615 op_free(expr);
2616 op_free(repl);
2617 return o;
2618 }
2619
2620 tbl = (short*)cPVOPo->op_pv;
79072805
LW
2621 if (complement) {
2622 Zero(tbl, 256, short);
eb160463 2623 for (i = 0; i < (I32)tlen; i++)
ec49126f 2624 tbl[t[i]] = -1;
79072805
LW
2625 for (i = 0, j = 0; i < 256; i++) {
2626 if (!tbl[i]) {
eb160463 2627 if (j >= (I32)rlen) {
a0ed51b3 2628 if (del)
79072805
LW
2629 tbl[i] = -2;
2630 else if (rlen)
ec49126f 2631 tbl[i] = r[j-1];
79072805 2632 else
eb160463 2633 tbl[i] = (short)i;
79072805 2634 }
9b877dbb
IH
2635 else {
2636 if (i < 128 && r[j] >= 128)
2637 grows = 1;
ec49126f 2638 tbl[i] = r[j++];
9b877dbb 2639 }
79072805
LW
2640 }
2641 }
05d340b8
JH
2642 if (!del) {
2643 if (!rlen) {
2644 j = rlen;
2645 if (!squash)
2646 o->op_private |= OPpTRANS_IDENTICAL;
2647 }
eb160463 2648 else if (j >= (I32)rlen)
05d340b8
JH
2649 j = rlen - 1;
2650 else
2651 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 2652 tbl[0x100] = rlen - j;
eb160463 2653 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH
2654 tbl[0x101+i] = r[j+i];
2655 }
79072805
LW
2656 }
2657 else {
a0ed51b3 2658 if (!rlen && !del) {
79072805 2659 r = t; rlen = tlen;
5d06d08e 2660 if (!squash)
4757a243 2661 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2662 }
94bfe852
RGS
2663 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2664 o->op_private |= OPpTRANS_IDENTICAL;
2665 }
79072805
LW
2666 for (i = 0; i < 256; i++)
2667 tbl[i] = -1;
eb160463
GS
2668 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2669 if (j >= (I32)rlen) {
a0ed51b3 2670 if (del) {
ec49126f 2671 if (tbl[t[i]] == -1)
2672 tbl[t[i]] = -2;
79072805
LW
2673 continue;
2674 }
2675 --j;
2676 }
9b877dbb
IH
2677 if (tbl[t[i]] == -1) {
2678 if (t[i] < 128 && r[j] >= 128)
2679 grows = 1;
ec49126f 2680 tbl[t[i]] = r[j];
9b877dbb 2681 }
79072805
LW
2682 }
2683 }
9b877dbb
IH
2684 if (grows)
2685 o->op_private |= OPpTRANS_GROWS;
79072805
LW
2686 op_free(expr);
2687 op_free(repl);
2688
11343788 2689 return o;
79072805
LW
2690}
2691
2692OP *
864dbfa3 2693Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 2694{
27da23d5 2695 dVAR;
79072805
LW
2696 PMOP *pmop;
2697
b7dc083c 2698 NewOp(1101, pmop, 1, PMOP);
eb160463 2699 pmop->op_type = (OPCODE)type;
22c35a8c 2700 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS
2701 pmop->op_flags = (U8)flags;
2702 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2703
3280af22 2704 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2705 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2706 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS
2707 pmop->op_pmpermflags |= PMf_LOCALE;
2708 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2709
debc9467 2710#ifdef USE_ITHREADS
13137afc
AB
2711 {
2712 SV* repointer;
2713 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2714 repointer = av_pop((AV*)PL_regex_pad[0]);
2715 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2716 SvREPADTMP_off(repointer);
13137afc 2717 sv_setiv(repointer,0);
1eb1540c 2718 } else {
13137afc
AB
2719 repointer = newSViv(0);
2720 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2721 pmop->op_pmoffset = av_len(PL_regex_padav);
2722 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2723 }
13137afc 2724 }
debc9467 2725#endif
1eb1540c 2726
1fcf4c12 2727 /* link into pm list */
3280af22 2728 if (type != OP_TRANS && PL_curstash) {
8d2f4536
NC
2729 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2730
2731 if (!mg) {
2732 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2733 }
2734 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2735 mg->mg_obj = (SV*)pmop;
cb55de95 2736 PmopSTASH_set(pmop,PL_curstash);
79072805
LW
2737 }
2738
463d09e6 2739 return CHECKOP(type, pmop);
79072805
LW
2740}
2741
131b3ad0
DM
2742/* Given some sort of match op o, and an expression expr containing a
2743 * pattern, either compile expr into a regex and attach it to o (if it's
2744 * constant), or convert expr into a runtime regcomp op sequence (if it's
2745 * not)
2746 *
2747 * isreg indicates that the pattern is part of a regex construct, eg
2748 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2749 * split "pattern", which aren't. In the former case, expr will be a list
2750 * if the pattern contains more than one term (eg /a$b/) or if it contains
2751 * a replacement, ie s/// or tr///.
2752 */
2753
79072805 2754OP *
131b3ad0 2755Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 2756{
27da23d5 2757 dVAR;
79072805
LW
2758 PMOP *pm;
2759 LOGOP *rcop;
ce862d02 2760 I32 repl_has_vars = 0;
131b3ad0
DM
2761 OP* repl = Nullop;
2762 bool reglist;
2763
2764 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2765 /* last element in list is the replacement; pop it */
2766 OP* kid;
2767 repl = cLISTOPx(expr)->op_last;
2768 kid = cLISTOPx(expr)->op_first;
2769 while (kid->op_sibling != repl)
2770 kid = kid->op_sibling;
2771 kid->op_sibling = Nullop;
2772 cLISTOPx(expr)->op_last = kid;
2773 }
79072805 2774
131b3ad0
DM
2775 if (isreg && expr->op_type == OP_LIST &&
2776 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2777 {
2778 /* convert single element list to element */
2779 OP* oe = expr;
2780 expr = cLISTOPx(oe)->op_first->op_sibling;
2781 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2782 cLISTOPx(oe)->op_last = Nullop;
2783 op_free(oe);
2784 }
2785
2786 if (o->op_type == OP_TRANS) {
11343788 2787 return pmtrans(o, expr, repl);
131b3ad0
DM
2788 }
2789
2790 reglist = isreg && expr->op_type == OP_LIST;
2791 if (reglist)
2792 op_null(expr);
79072805 2793
3280af22 2794 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2795 pm = (PMOP*)o;
79072805
LW
2796
2797 if (expr->op_type == OP_CONST) {
463ee0b2 2798 STRLEN plen;
79072805 2799 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2800 char *p = SvPV(pat, plen);
770526c1 2801 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
93a17b20 2802 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2803 p = SvPV(pat, plen);
79072805
LW
2804 pm->op_pmflags |= PMf_SKIPWHITE;
2805 }
5b71a6a7 2806 if (DO_UTF8(pat))
a5961de5 2807 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS
2808 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2809 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2810 pm->op_pmflags |= PMf_WHITE;
79072805
LW
2811 op_free(expr);
2812 }
2813 else {
3280af22 2814 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2815 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
2816 ? OP_REGCRESET
2817 : OP_REGCMAYBE),0,expr);
463ee0b2 2818
b7dc083c 2819 NewOp(1101, rcop, 1, LOGOP);
79072805 2820 rcop->op_type = OP_REGCOMP;
22c35a8c 2821 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2822 rcop->op_first = scalar(expr);
131b3ad0
DM
2823 rcop->op_flags |= OPf_KIDS
2824 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2825 | (reglist ? OPf_STACKED : 0);
79072805 2826 rcop->op_private = 1;
11343788 2827 rcop->op_other = o;
131b3ad0
DM
2828 if (reglist)
2829 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2830
b5c19bd7
DM
2831 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2832 PL_cv_has_eval = 1;
79072805
LW
2833
2834 /* establish postfix order */
3280af22 2835 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW
2836 LINKLIST(expr);
2837 rcop->op_next = expr;
2838 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2839 }
2840 else {
2841 rcop->op_next = LINKLIST(expr);
2842 expr->op_next = (OP*)rcop;
2843 }
79072805 2844
11343788 2845 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW
2846 }
2847
2848 if (repl) {
748a9306 2849 OP *curop;
0244c3a4 2850 if (pm->op_pmflags & PMf_EVAL) {
748a9306 2851 curop = 0;
8bafa735 2852 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2853 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2854 }
748a9306
LW
2855 else if (repl->op_type == OP_CONST)
2856 curop = repl;
79072805 2857 else {
79072805
LW
2858 OP *lastop = 0;
2859 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2860 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2861 if (curop->op_type == OP_GV) {
638eceb6 2862 GV *gv = cGVOPx_gv(curop);
ce862d02 2863 repl_has_vars = 1;
f702bf4a 2864 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW
2865 break;
2866 }
2867 else if (curop->op_type == OP_RV2CV)
2868 break;
2869 else if (curop->op_type == OP_RV2SV ||
2870 curop->op_type == OP_RV2AV ||
2871 curop->op_type == OP_RV2HV ||
2872 curop->op_type == OP_RV2GV) {
2873 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2874 break;
2875 }
748a9306
LW
2876 else if (curop->op_type == OP_PADSV ||
2877 curop->op_type == OP_PADAV ||
2878 curop->op_type == OP_PADHV ||
554b3eca 2879 curop->op_type == OP_PADANY) {
ce862d02 2880 repl_has_vars = 1;
748a9306 2881 }
1167e5da
SM
2882 else if (curop->op_type == OP_PUSHRE)
2883 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW
2884 else
2885 break;
2886 }
2887 lastop = curop;
2888 }
748a9306 2889 }
ce862d02 2890 if (curop == repl
1c846c1f 2891 && !(repl_has_vars
aaa362c4
RS
2892 && (!PM_GETRE(pm)
2893 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2894 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2895 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2896 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW
2897 }
2898 else {
aaa362c4 2899 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ
2900 pm->op_pmflags |= PMf_MAYBE_CONST;
2901 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2902 }
b7dc083c 2903 NewOp(1101, rcop, 1, LOGOP);
748a9306 2904 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2905 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW
2906 rcop->op_first = scalar(repl);
2907 rcop->op_flags |= OPf_KIDS;
2908 rcop->op_private = 1;
11343788 2909 rcop->op_other = o;
748a9306
LW
2910
2911 /* establish postfix order */
2912 rcop->op_next = LINKLIST(repl);
2913 repl->op_next = (OP*)rcop;
2914
2915 pm->op_pmreplroot = scalar((OP*)rcop);
2916 pm->op_pmreplstart = LINKLIST(rcop);
2917 rcop->op_next = 0;
79072805
LW
2918 }
2919 }
2920
2921 return (OP*)pm;
2922}
2923
2924OP *
864dbfa3 2925Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 2926{
27da23d5 2927 dVAR;
79072805 2928 SVOP *svop;
b7dc083c 2929 NewOp(1101, svop, 1, SVOP);
eb160463 2930 svop->op_type = (OPCODE)type;
22c35a8c 2931 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2932 svop->op_sv = sv;
2933 svop->op_next = (OP*)svop;
eb160463 2934 svop->op_flags = (U8)flags;
22c35a8c 2935 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2936 scalar((OP*)svop);
22c35a8c 2937 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2938 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2939 return CHECKOP(type, svop);
79072805
LW
2940}
2941
2942OP *
350de78d
GS
2943Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2944{
27da23d5 2945 dVAR;
350de78d
GS
2946 PADOP *padop;
2947 NewOp(1101, padop, 1, PADOP);
eb160463 2948 padop->op_type = (OPCODE)type;
350de78d
GS
2949 padop->op_ppaddr = PL_ppaddr[type];
2950 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM
2951 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2952 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS
2953 if (sv)
2954 SvPADTMP_on(sv);
350de78d 2955 padop->op_next = (OP*)padop;
eb160463 2956 padop->op_flags = (U8)flags;
350de78d
GS
2957 if (PL_opargs[type] & OA_RETSCALAR)
2958 scalar((OP*)padop);
2959 if (PL_opargs[type] & OA_TARGET)
2960 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2961 return CHECKOP(type, padop);
2962}
2963
2964OP *
864dbfa3 2965Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 2966{
27da23d5 2967 dVAR;
350de78d 2968#ifdef USE_ITHREADS
ce50c033
AMS
2969 if (gv)
2970 GvIN_PAD_on(gv);
350de78d
GS
2971 return newPADOP(type, flags, SvREFCNT_inc(gv));
2972#else
7934575e 2973 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 2974#endif
79072805
LW
2975}
2976
2977OP *
864dbfa3 2978Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 2979{
27da23d5 2980 dVAR;
79072805 2981 PVOP *pvop;
b7dc083c 2982 NewOp(1101, pvop, 1, PVOP);
eb160463 2983 pvop->op_type = (OPCODE)type;
22c35a8c 2984 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2985 pvop->op_pv = pv;
2986 pvop->op_next = (OP*)pvop;
eb160463 2987 pvop->op_flags = (U8)flags;
22c35a8c 2988 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2989 scalar((OP*)pvop);
22c35a8c 2990 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2991 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2992 return CHECKOP(type, pvop);
79072805
LW
2993}
2994
79072805 2995void
864dbfa3 2996Perl_package(pTHX_ OP *o)
79072805 2997{
6867be6d 2998 const char *name;
de11ba31 2999 STRLEN len;
79072805 3000
3280af22
NIS
3001 save_hptr(&PL_curstash);
3002 save_item(PL_curstname);
de11ba31
AMS
3003
3004 name = SvPV(cSVOPo->op_sv, len);
3005 PL_curstash = gv_stashpvn(name, len, TRUE);
3006 sv_setpvn(PL_curstname, name, len);
3007 op_free(o);
3008
7ad382f4 3009 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3010 PL_copline = NOLINE;
3011 PL_expect = XSTATE;
79072805
LW
3012}
3013
85e6fe83 3014void
88d95a4d 3015Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3016{
a0d0e21e 3017 OP *pack;
a0d0e21e 3018 OP *imop;
b1cb66bf 3019 OP *veop;
85e6fe83 3020
88d95a4d 3021 if (idop->op_type != OP_CONST)
cea2e8a9 3022 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3023
b1cb66bf 3024 veop = Nullop;
3025
0f79a09d 3026 if (version != Nullop) {
b1cb66bf 3027 SV *vesv = ((SVOP*)version)->op_sv;
3028
44dcb63b 3029 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3030 arg = version;
3031 }
3032 else {
3033 OP *pack;
0f79a09d 3034 SV *meth;
b1cb66bf 3035
44dcb63b 3036 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3037 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3038
88d95a4d
JH
3039 /* Make copy of idop so we don't free it twice */
3040 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3041
3042 /* Fake up a method call to VERSION */
0f79a09d
GS
3043 meth = newSVpvn("VERSION",7);
3044 sv_upgrade(meth, SVt_PVIV);
155aba94 3045 (void)SvIOK_on(meth);
4946a0fa
NC
3046 {
3047 U32 hash;
b15aece3 3048 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
4946a0fa
NC
3049 SvUV_set(meth, hash);
3050 }
b1cb66bf 3051 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3052 append_elem(OP_LIST,
0f79a09d
GS
3053 prepend_elem(OP_LIST, pack, list(version)),
3054 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3055 }
3056 }
aeea060c 3057
a0d0e21e 3058 /* Fake up an import/unimport */
4633a7c4
LW
3059 if (arg && arg->op_type == OP_STUB)
3060 imop = arg; /* no import on explicit () */
88d95a4d 3061 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf 3062 imop = Nullop; /* use 5.0; */
3063 }
4633a7c4 3064 else {
0f79a09d
GS
3065 SV *meth;
3066
88d95a4d
JH
3067 /* Make copy of idop so we don't free it twice */
3068 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS
3069
3070 /* Fake up a method call to import/unimport */
b47cad08 3071 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 3072 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3073 (void)SvIOK_on(meth);
4946a0fa
NC
3074 {
3075 U32 hash;
b15aece3 3076 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
4946a0fa
NC
3077 SvUV_set(meth, hash);
3078 }
4633a7c4 3079 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS
3080 append_elem(OP_LIST,
3081 prepend_elem(OP_LIST, pack, list(arg)),
3082 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW
3083 }
3084
a0d0e21e 3085 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3086 newATTRSUB(floor,
79cb57f6 3087 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3088 Nullop,
09bef843 3089 Nullop,
a0d0e21e 3090 append_elem(OP_LINESEQ,
b1cb66bf 3091 append_elem(OP_LINESEQ,
88d95a4d 3092 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 3093 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3094 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3095
70f5e4ed
JH
3096 /* The "did you use incorrect case?" warning used to be here.
3097 * The problem is that on case-insensitive filesystems one
3098 * might get false positives for "use" (and "require"):
3099 * "use Strict" or "require CARP" will work. This causes
3100 * portability problems for the script: in case-strict
3101 * filesystems the script will stop working.
3102 *
3103 * The "incorrect case" warning checked whether "use Foo"
3104 * imported "Foo" to your namespace, but that is wrong, too:
3105 * there is no requirement nor promise in the language that
3106 * a Foo.pm should or would contain anything in package "Foo".
3107 *
3108 * There is very little Configure-wise that can be done, either:
3109 * the case-sensitivity of the build filesystem of Perl does not
3110 * help in guessing the case-sensitivity of the runtime environment.
3111 */
18fc9488 3112
c305c6a0 3113 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3114 PL_copline = NOLINE;
3115 PL_expect = XSTATE;
8ec8fbef 3116 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW
3117}
3118
7d3fb230 3119/*
ccfc67b7
JH
3120=head1 Embedding Functions
3121
7d3fb230
BS
3122=for apidoc load_module
3123
3124Loads the module whose name is pointed to by the string part of name.
3125Note that the actual module name, not its filename, should be given.
3126Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3127PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3128(or 0 for no flags). ver, if specified, provides version semantics
3129similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3130arguments can be used to specify arguments to the module's import()
3131method, similar to C<use Foo::Bar VERSION LIST>.
3132
3133=cut */
3134
e4783991
GS
3135void
3136Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3137{
3138 va_list args;
3139 va_start(args, ver);
3140 vload_module(flags, name, ver, &args);
3141 va_end(args);
3142}
3143
3144#ifdef PERL_IMPLICIT_CONTEXT
3145void
3146Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3147{
3148 dTHX;
3149 va_list args;
3150 va_start(args, ver);
3151 vload_module(flags, name, ver, &args);
3152 va_end(args);
3153}
3154#endif
3155
3156void
3157Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3158{
3159 OP *modname, *veop, *imop;
3160
3161 modname = newSVOP(OP_CONST, 0, name);
3162 modname->op_private |= OPpCONST_BARE;
3163 if (ver) {
3164 veop = newSVOP(OP_CONST, 0, ver);
3165 }
3166 else
3167 veop = Nullop;
3168 if (flags & PERL_LOADMOD_NOIMPORT) {
3169 imop = sawparens(newNULLLIST());
3170 }
3171 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3172 imop = va_arg(*args, OP*);
3173 }
3174 else {
3175 SV *sv;
3176 imop = Nullop;
3177 sv = va_arg(*args, SV*);
3178 while (sv) {
3179 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3180 sv = va_arg(*args, SV*);
3181 }
3182 }
81885997 3183 {
6867be6d
AL
3184 const line_t ocopline = PL_copline;
3185 COP * const ocurcop = PL_curcop;
3186 const int oexpect = PL_expect;
81885997
GS
3187
3188 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3189 veop, modname, imop);
3190 PL_expect = oexpect;
3191 PL_copline = ocopline;
834a3ffa 3192 PL_curcop = ocurcop;
81885997 3193 }
e4783991
GS
3194}
3195
79072805 3196OP *
864dbfa3 3197Perl_dofile(pTHX_ OP *term)
78ca652e
GS
3198{
3199 OP *doop;
3200 GV *gv;
3201
3202 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3203 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS
3204 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3205
b9f751c0 3206 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS
3207 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3208 append_elem(OP_LIST, term,
3209 scalar(newUNOP(OP_RV2CV, 0,
3210 newGVOP(OP_GV, 0,
3211 gv))))));
3212 }
3213 else {
3214 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3215 }
3216 return doop;
3217}
3218
3219OP *
864dbfa3 3220Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW
3221{
3222 return newBINOP(OP_LSLICE, flags,
8990e307
LW
3223 list(force_list(subscript)),
3224 list(force_list(listval)) );
79072805
LW
3225}
3226
76e3520e 3227STATIC I32
504618e9 3228S_is_list_assignment(pTHX_ register const OP *o)
79072805 3229{
11343788 3230 if (!o)
79072805
LW
3231 return TRUE;
3232
11343788
MB
3233 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3234 o = cUNOPo->op_first;
79072805 3235
11343788 3236 if (o->op_type == OP_COND_EXPR) {
504618e9
AL
3237 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3238 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW
3239
3240 if (t && f)
3241 return TRUE;
3242 if (t || f)
3243 yyerror("Assignment to both a list and a scalar");
3244 return FALSE;
3245 }
3246
95f0a2f1
SB
3247 if (o->op_type == OP_LIST &&
3248 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3249 o->op_private & OPpLVAL_INTRO)
3250 return FALSE;
3251
11343788
MB
3252 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3253 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3254 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW
3255 return TRUE;
3256
11343788 3257 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW
3258 return TRUE;
3259
11343788 3260 if (o->op_type == OP_RV2SV)
79072805
LW
3261 return FALSE;
3262
3263 return FALSE;
3264}
3265
3266OP *
864dbfa3 3267Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3268{
11343788 3269 OP *o;
79072805 3270
a0d0e21e 3271 if (optype) {
c963b151 3272 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW
3273 return newLOGOP(optype, 0,
3274 mod(scalar(left), optype),
3275 newUNOP(OP_SASSIGN, 0, scalar(right)));
3276 }
3277 else {
3278 return newBINOP(optype, OPf_STACKED,
3279 mod(scalar(left), optype), scalar(right));
3280 }
3281 }
3282
504618e9 3283 if (is_list_assignment(left)) {
10c8fecd
GS
3284 OP *curop;
3285
3280af22
NIS
3286 PL_modcount = 0;
3287 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3288 left = mod(left, OP_AASSIGN);
3280af22
NIS
3289 if (PL_eval_start)
3290 PL_eval_start = 0;
748a9306 3291 else {
a0d0e21e
LW
3292 op_free(left);
3293 op_free(right);
3294 return Nullop;
3295 }
b9d46b39
RGS
3296 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3297 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3298 && right->op_type == OP_STUB
3299 && (left->op_private & OPpLVAL_INTRO))
3300 {
3301 op_free(right);
9ff53bc9 3302 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
b9d46b39
RGS
3303 return left;
3304 }
10c8fecd
GS
3305 curop = list(force_list(left));
3306 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3307 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM
3308
3309 /* PL_generation sorcery:
3310 * an assignment like ($a,$b) = ($c,$d) is easier than
3311 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3312 * To detect whether there are common vars, the global var
3313 * PL_generation is incremented for each assign op we compile.
3314 * Then, while compiling the assign op, we run through all the
3315 * variables on both sides of the assignment, setting a spare slot
3316 * in each of them to PL_generation. If any of them already have
3317 * that value, we know we've got commonality. We could use a
3318 * single bit marker, but then we'd have to make 2 passes, first
3319 * to clear the flag, then to test and set it. To find somewhere
3320 * to store these values, evil chicanery is done with SvCUR().
3321 */
3322
a0d0e21e 3323 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3324 OP *lastop = o;
3280af22 3325 PL_generation++;
11343788 3326 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3327 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3328 if (curop->op_type == OP_GV) {
638eceb6 3329 GV *gv = cGVOPx_gv(curop);
eb160463 3330 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3331 break;
b162af07 3332 SvCUR_set(gv, PL_generation);
79072805 3333 }
748a9306
LW
3334 else if (curop->op_type == OP_PADSV ||
3335 curop->op_type == OP_PADAV ||
3336 curop->op_type == OP_PADHV ||
dd2155a4
DM
3337 curop->op_type == OP_PADANY)
3338 {
3339 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3340 == (STRLEN)PL_generation)
748a9306 3341 break;
b162af07 3342 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 3343
748a9306 3344 }
79072805
LW
3345 else if (curop->op_type == OP_RV2CV)
3346 break;
3347 else if (curop->op_type == OP_RV2SV ||
3348 curop->op_type == OP_RV2AV ||
3349 curop->op_type == OP_RV2HV ||
3350 curop->op_type == OP_RV2GV) {
3351 if (lastop->op_type != OP_GV) /* funny deref? */
3352 break;
3353 }
1167e5da
SM
3354 else if (curop->op_type == OP_PUSHRE) {
3355 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3356#ifdef USE_ITHREADS
dd2155a4
DM
3357 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3358 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3359#else
1167e5da 3360 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3361#endif
eb160463 3362 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3363 break;
b162af07 3364 SvCUR_set(gv, PL_generation);
b2ffa427 3365 }
1167e5da 3366 }
79072805
LW
3367 else
3368 break;
3369 }
3370 lastop = curop;
3371 }
11343788 3372 if (curop != o)
10c8fecd 3373 o->op_private |= OPpASSIGN_COMMON;
79072805 3374 }
c07a80fd 3375 if (right && right->op_type == OP_SPLIT) {
3376 OP* tmpop;
3377 if ((tmpop = ((LISTOP*)right)->op_first) &&
3378 tmpop->op_type == OP_PUSHRE)
3379 {
3380 PMOP *pm = (PMOP*)tmpop;
3381 if (left->op_type == OP_RV2AV &&
3382 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3383 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3384 {
3385 tmpop = ((UNOP*)left)->op_first;
3386 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3387#ifdef USE_ITHREADS
ba89bb6e 3388 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS
3389 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3390#else
3391 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3392 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3393#endif
c07a80fd 3394 pm->op_pmflags |= PMf_ONCE;
11343788 3395 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3396 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3397 tmpop->op_sibling = Nullop; /* don't free split */
3398 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3399 op_free(o); /* blow off assign */
54310121 3400 right->op_flags &= ~OPf_WANT;
a5f75d66 3401 /* "I don't know and I don't care." */
c07a80fd 3402 return right;
3403 }
3404 }
3405 else {
e6438c1a 3406 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3407 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3408 {
3409 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3410 if (SvIVX(sv) == 0)
3280af22 3411 sv_setiv(sv, PL_modcount+1);
c07a80fd 3412 }
3413 }
3414 }
3415 }
11343788 3416 return o;
79072805
LW
3417 }
3418 if (!right)
3419 right = newOP(OP_UNDEF, 0);
3420 if (right->op_type == OP_READLINE) {
3421 right->op_flags |= OPf_STACKED;
463ee0b2 3422 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3423 }
a0d0e21e 3424 else {
3280af22 3425 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3426 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3427 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS
3428 if (PL_eval_start)
3429 PL_eval_start = 0;
748a9306 3430 else {
11343788 3431 op_free(o);
a0d0e21e
LW
3432 return Nullop;
3433 }
3434 }
11343788 3435 return o;
79072805
LW
3436}
3437
3438OP *
864dbfa3 3439Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3440{
27da23d5 3441 dVAR;
e1ec3a88 3442 const U32 seq = intro_my();
79072805
LW
3443 register COP *cop;
3444
b7dc083c 3445 NewOp(1101, cop, 1, COP);
57843af0 3446 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3447 cop->op_type = OP_DBSTATE;
22c35a8c 3448 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW
3449 }
3450 else {
3451 cop->op_type = OP_NEXTSTATE;
22c35a8c 3452 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3453 }
eb160463
GS
3454 cop->op_flags = (U8)flags;
3455 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3456#ifdef NATIVE_HINTS
3457 cop->op_private |= NATIVE_HINTS;
3458#endif
e24b16f9 3459 PL_compiling.op_private = cop->op_private;
79072805
LW
3460 cop->op_next = (OP*)cop;
3461
463ee0b2
LW
3462 if (label) {
3463 cop->cop_label = label;
3280af22 3464 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3465 }
bbce6d69 3466 cop->cop_seq = seq;
3280af22 3467 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3468 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3469 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3470 else
599cee73 3471 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS
3472 if (specialCopIO(PL_curcop->cop_io))
3473 cop->cop_io = PL_curcop->cop_io;
3474 else
3475 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3476
79072805 3477
3280af22 3478 if (PL_copline == NOLINE)
57843af0 3479 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3480 else {
57843af0 3481 CopLINE_set(cop, PL_copline);
3280af22 3482 PL_copline = NOLINE;
79072805 3483 }
57843af0 3484#ifdef USE_ITHREADS
f4dd75d9 3485 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3486#else
f4dd75d9 3487 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3488#endif
11faa288 3489 CopSTASH_set(cop, PL_curstash);
79072805 3490
3280af22 3491 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3492 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3493 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3494 (void)SvIOK_on(*svp);
45977657 3495 SvIV_set(*svp, PTR2IV(cop));
1eb1540c 3496 }
93a17b20
LW
3497 }
3498
722969e2 3499 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW
3500}
3501
bbce6d69 3502
79072805 3503OP *
864dbfa3 3504Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3505{
27da23d5 3506 dVAR;
883ffac3
CS
3507 return new_logop(type, flags, &first, &other);
3508}
3509
3bd495df 3510STATIC OP *
cea2e8a9 3511S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3512{
27da23d5 3513 dVAR;
79072805 3514 LOGOP *logop;
11343788