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