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