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