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