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