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