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