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