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