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