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