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