This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement "my $_".
[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
59f00321 158 /* complain about "my $<special_var>" 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])) ||
59f00321 162 (name[1] == '_' && (*name == '$' || (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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
1236{
1237 switch (type) {
1238 case OP_SASSIGN:
5196be3e 1239 if (o->op_type == OP_RV2GV)
3fe9a6f1
PP
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
PP
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;
59f00321 1676 bool ismatchop = 0;
79072805 1677
e476b1b5 1678 if (ckWARN(WARN_MISC) &&
599cee73
PM
1679 (left->op_type == OP_RV2AV ||
1680 left->op_type == OP_RV2HV ||
1681 left->op_type == OP_PADAV ||
1682 left->op_type == OP_PADHV)) {
22c35a8c 1683 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM
1684 right->op_type == OP_TRANS)
1685 ? right->op_type : OP_MATCH];
dff6d3cd
GS
1686 const char *sample = ((left->op_type == OP_RV2AV ||
1687 left->op_type == OP_PADAV)
1688 ? "@array" : "%hash");
9014280d 1689 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1690 "Applying %s to %s will act on scalar(%s)",
599cee73 1691 desc, sample, sample);
2ae324a7
PP
1692 }
1693
5cc9e5c9
RH
1694 if (right->op_type == OP_CONST &&
1695 cSVOPx(right)->op_private & OPpCONST_BARE &&
1696 cSVOPx(right)->op_private & OPpCONST_STRICT)
1697 {
1698 no_bareword_allowed(right);
1699 }
1700
59f00321
RGS
1701 ismatchop = right->op_type == OP_MATCH ||
1702 right->op_type == OP_SUBST ||
1703 right->op_type == OP_TRANS;
1704 if (ismatchop && right->op_private & OPpTARGET_MY) {
1705 right->op_targ = 0;
1706 right->op_private &= ~OPpTARGET_MY;
1707 }
1708 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1709 right->op_flags |= OPf_STACKED;
18808301
JH
1710 if (right->op_type != OP_MATCH &&
1711 ! (right->op_type == OP_TRANS &&
1712 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1713 left = mod(left, right->op_type);
79072805 1714 if (right->op_type == OP_TRANS)
11343788 1715 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1716 else
11343788 1717 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1718 if (type == OP_NOT)
11343788
MB
1719 return newUNOP(OP_NOT, 0, scalar(o));
1720 return o;
79072805
LW
1721 }
1722 else
1723 return bind_match(type, left,
1724 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1725}
1726
1727OP *
864dbfa3 1728Perl_invert(pTHX_ OP *o)
79072805 1729{
11343788
MB
1730 if (!o)
1731 return o;
79072805 1732 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1733 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
1734}
1735
1736OP *
864dbfa3 1737Perl_scope(pTHX_ OP *o)
79072805
LW
1738{
1739 if (o) {
3280af22 1740 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW
1741 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1742 o->op_type = OP_LEAVE;
22c35a8c 1743 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1744 }
fdb22418
HS
1745 else if (o->op_type == OP_LINESEQ) {
1746 OP *kid;
1747 o->op_type = OP_SCOPE;
1748 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1749 kid = ((LISTOP*)o)->op_first;
1750 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1751 op_null(kid);
463ee0b2 1752 }
fdb22418
HS
1753 else
1754 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
79072805
LW
1755 }
1756 return o;
1757}
1758
b3ac6de7 1759void
864dbfa3 1760Perl_save_hints(pTHX)
b3ac6de7 1761{
3280af22
NIS
1762 SAVEI32(PL_hints);
1763 SAVESPTR(GvHV(PL_hintgv));
1764 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1765 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ
1766}
1767
a0d0e21e 1768int
864dbfa3 1769Perl_block_start(pTHX_ int full)
79072805 1770{
3280af22 1771 int retval = PL_savestack_ix;
39aa8287
RGS
1772 /* If there were syntax errors, don't try to start a block */
1773 if (PL_yynerrs) return retval;
b3ac6de7 1774
dd2155a4 1775 pad_block_start(full);
b3ac6de7 1776 SAVEHINTS();
3280af22 1777 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1778 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1779 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
1780 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1781 SAVEFREESV(PL_compiling.cop_warnings) ;
1782 }
ac27b0f5
NIS
1783 SAVESPTR(PL_compiling.cop_io);
1784 if (! specialCopIO(PL_compiling.cop_io)) {
1785 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1786 SAVEFREESV(PL_compiling.cop_io) ;
1787 }
a0d0e21e
LW
1788 return retval;
1789}
1790
1791OP*
864dbfa3 1792Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1793{
3280af22 1794 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
e9f19e3c 1795 OP* retval = scalarseq(seq);
39aa8287
RGS
1796 /* If there were syntax errors, don't try to close a block */
1797 if (PL_yynerrs) return retval;
e9818f4e 1798 LEAVE_SCOPE(floor);
eb160463 1799 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1800 if (needblockscope)
3280af22 1801 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1802 pad_leavemy();
a0d0e21e
LW
1803 return retval;
1804}
1805
76e3520e 1806STATIC OP *
cea2e8a9 1807S_newDEFSVOP(pTHX)
54b9620d 1808{
59f00321
RGS
1809 I32 offset = pad_findmy("$_");
1810 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1811 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1812 }
1813 else {
1814 OP *o = newOP(OP_PADSV, 0);
1815 o->op_targ = offset;
1816 return o;
1817 }
54b9620d
MB
1818}
1819
a0d0e21e 1820void
864dbfa3 1821Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1822{
3280af22 1823 if (PL_in_eval) {
b295d113
TH
1824 if (PL_eval_root)
1825 return;
faef0170
HS
1826 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1827 ((PL_in_eval & EVAL_KEEPERR)
1828 ? OPf_SPECIAL : 0), o);
3280af22 1829 PL_eval_start = linklist(PL_eval_root);
7934575e
GS
1830 PL_eval_root->op_private |= OPpREFCOUNTED;
1831 OpREFCNT_set(PL_eval_root, 1);
3280af22 1832 PL_eval_root->op_next = 0;
a2efc822 1833 CALL_PEEP(PL_eval_start);
a0d0e21e
LW
1834 }
1835 else {
6be89cf9
AE
1836 if (o->op_type == OP_STUB) {
1837 PL_comppad_name = 0;
1838 PL_compcv = 0;
2a4f803a 1839 FreeOp(o);
a0d0e21e 1840 return;
6be89cf9 1841 }
3280af22
NIS
1842 PL_main_root = scope(sawparens(scalarvoid(o)));
1843 PL_curcop = &PL_compiling;
1844 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
1845 PL_main_root->op_private |= OPpREFCOUNTED;
1846 OpREFCNT_set(PL_main_root, 1);
3280af22 1847 PL_main_root->op_next = 0;
a2efc822 1848 CALL_PEEP(PL_main_start);
3280af22 1849 PL_compcv = 0;
3841441e 1850
4fdae800 1851 /* Register with debugger */
84902520 1852 if (PERLDB_INTER) {
864dbfa3 1853 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS
1854 if (cv) {
1855 dSP;
924508f0 1856 PUSHMARK(SP);
cc49e20b 1857 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1858 PUTBACK;
864dbfa3 1859 call_sv((SV*)cv, G_DISCARD);
3841441e
CS
1860 }
1861 }
79072805 1862 }
79072805
LW
1863}
1864
1865OP *
864dbfa3 1866Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW
1867{
1868 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
1869/* [perl #17376]: this appears to be premature, and results in code such as
1870 C< our(%x); > executing in list mode rather than void mode */
1871#if 0
79072805 1872 list(o);
d2be0de5
YST
1873#else
1874 ;
1875#endif
8990e307 1876 else {
64420d0d
JH
1877 if (ckWARN(WARN_PARENTHESIS)
1878 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1879 {
1880 char *s = PL_bufptr;
bac662ee 1881 bool sigil = FALSE;
64420d0d 1882
8473848f 1883 /* some heuristics to detect a potential error */
bac662ee 1884 while (*s && (strchr(", \t\n", *s)))
64420d0d 1885 s++;
8473848f 1886
bac662ee
ST
1887 while (1) {
1888 if (*s && strchr("@$%*", *s) && *++s
1889 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1890 s++;
1891 sigil = TRUE;
1892 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1893 s++;
1894 while (*s && (strchr(", \t\n", *s)))
1895 s++;
1896 }
1897 else
1898 break;
1899 }
1900 if (sigil && (*s == ';' || *s == '=')) {
1901 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS
1902 "Parentheses missing around \"%s\" list",
1903 lex ? (PL_in_my == KEY_our ? "our" : "my")
1904 : "local");
1905 }
8990e307
LW
1906 }
1907 }
93a17b20 1908 if (lex)
eb64745e 1909 o = my(o);
93a17b20 1910 else
eb64745e
GS
1911 o = mod(o, OP_NULL); /* a bit kludgey */
1912 PL_in_my = FALSE;
1913 PL_in_my_stash = Nullhv;
1914 return o;
79072805
LW
1915}
1916
1917OP *
864dbfa3 1918Perl_jmaybe(pTHX_ OP *o)
79072805
LW
1919{
1920 if (o->op_type == OP_LIST) {
554b3eca 1921 OP *o2;
554b3eca 1922 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
554b3eca 1923 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW
1924 }
1925 return o;
1926}
1927
1928OP *
864dbfa3 1929Perl_fold_constants(pTHX_ register OP *o)
79072805
LW
1930{
1931 register OP *curop;
1932 I32 type = o->op_type;
748a9306 1933 SV *sv;
79072805 1934
22c35a8c 1935 if (PL_opargs[type] & OA_RETSCALAR)
79072805 1936 scalar(o);
b162f9ea 1937 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 1938 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 1939
eac055e9
GS
1940 /* integerize op, unless it happens to be C<-foo>.
1941 * XXX should pp_i_negate() do magic string negation instead? */
1942 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1943 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1944 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1945 {
22c35a8c 1946 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 1947 }
85e6fe83 1948
22c35a8c 1949 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
1950 goto nope;
1951
de939608 1952 switch (type) {
7a52d87a
GS
1953 case OP_NEGATE:
1954 /* XXX might want a ck_negate() for this */
1955 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1956 break;
de939608
CS
1957 case OP_SPRINTF:
1958 case OP_UCFIRST:
1959 case OP_LCFIRST:
1960 case OP_UC:
1961 case OP_LC:
69dcf70c
MB
1962 case OP_SLT:
1963 case OP_SGT:
1964 case OP_SLE:
1965 case OP_SGE:
1966 case OP_SCMP:
2de3dbcc
JH
1967 /* XXX what about the numeric ops? */
1968 if (PL_hints & HINT_LOCALE)
de939608
CS
1969 goto nope;
1970 }
1971
3280af22 1972 if (PL_error_count)
a0d0e21e
LW
1973 goto nope; /* Don't try to run w/ errors */
1974
79072805 1975 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS
1976 if ((curop->op_type != OP_CONST ||
1977 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS
1978 curop->op_type != OP_LIST &&
1979 curop->op_type != OP_SCALAR &&
1980 curop->op_type != OP_NULL &&
1981 curop->op_type != OP_PUSHMARK)
1982 {
79072805
LW
1983 goto nope;
1984 }
1985 }
1986
1987 curop = LINKLIST(o);
1988 o->op_next = 0;
533c011a 1989 PL_op = curop;
cea2e8a9 1990 CALLRUNOPS(aTHX);
3280af22 1991 sv = *(PL_stack_sp--);
748a9306 1992 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 1993 pad_swipe(o->op_targ, FALSE);
748a9306
LW
1994 else if (SvTEMP(sv)) { /* grab mortal temp? */
1995 (void)SvREFCNT_inc(sv);
1996 SvTEMP_off(sv);
85e6fe83 1997 }
79072805
LW
1998 op_free(o);
1999 if (type == OP_RV2GV)
b1cb66bf 2000 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 2001 return newSVOP(OP_CONST, 0, sv);
aeea060c 2002
79072805 2003 nope:
79072805
LW
2004 return o;
2005}
2006
2007OP *
864dbfa3 2008Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW
2009{
2010 register OP *curop;
3280af22 2011 I32 oldtmps_floor = PL_tmps_floor;
79072805 2012
a0d0e21e 2013 list(o);
3280af22 2014 if (PL_error_count)
a0d0e21e
LW
2015 return o; /* Don't attempt to run with errors */
2016
533c011a 2017 PL_op = curop = LINKLIST(o);
a0d0e21e 2018 o->op_next = 0;
a2efc822 2019 CALL_PEEP(curop);
cea2e8a9
GS
2020 pp_pushmark();
2021 CALLRUNOPS(aTHX);
533c011a 2022 PL_op = curop;
cea2e8a9 2023 pp_anonlist();
3280af22 2024 PL_tmps_floor = oldtmps_floor;
79072805
LW
2025
2026 o->op_type = OP_RV2AV;
22c35a8c 2027 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
2028 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2029 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
c13f253a 2030 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2031 curop = ((UNOP*)o)->op_first;
3280af22 2032 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2033 op_free(curop);
79072805
LW
2034 linklist(o);
2035 return list(o);
2036}
2037
2038OP *
864dbfa3 2039Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2040{
11343788
MB
2041 if (!o || o->op_type != OP_LIST)
2042 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2043 else
5dc0d613 2044 o->op_flags &= ~OPf_WANT;
79072805 2045
22c35a8c 2046 if (!(PL_opargs[type] & OA_MARK))
93c66552 2047 op_null(cLISTOPo->op_first);
8990e307 2048
eb160463 2049 o->op_type = (OPCODE)type;
22c35a8c 2050 o->op_ppaddr = PL_ppaddr[type];
11343788 2051 o->op_flags |= flags;
79072805 2052
11343788
MB
2053 o = CHECKOP(type, o);
2054 if (o->op_type != type)
2055 return o;
79072805 2056
11343788 2057 return fold_constants(o);
79072805
LW
2058}
2059
2060/* List constructors */
2061
2062OP *
864dbfa3 2063Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2064{
2065 if (!first)
2066 return last;
8990e307
LW
2067
2068 if (!last)
79072805 2069 return first;
8990e307 2070
155aba94
GS
2071 if (first->op_type != type
2072 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2073 {
2074 return newLISTOP(type, 0, first, last);
2075 }
79072805 2076
a0d0e21e
LW
2077 if (first->op_flags & OPf_KIDS)
2078 ((LISTOP*)first)->op_last->op_sibling = last;
2079 else {
2080 first->op_flags |= OPf_KIDS;
2081 ((LISTOP*)first)->op_first = last;
2082 }
2083 ((LISTOP*)first)->op_last = last;
a0d0e21e 2084 return first;
79072805
LW
2085}
2086
2087OP *
864dbfa3 2088Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW
2089{
2090 if (!first)
2091 return (OP*)last;
8990e307
LW
2092
2093 if (!last)
79072805 2094 return (OP*)first;
8990e307
LW
2095
2096 if (first->op_type != type)
79072805 2097 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW
2098
2099 if (last->op_type != type)
79072805
LW
2100 return append_elem(type, (OP*)first, (OP*)last);
2101
2102 first->op_last->op_sibling = last->op_first;
2103 first->op_last = last->op_last;
117dada2 2104 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2105
238a4c30
NIS
2106 FreeOp(last);
2107
79072805
LW
2108 return (OP*)first;
2109}
2110
2111OP *
864dbfa3 2112Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2113{
2114 if (!first)
2115 return last;
8990e307
LW
2116
2117 if (!last)
79072805 2118 return first;
8990e307
LW
2119
2120 if (last->op_type == type) {
2121 if (type == OP_LIST) { /* already a PUSHMARK there */
2122 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2123 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
2124 if (!(first->op_flags & OPf_PARENS))
2125 last->op_flags &= ~OPf_PARENS;
8990e307
LW
2126 }
2127 else {
2128 if (!(last->op_flags & OPf_KIDS)) {
2129 ((LISTOP*)last)->op_last = first;
2130 last->op_flags |= OPf_KIDS;
2131 }
2132 first->op_sibling = ((LISTOP*)last)->op_first;
2133 ((LISTOP*)last)->op_first = first;
79072805 2134 }
117dada2 2135 last->op_flags |= OPf_KIDS;
79072805
LW
2136 return last;
2137 }
2138
2139 return newLISTOP(type, 0, first, last);
2140}
2141
2142/* Constructors */
2143
2144OP *
864dbfa3 2145Perl_newNULLLIST(pTHX)
79072805 2146{
8990e307
LW
2147 return newOP(OP_STUB, 0);
2148}
2149
2150OP *
864dbfa3 2151Perl_force_list(pTHX_ OP *o)
8990e307 2152{
11343788
MB
2153 if (!o || o->op_type != OP_LIST)
2154 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2155 op_null(o);
11343788 2156 return o;
79072805
LW
2157}
2158
2159OP *
864dbfa3 2160Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2161{
2162 LISTOP *listop;
2163
b7dc083c 2164 NewOp(1101, listop, 1, LISTOP);
79072805 2165
eb160463 2166 listop->op_type = (OPCODE)type;
22c35a8c 2167 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
2168 if (first || last)
2169 flags |= OPf_KIDS;
eb160463 2170 listop->op_flags = (U8)flags;
79072805
LW
2171
2172 if (!last && first)
2173 last = first;
2174 else if (!first && last)
2175 first = last;
8990e307
LW
2176 else if (first)
2177 first->op_sibling = last;
79072805
LW
2178 listop->op_first = first;
2179 listop->op_last = last;
8990e307
LW
2180 if (type == OP_LIST) {
2181 OP* pushop;
2182 pushop = newOP(OP_PUSHMARK, 0);
2183 pushop->op_sibling = first;
2184 listop->op_first = pushop;
2185 listop->op_flags |= OPf_KIDS;
2186 if (!last)
2187 listop->op_last = pushop;
2188 }
79072805 2189
463d09e6 2190 return CHECKOP(type, listop);
79072805
LW
2191}
2192
2193OP *
864dbfa3 2194Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2195{
11343788 2196 OP *o;
b7dc083c 2197 NewOp(1101, o, 1, OP);
eb160463 2198 o->op_type = (OPCODE)type;
22c35a8c 2199 o->op_ppaddr = PL_ppaddr[type];
eb160463 2200 o->op_flags = (U8)flags;
79072805 2201
11343788 2202 o->op_next = o;
eb160463 2203 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2204 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2205 scalar(o);
22c35a8c 2206 if (PL_opargs[type] & OA_TARGET)
11343788
MB
2207 o->op_targ = pad_alloc(type, SVs_PADTMP);
2208 return CHECKOP(type, o);
79072805
LW
2209}
2210
2211OP *
864dbfa3 2212Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW
2213{
2214 UNOP *unop;
2215
93a17b20 2216 if (!first)
aeea060c 2217 first = newOP(OP_STUB, 0);
22c35a8c 2218 if (PL_opargs[type] & OA_MARK)
8990e307 2219 first = force_list(first);
93a17b20 2220
b7dc083c 2221 NewOp(1101, unop, 1, UNOP);
eb160463 2222 unop->op_type = (OPCODE)type;
22c35a8c 2223 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2224 unop->op_first = first;
2225 unop->op_flags = flags | OPf_KIDS;
eb160463 2226 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2227 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
2228 if (unop->op_next)
2229 return (OP*)unop;
2230
a0d0e21e 2231 return fold_constants((OP *) unop);
79072805
LW
2232}
2233
2234OP *
864dbfa3 2235Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2236{
2237 BINOP *binop;
b7dc083c 2238 NewOp(1101, binop, 1, BINOP);
79072805
LW
2239
2240 if (!first)
2241 first = newOP(OP_NULL, 0);
2242
eb160463 2243 binop->op_type = (OPCODE)type;
22c35a8c 2244 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2245 binop->op_first = first;
2246 binop->op_flags = flags | OPf_KIDS;
2247 if (!last) {
2248 last = first;
eb160463 2249 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW
2250 }
2251 else {
eb160463 2252 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW
2253 first->op_sibling = last;
2254 }
2255
e50aee73 2256 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2257 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW
2258 return (OP*)binop;
2259
7284ab6f 2260 binop->op_last = binop->op_first->op_sibling;
79072805 2261
a0d0e21e 2262 return fold_constants((OP *)binop);
79072805
LW
2263}
2264
a0ed51b3 2265static int
2b9d42f0
NIS
2266uvcompare(const void *a, const void *b)
2267{
2268 if (*((UV *)a) < (*(UV *)b))
2269 return -1;
2270 if (*((UV *)a) > (*(UV *)b))
2271 return 1;
2272 if (*((UV *)a+1) < (*(UV *)b+1))
2273 return -1;
2274 if (*((UV *)a+1) > (*(UV *)b+1))
2275 return 1;
a0ed51b3
LW
2276 return 0;
2277}
2278
79072805 2279OP *
864dbfa3 2280Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2281{
79072805
LW
2282 SV *tstr = ((SVOP*)expr)->op_sv;
2283 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW
2284 STRLEN tlen;
2285 STRLEN rlen;
9b877dbb
IH
2286 U8 *t = (U8*)SvPV(tstr, tlen);
2287 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW
2288 register I32 i;
2289 register I32 j;
a0ed51b3 2290 I32 del;
79072805 2291 I32 complement;
5d06d08e 2292 I32 squash;
9b877dbb 2293 I32 grows = 0;
79072805
LW
2294 register short *tbl;
2295
800b4dc4 2296 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2297 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2298 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2299 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2300
036b4402
GS
2301 if (SvUTF8(tstr))
2302 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS
2303
2304 if (SvUTF8(rstr))
036b4402 2305 o->op_private |= OPpTRANS_TO_UTF;
79072805 2306
a0ed51b3 2307 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2308 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW
2309 SV* transv = 0;
2310 U8* tend = t + tlen;
2311 U8* rend = r + rlen;
ba210ebe 2312 STRLEN ulen;
84c133a0
RB
2313 UV tfirst = 1;
2314 UV tlast = 0;
2315 IV tdiff;
2316 UV rfirst = 1;
2317 UV rlast = 0;
2318 IV rdiff;
2319 IV diff;
a0ed51b3
LW
2320 I32 none = 0;
2321 U32 max = 0;
2322 I32 bits;
a0ed51b3 2323 I32 havefinal = 0;
9c5ffd7c 2324 U32 final = 0;
a0ed51b3
LW
2325 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2326 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH
2327 U8* tsave = NULL;
2328 U8* rsave = NULL;
2329
2330 if (!from_utf) {
2331 STRLEN len = tlen;
2332 tsave = t = bytes_to_utf8(t, &len);
2333 tend = t + len;
2334 }
2335 if (!to_utf && rlen) {
2336 STRLEN len = rlen;
2337 rsave = r = bytes_to_utf8(r, &len);
2338 rend = r + len;
2339 }
a0ed51b3 2340
2b9d42f0
NIS
2341/* There are several snags with this code on EBCDIC:
2342 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2343 2. scan_const() in toke.c has encoded chars in native encoding which makes
2344 ranges at least in EBCDIC 0..255 range the bottom odd.
2345*/
2346
a0ed51b3 2347 if (complement) {
ad391ad9 2348 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2349 UV *cp;
a0ed51b3 2350 UV nextmin = 0;
2b9d42f0 2351 New(1109, cp, 2*tlen, UV);
a0ed51b3 2352 i = 0;
79cb57f6 2353 transv = newSVpvn("",0);
a0ed51b3 2354 while (t < tend) {
2b9d42f0
NIS
2355 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2356 t += ulen;
2357 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2358 t++;
2b9d42f0
NIS
2359 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2360 t += ulen;
a0ed51b3 2361 }
2b9d42f0
NIS
2362 else {
2363 cp[2*i+1] = cp[2*i];
2364 }
2365 i++;
a0ed51b3 2366 }
2b9d42f0 2367 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2368 for (j = 0; j < i; j++) {
2b9d42f0 2369 UV val = cp[2*j];
a0ed51b3
LW
2370 diff = val - nextmin;
2371 if (diff > 0) {
9041c2e3 2372 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2373 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2374 if (diff > 1) {
2b9d42f0 2375 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2376 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2377 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2378 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW
2379 }
2380 }
2b9d42f0 2381 val = cp[2*j+1];
a0ed51b3
LW
2382 if (val >= nextmin)
2383 nextmin = val + 1;
2384 }
9041c2e3 2385 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2386 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS
2387 {
2388 U8 range_mark = UTF_TO_NATIVE(0xff);
2389 sv_catpvn(transv, (char *)&range_mark, 1);
2390 }
b851fbc1
JH
2391 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2392 UNICODE_ALLOW_SUPER);
dfe13c55
GS
2393 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2394 t = (U8*)SvPVX(transv);
a0ed51b3
LW
2395 tlen = SvCUR(transv);
2396 tend = t + tlen;
455d824a 2397 Safefree(cp);
a0ed51b3
LW
2398 }
2399 else if (!rlen && !del) {
2400 r = t; rlen = tlen; rend = tend;
4757a243
LW
2401 }
2402 if (!squash) {
05d340b8 2403 if ((!rlen && !del) || t == r ||
12ae5dfc 2404 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2405 {
4757a243 2406 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2407 }
a0ed51b3
LW
2408 }
2409
2410 while (t < tend || tfirst <= tlast) {
2411 /* see if we need more "t" chars */
2412 if (tfirst > tlast) {
9041c2e3 2413 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2414 t += ulen;
2b9d42f0 2415 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2416 t++;
9041c2e3 2417 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW
2418 t += ulen;
2419 }
2420 else
2421 tlast = tfirst;
2422 }
2423
2424 /* now see if we need more "r" chars */
2425 if (rfirst > rlast) {
2426 if (r < rend) {
9041c2e3 2427 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2428 r += ulen;
2b9d42f0 2429 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2430 r++;
9041c2e3 2431 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW
2432 r += ulen;
2433 }
2434 else
2435 rlast = rfirst;
2436 }
2437 else {
2438 if (!havefinal++)
2439 final = rlast;
2440 rfirst = rlast = 0xffffffff;
2441 }
2442 }
2443
2444 /* now see which range will peter our first, if either. */
2445 tdiff = tlast - tfirst;
2446 rdiff = rlast - rfirst;
2447
2448 if (tdiff <= rdiff)
2449 diff = tdiff;
2450 else
2451 diff = rdiff;
2452
2453 if (rfirst == 0xffffffff) {
2454 diff = tdiff; /* oops, pretend rdiff is infinite */
2455 if (diff > 0)
894356b3
GS
2456 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2457 (long)tfirst, (long)tlast);
a0ed51b3 2458 else
894356b3 2459 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW
2460 }
2461 else {
2462 if (diff > 0)
894356b3
GS
2463 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2464 (long)tfirst, (long)(tfirst + diff),
2465 (long)rfirst);
a0ed51b3 2466 else
894356b3
GS
2467 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2468 (long)tfirst, (long)rfirst);
a0ed51b3
LW
2469
2470 if (rfirst + diff > max)
2471 max = rfirst + diff;
9b877dbb 2472 if (!grows)
45005bfb
JH
2473 grows = (tfirst < rfirst &&
2474 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2475 rfirst += diff + 1;
a0ed51b3
LW
2476 }
2477 tfirst += diff + 1;
2478 }
2479
2480 none = ++max;
2481 if (del)
2482 del = ++max;
2483
2484 if (max > 0xffff)
2485 bits = 32;
2486 else if (max > 0xff)
2487 bits = 16;
2488 else
2489 bits = 8;
2490
455d824a 2491 Safefree(cPVOPo->op_pv);
a0ed51b3
LW
2492 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2493 SvREFCNT_dec(listsv);
2494 if (transv)
2495 SvREFCNT_dec(transv);
2496
45005bfb 2497 if (!del && havefinal && rlen)
b448e4fe
JH
2498 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2499 newSVuv((UV)final), 0);
a0ed51b3 2500
9b877dbb 2501 if (grows)
a0ed51b3
LW
2502 o->op_private |= OPpTRANS_GROWS;
2503
9b877dbb
IH
2504 if (tsave)
2505 Safefree(tsave);
2506 if (rsave)
2507 Safefree(rsave);
2508
a0ed51b3
LW
2509 op_free(expr);
2510 op_free(repl);
2511 return o;
2512 }
2513
2514 tbl = (short*)cPVOPo->op_pv;
79072805
LW
2515 if (complement) {
2516 Zero(tbl, 256, short);
eb160463 2517 for (i = 0; i < (I32)tlen; i++)
ec49126f 2518 tbl[t[i]] = -1;
79072805
LW
2519 for (i = 0, j = 0; i < 256; i++) {
2520 if (!tbl[i]) {
eb160463 2521 if (j >= (I32)rlen) {
a0ed51b3 2522 if (del)
79072805
LW
2523 tbl[i] = -2;
2524 else if (rlen)
ec49126f 2525 tbl[i] = r[j-1];
79072805 2526 else
eb160463 2527 tbl[i] = (short)i;
79072805 2528 }
9b877dbb
IH
2529 else {
2530 if (i < 128 && r[j] >= 128)
2531 grows = 1;
ec49126f 2532 tbl[i] = r[j++];
9b877dbb 2533 }
79072805
LW
2534 }
2535 }
05d340b8
JH
2536 if (!del) {
2537 if (!rlen) {
2538 j = rlen;
2539 if (!squash)
2540 o->op_private |= OPpTRANS_IDENTICAL;
2541 }
eb160463 2542 else if (j >= (I32)rlen)
05d340b8
JH
2543 j = rlen - 1;
2544 else
2545 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 2546 tbl[0x100] = rlen - j;
eb160463 2547 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH
2548 tbl[0x101+i] = r[j+i];
2549 }
79072805
LW
2550 }
2551 else {
a0ed51b3 2552 if (!rlen && !del) {
79072805 2553 r = t; rlen = tlen;
5d06d08e 2554 if (!squash)
4757a243 2555 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2556 }
94bfe852
RGS
2557 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2558 o->op_private |= OPpTRANS_IDENTICAL;
2559 }
79072805
LW
2560 for (i = 0; i < 256; i++)
2561 tbl[i] = -1;
eb160463
GS
2562 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2563 if (j >= (I32)rlen) {
a0ed51b3 2564 if (del) {
ec49126f
PP
2565 if (tbl[t[i]] == -1)
2566 tbl[t[i]] = -2;
79072805
LW
2567 continue;
2568 }
2569 --j;
2570 }
9b877dbb
IH
2571 if (tbl[t[i]] == -1) {
2572 if (t[i] < 128 && r[j] >= 128)
2573 grows = 1;
ec49126f 2574 tbl[t[i]] = r[j];
9b877dbb 2575 }
79072805
LW
2576 }
2577 }
9b877dbb
IH
2578 if (grows)
2579 o->op_private |= OPpTRANS_GROWS;
79072805
LW
2580 op_free(expr);
2581 op_free(repl);
2582
11343788 2583 return o;
79072805
LW
2584}
2585
2586OP *
864dbfa3 2587Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW
2588{
2589 PMOP *pmop;
2590
b7dc083c 2591 NewOp(1101, pmop, 1, PMOP);
eb160463 2592 pmop->op_type = (OPCODE)type;
22c35a8c 2593 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS
2594 pmop->op_flags = (U8)flags;
2595 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2596
3280af22 2597 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2598 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2599 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS
2600 pmop->op_pmpermflags |= PMf_LOCALE;
2601 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2602
debc9467 2603#ifdef USE_ITHREADS
13137afc
AB
2604 {
2605 SV* repointer;
2606 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2607 repointer = av_pop((AV*)PL_regex_pad[0]);
2608 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2609 SvREPADTMP_off(repointer);
13137afc 2610 sv_setiv(repointer,0);
1eb1540c 2611 } else {
13137afc
AB
2612 repointer = newSViv(0);
2613 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2614 pmop->op_pmoffset = av_len(PL_regex_padav);
2615 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2616 }
13137afc 2617 }
debc9467 2618#endif
1eb1540c 2619
1fcf4c12 2620 /* link into pm list */
3280af22
NIS
2621 if (type != OP_TRANS && PL_curstash) {
2622 pmop->op_pmnext = HvPMROOT(PL_curstash);
2623 HvPMROOT(PL_curstash) = pmop;
cb55de95 2624 PmopSTASH_set(pmop,PL_curstash);
79072805
LW
2625 }
2626
463d09e6 2627 return CHECKOP(type, pmop);
79072805
LW
2628}
2629
2630OP *
864dbfa3 2631Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW
2632{
2633 PMOP *pm;
2634 LOGOP *rcop;
ce862d02 2635 I32 repl_has_vars = 0;
79072805 2636
11343788
MB
2637 if (o->op_type == OP_TRANS)
2638 return pmtrans(o, expr, repl);
79072805 2639
3280af22 2640 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2641 pm = (PMOP*)o;
79072805
LW
2642
2643 if (expr->op_type == OP_CONST) {
463ee0b2 2644 STRLEN plen;
79072805 2645 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2646 char *p = SvPV(pat, plen);
11343788 2647 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2648 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2649 p = SvPV(pat, plen);
79072805
LW
2650 pm->op_pmflags |= PMf_SKIPWHITE;
2651 }
5b71a6a7 2652 if (DO_UTF8(pat))
a5961de5 2653 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS
2654 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2655 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2656 pm->op_pmflags |= PMf_WHITE;
79072805
LW
2657 op_free(expr);
2658 }
2659 else {
3280af22 2660 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2661 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
2662 ? OP_REGCRESET
2663 : OP_REGCMAYBE),0,expr);
463ee0b2 2664
b7dc083c 2665 NewOp(1101, rcop, 1, LOGOP);
79072805 2666 rcop->op_type = OP_REGCOMP;
22c35a8c 2667 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2668 rcop->op_first = scalar(expr);
1c846c1f 2669 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
2670 ? (OPf_SPECIAL | OPf_KIDS)
2671 : OPf_KIDS);
79072805 2672 rcop->op_private = 1;
11343788 2673 rcop->op_other = o;
b5c19bd7
DM
2674 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2675 PL_cv_has_eval = 1;
79072805
LW
2676
2677 /* establish postfix order */
3280af22 2678 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW
2679 LINKLIST(expr);
2680 rcop->op_next = expr;
2681 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2682 }
2683 else {
2684 rcop->op_next = LINKLIST(expr);
2685 expr->op_next = (OP*)rcop;
2686 }
79072805 2687
11343788 2688 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW
2689 }
2690
2691 if (repl) {
748a9306 2692 OP *curop;
0244c3a4 2693 if (pm->op_pmflags & PMf_EVAL) {
748a9306 2694 curop = 0;
8bafa735 2695 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2696 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2697 }
748a9306
LW
2698 else if (repl->op_type == OP_CONST)
2699 curop = repl;
79072805 2700 else {
79072805
LW
2701 OP *lastop = 0;
2702 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2703 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2704 if (curop->op_type == OP_GV) {
638eceb6 2705 GV *gv = cGVOPx_gv(curop);
ce862d02 2706 repl_has_vars = 1;
f702bf4a 2707 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW
2708 break;
2709 }
2710 else if (curop->op_type == OP_RV2CV)
2711 break;
2712 else if (curop->op_type == OP_RV2SV ||
2713 curop->op_type == OP_RV2AV ||
2714 curop->op_type == OP_RV2HV ||
2715 curop->op_type == OP_RV2GV) {
2716 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2717 break;
2718 }
748a9306
LW
2719 else if (curop->op_type == OP_PADSV ||
2720 curop->op_type == OP_PADAV ||
2721 curop->op_type == OP_PADHV ||
554b3eca 2722 curop->op_type == OP_PADANY) {
ce862d02 2723 repl_has_vars = 1;
748a9306 2724 }
1167e5da
SM
2725 else if (curop->op_type == OP_PUSHRE)
2726 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW
2727 else
2728 break;
2729 }
2730 lastop = curop;
2731 }
748a9306 2732 }
ce862d02 2733 if (curop == repl
1c846c1f 2734 && !(repl_has_vars
aaa362c4
RS
2735 && (!PM_GETRE(pm)
2736 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2737 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2738 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2739 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW
2740 }
2741 else {
aaa362c4 2742 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ
2743 pm->op_pmflags |= PMf_MAYBE_CONST;
2744 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2745 }
b7dc083c 2746 NewOp(1101, rcop, 1, LOGOP);
748a9306 2747 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2748 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW
2749 rcop->op_first = scalar(repl);
2750 rcop->op_flags |= OPf_KIDS;
2751 rcop->op_private = 1;
11343788 2752 rcop->op_other = o;
748a9306
LW
2753
2754 /* establish postfix order */
2755 rcop->op_next = LINKLIST(repl);
2756 repl->op_next = (OP*)rcop;
2757
2758 pm->op_pmreplroot = scalar((OP*)rcop);
2759 pm->op_pmreplstart = LINKLIST(rcop);
2760 rcop->op_next = 0;
79072805
LW
2761 }
2762 }
2763
2764 return (OP*)pm;
2765}
2766
2767OP *
864dbfa3 2768Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW
2769{
2770 SVOP *svop;
b7dc083c 2771 NewOp(1101, svop, 1, SVOP);
eb160463 2772 svop->op_type = (OPCODE)type;
22c35a8c 2773 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2774 svop->op_sv = sv;
2775 svop->op_next = (OP*)svop;
eb160463 2776 svop->op_flags = (U8)flags;
22c35a8c 2777 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2778 scalar((OP*)svop);
22c35a8c 2779 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2780 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2781 return CHECKOP(type, svop);
79072805
LW
2782}
2783
2784OP *
350de78d
GS
2785Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2786{
2787 PADOP *padop;
2788 NewOp(1101, padop, 1, PADOP);
eb160463 2789 padop->op_type = (OPCODE)type;
350de78d
GS
2790 padop->op_ppaddr = PL_ppaddr[type];
2791 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM
2792 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2793 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS
2794 if (sv)
2795 SvPADTMP_on(sv);
350de78d 2796 padop->op_next = (OP*)padop;
eb160463 2797 padop->op_flags = (U8)flags;
350de78d
GS
2798 if (PL_opargs[type] & OA_RETSCALAR)
2799 scalar((OP*)padop);
2800 if (PL_opargs[type] & OA_TARGET)
2801 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2802 return CHECKOP(type, padop);
2803}
2804
2805OP *
864dbfa3 2806Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 2807{
350de78d 2808#ifdef USE_ITHREADS
ce50c033
AMS
2809 if (gv)
2810 GvIN_PAD_on(gv);
350de78d
GS
2811 return newPADOP(type, flags, SvREFCNT_inc(gv));
2812#else
7934575e 2813 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 2814#endif
79072805
LW
2815}
2816
2817OP *
864dbfa3 2818Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW
2819{
2820 PVOP *pvop;
b7dc083c 2821 NewOp(1101, pvop, 1, PVOP);
eb160463 2822 pvop->op_type = (OPCODE)type;
22c35a8c 2823 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2824 pvop->op_pv = pv;
2825 pvop->op_next = (OP*)pvop;
eb160463 2826 pvop->op_flags = (U8)flags;
22c35a8c 2827 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2828 scalar((OP*)pvop);
22c35a8c 2829 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2830 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2831 return CHECKOP(type, pvop);
79072805
LW
2832}
2833
79072805 2834void
864dbfa3 2835Perl_package(pTHX_ OP *o)
79072805 2836{
de11ba31
AMS
2837 char *name;
2838 STRLEN len;
79072805 2839
3280af22
NIS
2840 save_hptr(&PL_curstash);
2841 save_item(PL_curstname);
de11ba31
AMS
2842
2843 name = SvPV(cSVOPo->op_sv, len);
2844 PL_curstash = gv_stashpvn(name, len, TRUE);
2845 sv_setpvn(PL_curstname, name, len);
2846 op_free(o);
2847
7ad382f4 2848 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
2849 PL_copline = NOLINE;
2850 PL_expect = XSTATE;
79072805
LW
2851}
2852
85e6fe83 2853void
88d95a4d 2854Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 2855{
a0d0e21e 2856 OP *pack;
a0d0e21e 2857 OP *imop;
b1cb66bf 2858 OP *veop;
85e6fe83 2859
88d95a4d 2860 if (idop->op_type != OP_CONST)
cea2e8a9 2861 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 2862
b1cb66bf
PP
2863 veop = Nullop;
2864
0f79a09d 2865 if (version != Nullop) {
b1cb66bf
PP
2866 SV *vesv = ((SVOP*)version)->op_sv;
2867
44dcb63b 2868 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf
PP
2869 arg = version;
2870 }
2871 else {
2872 OP *pack;
0f79a09d 2873 SV *meth;
b1cb66bf 2874
44dcb63b 2875 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 2876 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 2877
88d95a4d
JH
2878 /* Make copy of idop so we don't free it twice */
2879 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf
PP
2880
2881 /* Fake up a method call to VERSION */
0f79a09d
GS
2882 meth = newSVpvn("VERSION",7);
2883 sv_upgrade(meth, SVt_PVIV);
155aba94 2884 (void)SvIOK_on(meth);
5afd6d42 2885 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf
PP
2886 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2887 append_elem(OP_LIST,
0f79a09d
GS
2888 prepend_elem(OP_LIST, pack, list(version)),
2889 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf
PP
2890 }
2891 }
aeea060c 2892
a0d0e21e 2893 /* Fake up an import/unimport */
4633a7c4
LW
2894 if (arg && arg->op_type == OP_STUB)
2895 imop = arg; /* no import on explicit () */
88d95a4d 2896 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf
PP
2897 imop = Nullop; /* use 5.0; */
2898 }
4633a7c4 2899 else {
0f79a09d
GS
2900 SV *meth;
2901
88d95a4d
JH
2902 /* Make copy of idop so we don't free it twice */
2903 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS
2904
2905 /* Fake up a method call to import/unimport */
b47cad08 2906 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 2907 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 2908 (void)SvIOK_on(meth);
5afd6d42 2909 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 2910 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS
2911 append_elem(OP_LIST,
2912 prepend_elem(OP_LIST, pack, list(arg)),
2913 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW
2914 }
2915
a0d0e21e 2916 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 2917 newATTRSUB(floor,
79cb57f6 2918 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 2919 Nullop,
09bef843 2920 Nullop,
a0d0e21e 2921 append_elem(OP_LINESEQ,
b1cb66bf 2922 append_elem(OP_LINESEQ,
88d95a4d 2923 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 2924 newSTATEOP(0, Nullch, veop)),
a0d0e21e 2925 newSTATEOP(0, Nullch, imop) ));
85e6fe83 2926
70f5e4ed
JH
2927 /* The "did you use incorrect case?" warning used to be here.
2928 * The problem is that on case-insensitive filesystems one
2929 * might get false positives for "use" (and "require"):
2930 * "use Strict" or "require CARP" will work. This causes
2931 * portability problems for the script: in case-strict
2932 * filesystems the script will stop working.
2933 *
2934 * The "incorrect case" warning checked whether "use Foo"
2935 * imported "Foo" to your namespace, but that is wrong, too:
2936 * there is no requirement nor promise in the language that
2937 * a Foo.pm should or would contain anything in package "Foo".
2938 *
2939 * There is very little Configure-wise that can be done, either:
2940 * the case-sensitivity of the build filesystem of Perl does not
2941 * help in guessing the case-sensitivity of the runtime environment.
2942 */
18fc9488 2943
c305c6a0 2944 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
2945 PL_copline = NOLINE;
2946 PL_expect = XSTATE;
8ec8fbef 2947 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW
2948}
2949
7d3fb230 2950/*
ccfc67b7
JH
2951=head1 Embedding Functions
2952
7d3fb230
BS
2953=for apidoc load_module
2954
2955Loads the module whose name is pointed to by the string part of name.
2956Note that the actual module name, not its filename, should be given.
2957Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2958PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2959(or 0 for no flags). ver, if specified, provides version semantics
2960similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2961arguments can be used to specify arguments to the module's import()
2962method, similar to C<use Foo::Bar VERSION LIST>.
2963
2964=cut */
2965
e4783991
GS
2966void
2967Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2968{
2969 va_list args;
2970 va_start(args, ver);
2971 vload_module(flags, name, ver, &args);
2972 va_end(args);
2973}
2974
2975#ifdef PERL_IMPLICIT_CONTEXT
2976void
2977Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2978{
2979 dTHX;
2980 va_list args;
2981 va_start(args, ver);
2982 vload_module(flags, name, ver, &args);
2983 va_end(args);
2984}
2985#endif
2986
2987void
2988Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2989{
2990 OP *modname, *veop, *imop;
2991
2992 modname = newSVOP(OP_CONST, 0, name);
2993 modname->op_private |= OPpCONST_BARE;
2994 if (ver) {
2995 veop = newSVOP(OP_CONST, 0, ver);
2996 }
2997 else
2998 veop = Nullop;
2999 if (flags & PERL_LOADMOD_NOIMPORT) {
3000 imop = sawparens(newNULLLIST());
3001 }
3002 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3003 imop = va_arg(*args, OP*);
3004 }
3005 else {
3006 SV *sv;
3007 imop = Nullop;
3008 sv = va_arg(*args, SV*);
3009 while (sv) {
3010 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3011 sv = va_arg(*args, SV*);
3012 }
3013 }
81885997
GS
3014 {
3015 line_t ocopline = PL_copline;
834a3ffa 3016 COP *ocurcop = PL_curcop;
81885997
GS
3017 int oexpect = PL_expect;
3018
3019 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3020 veop, modname, imop);
3021 PL_expect = oexpect;
3022 PL_copline = ocopline;
834a3ffa 3023 PL_curcop = ocurcop;
81885997 3024 }
e4783991
GS
3025}
3026
79072805 3027OP *
864dbfa3 3028Perl_dofile(pTHX_ OP *term)
78ca652e
GS
3029{
3030 OP *doop;
3031 GV *gv;
3032
3033 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3034 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS
3035 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3036
b9f751c0 3037 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS
3038 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3039 append_elem(OP_LIST, term,
3040 scalar(newUNOP(OP_RV2CV, 0,
3041 newGVOP(OP_GV, 0,
3042 gv))))));
3043 }
3044 else {
3045 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3046 }
3047 return doop;
3048}
3049
3050OP *
864dbfa3 3051Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW
3052{
3053 return newBINOP(OP_LSLICE, flags,
8990e307
LW
3054 list(force_list(subscript)),
3055 list(force_list(listval)) );
79072805
LW
3056}
3057
76e3520e 3058STATIC I32
cea2e8a9 3059S_list_assignment(pTHX_ register OP *o)
79072805 3060{
11343788 3061 if (!o)
79072805
LW
3062 return TRUE;
3063
11343788
MB
3064 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3065 o = cUNOPo->op_first;
79072805 3066
11343788 3067 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM
3068 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3069 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW
3070
3071 if (t && f)
3072 return TRUE;
3073 if (t || f)
3074 yyerror("Assignment to both a list and a scalar");
3075 return FALSE;
3076 }
3077
95f0a2f1
SB
3078 if (o->op_type == OP_LIST &&
3079 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3080 o->op_private & OPpLVAL_INTRO)
3081 return FALSE;
3082
11343788
MB
3083 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3084 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3085 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW
3086 return TRUE;
3087
11343788 3088 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW
3089 return TRUE;
3090
11343788 3091 if (o->op_type == OP_RV2SV)
79072805
LW
3092 return FALSE;
3093
3094 return FALSE;
3095}
3096
3097OP *
864dbfa3 3098Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3099{
11343788 3100 OP *o;
79072805 3101
a0d0e21e 3102 if (optype) {
c963b151 3103 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW
3104 return newLOGOP(optype, 0,
3105 mod(scalar(left), optype),
3106 newUNOP(OP_SASSIGN, 0, scalar(right)));
3107 }
3108 else {
3109 return newBINOP(optype, OPf_STACKED,
3110 mod(scalar(left), optype), scalar(right));
3111 }
3112 }
3113
79072805 3114 if (list_assignment(left)) {
10c8fecd
GS
3115 OP *curop;
3116
3280af22
NIS
3117 PL_modcount = 0;
3118 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3119 left = mod(left, OP_AASSIGN);
3280af22
NIS
3120 if (PL_eval_start)
3121 PL_eval_start = 0;
748a9306 3122 else {
a0d0e21e
LW
3123 op_free(left);
3124 op_free(right);
3125 return Nullop;
3126 }
10c8fecd
GS
3127 curop = list(force_list(left));
3128 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3129 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM
3130
3131 /* PL_generation sorcery:
3132 * an assignment like ($a,$b) = ($c,$d) is easier than
3133 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3134 * To detect whether there are common vars, the global var
3135 * PL_generation is incremented for each assign op we compile.
3136 * Then, while compiling the assign op, we run through all the
3137 * variables on both sides of the assignment, setting a spare slot
3138 * in each of them to PL_generation. If any of them already have
3139 * that value, we know we've got commonality. We could use a
3140 * single bit marker, but then we'd have to make 2 passes, first
3141 * to clear the flag, then to test and set it. To find somewhere
3142 * to store these values, evil chicanery is done with SvCUR().
3143 */
3144
a0d0e21e 3145 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3146 OP *lastop = o;
3280af22 3147 PL_generation++;
11343788 3148 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3149 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3150 if (curop->op_type == OP_GV) {
638eceb6 3151 GV *gv = cGVOPx_gv(curop);
eb160463 3152 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3153 break;
3280af22 3154 SvCUR(gv) = PL_generation;
79072805 3155 }
748a9306
LW
3156 else if (curop->op_type == OP_PADSV ||
3157 curop->op_type == OP_PADAV ||
3158 curop->op_type == OP_PADHV ||
dd2155a4
DM
3159 curop->op_type == OP_PADANY)
3160 {
3161 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3162 == (STRLEN)PL_generation)
748a9306 3163 break;
dd2155a4
DM
3164 PAD_COMPNAME_GEN(curop->op_targ)
3165 = PL_generation;
3166
748a9306 3167 }
79072805
LW
3168 else if (curop->op_type == OP_RV2CV)
3169 break;
3170 else if (curop->op_type == OP_RV2SV ||
3171 curop->op_type == OP_RV2AV ||
3172 curop->op_type == OP_RV2HV ||
3173 curop->op_type == OP_RV2GV) {
3174 if (lastop->op_type != OP_GV) /* funny deref? */
3175 break;
3176 }
1167e5da
SM
3177 else if (curop->op_type == OP_PUSHRE) {
3178 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3179#ifdef USE_ITHREADS
dd2155a4
DM
3180 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3181 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3182#else
1167e5da 3183 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3184#endif
eb160463 3185 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3186 break;
3280af22 3187 SvCUR(gv) = PL_generation;
b2ffa427 3188 }
1167e5da 3189 }
79072805
LW
3190 else
3191 break;
3192 }
3193 lastop = curop;
3194 }
11343788 3195 if (curop != o)
10c8fecd 3196 o->op_private |= OPpASSIGN_COMMON;
79072805 3197 }
c07a80fd
PP
3198 if (right && right->op_type == OP_SPLIT) {
3199 OP* tmpop;
3200 if ((tmpop = ((LISTOP*)right)->op_first) &&
3201 tmpop->op_type == OP_PUSHRE)
3202 {
3203 PMOP *pm = (PMOP*)tmpop;
3204 if (left->op_type == OP_RV2AV &&
3205 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3206 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd
PP
3207 {
3208 tmpop = ((UNOP*)left)->op_first;
3209 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3210#ifdef USE_ITHREADS
ba89bb6e 3211 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS
3212 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3213#else
3214 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3215 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3216#endif
c07a80fd 3217 pm->op_pmflags |= PMf_ONCE;
11343788 3218 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd
PP
3219 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3220 tmpop->op_sibling = Nullop; /* don't free split */
3221 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3222 op_free(o); /* blow off assign */
54310121 3223 right->op_flags &= ~OPf_WANT;
a5f75d66 3224 /* "I don't know and I don't care." */
c07a80fd
PP
3225 return right;
3226 }
3227 }
3228 else {
e6438c1a 3229 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd
PP
3230 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3231 {
3232 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3233 if (SvIVX(sv) == 0)
3280af22 3234 sv_setiv(sv, PL_modcount+1);
c07a80fd
PP
3235 }
3236 }
3237 }
3238 }
11343788 3239 return o;
79072805
LW
3240 }
3241 if (!right)
3242 right = newOP(OP_UNDEF, 0);
3243 if (right->op_type == OP_READLINE) {
3244 right->op_flags |= OPf_STACKED;
463ee0b2 3245 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3246 }
a0d0e21e 3247 else {
3280af22 3248 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3249 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3250 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS
3251 if (PL_eval_start)
3252 PL_eval_start = 0;
748a9306 3253 else {
11343788 3254 op_free(o);
a0d0e21e
LW
3255 return Nullop;
3256 }
3257 }
11343788 3258 return o;
79072805
LW
3259}
3260
3261OP *
864dbfa3 3262Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3263{
bbce6d69 3264 U32 seq = intro_my();
79072805
LW
3265 register COP *cop;
3266
b7dc083c 3267 NewOp(1101, cop, 1, COP);
57843af0 3268 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3269 cop->op_type = OP_DBSTATE;
22c35a8c 3270 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW
3271 }
3272 else {
3273 cop->op_type = OP_NEXTSTATE;
22c35a8c 3274 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3275 }
eb160463
GS
3276 cop->op_flags = (U8)flags;
3277 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69
PP
3278#ifdef NATIVE_HINTS
3279 cop->op_private |= NATIVE_HINTS;
3280#endif
e24b16f9 3281 PL_compiling.op_private = cop->op_private;
79072805
LW
3282 cop->op_next = (OP*)cop;
3283
463ee0b2
LW
3284 if (label) {
3285 cop->cop_label = label;
3280af22 3286 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3287 }
bbce6d69 3288 cop->cop_seq = seq;
3280af22 3289 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3290 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3291 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3292 else
599cee73 3293 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS
3294 if (specialCopIO(PL_curcop->cop_io))
3295 cop->cop_io = PL_curcop->cop_io;
3296 else
3297 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3298
79072805 3299
3280af22 3300 if (PL_copline == NOLINE)
57843af0 3301 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3302 else {
57843af0 3303 CopLINE_set(cop, PL_copline);
3280af22 3304 PL_copline = NOLINE;
79072805 3305 }
57843af0 3306#ifdef USE_ITHREADS
f4dd75d9 3307 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3308#else
f4dd75d9 3309 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3310#endif
11faa288 3311 CopSTASH_set(cop, PL_curstash);
79072805 3312
3280af22 3313 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3314 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3315 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3316 (void)SvIOK_on(*svp);
57b2e452 3317 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3318 }
93a17b20
LW
3319 }
3320
11343788 3321 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW
3322}
3323
bbce6d69 3324
79072805 3325OP *
864dbfa3 3326Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3327{
883ffac3
CS
3328 return new_logop(type, flags, &first, &other);
3329}
3330
3bd495df 3331STATIC OP *
cea2e8a9 3332S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3333{
79072805 3334 LOGOP *logop;
11343788 3335 OP *o;
883ffac3
CS
3336 OP *first = *firstp;
3337 OP *other = *otherp;
79072805 3338
a0d0e21e
LW
3339 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3340 return newBINOP(type, flags, scalar(first), scalar(other));
3341
8990e307 3342 scalarboolean(first);
79072805
LW
3343 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3344 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3345 if (type == OP_AND || type == OP_OR) {
3346 if (type == OP_AND)
3347 type = OP_OR;
3348 else
3349 type = OP_AND;
11343788 3350 o = first;
883ffac3 3351 first = *firstp = cUNOPo->op_first;
11343788
MB
3352 if (o->op_next)
3353 first->op_next = o->op_next;
3354 cUNOPo->op_first = Nullop;
3355 op_free(o);
79072805
LW
3356 }
3357 }
3358 if (first->op_type == OP_CONST) {
39a440a3
DM
3359 if (first->op_private & OPpCONST_STRICT)
3360 no_bareword_allowed(first);
3361 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
989dfb19 3362 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
79072805
LW
3363 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3364 op_free(first);
883ffac3 3365 *firstp = Nullop;
79072805
LW
3366 return other;
3367 }
3368 else {
3369 op_free(other);
883ffac3 3370 *otherp = Nullop;
79072805
LW
3371 return first;
3372 }
3373 }
59e10468
RGS
3374 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3375 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3376 {
a6006777
PP
3377 OP *k1 = ((UNOP*)first)->op_first;
3378 OP *k2 = k1->op_sibling;
3379 OPCODE warnop = 0;
3380 switch (first->op_type)
3381 {
3382 case OP_NULL:
3383 if (k2 && k2->op_type == OP_READLINE
3384 && (k2->op_flags & OPf_STACKED)
1c846c1f 3385 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3386 {
a6006777 3387 warnop = k2->op_type;
72b16652 3388 }
a6006777
PP
3389 break;
3390
3391 case OP_SASSIGN:
68dc0745
PP
3392 if (k1->op_type == OP_READDIR
3393 || k1->op_type == OP_GLOB
72b16652 3394 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3395 || k1->op_type == OP_EACH)
72b16652
GS
3396 {
3397 warnop = ((k1->op_type == OP_NULL)
eb160463 3398 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3399 }
a6006777
PP
3400 break;
3401 }
8ebc5c01 3402 if (warnop) {
57843af0
GS
3403 line_t oldline = CopLINE(PL_curcop);
3404 CopLINE_set(PL_curcop, PL_copline);
9014280d 3405 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3406 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3407 PL_op_desc[warnop],
68dc0745
PP
3408 ((warnop == OP_READLINE || warnop == OP_GLOB)
3409 ? " construct" : "() operator"));
57843af0 3410 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3411 }
a6006777 3412 }
79072805
LW
3413
3414 if (!other)
3415 return first;
3416
c963b151 3417 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW
3418 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3419
b7dc083c 3420 NewOp(1101, logop, 1, LOGOP);
79072805 3421
eb160463 3422 logop->op_type = (OPCODE)type;
22c35a8c 3423 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW
3424 logop->op_first = first;
3425 logop->op_flags = flags | OPf_KIDS;
3426 logop->op_other = LINKLIST(other);
eb160463 3427 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW
3428
3429 /* establish postfix order */
3430 logop->op_next = LINKLIST(first);
3431 first->op_next = (OP*)logop;
3432 first->op_sibling = other;
3433
463d09e6
RGS
3434 CHECKOP(type,logop);
3435
11343788
MB
3436 o = newUNOP(OP_NULL, 0, (OP*)logop);
3437 other->op_next = o;
79072805 3438
11343788 3439 return o;
79072805
LW
3440}
3441
3442OP *
864dbfa3 3443Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3444{
1a67a97c
SM
3445 LOGOP *logop;
3446 OP *start;
11343788 3447 OP *o;
79072805 3448
b1cb66bf
PP
3449 if (!falseop)
3450 return newLOGOP(OP_AND, 0, first, trueop);
3451 if (!trueop)
3452 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3453
8990e307 3454 scalarboolean(first);
79072805 3455 if (first->op_type == OP_CONST) {
2bc6235c
K
3456 if (first->op_private & OPpCONST_BARE &&
3457 first->op_private & OPpCONST_STRICT) {
3458 no_bareword_allowed(first);
3459 }
79072805
LW
3460 if (SvTRUE(((SVOP*)first)->op_sv)) {
3461 op_free(first);
b1cb66bf
PP
3462 op_free(falseop);
3463 return trueop;
79072805
LW
3464 }
3465 else {
3466 op_free(first);
b1cb66bf
PP
3467 op_free(trueop);
3468 return falseop;
79072805
LW
3469 }
3470 }
1a67a97c
SM
3471 NewOp(1101, logop, 1, LOGOP);
3472 logop->op_type = OP_COND_EXPR;
3473 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3474 logop->op_first = first;
3475 logop->op_flags = flags | OPf_KIDS;
eb160463 3476 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM
3477 logop->op_other = LINKLIST(trueop);
3478 logop->op_next = LINKLIST(falseop);
79072805 3479
463d09e6
RGS
3480 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3481 logop);
79072805
LW
3482
3483 /* establish postfix order */
1a67a97c
SM
3484 start = LINKLIST(first);
3485 first->op_next = (OP*)logop;
79072805 3486
b1cb66bf
PP
3487 first->op_sibling = trueop;
3488 trueop->op_sibling = falseop;
1a67a97c 3489 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3490
1a67a97c 3491 trueop->op_next = falseop->op_next = o;
79072805 3492
1a67a97c 3493 o->op_next = start;
11343788 3494 return o;
79072805
LW
3495}
3496
3497OP *
864dbfa3 3498Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3499{
1a67a97c 3500 LOGOP *range;
79072805
LW
3501 OP *flip;
3502 OP *flop;
1a67a97c 3503 OP *leftstart;
11343788 3504 OP *o;
79072805 3505
1a67a97c 3506 NewOp(1101, range, 1, LOGOP);
79072805 3507
1a67a97c
SM
3508 range->op_type = OP_RANGE;
3509 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3510 range->op_first = left;
3511 range->op_flags = OPf_KIDS;
3512 leftstart = LINKLIST(left);
3513 range->op_other = LINKLIST(right);
eb160463 3514 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW
3515
3516 left->op_sibling = right;
3517
1a67a97c
SM
3518 range->op_next = (OP*)range;
3519 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3520 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3521 o = newUNOP(OP_NULL, 0, flop);
79072805 3522 linklist(flop);
1a67a97c 3523 range->op_next = leftstart;
79072805
LW
3524
3525 left->op_next = flip;
3526 right->op_next = flop;
3527
1a67a97c
SM
3528 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);