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