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