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
Upgrade to Unicode::Collate 0.27.
[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 {
6be89cf9
AE		 1832 if (o->op_type == OP_STUB) {
1833 PL_comppad_name = 0;
1834 PL_compcv = 0;
a0d0e21e 1835 return;
6be89cf9 1836 }
3280af22
NIS		 1837 PL_main_root = scope(sawparens(scalarvoid(o)));
1838 PL_curcop = &PL_compiling;
1839 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 1840 PL_main_root->op_private |= OPpREFCOUNTED;
1841 OpREFCNT_set(PL_main_root, 1);
3280af22 1842 PL_main_root->op_next = 0;
a2efc822 1843 CALL_PEEP(PL_main_start);
3280af22 1844 PL_compcv = 0;
3841441e 1845
4fdae800 1846 /* Register with debugger */
84902520 1847 if (PERLDB_INTER) {
864dbfa3 1848 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 1849 if (cv) {
1850 dSP;
924508f0 1851 PUSHMARK(SP);
cc49e20b 1852 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1853 PUTBACK;
864dbfa3 1854 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 1855 }
1856 }
79072805 1857 }
79072805
LW		 1858}
1859
1860OP *
864dbfa3 1861Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 1862{
1863 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 1864/* [perl #17376]: this appears to be premature, and results in code such as
1865 C< our(%x); > executing in list mode rather than void mode */
1866#if 0
79072805 1867 list(o);
d2be0de5
YST		 1868#else
1869 ;
1870#endif
8990e307 1871 else {
64420d0d
JH		 1872 if (ckWARN(WARN_PARENTHESIS)
1873 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1874 {
1875 char *s = PL_bufptr;
8473848f 1876 int sigil = 0;
64420d0d 1877
8473848f
RGS		 1878 /* some heuristics to detect a potential error */
1879 while (*s && (strchr(", \t\n", *s)
1880 || (strchr("@$%*", *s) && ++sigil) ))
64420d0d 1881 s++;
8473848f
RGS		 1882 if (sigil) {
1883 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1884 || strchr("@$%*, \t\n", *s)))
1885 s++;
1886
1887 if (*s == ';' || *s == '=')
1888 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1889 "Parentheses missing around \"%s\" list",
1890 lex ? (PL_in_my == KEY_our ? "our" : "my")
1891 : "local");
1892 }
8990e307
LW		 1893 }
1894 }
93a17b20 1895 if (lex)
eb64745e 1896 o = my(o);
93a17b20 1897 else
eb64745e
GS		 1898 o = mod(o, OP_NULL); /* a bit kludgey */
1899 PL_in_my = FALSE;
1900 PL_in_my_stash = Nullhv;
1901 return o;
79072805
LW		 1902}
1903
1904OP *
864dbfa3 1905Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 1906{
1907 if (o->op_type == OP_LIST) {
554b3eca 1908 OP *o2;
554b3eca 1909 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
554b3eca 1910 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 1911 }
1912 return o;
1913}
1914
1915OP *
864dbfa3 1916Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 1917{
1918 register OP *curop;
1919 I32 type = o->op_type;
748a9306 1920 SV *sv;
79072805 1921
22c35a8c 1922 if (PL_opargs[type] & OA_RETSCALAR)
79072805 1923 scalar(o);
b162f9ea 1924 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 1925 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 1926
eac055e9
GS		 1927 /* integerize op, unless it happens to be C<-foo>.
1928 * XXX should pp_i_negate() do magic string negation instead? */
1929 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1930 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1931 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1932 {
22c35a8c 1933 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 1934 }
85e6fe83 1935
22c35a8c 1936 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 1937 goto nope;
1938
de939608 1939 switch (type) {
7a52d87a
GS		 1940 case OP_NEGATE:
1941 /* XXX might want a ck_negate() for this */
1942 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1943 break;
de939608
CS		 1944 case OP_SPRINTF:
1945 case OP_UCFIRST:
1946 case OP_LCFIRST:
1947 case OP_UC:
1948 case OP_LC:
69dcf70c
MB		 1949 case OP_SLT:
1950 case OP_SGT:
1951 case OP_SLE:
1952 case OP_SGE:
1953 case OP_SCMP:
2de3dbcc
JH		 1954 /* XXX what about the numeric ops? */
1955 if (PL_hints & HINT_LOCALE)
de939608
CS		 1956 goto nope;
1957 }
1958
3280af22 1959 if (PL_error_count)
a0d0e21e
LW		 1960 goto nope; /* Don't try to run w/ errors */
1961
79072805 1962 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 1963 if ((curop->op_type != OP_CONST ||
1964 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 1965 curop->op_type != OP_LIST &&
1966 curop->op_type != OP_SCALAR &&
1967 curop->op_type != OP_NULL &&
1968 curop->op_type != OP_PUSHMARK)
1969 {
79072805
LW		 1970 goto nope;
1971 }
1972 }
1973
1974 curop = LINKLIST(o);
1975 o->op_next = 0;
533c011a 1976 PL_op = curop;
cea2e8a9 1977 CALLRUNOPS(aTHX);
3280af22 1978 sv = *(PL_stack_sp--);
748a9306 1979 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 1980 pad_swipe(o->op_targ, FALSE);
748a9306
LW		 1981 else if (SvTEMP(sv)) { /* grab mortal temp? */
1982 (void)SvREFCNT_inc(sv);
1983 SvTEMP_off(sv);
85e6fe83 1984 }
79072805
LW		 1985 op_free(o);
1986 if (type == OP_RV2GV)
b1cb66bf 1987 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 1988 return newSVOP(OP_CONST, 0, sv);
aeea060c 1989
79072805 1990 nope:
79072805
LW		 1991 return o;
1992}
1993
1994OP *
864dbfa3 1995Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 1996{
1997 register OP *curop;
3280af22 1998 I32 oldtmps_floor = PL_tmps_floor;
79072805 1999
a0d0e21e 2000 list(o);
3280af22 2001 if (PL_error_count)
a0d0e21e
LW		 2002 return o; /* Don't attempt to run with errors */
2003
533c011a 2004 PL_op = curop = LINKLIST(o);
a0d0e21e 2005 o->op_next = 0;
a2efc822 2006 CALL_PEEP(curop);
cea2e8a9
GS		 2007 pp_pushmark();
2008 CALLRUNOPS(aTHX);
533c011a 2009 PL_op = curop;
cea2e8a9 2010 pp_anonlist();
3280af22 2011 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2012
2013 o->op_type = OP_RV2AV;
22c35a8c 2014 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2015 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2016 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
c13f253a 2017 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2018 curop = ((UNOP*)o)->op_first;
3280af22 2019 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2020 op_free(curop);
79072805
LW		 2021 linklist(o);
2022 return list(o);
2023}
2024
2025OP *
864dbfa3 2026Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2027{
11343788
MB		 2028 if (!o || o->op_type != OP_LIST)
2029 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2030 else
5dc0d613 2031 o->op_flags &= ~OPf_WANT;
79072805 2032
22c35a8c 2033 if (!(PL_opargs[type] & OA_MARK))
93c66552 2034 op_null(cLISTOPo->op_first);
8990e307 2035
eb160463 2036 o->op_type = (OPCODE)type;
22c35a8c 2037 o->op_ppaddr = PL_ppaddr[type];
11343788 2038 o->op_flags |= flags;
79072805 2039
11343788
MB		 2040 o = CHECKOP(type, o);
2041 if (o->op_type != type)
2042 return o;
79072805 2043
11343788 2044 return fold_constants(o);
79072805
LW		 2045}
2046
2047/* List constructors */
2048
2049OP *
864dbfa3 2050Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2051{
2052 if (!first)
2053 return last;
8990e307
LW		 2054
2055 if (!last)
79072805 2056 return first;
8990e307 2057
155aba94
GS		 2058 if (first->op_type != type
2059 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2060 {
2061 return newLISTOP(type, 0, first, last);
2062 }
79072805 2063
a0d0e21e
LW		 2064 if (first->op_flags & OPf_KIDS)
2065 ((LISTOP*)first)->op_last->op_sibling = last;
2066 else {
2067 first->op_flags |= OPf_KIDS;
2068 ((LISTOP*)first)->op_first = last;
2069 }
2070 ((LISTOP*)first)->op_last = last;
a0d0e21e 2071 return first;
79072805
LW		 2072}
2073
2074OP *
864dbfa3 2075Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2076{
2077 if (!first)
2078 return (OP*)last;
8990e307
LW		 2079
2080 if (!last)
79072805 2081 return (OP*)first;
8990e307
LW		 2082
2083 if (first->op_type != type)
79072805 2084 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2085
2086 if (last->op_type != type)
79072805
LW		 2087 return append_elem(type, (OP*)first, (OP*)last);
2088
2089 first->op_last->op_sibling = last->op_first;
2090 first->op_last = last->op_last;
117dada2 2091 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2092
238a4c30
NIS		 2093 FreeOp(last);
2094
79072805
LW		 2095 return (OP*)first;
2096}
2097
2098OP *
864dbfa3 2099Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2100{
2101 if (!first)
2102 return last;
8990e307
LW		 2103
2104 if (!last)
79072805 2105 return first;
8990e307
LW		 2106
2107 if (last->op_type == type) {
2108 if (type == OP_LIST) { /* already a PUSHMARK there */
2109 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2110 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2111 if (!(first->op_flags & OPf_PARENS))
2112 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2113 }
2114 else {
2115 if (!(last->op_flags & OPf_KIDS)) {
2116 ((LISTOP*)last)->op_last = first;
2117 last->op_flags |= OPf_KIDS;
2118 }
2119 first->op_sibling = ((LISTOP*)last)->op_first;
2120 ((LISTOP*)last)->op_first = first;
79072805 2121 }
117dada2 2122 last->op_flags |= OPf_KIDS;
79072805
LW		 2123 return last;
2124 }
2125
2126 return newLISTOP(type, 0, first, last);
2127}
2128
2129/* Constructors */
2130
2131OP *
864dbfa3 2132Perl_newNULLLIST(pTHX)
79072805 2133{
8990e307
LW		 2134 return newOP(OP_STUB, 0);
2135}
2136
2137OP *
864dbfa3 2138Perl_force_list(pTHX_ OP *o)
8990e307 2139{
11343788
MB		 2140 if (!o || o->op_type != OP_LIST)
2141 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2142 op_null(o);
11343788 2143 return o;
79072805
LW		 2144}
2145
2146OP *
864dbfa3 2147Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2148{
2149 LISTOP *listop;
2150
b7dc083c 2151 NewOp(1101, listop, 1, LISTOP);
79072805 2152
eb160463 2153 listop->op_type = (OPCODE)type;
22c35a8c 2154 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2155 if (first || last)
2156 flags |= OPf_KIDS;
eb160463 2157 listop->op_flags = (U8)flags;
79072805
LW		 2158
2159 if (!last && first)
2160 last = first;
2161 else if (!first && last)
2162 first = last;
8990e307
LW		 2163 else if (first)
2164 first->op_sibling = last;
79072805
LW		 2165 listop->op_first = first;
2166 listop->op_last = last;
8990e307
LW		 2167 if (type == OP_LIST) {
2168 OP* pushop;
2169 pushop = newOP(OP_PUSHMARK, 0);
2170 pushop->op_sibling = first;
2171 listop->op_first = pushop;
2172 listop->op_flags |= OPf_KIDS;
2173 if (!last)
2174 listop->op_last = pushop;
2175 }
79072805 2176
463d09e6 2177 return CHECKOP(type, listop);
79072805
LW		 2178}
2179
2180OP *
864dbfa3 2181Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2182{
11343788 2183 OP *o;
b7dc083c 2184 NewOp(1101, o, 1, OP);
eb160463 2185 o->op_type = (OPCODE)type;
22c35a8c 2186 o->op_ppaddr = PL_ppaddr[type];
eb160463 2187 o->op_flags = (U8)flags;
79072805 2188
11343788 2189 o->op_next = o;
eb160463 2190 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2191 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2192 scalar(o);
22c35a8c 2193 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2194 o->op_targ = pad_alloc(type, SVs_PADTMP);
2195 return CHECKOP(type, o);
79072805
LW		 2196}
2197
2198OP *
864dbfa3 2199Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2200{
2201 UNOP *unop;
2202
93a17b20 2203 if (!first)
aeea060c 2204 first = newOP(OP_STUB, 0);
22c35a8c 2205 if (PL_opargs[type] & OA_MARK)
8990e307 2206 first = force_list(first);
93a17b20 2207
b7dc083c 2208 NewOp(1101, unop, 1, UNOP);
eb160463 2209 unop->op_type = (OPCODE)type;
22c35a8c 2210 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2211 unop->op_first = first;
2212 unop->op_flags = flags | OPf_KIDS;
eb160463 2213 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2214 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2215 if (unop->op_next)
2216 return (OP*)unop;
2217
a0d0e21e 2218 return fold_constants((OP *) unop);
79072805
LW		 2219}
2220
2221OP *
864dbfa3 2222Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2223{
2224 BINOP *binop;
b7dc083c 2225 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2226
2227 if (!first)
2228 first = newOP(OP_NULL, 0);
2229
eb160463 2230 binop->op_type = (OPCODE)type;
22c35a8c 2231 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2232 binop->op_first = first;
2233 binop->op_flags = flags | OPf_KIDS;
2234 if (!last) {
2235 last = first;
eb160463 2236 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2237 }
2238 else {
eb160463 2239 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2240 first->op_sibling = last;
2241 }
2242
e50aee73 2243 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2244 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2245 return (OP*)binop;
2246
7284ab6f 2247 binop->op_last = binop->op_first->op_sibling;
79072805 2248
a0d0e21e 2249 return fold_constants((OP *)binop);
79072805
LW		 2250}
2251
a0ed51b3 2252static int
2b9d42f0
NIS		 2253uvcompare(const void *a, const void *b)
2254{
2255 if (*((UV *)a) < (*(UV *)b))
2256 return -1;
2257 if (*((UV *)a) > (*(UV *)b))
2258 return 1;
2259 if (*((UV *)a+1) < (*(UV *)b+1))
2260 return -1;
2261 if (*((UV *)a+1) > (*(UV *)b+1))
2262 return 1;
a0ed51b3
LW		 2263 return 0;
2264}
2265
79072805 2266OP *
864dbfa3 2267Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2268{
79072805
LW		 2269 SV *tstr = ((SVOP*)expr)->op_sv;
2270 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2271 STRLEN tlen;
2272 STRLEN rlen;
9b877dbb
IH		 2273 U8 *t = (U8*)SvPV(tstr, tlen);
2274 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2275 register I32 i;
2276 register I32 j;
a0ed51b3 2277 I32 del;
79072805 2278 I32 complement;
5d06d08e 2279 I32 squash;
9b877dbb 2280 I32 grows = 0;
79072805
LW		 2281 register short *tbl;
2282
800b4dc4 2283 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2284 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2285 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2286 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2287
036b4402
GS		 2288 if (SvUTF8(tstr))
2289 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2290
2291 if (SvUTF8(rstr))
036b4402 2292 o->op_private |= OPpTRANS_TO_UTF;
79072805 2293
a0ed51b3 2294 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2295 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2296 SV* transv = 0;
2297 U8* tend = t + tlen;
2298 U8* rend = r + rlen;
ba210ebe 2299 STRLEN ulen;
84c133a0
RB		 2300 UV tfirst = 1;
2301 UV tlast = 0;
2302 IV tdiff;
2303 UV rfirst = 1;
2304 UV rlast = 0;
2305 IV rdiff;
2306 IV diff;
a0ed51b3
LW		 2307 I32 none = 0;
2308 U32 max = 0;
2309 I32 bits;
a0ed51b3 2310 I32 havefinal = 0;
9c5ffd7c 2311 U32 final = 0;
a0ed51b3
LW		 2312 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2313 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2314 U8* tsave = NULL;
2315 U8* rsave = NULL;
2316
2317 if (!from_utf) {
2318 STRLEN len = tlen;
2319 tsave = t = bytes_to_utf8(t, &len);
2320 tend = t + len;
2321 }
2322 if (!to_utf && rlen) {
2323 STRLEN len = rlen;
2324 rsave = r = bytes_to_utf8(r, &len);
2325 rend = r + len;
2326 }
a0ed51b3 2327
2b9d42f0
NIS		 2328/* There are several snags with this code on EBCDIC:
2329 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2330 2. scan_const() in toke.c has encoded chars in native encoding which makes
2331 ranges at least in EBCDIC 0..255 range the bottom odd.
2332*/
2333
a0ed51b3 2334 if (complement) {
ad391ad9 2335 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2336 UV *cp;
a0ed51b3 2337 UV nextmin = 0;
2b9d42f0 2338 New(1109, cp, 2*tlen, UV);
a0ed51b3 2339 i = 0;
79cb57f6 2340 transv = newSVpvn("",0);
a0ed51b3 2341 while (t < tend) {
2b9d42f0
NIS		 2342 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2343 t += ulen;
2344 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2345 t++;
2b9d42f0
NIS		 2346 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2347 t += ulen;
a0ed51b3 2348 }
2b9d42f0
NIS		 2349 else {
2350 cp[2*i+1] = cp[2*i];
2351 }
2352 i++;
a0ed51b3 2353 }
2b9d42f0 2354 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2355 for (j = 0; j < i; j++) {
2b9d42f0 2356 UV val = cp[2*j];
a0ed51b3
LW		 2357 diff = val - nextmin;
2358 if (diff > 0) {
9041c2e3 2359 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2360 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2361 if (diff > 1) {
2b9d42f0 2362 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2363 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2364 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2365 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2366 }
2367 }
2b9d42f0 2368 val = cp[2*j+1];
a0ed51b3
LW		 2369 if (val >= nextmin)
2370 nextmin = val + 1;
2371 }
9041c2e3 2372 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2373 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2374 {
2375 U8 range_mark = UTF_TO_NATIVE(0xff);
2376 sv_catpvn(transv, (char *)&range_mark, 1);
2377 }
b851fbc1
JH		 2378 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2379 UNICODE_ALLOW_SUPER);
dfe13c55
GS		 2380 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2381 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2382 tlen = SvCUR(transv);
2383 tend = t + tlen;
455d824a 2384 Safefree(cp);
a0ed51b3
LW		 2385 }
2386 else if (!rlen && !del) {
2387 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2388 }
2389 if (!squash) {
05d340b8 2390 if ((!rlen && !del) || t == r ||
12ae5dfc 2391 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2392 {
4757a243 2393 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2394 }
a0ed51b3
LW		 2395 }
2396
2397 while (t < tend || tfirst <= tlast) {
2398 /* see if we need more "t" chars */
2399 if (tfirst > tlast) {
9041c2e3 2400 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2401 t += ulen;
2b9d42f0 2402 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2403 t++;
9041c2e3 2404 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2405 t += ulen;
2406 }
2407 else
2408 tlast = tfirst;
2409 }
2410
2411 /* now see if we need more "r" chars */
2412 if (rfirst > rlast) {
2413 if (r < rend) {
9041c2e3 2414 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2415 r += ulen;
2b9d42f0 2416 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2417 r++;
9041c2e3 2418 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2419 r += ulen;
2420 }
2421 else
2422 rlast = rfirst;
2423 }
2424 else {
2425 if (!havefinal++)
2426 final = rlast;
2427 rfirst = rlast = 0xffffffff;
2428 }
2429 }
2430
2431 /* now see which range will peter our first, if either. */
2432 tdiff = tlast - tfirst;
2433 rdiff = rlast - rfirst;
2434
2435 if (tdiff <= rdiff)
2436 diff = tdiff;
2437 else
2438 diff = rdiff;
2439
2440 if (rfirst == 0xffffffff) {
2441 diff = tdiff; /* oops, pretend rdiff is infinite */
2442 if (diff > 0)
894356b3
GS		 2443 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2444 (long)tfirst, (long)tlast);
a0ed51b3 2445 else
894356b3 2446 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2447 }
2448 else {
2449 if (diff > 0)
894356b3
GS		 2450 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2451 (long)tfirst, (long)(tfirst + diff),
2452 (long)rfirst);
a0ed51b3 2453 else
894356b3
GS		 2454 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2455 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2456
2457 if (rfirst + diff > max)
2458 max = rfirst + diff;
9b877dbb 2459 if (!grows)
45005bfb
JH		 2460 grows = (tfirst < rfirst &&
2461 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2462 rfirst += diff + 1;
a0ed51b3
LW		 2463 }
2464 tfirst += diff + 1;
2465 }
2466
2467 none = ++max;
2468 if (del)
2469 del = ++max;
2470
2471 if (max > 0xffff)
2472 bits = 32;
2473 else if (max > 0xff)
2474 bits = 16;
2475 else
2476 bits = 8;
2477
455d824a 2478 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2479 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2480 SvREFCNT_dec(listsv);
2481 if (transv)
2482 SvREFCNT_dec(transv);
2483
45005bfb 2484 if (!del && havefinal && rlen)
b448e4fe
JH		 2485 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2486 newSVuv((UV)final), 0);
a0ed51b3 2487
9b877dbb 2488 if (grows)
a0ed51b3
LW		 2489 o->op_private |= OPpTRANS_GROWS;
2490
9b877dbb
IH		 2491 if (tsave)
2492 Safefree(tsave);
2493 if (rsave)
2494 Safefree(rsave);
2495
a0ed51b3
LW		 2496 op_free(expr);
2497 op_free(repl);
2498 return o;
2499 }
2500
2501 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2502 if (complement) {
2503 Zero(tbl, 256, short);
eb160463 2504 for (i = 0; i < (I32)tlen; i++)
ec49126f 2505 tbl[t[i]] = -1;
79072805
LW		 2506 for (i = 0, j = 0; i < 256; i++) {
2507 if (!tbl[i]) {
eb160463 2508 if (j >= (I32)rlen) {
a0ed51b3 2509 if (del)
79072805
LW		 2510 tbl[i] = -2;
2511 else if (rlen)
ec49126f 2512 tbl[i] = r[j-1];
79072805 2513 else
eb160463 2514 tbl[i] = (short)i;
79072805 2515 }
9b877dbb
IH		 2516 else {
2517 if (i < 128 && r[j] >= 128)
2518 grows = 1;
ec49126f 2519 tbl[i] = r[j++];
9b877dbb 2520 }
79072805
LW		 2521 }
2522 }
05d340b8
JH		 2523 if (!del) {
2524 if (!rlen) {
2525 j = rlen;
2526 if (!squash)
2527 o->op_private |= OPpTRANS_IDENTICAL;
2528 }
eb160463 2529 else if (j >= (I32)rlen)
05d340b8
JH		 2530 j = rlen - 1;
2531 else
2532 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 2533 tbl[0x100] = rlen - j;
eb160463 2534 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 2535 tbl[0x101+i] = r[j+i];
2536 }
79072805
LW		 2537 }
2538 else {
a0ed51b3 2539 if (!rlen && !del) {
79072805 2540 r = t; rlen = tlen;
5d06d08e 2541 if (!squash)
4757a243 2542 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2543 }
94bfe852
RGS		 2544 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2545 o->op_private |= OPpTRANS_IDENTICAL;
2546 }
79072805
LW		 2547 for (i = 0; i < 256; i++)
2548 tbl[i] = -1;
eb160463
GS		 2549 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2550 if (j >= (I32)rlen) {
a0ed51b3 2551 if (del) {
ec49126f 2552 if (tbl[t[i]] == -1)
2553 tbl[t[i]] = -2;
79072805
LW		 2554 continue;
2555 }
2556 --j;
2557 }
9b877dbb
IH		 2558 if (tbl[t[i]] == -1) {
2559 if (t[i] < 128 && r[j] >= 128)
2560 grows = 1;
ec49126f 2561 tbl[t[i]] = r[j];
9b877dbb 2562 }
79072805
LW		 2563 }
2564 }
9b877dbb
IH		 2565 if (grows)
2566 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2567 op_free(expr);
2568 op_free(repl);
2569
11343788 2570 return o;
79072805
LW		 2571}
2572
2573OP *
864dbfa3 2574Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2575{
2576 PMOP *pmop;
2577
b7dc083c 2578 NewOp(1101, pmop, 1, PMOP);
eb160463 2579 pmop->op_type = (OPCODE)type;
22c35a8c 2580 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 2581 pmop->op_flags = (U8)flags;
2582 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2583
3280af22 2584 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2585 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2586 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2587 pmop->op_pmpermflags |= PMf_LOCALE;
2588 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2589
debc9467 2590#ifdef USE_ITHREADS
13137afc
AB		 2591 {
2592 SV* repointer;
2593 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2594 repointer = av_pop((AV*)PL_regex_pad[0]);
2595 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2596 SvREPADTMP_off(repointer);
13137afc 2597 sv_setiv(repointer,0);
1eb1540c 2598 } else {
13137afc
AB		 2599 repointer = newSViv(0);
2600 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2601 pmop->op_pmoffset = av_len(PL_regex_padav);
2602 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2603 }
13137afc 2604 }
debc9467 2605#endif
1eb1540c 2606
1fcf4c12 2607 /* link into pm list */
3280af22
NIS		 2608 if (type != OP_TRANS && PL_curstash) {
2609 pmop->op_pmnext = HvPMROOT(PL_curstash);
2610 HvPMROOT(PL_curstash) = pmop;
cb55de95 2611 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2612 }
2613
463d09e6 2614 return CHECKOP(type, pmop);
79072805
LW		 2615}
2616
2617OP *
864dbfa3 2618Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 2619{
2620 PMOP *pm;
2621 LOGOP *rcop;
ce862d02 2622 I32 repl_has_vars = 0;
79072805 2623
11343788
MB		 2624 if (o->op_type == OP_TRANS)
2625 return pmtrans(o, expr, repl);
79072805 2626
3280af22 2627 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2628 pm = (PMOP*)o;
79072805
LW		 2629
2630 if (expr->op_type == OP_CONST) {
463ee0b2 2631 STRLEN plen;
79072805 2632 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2633 char *p = SvPV(pat, plen);
11343788 2634 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2635 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2636 p = SvPV(pat, plen);
79072805
LW		 2637 pm->op_pmflags |= PMf_SKIPWHITE;
2638 }
5b71a6a7 2639 if (DO_UTF8(pat))
a5961de5 2640 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS		 2641 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2642 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2643 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 2644 op_free(expr);
2645 }
2646 else {
3280af22 2647 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2648 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2649 ? OP_REGCRESET
2650 : OP_REGCMAYBE),0,expr);
463ee0b2 2651
b7dc083c 2652 NewOp(1101, rcop, 1, LOGOP);
79072805 2653 rcop->op_type = OP_REGCOMP;
22c35a8c 2654 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2655 rcop->op_first = scalar(expr);
1c846c1f 2656 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2657 ? (OPf_SPECIAL | OPf_KIDS)
2658 : OPf_KIDS);
79072805 2659 rcop->op_private = 1;
11343788 2660 rcop->op_other = o;
b5c19bd7
DM		 2661 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2662 PL_cv_has_eval = 1;
79072805
LW		 2663
2664 /* establish postfix order */
3280af22 2665 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 2666 LINKLIST(expr);
2667 rcop->op_next = expr;
2668 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2669 }
2670 else {
2671 rcop->op_next = LINKLIST(expr);
2672 expr->op_next = (OP*)rcop;
2673 }
79072805 2674
11343788 2675 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 2676 }
2677
2678 if (repl) {
748a9306 2679 OP *curop;
0244c3a4 2680 if (pm->op_pmflags & PMf_EVAL) {
748a9306 2681 curop = 0;
8bafa735 2682 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2683 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2684 }
748a9306
LW		 2685 else if (repl->op_type == OP_CONST)
2686 curop = repl;
79072805 2687 else {
79072805
LW		 2688 OP *lastop = 0;
2689 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2690 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2691 if (curop->op_type == OP_GV) {
638eceb6 2692 GV *gv = cGVOPx_gv(curop);
ce862d02 2693 repl_has_vars = 1;
f702bf4a 2694 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 2695 break;
2696 }
2697 else if (curop->op_type == OP_RV2CV)
2698 break;
2699 else if (curop->op_type == OP_RV2SV ||
2700 curop->op_type == OP_RV2AV ||
2701 curop->op_type == OP_RV2HV ||
2702 curop->op_type == OP_RV2GV) {
2703 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2704 break;
2705 }
748a9306
LW		 2706 else if (curop->op_type == OP_PADSV ||
2707 curop->op_type == OP_PADAV ||
2708 curop->op_type == OP_PADHV ||
554b3eca 2709 curop->op_type == OP_PADANY) {
ce862d02 2710 repl_has_vars = 1;
748a9306 2711 }
1167e5da
SM		 2712 else if (curop->op_type == OP_PUSHRE)
2713 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 2714 else
2715 break;
2716 }
2717 lastop = curop;
2718 }
748a9306 2719 }
ce862d02 2720 if (curop == repl
1c846c1f 2721 && !(repl_has_vars
aaa362c4
RS		 2722 && (!PM_GETRE(pm)
2723 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2724 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2725 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2726 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 2727 }
2728 else {
aaa362c4 2729 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 2730 pm->op_pmflags |= PMf_MAYBE_CONST;
2731 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2732 }
b7dc083c 2733 NewOp(1101, rcop, 1, LOGOP);
748a9306 2734 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2735 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 2736 rcop->op_first = scalar(repl);
2737 rcop->op_flags |= OPf_KIDS;
2738 rcop->op_private = 1;
11343788 2739 rcop->op_other = o;
748a9306
LW		 2740
2741 /* establish postfix order */
2742 rcop->op_next = LINKLIST(repl);
2743 repl->op_next = (OP*)rcop;
2744
2745 pm->op_pmreplroot = scalar((OP*)rcop);
2746 pm->op_pmreplstart = LINKLIST(rcop);
2747 rcop->op_next = 0;
79072805
LW		 2748 }
2749 }
2750
2751 return (OP*)pm;
2752}
2753
2754OP *
864dbfa3 2755Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 2756{
2757 SVOP *svop;
b7dc083c 2758 NewOp(1101, svop, 1, SVOP);
eb160463 2759 svop->op_type = (OPCODE)type;
22c35a8c 2760 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2761 svop->op_sv = sv;
2762 svop->op_next = (OP*)svop;
eb160463 2763 svop->op_flags = (U8)flags;
22c35a8c 2764 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2765 scalar((OP*)svop);
22c35a8c 2766 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2767 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2768 return CHECKOP(type, svop);
79072805
LW		 2769}
2770
2771OP *
350de78d
GS		 2772Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2773{
2774 PADOP *padop;
2775 NewOp(1101, padop, 1, PADOP);
eb160463 2776 padop->op_type = (OPCODE)type;
350de78d
GS		 2777 padop->op_ppaddr = PL_ppaddr[type];
2778 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 2779 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2780 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 2781 if (sv)
2782 SvPADTMP_on(sv);
350de78d 2783 padop->op_next = (OP*)padop;
eb160463 2784 padop->op_flags = (U8)flags;
350de78d
GS		 2785 if (PL_opargs[type] & OA_RETSCALAR)
2786 scalar((OP*)padop);
2787 if (PL_opargs[type] & OA_TARGET)
2788 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2789 return CHECKOP(type, padop);
2790}
2791
2792OP *
864dbfa3 2793Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 2794{
350de78d 2795#ifdef USE_ITHREADS
ce50c033
AMS		 2796 if (gv)
2797 GvIN_PAD_on(gv);
350de78d
GS		 2798 return newPADOP(type, flags, SvREFCNT_inc(gv));
2799#else
7934575e 2800 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 2801#endif
79072805
LW		 2802}
2803
2804OP *
864dbfa3 2805Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 2806{
2807 PVOP *pvop;
b7dc083c 2808 NewOp(1101, pvop, 1, PVOP);
eb160463 2809 pvop->op_type = (OPCODE)type;
22c35a8c 2810 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2811 pvop->op_pv = pv;
2812 pvop->op_next = (OP*)pvop;
eb160463 2813 pvop->op_flags = (U8)flags;
22c35a8c 2814 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2815 scalar((OP*)pvop);
22c35a8c 2816 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2817 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2818 return CHECKOP(type, pvop);
79072805
LW		 2819}
2820
79072805 2821void
864dbfa3 2822Perl_package(pTHX_ OP *o)
79072805 2823{
de11ba31
AMS		 2824 char *name;
2825 STRLEN len;
79072805 2826
3280af22
NIS		 2827 save_hptr(&PL_curstash);
2828 save_item(PL_curstname);
de11ba31
AMS		 2829
2830 name = SvPV(cSVOPo->op_sv, len);
2831 PL_curstash = gv_stashpvn(name, len, TRUE);
2832 sv_setpvn(PL_curstname, name, len);
2833 op_free(o);
2834
7ad382f4 2835 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2836 PL_copline = NOLINE;
2837 PL_expect = XSTATE;
79072805
LW		 2838}
2839
85e6fe83 2840void
88d95a4d 2841Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 2842{
a0d0e21e 2843 OP *pack;
a0d0e21e 2844 OP *imop;
b1cb66bf 2845 OP *veop;
85e6fe83 2846
88d95a4d 2847 if (idop->op_type != OP_CONST)
cea2e8a9 2848 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 2849
b1cb66bf 2850 veop = Nullop;
2851
0f79a09d 2852 if (version != Nullop) {
b1cb66bf 2853 SV *vesv = ((SVOP*)version)->op_sv;
2854
44dcb63b 2855 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 2856 arg = version;
2857 }
2858 else {
2859 OP *pack;
0f79a09d 2860 SV *meth;
b1cb66bf 2861
44dcb63b 2862 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 2863 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 2864
88d95a4d
JH		 2865 /* Make copy of idop so we don't free it twice */
2866 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 2867
2868 /* Fake up a method call to VERSION */
0f79a09d
GS		 2869 meth = newSVpvn("VERSION",7);
2870 sv_upgrade(meth, SVt_PVIV);
155aba94 2871 (void)SvIOK_on(meth);
5afd6d42 2872 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 2873 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2874 append_elem(OP_LIST,
0f79a09d
GS		 2875 prepend_elem(OP_LIST, pack, list(version)),
2876 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 2877 }
2878 }
aeea060c 2879
a0d0e21e 2880 /* Fake up an import/unimport */
4633a7c4
LW		 2881 if (arg && arg->op_type == OP_STUB)
2882 imop = arg; /* no import on explicit () */
88d95a4d 2883 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf 2884 imop = Nullop; /* use 5.0; */
2885 }
4633a7c4 2886 else {
0f79a09d
GS		 2887 SV *meth;
2888
88d95a4d
JH		 2889 /* Make copy of idop so we don't free it twice */
2890 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 2891
2892 /* Fake up a method call to import/unimport */
b47cad08 2893 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 2894 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 2895 (void)SvIOK_on(meth);
5afd6d42 2896 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 2897 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 2898 append_elem(OP_LIST,
2899 prepend_elem(OP_LIST, pack, list(arg)),
2900 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 2901 }
2902
a0d0e21e 2903 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 2904 newATTRSUB(floor,
79cb57f6 2905 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 2906 Nullop,
09bef843 2907 Nullop,
a0d0e21e 2908 append_elem(OP_LINESEQ,
b1cb66bf 2909 append_elem(OP_LINESEQ,
88d95a4d 2910 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 2911 newSTATEOP(0, Nullch, veop)),
a0d0e21e 2912 newSTATEOP(0, Nullch, imop) ));
85e6fe83 2913
70f5e4ed
JH		 2914 /* The "did you use incorrect case?" warning used to be here.
2915 * The problem is that on case-insensitive filesystems one
2916 * might get false positives for "use" (and "require"):
2917 * "use Strict" or "require CARP" will work. This causes
2918 * portability problems for the script: in case-strict
2919 * filesystems the script will stop working.
2920 *
2921 * The "incorrect case" warning checked whether "use Foo"
2922 * imported "Foo" to your namespace, but that is wrong, too:
2923 * there is no requirement nor promise in the language that
2924 * a Foo.pm should or would contain anything in package "Foo".
2925 *
2926 * There is very little Configure-wise that can be done, either:
2927 * the case-sensitivity of the build filesystem of Perl does not
2928 * help in guessing the case-sensitivity of the runtime environment.
2929 */
18fc9488 2930
c305c6a0 2931 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2932 PL_copline = NOLINE;
2933 PL_expect = XSTATE;
8ec8fbef 2934 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW		 2935}
2936
7d3fb230 2937/*
ccfc67b7
JH		 2938=head1 Embedding Functions
2939
7d3fb230
BS		 2940=for apidoc load_module
2941
2942Loads the module whose name is pointed to by the string part of name.
2943Note that the actual module name, not its filename, should be given.
2944Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2945PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2946(or 0 for no flags). ver, if specified, provides version semantics
2947similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2948arguments can be used to specify arguments to the module's import()
2949method, similar to C<use Foo::Bar VERSION LIST>.
2950
2951=cut */
2952
e4783991
GS		 2953void
2954Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2955{
2956 va_list args;
2957 va_start(args, ver);
2958 vload_module(flags, name, ver, &args);
2959 va_end(args);
2960}
2961
2962#ifdef PERL_IMPLICIT_CONTEXT
2963void
2964Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2965{
2966 dTHX;
2967 va_list args;
2968 va_start(args, ver);
2969 vload_module(flags, name, ver, &args);
2970 va_end(args);
2971}
2972#endif
2973
2974void
2975Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2976{
2977 OP *modname, *veop, *imop;
2978
2979 modname = newSVOP(OP_CONST, 0, name);
2980 modname->op_private |= OPpCONST_BARE;
2981 if (ver) {
2982 veop = newSVOP(OP_CONST, 0, ver);
2983 }
2984 else
2985 veop = Nullop;
2986 if (flags & PERL_LOADMOD_NOIMPORT) {
2987 imop = sawparens(newNULLLIST());
2988 }
2989 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2990 imop = va_arg(*args, OP*);
2991 }
2992 else {
2993 SV *sv;
2994 imop = Nullop;
2995 sv = va_arg(*args, SV*);
2996 while (sv) {
2997 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2998 sv = va_arg(*args, SV*);
2999 }
3000 }
81885997
GS		 3001 {
3002 line_t ocopline = PL_copline;
834a3ffa 3003 COP *ocurcop = PL_curcop;
81885997
GS		 3004 int oexpect = PL_expect;
3005
3006 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3007 veop, modname, imop);
3008 PL_expect = oexpect;
3009 PL_copline = ocopline;
834a3ffa 3010 PL_curcop = ocurcop;
81885997 3011 }
e4783991
GS		 3012}
3013
79072805 3014OP *
864dbfa3 3015Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3016{
3017 OP *doop;
3018 GV *gv;
3019
3020 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3021 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS		 3022 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3023
b9f751c0 3024 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3025 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3026 append_elem(OP_LIST, term,
3027 scalar(newUNOP(OP_RV2CV, 0,
3028 newGVOP(OP_GV, 0,
3029 gv))))));
3030 }
3031 else {
3032 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3033 }
3034 return doop;
3035}
3036
3037OP *
864dbfa3 3038Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3039{
3040 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3041 list(force_list(subscript)),
3042 list(force_list(listval)) );
79072805
LW		 3043}
3044
76e3520e 3045STATIC I32
cea2e8a9 3046S_list_assignment(pTHX_ register OP *o)
79072805 3047{
11343788 3048 if (!o)
79072805
LW		 3049 return TRUE;
3050
11343788
MB		 3051 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3052 o = cUNOPo->op_first;
79072805 3053
11343788 3054 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3055 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3056 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3057
3058 if (t && f)
3059 return TRUE;
3060 if (t || f)
3061 yyerror("Assignment to both a list and a scalar");
3062 return FALSE;
3063 }
3064
95f0a2f1
SB		 3065 if (o->op_type == OP_LIST &&
3066 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3067 o->op_private & OPpLVAL_INTRO)
3068 return FALSE;
3069
11343788
MB		 3070 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3071 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3072 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3073 return TRUE;
3074
11343788 3075 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3076 return TRUE;
3077
11343788 3078 if (o->op_type == OP_RV2SV)
79072805
LW		 3079 return FALSE;
3080
3081 return FALSE;
3082}
3083
3084OP *
864dbfa3 3085Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3086{
11343788 3087 OP *o;
79072805 3088
a0d0e21e 3089 if (optype) {
c963b151 3090 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3091 return newLOGOP(optype, 0,
3092 mod(scalar(left), optype),
3093 newUNOP(OP_SASSIGN, 0, scalar(right)));
3094 }
3095 else {
3096 return newBINOP(optype, OPf_STACKED,
3097 mod(scalar(left), optype), scalar(right));
3098 }
3099 }
3100
79072805 3101 if (list_assignment(left)) {
10c8fecd
GS		 3102 OP *curop;
3103
3280af22
NIS		 3104 PL_modcount = 0;
3105 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3106 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3107 if (PL_eval_start)
3108 PL_eval_start = 0;
748a9306 3109 else {
a0d0e21e
LW		 3110 op_free(left);
3111 op_free(right);
3112 return Nullop;
3113 }
10c8fecd
GS		 3114 curop = list(force_list(left));
3115 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3116 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3117
3118 /* PL_generation sorcery:
3119 * an assignment like ($a,$b) = ($c,$d) is easier than
3120 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3121 * To detect whether there are common vars, the global var
3122 * PL_generation is incremented for each assign op we compile.
3123 * Then, while compiling the assign op, we run through all the
3124 * variables on both sides of the assignment, setting a spare slot
3125 * in each of them to PL_generation. If any of them already have
3126 * that value, we know we've got commonality. We could use a
3127 * single bit marker, but then we'd have to make 2 passes, first
3128 * to clear the flag, then to test and set it. To find somewhere
3129 * to store these values, evil chicanery is done with SvCUR().
3130 */
3131
a0d0e21e 3132 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3133 OP *lastop = o;
3280af22 3134 PL_generation++;
11343788 3135 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3136 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3137 if (curop->op_type == OP_GV) {
638eceb6 3138 GV *gv = cGVOPx_gv(curop);
eb160463 3139 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3140 break;
3280af22 3141 SvCUR(gv) = PL_generation;
79072805 3142 }
748a9306
LW		 3143 else if (curop->op_type == OP_PADSV ||
3144 curop->op_type == OP_PADAV ||
3145 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3146 curop->op_type == OP_PADANY)
3147 {
3148 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3149 == (STRLEN)PL_generation)
748a9306 3150 break;
dd2155a4
DM		 3151 PAD_COMPNAME_GEN(curop->op_targ)
3152 = PL_generation;
3153
748a9306 3154 }
79072805
LW		 3155 else if (curop->op_type == OP_RV2CV)
3156 break;
3157 else if (curop->op_type == OP_RV2SV ||
3158 curop->op_type == OP_RV2AV ||
3159 curop->op_type == OP_RV2HV ||
3160 curop->op_type == OP_RV2GV) {
3161 if (lastop->op_type != OP_GV) /* funny deref? */
3162 break;
3163 }
1167e5da
SM		 3164 else if (curop->op_type == OP_PUSHRE) {
3165 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3166#ifdef USE_ITHREADS
dd2155a4
DM		 3167 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3168 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3169#else
1167e5da 3170 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3171#endif
eb160463 3172 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3173 break;
3280af22 3174 SvCUR(gv) = PL_generation;
b2ffa427 3175 }
1167e5da 3176 }
79072805
LW		 3177 else
3178 break;
3179 }
3180 lastop = curop;
3181 }
11343788 3182 if (curop != o)
10c8fecd 3183 o->op_private |= OPpASSIGN_COMMON;
79072805 3184 }
c07a80fd 3185 if (right && right->op_type == OP_SPLIT) {
3186 OP* tmpop;
3187 if ((tmpop = ((LISTOP*)right)->op_first) &&
3188 tmpop->op_type == OP_PUSHRE)
3189 {
3190 PMOP *pm = (PMOP*)tmpop;
3191 if (left->op_type == OP_RV2AV &&
3192 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3193 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3194 {
3195 tmpop = ((UNOP*)left)->op_first;
3196 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3197#ifdef USE_ITHREADS
ba89bb6e 3198 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3199 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3200#else
3201 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3202 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3203#endif
c07a80fd 3204 pm->op_pmflags |= PMf_ONCE;
11343788 3205 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3206 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3207 tmpop->op_sibling = Nullop; /* don't free split */
3208 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3209 op_free(o); /* blow off assign */
54310121 3210 right->op_flags &= ~OPf_WANT;
a5f75d66 3211 /* "I don't know and I don't care." */
c07a80fd 3212 return right;
3213 }
3214 }
3215 else {
e6438c1a 3216 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3217 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3218 {
3219 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3220 if (SvIVX(sv) == 0)
3280af22 3221 sv_setiv(sv, PL_modcount+1);
c07a80fd 3222 }
3223 }
3224 }
3225 }
11343788 3226 return o;
79072805
LW		 3227 }
3228 if (!right)
3229 right = newOP(OP_UNDEF, 0);
3230 if (right->op_type == OP_READLINE) {
3231 right->op_flags |= OPf_STACKED;
463ee0b2 3232 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3233 }
a0d0e21e 3234 else {
3280af22 3235 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3236 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3237 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3238 if (PL_eval_start)
3239 PL_eval_start = 0;
748a9306 3240 else {
11343788 3241 op_free(o);
a0d0e21e
LW		 3242 return Nullop;
3243 }
3244 }
11343788 3245 return o;
79072805
LW		 3246}
3247
3248OP *
864dbfa3 3249Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3250{
bbce6d69 3251 U32 seq = intro_my();
79072805
LW		 3252 register COP *cop;
3253
b7dc083c 3254 NewOp(1101, cop, 1, COP);
57843af0 3255 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3256 cop->op_type = OP_DBSTATE;
22c35a8c 3257 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3258 }
3259 else {
3260 cop->op_type = OP_NEXTSTATE;
22c35a8c 3261 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3262 }
eb160463
GS		 3263 cop->op_flags = (U8)flags;
3264 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3265#ifdef NATIVE_HINTS
3266 cop->op_private |= NATIVE_HINTS;
3267#endif
e24b16f9 3268 PL_compiling.op_private = cop->op_private;
79072805
LW		 3269 cop->op_next = (OP*)cop;
3270
463ee0b2
LW		 3271 if (label) {
3272 cop->cop_label = label;
3280af22 3273 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3274 }
bbce6d69 3275 cop->cop_seq = seq;
3280af22 3276 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3277 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3278 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3279 else
599cee73 3280 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3281 if (specialCopIO(PL_curcop->cop_io))
3282 cop->cop_io = PL_curcop->cop_io;
3283 else
3284 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3285
79072805 3286
3280af22 3287 if (PL_copline == NOLINE)
57843af0 3288 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3289 else {
57843af0 3290 CopLINE_set(cop, PL_copline);
3280af22 3291 PL_copline = NOLINE;
79072805 3292 }
57843af0 3293#ifdef USE_ITHREADS
f4dd75d9 3294 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3295#else
f4dd75d9 3296 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3297#endif
11faa288 3298 CopSTASH_set(cop, PL_curstash);
79072805 3299
3280af22 3300 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3301 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3302 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3303 (void)SvIOK_on(*svp);
57b2e452 3304 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3305 }
93a17b20
LW		 3306 }
3307
11343788 3308 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3309}
3310
bbce6d69 3311
79072805 3312OP *
864dbfa3 3313Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3314{
883ffac3
CS		 3315 return new_logop(type, flags, &first, &other);
3316}
3317
3bd495df 3318STATIC OP *
cea2e8a9 3319S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3320{
79072805 3321 LOGOP *logop;
11343788 3322 OP *o;
883ffac3
CS		 3323 OP *first = *firstp;
3324 OP *other = *otherp;
79072805 3325
a0d0e21e
LW		 3326 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3327 return newBINOP(type, flags, scalar(first), scalar(other));
3328
8990e307 3329 scalarboolean(first);
79072805
LW		 3330 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3331 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3332 if (type == OP_AND || type == OP_OR) {
3333 if (type == OP_AND)
3334 type = OP_OR;
3335 else
3336 type = OP_AND;
11343788 3337 o = first;
883ffac3 3338 first = *firstp = cUNOPo->op_first;
11343788
MB		 3339 if (o->op_next)
3340 first->op_next = o->op_next;
3341 cUNOPo->op_first = Nullop;
3342 op_free(o);
79072805
LW		 3343 }
3344 }
3345 if (first->op_type == OP_CONST) {
989dfb19 3346 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
6d5637c3 3347 if (first->op_private & OPpCONST_STRICT)
989dfb19
K		 3348 no_bareword_allowed(first);
3349 else
3350 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3351 }
79072805
LW		 3352 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3353 op_free(first);
883ffac3 3354 *firstp = Nullop;
79072805
LW		 3355 return other;
3356 }
3357 else {
3358 op_free(other);
883ffac3 3359 *otherp = Nullop;
79072805
LW		 3360 return first;
3361 }
3362 }
e476b1b5 3363 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
a6006777 3364 OP *k1 = ((UNOP*)first)->op_first;
3365 OP *k2 = k1->op_sibling;
3366 OPCODE warnop = 0;
3367 switch (first->op_type)
3368 {
3369 case OP_NULL:
3370 if (k2 && k2->op_type == OP_READLINE
3371 && (k2->op_flags & OPf_STACKED)
1c846c1f 3372 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3373 {
a6006777 3374 warnop = k2->op_type;
72b16652 3375 }
a6006777 3376 break;
3377
3378 case OP_SASSIGN:
68dc0745 3379 if (k1->op_type == OP_READDIR
3380 || k1->op_type == OP_GLOB
72b16652 3381 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3382 || k1->op_type == OP_EACH)
72b16652
GS		 3383 {
3384 warnop = ((k1->op_type == OP_NULL)
eb160463 3385 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3386 }
a6006777 3387 break;
3388 }
8ebc5c01 3389 if (warnop) {
57843af0
GS		 3390 line_t oldline = CopLINE(PL_curcop);
3391 CopLINE_set(PL_curcop, PL_copline);
9014280d 3392 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3393 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3394 PL_op_desc[warnop],
68dc0745 3395 ((warnop == OP_READLINE || warnop == OP_GLOB)
3396 ? " construct" : "() operator"));
57843af0 3397 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3398 }
a6006777 3399 }
79072805
LW		 3400
3401 if (!other)
3402 return first;
3403
c963b151 3404 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 3405 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3406
b7dc083c 3407 NewOp(1101, logop, 1, LOGOP);
79072805 3408
eb160463 3409 logop->op_type = (OPCODE)type;
22c35a8c 3410 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3411 logop->op_first = first;
3412 logop->op_flags = flags | OPf_KIDS;
3413 logop->op_other = LINKLIST(other);
eb160463 3414 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3415
3416 /* establish postfix order */
3417 logop->op_next = LINKLIST(first);
3418 first->op_next = (OP*)logop;
3419 first->op_sibling = other;
3420
463d09e6
RGS		 3421 CHECKOP(type,logop);
3422
11343788
MB		 3423 o = newUNOP(OP_NULL, 0, (OP*)logop);
3424 other->op_next = o;
79072805 3425
11343788 3426 return o;
79072805
LW		 3427}
3428
3429OP *
864dbfa3 3430Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3431{
1a67a97c
SM		 3432 LOGOP *logop;
3433 OP *start;
11343788 3434 OP *o;
79072805 3435
b1cb66bf 3436 if (!falseop)
3437 return newLOGOP(OP_AND, 0, first, trueop);
3438 if (!trueop)
3439 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3440
8990e307 3441 scalarboolean(first);
79072805 3442 if (first->op_type == OP_CONST) {
2bc6235c
K		 3443 if (first->op_private & OPpCONST_BARE &&
3444 first->op_private & OPpCONST_STRICT) {
3445 no_bareword_allowed(first);
3446 }
79072805
LW		 3447 if (SvTRUE(((SVOP*)first)->op_sv)) {
3448 op_free(first);
b1cb66bf 3449 op_free(falseop);
3450 return trueop;
79072805
LW		 3451 }
3452 else {
3453 op_free(first);
b1cb66bf 3454 op_free(trueop);
3455 return falseop;
79072805
LW		 3456 }
3457 }
1a67a97c
SM		 3458 NewOp(1101, logop, 1, LOGOP);
3459 logop->op_type = OP_COND_EXPR;
3460 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3461 logop->op_first = first;
3462 logop->op_flags = flags | OPf_KIDS;
eb160463 3463 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 3464 logop->op_other = LINKLIST(trueop);
3465 logop->op_next = LINKLIST(falseop);
79072805 3466
463d09e6
RGS		 3467 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3468 logop);
79072805
LW		 3469
3470 /* establish postfix order */
1a67a97c
SM		 3471 start = LINKLIST(first);
3472 first->op_next = (OP*)logop;
79072805 3473
b1cb66bf 3474 first->op_sibling = trueop;
3475 trueop->op_sibling = falseop;
1a67a97c 3476 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3477
1a67a97c 3478 trueop->op_next = falseop->op_next = o;
79072805 3479
1a67a97c 3480 o->op_next = start;
11343788 3481 return o;
79072805
LW		 3482}
3483
3484OP *
864dbfa3 3485Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3486{
1a67a97c 3487 LOGOP *range;
79072805
LW		 3488 OP *flip;
3489 OP *flop;
1a67a97c 3490 OP *leftstart;
11343788 3491 OP *o;
79072805 3492
1a67a97c 3493 NewOp(1101, range, 1, LOGOP);
79072805 3494
1a67a97c
SM		 3495 range->op_type = OP_RANGE;
3496 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3497 range->op_first = left;
3498 range->op_flags = OPf_KIDS;
3499 leftstart = LINKLIST(left);
3500 range->op_other = LINKLIST(right);
eb160463 3501 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3502
3503 left->op_sibling = right;
3504
1a67a97c
SM		 3505 range->op_next = (OP*)range;
3506 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3507 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3508 o = newUNOP(OP_NULL, 0, flop);
79072805 3509 linklist(flop);
1a67a97c 3510 range->op_next = leftstart;
79072805
LW		 3511
3512 left->op_next = flip;
3513 right->op_next = flop;
3514
1a67a97c
SM		 3515 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3516 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3517 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3518 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3519
3520 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3521 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3522
11343788 3523 flip->op_next = o;
79072805 3524 if (!flip->op_private || !flop->op_private)
11343788 3525 linklist(o); /* blow off optimizer unless constant */
79072805 3526
11343788 3527 return o;