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