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