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