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
EU::MM::MM_VMS::one_liner must quote "--" argument
[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
RGS		 818 if (o->op_private & OPpCONST_ARYBASE)
819 useless = 0;
e7fec78e 820 /* don't warn on optimised away booleans, eg
b5a930ec 821 * use constant Foo, 5; Foo || print; */
e7fec78e
DM		 822 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
823 useless = 0;
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))
d008e5eb
GS		 828 useless = 0;
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))
d008e5eb
GS		 840 useless = 0;
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
SP		 1748 type = o->op_type;
1749
eb8433b7
NC		 1750 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1751 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1752 return o;
1753 }
1754
93a17b20 1755 if (type == OP_LIST) {
6867be6d 1756 OP *kid;
11343788 1757 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1758 my_kid(kid, attrs, imopsp);
eb8433b7
NC		 1759 } else if (type == OP_UNDEF
1760#ifdef PERL_MAD
1761 || type == OP_STUB
1762#endif
1763 ) {
7766148a 1764 return o;
77ca0c92
LW		 1765 } else if (type == OP_RV2SV || /* "our" declaration */
1766 type == OP_RV2AV ||
1767 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS		 1768 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1769 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1770 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1771 } else if (attrs) {
551405c4 1772 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1ce0b88c 1773 PL_in_my = FALSE;
5c284bb0 1774 PL_in_my_stash = NULL;
1ce0b88c
RGS		 1775 apply_attrs(GvSTASH(gv),
1776 (type == OP_RV2SV ? GvSV(gv) :
1777 type == OP_RV2AV ? (SV*)GvAV(gv) :
1778 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1779 attrs, FALSE);
1780 }
192587c2 1781 o->op_private |= OPpOUR_INTRO;
77ca0c92 1782 return o;
95f0a2f1
SB		 1783 }
1784 else if (type != OP_PADSV &&
93a17b20
LW		 1785 type != OP_PADAV &&
1786 type != OP_PADHV &&
1787 type != OP_PUSHMARK)
1788 {
eb64745e 1789 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1790 OP_DESC(o),
eb64745e 1791 PL_in_my == KEY_our ? "our" : "my"));
11343788 1792 return o;
93a17b20 1793 }
09bef843
SB		 1794 else if (attrs && type != OP_PUSHMARK) {
1795 HV *stash;
09bef843 1796
eb64745e 1797 PL_in_my = FALSE;
5c284bb0 1798 PL_in_my_stash = NULL;
eb64745e 1799
09bef843 1800 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1801 stash = PAD_COMPNAME_TYPE(o->op_targ);
1802 if (!stash)
09bef843 1803 stash = PL_curstash;
95f0a2f1 1804 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1805 }
11343788
MB		 1806 o->op_flags |= OPf_MOD;
1807 o->op_private |= OPpLVAL_INTRO;
1808 return o;
93a17b20
LW		 1809}
1810
1811OP *
09bef843
SB		 1812Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1813{
97aff369 1814 dVAR;
0bd48802 1815 OP *rops;
95f0a2f1
SB		 1816 int maybe_scalar = 0;
1817
d2be0de5 1818/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1819 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1820#if 0
09bef843
SB		 1821 if (o->op_flags & OPf_PARENS)
1822 list(o);
95f0a2f1
SB		 1823 else
1824 maybe_scalar = 1;
d2be0de5
YST		 1825#else
1826 maybe_scalar = 1;
1827#endif
09bef843
SB		 1828 if (attrs)
1829 SAVEFREEOP(attrs);
5f66b61c 1830 rops = NULL;
95f0a2f1
SB		 1831 o = my_kid(o, attrs, &rops);
1832 if (rops) {
1833 if (maybe_scalar && o->op_type == OP_PADSV) {
1834 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1835 o->op_private |= OPpLVAL_INTRO;
1836 }
1837 else
1838 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1839 }
eb64745e 1840 PL_in_my = FALSE;
5c284bb0 1841 PL_in_my_stash = NULL;
eb64745e 1842 return o;
09bef843
SB		 1843}
1844
1845OP *
1846Perl_my(pTHX_ OP *o)
1847{
5f66b61c 1848 return my_attrs(o, NULL);
09bef843
SB		 1849}
1850
1851OP *
864dbfa3 1852Perl_sawparens(pTHX_ OP *o)
79072805 1853{
96a5add6 1854 PERL_UNUSED_CONTEXT;
79072805
LW		 1855 if (o)
1856 o->op_flags |= OPf_PARENS;
1857 return o;
1858}
1859
1860OP *
864dbfa3 1861Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1862{
11343788 1863 OP *o;
59f00321 1864 bool ismatchop = 0;
79072805 1865
041457d9 1866 if ( (left->op_type == OP_RV2AV ||
599cee73
PM		 1867 left->op_type == OP_RV2HV ||
1868 left->op_type == OP_PADAV ||
041457d9
DM		 1869 left->op_type == OP_PADHV)
1870 && ckWARN(WARN_MISC))
1871 {
551405c4 1872 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 1873 right->op_type == OP_TRANS)
1874 ? right->op_type : OP_MATCH];
551405c4 1875 const char * const sample = ((left->op_type == OP_RV2AV ||
dff6d3cd
GS		 1876 left->op_type == OP_PADAV)
1877 ? "@array" : "%hash");
9014280d 1878 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1879 "Applying %s to %s will act on scalar(%s)",
599cee73 1880 desc, sample, sample);
2ae324a7 1881 }
1882
5cc9e5c9
RH		 1883 if (right->op_type == OP_CONST &&
1884 cSVOPx(right)->op_private & OPpCONST_BARE &&
1885 cSVOPx(right)->op_private & OPpCONST_STRICT)
1886 {
1887 no_bareword_allowed(right);
1888 }
1889
59f00321
RGS		 1890 ismatchop = right->op_type == OP_MATCH ||
1891 right->op_type == OP_SUBST ||
1892 right->op_type == OP_TRANS;
1893 if (ismatchop && right->op_private & OPpTARGET_MY) {
1894 right->op_targ = 0;
1895 right->op_private &= ~OPpTARGET_MY;
1896 }
1897 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1898 right->op_flags |= OPf_STACKED;
6fbb66d6
NC		 1899 if (right->op_type != OP_MATCH &&
1900 ! (right->op_type == OP_TRANS &&
1901 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1902 left = mod(left, right->op_type);
79072805 1903 if (right->op_type == OP_TRANS)
11343788 1904 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1905 else
11343788 1906 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1907 if (type == OP_NOT)
11343788
MB		 1908 return newUNOP(OP_NOT, 0, scalar(o));
1909 return o;
79072805
LW		 1910 }
1911 else
1912 return bind_match(type, left,
131b3ad0 1913 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 1914}
1915
1916OP *
864dbfa3 1917Perl_invert(pTHX_ OP *o)
79072805 1918{
11343788 1919 if (!o)
1d866c12 1920 return NULL;
11343788 1921 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1922}
1923
1924OP *
864dbfa3 1925Perl_scope(pTHX_ OP *o)
79072805 1926{
27da23d5 1927 dVAR;
79072805 1928 if (o) {
3280af22 1929 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1930 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1931 o->op_type = OP_LEAVE;
22c35a8c 1932 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1933 }
fdb22418
HS		 1934 else if (o->op_type == OP_LINESEQ) {
1935 OP *kid;
1936 o->op_type = OP_SCOPE;
1937 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1938 kid = ((LISTOP*)o)->op_first;
59110972 1939 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 1940 op_null(kid);
59110972
RH		 1941
1942 /* The following deals with things like 'do {1 for 1}' */
1943 kid = kid->op_sibling;
1944 if (kid &&
1945 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1946 op_null(kid);
1947 }
463ee0b2 1948 }
fdb22418 1949 else
5f66b61c 1950 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 1951 }
1952 return o;
1953}
1954
a0d0e21e 1955int
864dbfa3 1956Perl_block_start(pTHX_ int full)
79072805 1957{
97aff369 1958 dVAR;
73d840c0 1959 const int retval = PL_savestack_ix;
dd2155a4 1960 pad_block_start(full);
b3ac6de7 1961 SAVEHINTS();
3280af22 1962 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1963 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1964 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 1965 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1966 SAVEFREESV(PL_compiling.cop_warnings) ;
1967 }
ac27b0f5
NIS		 1968 SAVESPTR(PL_compiling.cop_io);
1969 if (! specialCopIO(PL_compiling.cop_io)) {
1970 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1971 SAVEFREESV(PL_compiling.cop_io) ;
1972 }
a0d0e21e
LW		 1973 return retval;
1974}
1975
1976OP*
864dbfa3 1977Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1978{
97aff369 1979 dVAR;
6867be6d 1980 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 1981 OP* const retval = scalarseq(seq);
e9818f4e 1982 LEAVE_SCOPE(floor);
eb160463 1983 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1984 if (needblockscope)
3280af22 1985 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1986 pad_leavemy();
a0d0e21e
LW		 1987 return retval;
1988}
1989
76e3520e 1990STATIC OP *
cea2e8a9 1991S_newDEFSVOP(pTHX)
54b9620d 1992{
97aff369 1993 dVAR;
6867be6d 1994 const I32 offset = pad_findmy("$_");
00b1698f 1995 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 1996 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1997 }
1998 else {
551405c4 1999 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2000 o->op_targ = offset;
2001 return o;
2002 }
54b9620d
MB		 2003}
2004
a0d0e21e 2005void
864dbfa3 2006Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2007{
97aff369 2008 dVAR;
3280af22 2009 if (PL_in_eval) {
b295d113
TH		 2010 if (PL_eval_root)
2011 return;
faef0170
HS		 2012 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2013 ((PL_in_eval & EVAL_KEEPERR)
2014 ? OPf_SPECIAL : 0), o);
3280af22 2015 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2016 PL_eval_root->op_private |= OPpREFCOUNTED;
2017 OpREFCNT_set(PL_eval_root, 1);
3280af22 2018 PL_eval_root->op_next = 0;
a2efc822 2019 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2020 }
2021 else {
6be89cf9
AE		 2022 if (o->op_type == OP_STUB) {
2023 PL_comppad_name = 0;
2024 PL_compcv = 0;
2a4f803a 2025 FreeOp(o);
a0d0e21e 2026 return;
6be89cf9 2027 }
3280af22
NIS		 2028 PL_main_root = scope(sawparens(scalarvoid(o)));
2029 PL_curcop = &PL_compiling;
2030 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2031 PL_main_root->op_private |= OPpREFCOUNTED;
2032 OpREFCNT_set(PL_main_root, 1);
3280af22 2033 PL_main_root->op_next = 0;
a2efc822 2034 CALL_PEEP(PL_main_start);
3280af22 2035 PL_compcv = 0;
3841441e 2036
4fdae800 2037 /* Register with debugger */
84902520 2038 if (PERLDB_INTER) {
551405c4 2039 CV * const cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 2040 if (cv) {
2041 dSP;
924508f0 2042 PUSHMARK(SP);
cc49e20b 2043 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2044 PUTBACK;
864dbfa3 2045 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2046 }
2047 }
79072805 2048 }
79072805
LW		 2049}
2050
2051OP *
864dbfa3 2052Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2053{
97aff369 2054 dVAR;
79072805 2055 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2056/* [perl #17376]: this appears to be premature, and results in code such as
2057 C< our(%x); > executing in list mode rather than void mode */
2058#if 0
79072805 2059 list(o);
d2be0de5 2060#else
bb263b4e 2061 /*EMPTY*/;
d2be0de5 2062#endif
8990e307 2063 else {
041457d9
DM		 2064 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2065 && ckWARN(WARN_PARENTHESIS))
64420d0d
JH		 2066 {
2067 char *s = PL_bufptr;
bac662ee 2068 bool sigil = FALSE;
64420d0d 2069
8473848f 2070 /* some heuristics to detect a potential error */
bac662ee 2071 while (*s && (strchr(", \t\n", *s)))
64420d0d 2072 s++;
8473848f 2073
bac662ee
TS		 2074 while (1) {
2075 if (*s && strchr("@$%*", *s) && *++s
2076 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2077 s++;
2078 sigil = TRUE;
2079 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2080 s++;
2081 while (*s && (strchr(", \t\n", *s)))
2082 s++;
2083 }
2084 else
2085 break;
2086 }
2087 if (sigil && (*s == ';' || *s == '=')) {
2088 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS		 2089 "Parentheses missing around \"%s\" list",
2090 lex ? (PL_in_my == KEY_our ? "our" : "my")
2091 : "local");
2092 }
8990e307
LW		 2093 }
2094 }
93a17b20 2095 if (lex)
eb64745e 2096 o = my(o);
93a17b20 2097 else
eb64745e
GS		 2098 o = mod(o, OP_NULL); /* a bit kludgey */
2099 PL_in_my = FALSE;
5c284bb0 2100 PL_in_my_stash = NULL;
eb64745e 2101 return o;
79072805
LW		 2102}
2103
2104OP *
864dbfa3 2105Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2106{
2107 if (o->op_type == OP_LIST) {
fafc274c
NC		 2108 OP * const o2
2109 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2110 SVt_PV)));
554b3eca 2111 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2112 }
2113 return o;
2114}
2115
2116OP *
864dbfa3 2117Perl_fold_constants(pTHX_ register OP *o)
79072805 2118{
27da23d5 2119 dVAR;
79072805 2120 register OP *curop;
eb8433b7 2121 OP *newop;
79072805 2122 I32 type = o->op_type;
748a9306 2123 SV *sv;
79072805 2124
22c35a8c 2125 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2126 scalar(o);
b162f9ea 2127 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2128 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2129
eac055e9
GS		 2130 /* integerize op, unless it happens to be C<-foo>.
2131 * XXX should pp_i_negate() do magic string negation instead? */
2132 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2133 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2134 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2135 {
22c35a8c 2136 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2137 }
85e6fe83 2138
22c35a8c 2139 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2140 goto nope;
2141
de939608 2142 switch (type) {
7a52d87a
GS		 2143 case OP_NEGATE:
2144 /* XXX might want a ck_negate() for this */
2145 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2146 break;
de939608
CS		 2147 case OP_UCFIRST:
2148 case OP_LCFIRST:
2149 case OP_UC:
2150 case OP_LC:
69dcf70c
MB		 2151 case OP_SLT:
2152 case OP_SGT:
2153 case OP_SLE:
2154 case OP_SGE:
2155 case OP_SCMP:
2de3dbcc
JH		 2156 /* XXX what about the numeric ops? */
2157 if (PL_hints & HINT_LOCALE)
de939608
CS		 2158 goto nope;
2159 }
2160
3280af22 2161 if (PL_error_count)
a0d0e21e
LW		 2162 goto nope; /* Don't try to run w/ errors */
2163
79072805 2164 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 2165 if ((curop->op_type != OP_CONST ||
2166 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 2167 curop->op_type != OP_LIST &&
2168 curop->op_type != OP_SCALAR &&
2169 curop->op_type != OP_NULL &&
2170 curop->op_type != OP_PUSHMARK)
2171 {
79072805
LW		 2172 goto nope;
2173 }
2174 }
2175
2176 curop = LINKLIST(o);
2177 o->op_next = 0;
533c011a 2178 PL_op = curop;
cea2e8a9 2179 CALLRUNOPS(aTHX);
3280af22 2180 sv = *(PL_stack_sp--);
748a9306 2181 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 2182 pad_swipe(o->op_targ, FALSE);
748a9306 2183 else if (SvTEMP(sv)) { /* grab mortal temp? */
b37c2d43 2184 SvREFCNT_inc_simple_void(sv);
748a9306 2185 SvTEMP_off(sv);
85e6fe83 2186 }
eb8433b7
NC		 2187
2188#ifndef PERL_MAD
79072805 2189 op_free(o);
eb8433b7 2190#endif
79072805 2191 if (type == OP_RV2GV)
eb8433b7
NC		 2192 newop = newGVOP(OP_GV, 0, (GV*)sv);
2193 else
2194 newop = newSVOP(OP_CONST, 0, sv);
2195 op_getmad(o,newop,'f');
2196 return newop;
aeea060c 2197
79072805 2198 nope:
79072805
LW		 2199 return o;
2200}
2201
2202OP *
864dbfa3 2203Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2204{
27da23d5 2205 dVAR;
79072805 2206 register OP *curop;
6867be6d 2207 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2208
a0d0e21e 2209 list(o);
3280af22 2210 if (PL_error_count)
a0d0e21e
LW		 2211 return o; /* Don't attempt to run with errors */
2212
533c011a 2213 PL_op = curop = LINKLIST(o);
a0d0e21e 2214 o->op_next = 0;
a2efc822 2215 CALL_PEEP(curop);
cea2e8a9
GS		 2216 pp_pushmark();
2217 CALLRUNOPS(aTHX);
533c011a 2218 PL_op = curop;
cea2e8a9 2219 pp_anonlist();
3280af22 2220 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2221
2222 o->op_type = OP_RV2AV;
22c35a8c 2223 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2224 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2225 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2226 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2227 curop = ((UNOP*)o)->op_first;
b37c2d43 2228 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2229#ifdef PERL_MAD
2230 op_getmad(curop,o,'O');
2231#else
79072805 2232 op_free(curop);
eb8433b7 2233#endif
79072805
LW		 2234 linklist(o);
2235 return list(o);
2236}
2237
2238OP *
864dbfa3 2239Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2240{
27da23d5 2241 dVAR;
11343788 2242 if (!o || o->op_type != OP_LIST)
5f66b61c 2243 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2244 else
5dc0d613 2245 o->op_flags &= ~OPf_WANT;
79072805 2246
22c35a8c 2247 if (!(PL_opargs[type] & OA_MARK))
93c66552 2248 op_null(cLISTOPo->op_first);
8990e307 2249
eb160463 2250 o->op_type = (OPCODE)type;
22c35a8c 2251 o->op_ppaddr = PL_ppaddr[type];
11343788 2252 o->op_flags |= flags;
79072805 2253
11343788 2254 o = CHECKOP(type, o);
fe2774ed 2255 if (o->op_type != (unsigned)type)
11343788 2256 return o;
79072805 2257
11343788 2258 return fold_constants(o);
79072805
LW		 2259}
2260
2261/* List constructors */
2262
2263OP *
864dbfa3 2264Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2265{
2266 if (!first)
2267 return last;
8990e307
LW		 2268
2269 if (!last)
79072805 2270 return first;
8990e307 2271
fe2774ed 2272 if (first->op_type != (unsigned)type
155aba94
GS		 2273 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2274 {
2275 return newLISTOP(type, 0, first, last);
2276 }
79072805 2277
a0d0e21e
LW		 2278 if (first->op_flags & OPf_KIDS)
2279 ((LISTOP*)first)->op_last->op_sibling = last;
2280 else {
2281 first->op_flags |= OPf_KIDS;
2282 ((LISTOP*)first)->op_first = last;
2283 }
2284 ((LISTOP*)first)->op_last = last;
a0d0e21e 2285 return first;
79072805
LW		 2286}
2287
2288OP *
864dbfa3 2289Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2290{
2291 if (!first)
2292 return (OP*)last;
8990e307
LW		 2293
2294 if (!last)
79072805 2295 return (OP*)first;
8990e307 2296
fe2774ed 2297 if (first->op_type != (unsigned)type)
79072805 2298 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2299
fe2774ed 2300 if (last->op_type != (unsigned)type)
79072805
LW		 2301 return append_elem(type, (OP*)first, (OP*)last);
2302
2303 first->op_last->op_sibling = last->op_first;
2304 first->op_last = last->op_last;
117dada2 2305 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2306
eb8433b7
NC		 2307#ifdef PERL_MAD
2308 if (last->op_first && first->op_madprop) {
2309 MADPROP *mp = last->op_first->op_madprop;
2310 if (mp) {
2311 while (mp->mad_next)
2312 mp = mp->mad_next;
2313 mp->mad_next = first->op_madprop;
2314 }
2315 else {
2316 last->op_first->op_madprop = first->op_madprop;
2317 }
2318 }
2319 first->op_madprop = last->op_madprop;
2320 last->op_madprop = 0;
2321#endif
2322
238a4c30
NIS		 2323 FreeOp(last);
2324
79072805
LW		 2325 return (OP*)first;
2326}
2327
2328OP *
864dbfa3 2329Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2330{
2331 if (!first)
2332 return last;
8990e307
LW		 2333
2334 if (!last)
79072805 2335 return first;
8990e307 2336
fe2774ed 2337 if (last->op_type == (unsigned)type) {
8990e307
LW		 2338 if (type == OP_LIST) { /* already a PUSHMARK there */
2339 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2340 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2341 if (!(first->op_flags & OPf_PARENS))
2342 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2343 }
2344 else {
2345 if (!(last->op_flags & OPf_KIDS)) {
2346 ((LISTOP*)last)->op_last = first;
2347 last->op_flags |= OPf_KIDS;
2348 }
2349 first->op_sibling = ((LISTOP*)last)->op_first;
2350 ((LISTOP*)last)->op_first = first;
79072805 2351 }
117dada2 2352 last->op_flags |= OPf_KIDS;
79072805
LW		 2353 return last;
2354 }
2355
2356 return newLISTOP(type, 0, first, last);
2357}
2358
2359/* Constructors */
2360
eb8433b7
NC		 2361#ifdef PERL_MAD
2362
2363TOKEN *
2364Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2365{
2366 TOKEN *tk;
99129197 2367 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2368 tk->tk_type = (OPCODE)optype;
2369 tk->tk_type = 12345;
2370 tk->tk_lval = lval;
2371 tk->tk_mad = madprop;
2372 return tk;
2373}
2374
2375void
2376Perl_token_free(pTHX_ TOKEN* tk)
2377{
2378 if (tk->tk_type != 12345)
2379 return;
2380 mad_free(tk->tk_mad);
2381 Safefree(tk);
2382}
2383
2384void
2385Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2386{
2387 MADPROP* mp;
2388 MADPROP* tm;
2389 if (tk->tk_type != 12345) {
2390 Perl_warner(aTHX_ packWARN(WARN_MISC),
2391 "Invalid TOKEN object ignored");
2392 return;
2393 }
2394 tm = tk->tk_mad;
2395 if (!tm)
2396 return;
2397
2398 /* faked up qw list? */
2399 if (slot == '(' &&
2400 tm->mad_type == MAD_SV &&
2401 SvPVX((SV*)tm->mad_val)[0] == 'q')
2402 slot = 'x';
2403
2404 if (o) {
2405 mp = o->op_madprop;
2406 if (mp) {
2407 for (;;) {
2408 /* pretend constant fold didn't happen? */
2409 if (mp->mad_key == 'f' &&
2410 (o->op_type == OP_CONST ||
2411 o->op_type == OP_GV) )
2412 {
2413 token_getmad(tk,(OP*)mp->mad_val,slot);
2414 return;
2415 }
2416 if (!mp->mad_next)
2417 break;
2418 mp = mp->mad_next;
2419 }
2420 mp->mad_next = tm;
2421 mp = mp->mad_next;
2422 }
2423 else {
2424 o->op_madprop = tm;
2425 mp = o->op_madprop;
2426 }
2427 if (mp->mad_key == 'X')
2428 mp->mad_key = slot; /* just change the first one */
2429
2430 tk->tk_mad = 0;
2431 }
2432 else
2433 mad_free(tm);
2434 Safefree(tk);
2435}
2436
2437void
2438Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2439{
2440 MADPROP* mp;
2441 if (!from)
2442 return;
2443 if (o) {
2444 mp = o->op_madprop;
2445 if (mp) {
2446 for (;;) {
2447 /* pretend constant fold didn't happen? */
2448 if (mp->mad_key == 'f' &&
2449 (o->op_type == OP_CONST ||
2450 o->op_type == OP_GV) )
2451 {
2452 op_getmad(from,(OP*)mp->mad_val,slot);
2453 return;
2454 }
2455 if (!mp->mad_next)
2456 break;
2457 mp = mp->mad_next;
2458 }
2459 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2460 }
2461 else {
2462 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2463 }
2464 }
2465}
2466
2467void
2468Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2469{
2470 MADPROP* mp;
2471 if (!from)
2472 return;
2473 if (o) {
2474 mp = o->op_madprop;
2475 if (mp) {
2476 for (;;) {
2477 /* pretend constant fold didn't happen? */
2478 if (mp->mad_key == 'f' &&
2479 (o->op_type == OP_CONST ||
2480 o->op_type == OP_GV) )
2481 {
2482 op_getmad(from,(OP*)mp->mad_val,slot);
2483 return;
2484 }
2485 if (!mp->mad_next)
2486 break;
2487 mp = mp->mad_next;
2488 }
2489 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2490 }
2491 else {
2492 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2493 }
2494 }
2495 else {
99129197
NC		 2496 PerlIO_printf(PerlIO_stderr(),
2497 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2498 op_free(from);
2499 }
2500}
2501
2502void
2503Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2504{
2505 MADPROP* tm;
2506 if (!mp || !o)
2507 return;
2508 if (slot)
2509 mp->mad_key = slot;
2510 tm = o->op_madprop;
2511 o->op_madprop = mp;
2512 for (;;) {
2513 if (!mp->mad_next)
2514 break;
2515 mp = mp->mad_next;
2516 }
2517 mp->mad_next = tm;
2518}
2519
2520void
2521Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2522{
2523 if (!o)
2524 return;
2525 addmad(tm, &(o->op_madprop), slot);
2526}
2527
2528void
2529Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2530{
2531 MADPROP* mp;
2532 if (!tm || !root)
2533 return;
2534 if (slot)
2535 tm->mad_key = slot;
2536 mp = *root;
2537 if (!mp) {
2538 *root = tm;
2539 return;
2540 }
2541 for (;;) {
2542 if (!mp->mad_next)
2543 break;
2544 mp = mp->mad_next;
2545 }
2546 mp->mad_next = tm;
2547}
2548
2549MADPROP *
2550Perl_newMADsv(pTHX_ char key, SV* sv)
2551{
2552 return newMADPROP(key, MAD_SV, sv, 0);
2553}
2554
2555MADPROP *
2556Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2557{
2558 MADPROP *mp;
99129197 2559 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 2560 mp->mad_next = 0;
2561 mp->mad_key = key;
2562 mp->mad_vlen = vlen;
2563 mp->mad_type = type;
2564 mp->mad_val = val;
2565/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2566 return mp;
2567}
2568
2569void
2570Perl_mad_free(pTHX_ MADPROP* mp)
2571{
2572/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2573 if (!mp)
2574 return;
2575 if (mp->mad_next)
2576 mad_free(mp->mad_next);
2577/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2578 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2579 switch (mp->mad_type) {
2580 case MAD_NULL:
2581 break;
2582 case MAD_PV:
2583 Safefree((char*)mp->mad_val);
2584 break;
2585 case MAD_OP:
2586 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2587 op_free((OP*)mp->mad_val);
2588 break;
2589 case MAD_SV:
2590 sv_free((SV*)mp->mad_val);
2591 break;
2592 default:
2593 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2594 break;
2595 }
2596 Safefree(mp);
2597}
2598
2599#endif
2600
79072805 2601OP *
864dbfa3 2602Perl_newNULLLIST(pTHX)
79072805 2603{
8990e307
LW		 2604 return newOP(OP_STUB, 0);
2605}
2606
2607OP *
864dbfa3 2608Perl_force_list(pTHX_ OP *o)
8990e307 2609{
11343788 2610 if (!o || o->op_type != OP_LIST)
5f66b61c 2611 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2612 op_null(o);
11343788 2613 return o;
79072805
LW		 2614}
2615
2616OP *
864dbfa3 2617Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2618{
27da23d5 2619 dVAR;
79072805
LW		 2620 LISTOP *listop;
2621
b7dc083c 2622 NewOp(1101, listop, 1, LISTOP);
79072805 2623
eb160463 2624 listop->op_type = (OPCODE)type;
22c35a8c 2625 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2626 if (first || last)
2627 flags |= OPf_KIDS;
eb160463 2628 listop->op_flags = (U8)flags;
79072805
LW		 2629
2630 if (!last && first)
2631 last = first;
2632 else if (!first && last)
2633 first = last;
8990e307
LW		 2634 else if (first)
2635 first->op_sibling = last;
79072805
LW		 2636 listop->op_first = first;
2637 listop->op_last = last;
8990e307 2638 if (type == OP_LIST) {
551405c4 2639 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2640 pushop->op_sibling = first;
2641 listop->op_first = pushop;
2642 listop->op_flags |= OPf_KIDS;
2643 if (!last)
2644 listop->op_last = pushop;
2645 }
79072805 2646
463d09e6 2647 return CHECKOP(type, listop);
79072805
LW		 2648}
2649
2650OP *
864dbfa3 2651Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2652{
27da23d5 2653 dVAR;
11343788 2654 OP *o;
b7dc083c 2655 NewOp(1101, o, 1, OP);
eb160463 2656 o->op_type = (OPCODE)type;
22c35a8c 2657 o->op_ppaddr = PL_ppaddr[type];
eb160463 2658 o->op_flags = (U8)flags;
79072805 2659
11343788 2660 o->op_next = o;
eb160463 2661 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2662 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2663 scalar(o);
22c35a8c 2664 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2665 o->op_targ = pad_alloc(type, SVs_PADTMP);
2666 return CHECKOP(type, o);
79072805
LW		 2667}
2668
2669OP *
864dbfa3 2670Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2671{
27da23d5 2672 dVAR;
79072805
LW		 2673 UNOP *unop;
2674
93a17b20 2675 if (!first)
aeea060c 2676 first = newOP(OP_STUB, 0);
22c35a8c 2677 if (PL_opargs[type] & OA_MARK)
8990e307 2678 first = force_list(first);
93a17b20 2679
b7dc083c 2680 NewOp(1101, unop, 1, UNOP);
eb160463 2681 unop->op_type = (OPCODE)type;
22c35a8c 2682 unop->op_ppaddr = PL_ppaddr[type];
79072805 2683 unop->op_first = first;
585ec06d 2684 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2685 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2686 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2687 if (unop->op_next)
2688 return (OP*)unop;
2689
a0d0e21e 2690 return fold_constants((OP *) unop);
79072805
LW		 2691}
2692
2693OP *
864dbfa3 2694Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2695{
27da23d5 2696 dVAR;
79072805 2697 BINOP *binop;
b7dc083c 2698 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2699
2700 if (!first)
2701 first = newOP(OP_NULL, 0);
2702
eb160463 2703 binop->op_type = (OPCODE)type;
22c35a8c 2704 binop->op_ppaddr = PL_ppaddr[type];
79072805 2705 binop->op_first = first;
585ec06d 2706 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2707 if (!last) {
2708 last = first;
eb160463 2709 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2710 }
2711 else {
eb160463 2712 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2713 first->op_sibling = last;
2714 }
2715
e50aee73 2716 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2717 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2718 return (OP*)binop;
2719
7284ab6f 2720 binop->op_last = binop->op_first->op_sibling;
79072805 2721
a0d0e21e 2722 return fold_constants((OP *)binop);
79072805
LW		 2723}
2724
5f66b61c
AL		 2725static int uvcompare(const void *a, const void *b)
2726 __attribute__nonnull__(1)
2727 __attribute__nonnull__(2)
2728 __attribute__pure__;
abb2c242 2729static int uvcompare(const void *a, const void *b)
2b9d42f0 2730{
e1ec3a88 2731 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2732 return -1;
e1ec3a88 2733 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2734 return 1;
e1ec3a88 2735 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2736 return -1;
e1ec3a88 2737 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2738 return 1;
a0ed51b3
LW		 2739 return 0;
2740}
2741
79072805 2742OP *
864dbfa3 2743Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2744{
97aff369 2745 dVAR;
2d03de9c
AL		 2746 SV * const tstr = ((SVOP*)expr)->op_sv;
2747 SV * const rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2748 STRLEN tlen;
2749 STRLEN rlen;
5c144d81
NC		 2750 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2751 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 2752 register I32 i;
2753 register I32 j;
9b877dbb 2754 I32 grows = 0;
79072805
LW		 2755 register short *tbl;
2756
551405c4
AL		 2757 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2758 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2759 I32 del = o->op_private & OPpTRANS_DELETE;
800b4dc4 2760 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 2761
036b4402
GS		 2762 if (SvUTF8(tstr))
2763 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2764
2765 if (SvUTF8(rstr))
036b4402 2766 o->op_private |= OPpTRANS_TO_UTF;
79072805 2767
a0ed51b3 2768 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 2769 SV* const listsv = newSVpvs("# comment\n");
c445ea15 2770 SV* transv = NULL;
5c144d81
NC		 2771 const U8* tend = t + tlen;
2772 const U8* rend = r + rlen;
ba210ebe 2773 STRLEN ulen;
84c133a0
RB		 2774 UV tfirst = 1;
2775 UV tlast = 0;
2776 IV tdiff;
2777 UV rfirst = 1;
2778 UV rlast = 0;
2779 IV rdiff;
2780 IV diff;
a0ed51b3
LW		 2781 I32 none = 0;
2782 U32 max = 0;
2783 I32 bits;
a0ed51b3 2784 I32 havefinal = 0;
9c5ffd7c 2785 U32 final = 0;
551405c4
AL		 2786 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2787 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2788 U8* tsave = NULL;
2789 U8* rsave = NULL;
2790
2791 if (!from_utf) {
2792 STRLEN len = tlen;
5c144d81 2793 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 2794 tend = t + len;
2795 }
2796 if (!to_utf && rlen) {
2797 STRLEN len = rlen;
5c144d81 2798 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 2799 rend = r + len;
2800 }
a0ed51b3 2801
2b9d42f0
NIS		 2802/* There are several snags with this code on EBCDIC:
2803 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2804 2. scan_const() in toke.c has encoded chars in native encoding which makes
2805 ranges at least in EBCDIC 0..255 range the bottom odd.
2806*/
2807
a0ed51b3 2808 if (complement) {
89ebb4a3 2809 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2810 UV *cp;
a0ed51b3 2811 UV nextmin = 0;
a02a5408 2812 Newx(cp, 2*tlen, UV);
a0ed51b3 2813 i = 0;
396482e1 2814 transv = newSVpvs("");
a0ed51b3 2815 while (t < tend) {
2b9d42f0
NIS		 2816 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2817 t += ulen;
2818 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2819 t++;
2b9d42f0
NIS		 2820 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2821 t += ulen;
a0ed51b3 2822 }
2b9d42f0
NIS		 2823 else {
2824 cp[2*i+1] = cp[2*i];
2825 }
2826 i++;
a0ed51b3 2827 }
2b9d42f0 2828 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2829 for (j = 0; j < i; j++) {
2b9d42f0 2830 UV val = cp[2*j];
a0ed51b3
LW		 2831 diff = val - nextmin;
2832 if (diff > 0) {
9041c2e3 2833 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2834 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2835 if (diff > 1) {
2b9d42f0 2836 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2837 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2838 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2839 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2840 }
2841 }
2b9d42f0 2842 val = cp[2*j+1];
a0ed51b3
LW		 2843 if (val >= nextmin)
2844 nextmin = val + 1;
2845 }
9041c2e3 2846 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2847 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2848 {
2849 U8 range_mark = UTF_TO_NATIVE(0xff);
2850 sv_catpvn(transv, (char *)&range_mark, 1);
2851 }
b851fbc1
JH		 2852 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2853 UNICODE_ALLOW_SUPER);
dfe13c55 2854 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 2855 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 2856 tlen = SvCUR(transv);
2857 tend = t + tlen;
455d824a 2858 Safefree(cp);
a0ed51b3
LW		 2859 }
2860 else if (!rlen && !del) {
2861 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2862 }
2863 if (!squash) {
05d340b8 2864 if ((!rlen && !del) || t == r ||
12ae5dfc 2865 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2866 {
4757a243 2867 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2868 }
a0ed51b3
LW		 2869 }
2870
2871 while (t < tend || tfirst <= tlast) {
2872 /* see if we need more "t" chars */
2873 if (tfirst > tlast) {
9041c2e3 2874 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2875 t += ulen;
2b9d42f0 2876 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2877 t++;
9041c2e3 2878 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2879 t += ulen;
2880 }
2881 else
2882 tlast = tfirst;
2883 }
2884
2885 /* now see if we need more "r" chars */
2886 if (rfirst > rlast) {
2887 if (r < rend) {
9041c2e3 2888 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2889 r += ulen;
2b9d42f0 2890 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2891 r++;
9041c2e3 2892 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2893 r += ulen;
2894 }
2895 else
2896 rlast = rfirst;
2897 }
2898 else {
2899 if (!havefinal++)
2900 final = rlast;
2901 rfirst = rlast = 0xffffffff;
2902 }
2903 }
2904
2905 /* now see which range will peter our first, if either. */
2906 tdiff = tlast - tfirst;
2907 rdiff = rlast - rfirst;
2908
2909 if (tdiff <= rdiff)
2910 diff = tdiff;
2911 else
2912 diff = rdiff;
2913
2914 if (rfirst == 0xffffffff) {
2915 diff = tdiff; /* oops, pretend rdiff is infinite */
2916 if (diff > 0)
894356b3
GS		 2917 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2918 (long)tfirst, (long)tlast);
a0ed51b3 2919 else
894356b3 2920 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2921 }
2922 else {
2923 if (diff > 0)
894356b3
GS		 2924 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2925 (long)tfirst, (long)(tfirst + diff),
2926 (long)rfirst);
a0ed51b3 2927 else
894356b3
GS		 2928 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2929 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2930
2931 if (rfirst + diff > max)
2932 max = rfirst + diff;
9b877dbb 2933 if (!grows)
45005bfb
JH		 2934 grows = (tfirst < rfirst &&
2935 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2936 rfirst += diff + 1;
a0ed51b3
LW		 2937 }
2938 tfirst += diff + 1;
2939 }
2940
2941 none = ++max;
2942 if (del)
2943 del = ++max;
2944
2945 if (max > 0xffff)
2946 bits = 32;
2947 else if (max > 0xff)
2948 bits = 16;
2949 else
2950 bits = 8;
2951
455d824a 2952 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2953 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2954 SvREFCNT_dec(listsv);
b37c2d43 2955 SvREFCNT_dec(transv);
a0ed51b3 2956
45005bfb 2957 if (!del && havefinal && rlen)
b448e4fe
JH		 2958 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2959 newSVuv((UV)final), 0);
a0ed51b3 2960
9b877dbb 2961 if (grows)
a0ed51b3
LW		 2962 o->op_private |= OPpTRANS_GROWS;
2963
b37c2d43
AL		 2964 Safefree(tsave);
2965 Safefree(rsave);
9b877dbb 2966
eb8433b7
NC		 2967#ifdef PERL_MAD
2968 op_getmad(expr,o,'e');
2969 op_getmad(repl,o,'r');
2970#else
a0ed51b3
LW		 2971 op_free(expr);
2972 op_free(repl);
eb8433b7 2973#endif
a0ed51b3
LW		 2974 return o;
2975 }
2976
2977 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2978 if (complement) {
2979 Zero(tbl, 256, short);
eb160463 2980 for (i = 0; i < (I32)tlen; i++)
ec49126f 2981 tbl[t[i]] = -1;
79072805
LW		 2982 for (i = 0, j = 0; i < 256; i++) {
2983 if (!tbl[i]) {
eb160463 2984 if (j >= (I32)rlen) {
a0ed51b3 2985 if (del)
79072805
LW		 2986 tbl[i] = -2;
2987 else if (rlen)
ec49126f 2988 tbl[i] = r[j-1];
79072805 2989 else
eb160463 2990 tbl[i] = (short)i;
79072805 2991 }
9b877dbb
IH		 2992 else {
2993 if (i < 128 && r[j] >= 128)
2994 grows = 1;
ec49126f 2995 tbl[i] = r[j++];
9b877dbb 2996 }
79072805
LW		 2997 }
2998 }
05d340b8
JH		 2999 if (!del) {
3000 if (!rlen) {
3001 j = rlen;
3002 if (!squash)
3003 o->op_private |= OPpTRANS_IDENTICAL;
3004 }
eb160463 3005 else if (j >= (I32)rlen)
05d340b8
JH		 3006 j = rlen - 1;
3007 else
3008 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
585ec06d 3009 tbl[0x100] = (short)(rlen - j);
eb160463 3010 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3011 tbl[0x101+i] = r[j+i];
3012 }
79072805
LW		 3013 }
3014 else {
a0ed51b3 3015 if (!rlen && !del) {
79072805 3016 r = t; rlen = tlen;
5d06d08e 3017 if (!squash)
4757a243 3018 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3019 }
94bfe852
RGS		 3020 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3021 o->op_private |= OPpTRANS_IDENTICAL;
3022 }
79072805
LW		 3023 for (i = 0; i < 256; i++)
3024 tbl[i] = -1;
eb160463
GS		 3025 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3026 if (j >= (I32)rlen) {
a0ed51b3 3027 if (del) {
ec49126f 3028 if (tbl[t[i]] == -1)
3029 tbl[t[i]] = -2;
79072805
LW		 3030 continue;
3031 }
3032 --j;
3033 }
9b877dbb
IH		 3034 if (tbl[t[i]] == -1) {
3035 if (t[i] < 128 && r[j] >= 128)
3036 grows = 1;
ec49126f 3037 tbl[t[i]] = r[j];
9b877dbb 3038 }
79072805
LW		 3039 }
3040 }
9b877dbb
IH		 3041 if (grows)
3042 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 3043#ifdef PERL_MAD
3044 op_getmad(expr,o,'e');
3045 op_getmad(repl,o,'r');
3046#else
79072805
LW		 3047 op_free(expr);
3048 op_free(repl);
eb8433b7 3049#endif
79072805 3050
11343788 3051 return o;
79072805
LW		 3052}
3053
3054OP *
864dbfa3 3055Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3056{
27da23d5 3057 dVAR;
79072805
LW		 3058 PMOP *pmop;
3059
b7dc083c 3060 NewOp(1101, pmop, 1, PMOP);
eb160463 3061 pmop->op_type = (OPCODE)type;
22c35a8c 3062 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3063 pmop->op_flags = (U8)flags;
3064 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3065
3280af22 3066 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 3067 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 3068 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 3069 pmop->op_pmpermflags |= PMf_LOCALE;
3070 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 3071
debc9467 3072#ifdef USE_ITHREADS
551405c4
AL		 3073 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3074 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3075 pmop->op_pmoffset = SvIV(repointer);
3076 SvREPADTMP_off(repointer);
3077 sv_setiv(repointer,0);
3078 } else {
3079 SV * const repointer = newSViv(0);
b37c2d43 3080 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
551405c4
AL		 3081 pmop->op_pmoffset = av_len(PL_regex_padav);
3082 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3083 }
debc9467 3084#endif
1eb1540c 3085
1fcf4c12 3086 /* link into pm list */
3280af22 3087 if (type != OP_TRANS && PL_curstash) {
8d2f4536
NC		 3088 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3089
3090 if (!mg) {
3091 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3092 }
3093 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3094 mg->mg_obj = (SV*)pmop;
cb55de95 3095 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 3096 }
3097
463d09e6 3098 return CHECKOP(type, pmop);
79072805
LW		 3099}
3100
131b3ad0
DM		 3101/* Given some sort of match op o, and an expression expr containing a
3102 * pattern, either compile expr into a regex and attach it to o (if it's
3103 * constant), or convert expr into a runtime regcomp op sequence (if it's
3104 * not)
3105 *
3106 * isreg indicates that the pattern is part of a regex construct, eg
3107 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3108 * split "pattern", which aren't. In the former case, expr will be a list
3109 * if the pattern contains more than one term (eg /a$b/) or if it contains
3110 * a replacement, ie s/// or tr///.
3111 */
3112
79072805 3113OP *
131b3ad0 3114Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3115{
27da23d5 3116 dVAR;
79072805
LW		 3117 PMOP *pm;
3118 LOGOP *rcop;
ce862d02 3119 I32 repl_has_vars = 0;
5f66b61c 3120 OP* repl = NULL;
131b3ad0
DM		 3121 bool reglist;
3122
3123 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3124 /* last element in list is the replacement; pop it */
3125 OP* kid;
3126 repl = cLISTOPx(expr)->op_last;
3127 kid = cLISTOPx(expr)->op_first;
3128 while (kid->op_sibling != repl)
3129 kid = kid->op_sibling;
5f66b61c 3130 kid->op_sibling = NULL;
131b3ad0
DM		 3131 cLISTOPx(expr)->op_last = kid;
3132 }
79072805 3133
131b3ad0
DM		 3134 if (isreg && expr->op_type == OP_LIST &&
3135 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3136 {
3137 /* convert single element list to element */
0bd48802 3138 OP* const oe = expr;
131b3ad0 3139 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3140 cLISTOPx(oe)->op_first->op_sibling = NULL;
3141 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3142 op_free(oe);
3143 }
3144
3145 if (o->op_type == OP_TRANS) {
11343788 3146 return pmtrans(o, expr, repl);
131b3ad0
DM		 3147 }
3148
3149 reglist = isreg && expr->op_type == OP_LIST;
3150 if (reglist)
3151 op_null(expr);
79072805 3152
3280af22 3153 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3154 pm = (PMOP*)o;
79072805
LW		 3155
3156 if (expr->op_type == OP_CONST) {
463ee0b2 3157 STRLEN plen;
6136c704 3158 SV * const pat = ((SVOP*)expr)->op_sv;
5c144d81 3159 const char *p = SvPV_const(pat, plen);
770526c1 3160 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
5c144d81
NC		 3161 U32 was_readonly = SvREADONLY(pat);
3162
3163 if (was_readonly) {
3164 if (SvFAKE(pat)) {
3165 sv_force_normal_flags(pat, 0);
3166 assert(!SvREADONLY(pat));
3167 was_readonly = 0;
3168 } else {
3169 SvREADONLY_off(pat);
3170 }
3171 }
3172
93a17b20 3173 sv_setpvn(pat, "\\s+", 3);
5c144d81
NC		 3174
3175 SvFLAGS(pat) |= was_readonly;
3176
3177 p = SvPV_const(pat, plen);
79072805
LW		 3178 pm->op_pmflags |= PMf_SKIPWHITE;
3179 }
5b71a6a7 3180 if (DO_UTF8(pat))
a5961de5 3181 pm->op_pmdynflags |= PMdf_UTF8;
5c144d81
NC		 3182 /* FIXME - can we make this function take const char * args? */
3183 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
aaa362c4 3184 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3185 pm->op_pmflags |= PMf_WHITE;
eb8433b7
NC		 3186#ifdef PERL_MAD
3187 op_getmad(expr,(OP*)pm,'e');
3188#else
79072805 3189 op_free(expr);
eb8433b7 3190#endif
79072805
LW		 3191 }
3192 else {
3280af22 3193 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3194 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3195 ? OP_REGCRESET
3196 : OP_REGCMAYBE),0,expr);
463ee0b2 3197
b7dc083c 3198 NewOp(1101, rcop, 1, LOGOP);
79072805 3199 rcop->op_type = OP_REGCOMP;
22c35a8c 3200 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3201 rcop->op_first = scalar(expr);
131b3ad0
DM		 3202 rcop->op_flags |= OPf_KIDS
3203 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3204 | (reglist ? OPf_STACKED : 0);
79072805 3205 rcop->op_private = 1;
11343788 3206 rcop->op_other = o;
131b3ad0
DM		 3207 if (reglist)
3208 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3209
b5c19bd7
DM		 3210 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3211 PL_cv_has_eval = 1;
79072805
LW		 3212
3213 /* establish postfix order */
3280af22 3214 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3215 LINKLIST(expr);
3216 rcop->op_next = expr;
3217 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3218 }
3219 else {
3220 rcop->op_next = LINKLIST(expr);
3221 expr->op_next = (OP*)rcop;
3222 }
79072805 3223
11343788 3224 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3225 }
3226
3227 if (repl) {
748a9306 3228 OP *curop;
0244c3a4 3229 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3230 curop = NULL;
8bafa735 3231 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 3232 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 3233 }
748a9306
LW		 3234 else if (repl->op_type == OP_CONST)
3235 curop = repl;
79072805 3236 else {
c445ea15 3237 OP *lastop = NULL;
79072805 3238 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3239 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3240 if (curop->op_type == OP_GV) {
6136c704 3241 GV * const gv = cGVOPx_gv(curop);
ce862d02 3242 repl_has_vars = 1;
f702bf4a 3243 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3244 break;
3245 }
3246 else if (curop->op_type == OP_RV2CV)
3247 break;
3248 else if (curop->op_type == OP_RV2SV ||
3249 curop->op_type == OP_RV2AV ||
3250 curop->op_type == OP_RV2HV ||
3251 curop->op_type == OP_RV2GV) {
3252 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3253 break;
3254 }
748a9306
LW		 3255 else if (curop->op_type == OP_PADSV ||
3256 curop->op_type == OP_PADAV ||
3257 curop->op_type == OP_PADHV ||
554b3eca 3258 curop->op_type == OP_PADANY) {
ce862d02 3259 repl_has_vars = 1;
748a9306 3260 }
1167e5da 3261 else if (curop->op_type == OP_PUSHRE)
bb263b4e 3262 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3263 else
3264 break;
3265 }
3266 lastop = curop;
3267 }
748a9306 3268 }
ce862d02 3269 if (curop == repl
1c846c1f 3270 && !(repl_has_vars
aaa362c4
RS		 3271 && (!PM_GETRE(pm)
3272 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3273 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3274 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3275 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3276 }
3277 else {
aaa362c4 3278 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3279 pm->op_pmflags |= PMf_MAYBE_CONST;
3280 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3281 }
b7dc083c 3282 NewOp(1101, rcop, 1, LOGOP);
748a9306 3283 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3284 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3285 rcop->op_first = scalar(repl);
3286 rcop->op_flags |= OPf_KIDS;
3287 rcop->op_private = 1;
11343788 3288 rcop->op_other = o;
748a9306
LW		 3289
3290 /* establish postfix order */
3291 rcop->op_next = LINKLIST(repl);
3292 repl->op_next = (OP*)rcop;
3293
3294 pm->op_pmreplroot = scalar((OP*)rcop);
3295 pm->op_pmreplstart = LINKLIST(rcop);
3296 rcop->op_next = 0;
79072805
LW		 3297 }
3298 }
3299
3300 return (OP*)pm;
3301}
3302
3303OP *
864dbfa3 3304Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3305{
27da23d5 3306 dVAR;
79072805 3307 SVOP *svop;
b7dc083c 3308 NewOp(1101, svop, 1, SVOP);
eb160463 3309 svop->op_type = (OPCODE)type;
22c35a8c 3310 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3311 svop->op_sv = sv;
3312 svop->op_next = (OP*)svop;
eb160463 3313 svop->op_flags = (U8)flags;
22c35a8c 3314 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3315 scalar((OP*)svop);
22c35a8c 3316 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3317 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3318 return CHECKOP(type, svop);
79072805
LW		 3319}
3320
3321OP *
350de78d
GS		 3322Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3323{
27da23d5 3324 dVAR;
350de78d
GS		 3325 PADOP *padop;
3326 NewOp(1101, padop, 1, PADOP);
eb160463 3327 padop->op_type = (OPCODE)type;
350de78d
GS		 3328 padop->op_ppaddr = PL_ppaddr[type];
3329 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 3330 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3331 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 3332 if (sv)
3333 SvPADTMP_on(sv);
350de78d 3334 padop->op_next = (OP*)padop;
eb160463 3335 padop->op_flags = (U8)flags;
350de78d
GS		 3336 if (PL_opargs[type] & OA_RETSCALAR)
3337 scalar((OP*)padop);
3338 if (PL_opargs[type] & OA_TARGET)
3339 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3340 return CHECKOP(type, padop);
3341}
3342
3343OP *
864dbfa3 3344Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3345{
27da23d5 3346 dVAR;
350de78d 3347#ifdef USE_ITHREADS
ce50c033
AMS		 3348 if (gv)
3349 GvIN_PAD_on(gv);
b37c2d43 3350 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3351#else
b37c2d43 3352 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3353#endif
79072805
LW		 3354}
3355
3356OP *
864dbfa3 3357Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 3358{
27da23d5 3359 dVAR;
79072805 3360 PVOP *pvop;
b7dc083c 3361 NewOp(1101, pvop, 1, PVOP);
eb160463 3362 pvop->op_type = (OPCODE)type;
22c35a8c 3363 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3364 pvop->op_pv = pv;
3365 pvop->op_next = (OP*)pvop;
eb160463 3366 pvop->op_flags = (U8)flags;
22c35a8c 3367 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3368 scalar((OP*)pvop);
22c35a8c 3369 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3370 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3371 return CHECKOP(type, pvop);
79072805
LW		 3372}
3373
eb8433b7
NC		 3374#ifdef PERL_MAD
3375OP*
3376#else
79072805 3377void
eb8433b7 3378#endif
864dbfa3 3379Perl_package(pTHX_ OP *o)
79072805 3380{
97aff369 3381 dVAR;
6867be6d 3382 const char *name;
de11ba31 3383 STRLEN len;
eb8433b7
NC		 3384#ifdef PERL_MAD
3385 OP *pegop;
3386#endif
79072805 3387
3280af22
NIS		 3388 save_hptr(&PL_curstash);
3389 save_item(PL_curstname);
de11ba31 3390
5c144d81 3391 name = SvPV_const(cSVOPo->op_sv, len);
de11ba31
AMS		 3392 PL_curstash = gv_stashpvn(name, len, TRUE);
3393 sv_setpvn(PL_curstname, name, len);
de11ba31 3394
7ad382f4 3395 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3396 PL_copline = NOLINE;
3397 PL_expect = XSTATE;
eb8433b7
NC		 3398
3399#ifndef PERL_MAD
3400 op_free(o);
3401#else
3402 if (!PL_madskills) {
3403 op_free(o);
1d866c12 3404 return NULL;
eb8433b7
NC		 3405 }
3406
3407 pegop = newOP(OP_NULL,0);
3408 op_getmad(o,pegop,'P');
3409 return pegop;
3410#endif
79072805
LW		 3411}
3412
eb8433b7
NC		 3413#ifdef PERL_MAD
3414OP*
3415#else
85e6fe83 3416void
eb8433b7 3417#endif
88d95a4d 3418Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3419{
97aff369 3420 dVAR;
a0d0e21e 3421 OP *pack;
a0d0e21e 3422 OP *imop;
b1cb66bf 3423 OP *veop;
eb8433b7
NC		 3424#ifdef PERL_MAD
3425 OP *pegop = newOP(OP_NULL,0);
3426#endif
85e6fe83 3427
88d95a4d 3428 if (idop->op_type != OP_CONST)
cea2e8a9 3429 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3430
eb8433b7
NC		 3431 if (PL_madskills)
3432 op_getmad(idop,pegop,'U');
3433
5f66b61c 3434 veop = NULL;
b1cb66bf 3435
aec46f14 3436 if (version) {
551405c4 3437 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3438
eb8433b7
NC		 3439 if (PL_madskills)
3440 op_getmad(version,pegop,'V');
aec46f14 3441 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3442 arg = version;
3443 }
3444 else {
3445 OP *pack;
0f79a09d 3446 SV *meth;
b1cb66bf 3447
44dcb63b 3448 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3449 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3450
88d95a4d
JH		 3451 /* Make copy of idop so we don't free it twice */
3452 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3453
3454 /* Fake up a method call to VERSION */
18916d0d 3455 meth = newSVpvs_share("VERSION");
b1cb66bf 3456 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3457 append_elem(OP_LIST,
0f79a09d
GS		 3458 prepend_elem(OP_LIST, pack, list(version)),
3459 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3460 }
3461 }
aeea060c 3462
a0d0e21e 3463 /* Fake up an import/unimport */
eb8433b7
NC		 3464 if (arg && arg->op_type == OP_STUB) {
3465 if (PL_madskills)
3466 op_getmad(arg,pegop,'S');
4633a7c4 3467 imop = arg; /* no import on explicit () */
eb8433b7 3468 }
88d95a4d 3469 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 3470 imop = NULL; /* use 5.0; */
468aa647
RGS		 3471 if (!aver)
3472 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3473 }
4633a7c4 3474 else {
0f79a09d
GS		 3475 SV *meth;
3476
eb8433b7
NC		 3477 if (PL_madskills)
3478 op_getmad(arg,pegop,'A');
3479
88d95a4d
JH		 3480 /* Make copy of idop so we don't free it twice */
3481 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 3482
3483 /* Fake up a method call to import/unimport */
427d62a4 3484 meth = aver
18916d0d 3485 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 3486 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3487 append_elem(OP_LIST,
3488 prepend_elem(OP_LIST, pack, list(arg)),
3489 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3490 }
3491
a0d0e21e 3492 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3493 newATTRSUB(floor,
18916d0d 3494 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 3495 NULL,
3496 NULL,
a0d0e21e 3497 append_elem(OP_LINESEQ,
b1cb66bf 3498 append_elem(OP_LINESEQ,
bd61b366
SS		 3499 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3500 newSTATEOP(0, NULL, veop)),
3501 newSTATEOP(0, NULL, imop) ));
85e6fe83 3502
70f5e4ed
JH		 3503 /* The "did you use incorrect case?" warning used to be here.
3504 * The problem is that on case-insensitive filesystems one
3505 * might get false positives for "use" (and "require"):
3506 * "use Strict" or "require CARP" will work. This causes
3507 * portability problems for the script: in case-strict
3508 * filesystems the script will stop working.
3509 *
3510 * The "incorrect case" warning checked whether "use Foo"
3511 * imported "Foo" to your namespace, but that is wrong, too:
3512 * there is no requirement nor promise in the language that
3513 * a Foo.pm should or would contain anything in package "Foo".
3514 *
3515 * There is very little Configure-wise that can be done, either:
3516 * the case-sensitivity of the build filesystem of Perl does not
3517 * help in guessing the case-sensitivity of the runtime environment.
3518 */
18fc9488 3519
c305c6a0 3520 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3521 PL_copline = NOLINE;
3522 PL_expect = XSTATE;
8ec8fbef 3523 PL_cop_seqmax++; /* Purely for B::*'s benefit */
eb8433b7
NC		 3524
3525#ifdef PERL_MAD
3526 if (!PL_madskills) {
3527 /* FIXME - don't allocate pegop if !PL_madskills */
3528 op_free(pegop);
1d866c12 3529 return NULL;
eb8433b7
NC		 3530 }
3531 return pegop;
3532#endif
85e6fe83
LW		 3533}
3534
7d3fb230 3535/*
ccfc67b7
JH		 3536=head1 Embedding Functions
3537
7d3fb230
BS		 3538=for apidoc load_module
3539
3540Loads the module whose name is pointed to by the string part of name.
3541Note that the actual module name, not its filename, should be given.
3542Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3543P