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