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