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