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