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