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