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