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