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
Fix bug [perl #24735] : make sure that the range (..) operator
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2
JH		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 17 */
18
ccfc67b7 19
79072805 20#include "EXTERN.h"
864dbfa3 21#define PERL_IN_OP_C
79072805 22#include "perl.h"
77ca0c92 23#include "keywords.h"
79072805 24
a07e034d 25#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 26
238a4c30
NIS		 27#if defined(PL_OP_SLAB_ALLOC)
28
29#ifndef PERL_SLAB_SIZE
30#define PERL_SLAB_SIZE 2048
31#endif
32
c7e45529
AE		 33void *
34Perl_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 35{
5a8e194f
NIS		 36 /*
37 * To make incrementing use count easy PL_OpSlab is an I32 *
38 * To make inserting the link to slab PL_OpPtr is I32 **
39 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
40 * Add an overhead for pointer to slab and round up as a number of pointers
41 */
42 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 43 if ((PL_OpSpace -= sz) < 0) {
083fcd59
JH		 44 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
45 if (!PL_OpPtr) {
238a4c30
NIS		 46 return NULL;
47 }
5a8e194f
NIS		 48 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
49 /* We reserve the 0'th I32 sized chunk as a use count */
50 PL_OpSlab = (I32 *) PL_OpPtr;
51 /* Reduce size by the use count word, and by the size we need.
52 * Latter is to mimic the '-=' in the if() above
53 */
54 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 55 /* Allocation pointer starts at the top.
56 Theory: because we build leaves before trunk allocating at end
57 means that at run time access is cache friendly upward
58 */
5a8e194f 59 PL_OpPtr += PERL_SLAB_SIZE;
238a4c30
NIS		 60 }
61 assert( PL_OpSpace >= 0 );
62 /* Move the allocation pointer down */
63 PL_OpPtr -= sz;
5a8e194f 64 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 65 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
66 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 67 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 68 assert( *PL_OpSlab > 0 );
69 return (void *)(PL_OpPtr + 1);
70}
71
c7e45529
AE		 72void
73Perl_Slab_Free(pTHX_ void *op)
238a4c30 74{
5a8e194f
NIS		 75 I32 **ptr = (I32 **) op;
76 I32 *slab = ptr[-1];
77 assert( ptr-1 > (I32 **) slab );
78 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30
NIS		 79 assert( *slab > 0 );
80 if (--(*slab) == 0) {
7e4e8c89
NC		 81# ifdef NETWARE
82# define PerlMemShared PerlMem
83# endif
083fcd59
JH		 84
85 PerlMemShared_free(slab);
238a4c30
NIS		 86 if (slab == PL_OpSlab) {
87 PL_OpSpace = 0;
88 }
89 }
b7dc083c 90}
b7dc083c 91#endif
e50aee73 92/*
5dc0d613 93 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 94 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 95 */
11343788 96#define CHECKOP(type,o) \
3280af22 97 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 98 ? ( op_free((OP*)o), \
cb77fdf0 99 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
28757baa 100 Nullop ) \
fc0dc3b3 101 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 102
e6438c1a 103#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 104
76e3520e 105STATIC char*
cea2e8a9 106S_gv_ename(pTHX_ GV *gv)
4633a7c4 107{
2d8e6c8d 108 STRLEN n_a;
4633a7c4 109 SV* tmpsv = sv_newmortal();
46fc3d4c 110 gv_efullname3(tmpsv, gv, Nullch);
2d8e6c8d 111 return SvPV(tmpsv,n_a);
4633a7c4
LW		 112}
113
76e3520e 114STATIC OP *
cea2e8a9 115S_no_fh_allowed(pTHX_ OP *o)
79072805 116{
cea2e8a9 117 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 118 OP_DESC(o)));
11343788 119 return o;
79072805
LW		 120}
121
76e3520e 122STATIC OP *
cea2e8a9 123S_too_few_arguments(pTHX_ OP *o, char *name)
79072805 124{
cea2e8a9 125 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 126 return o;
79072805
LW		 127}
128
76e3520e 129STATIC OP *
cea2e8a9 130S_too_many_arguments(pTHX_ OP *o, char *name)
79072805 131{
cea2e8a9 132 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 133 return o;
79072805
LW		 134}
135
76e3520e 136STATIC void
cea2e8a9 137S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
8990e307 138{
cea2e8a9 139 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 140 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 141}
142
7a52d87a 143STATIC void
cea2e8a9 144S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 145{
5a844595 146 qerror(Perl_mess(aTHX_
35c1215d
NC		 147 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
148 cSVOPo_sv));
7a52d87a
GS		 149}
150
79072805
LW		 151/* "register" allocation */
152
153PADOFFSET
dd2155a4 154Perl_allocmy(pTHX_ char *name)
93a17b20 155{
a0d0e21e 156 PADOFFSET off;
a0d0e21e 157
dd2155a4 158 /* complain about "my $_" etc etc */
155aba94
GS		 159 if (!(PL_in_my == KEY_our ||
160 isALPHA(name[1]) ||
39e02b42 161 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
155aba94 162 (name[1] == '_' && (int)strlen(name) > 2)))
834a4ddd 163 {
c4d0567e 164 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS		 165 /* 1999-02-27 mjd@plover.com */
166 char *p;
167 p = strchr(name, '\0');
168 /* The next block assumes the buffer is at least 205 chars
169 long. At present, it's always at least 256 chars. */
170 if (p-name > 200) {
171 strcpy(name+200, "...");
172 p = name+199;
173 }
174 else {
175 p[1] = '\0';
176 }
177 /* Move everything else down one character */
178 for (; p-name > 2; p--)
179 *p = *(p-1);
46fc3d4c 180 name[2] = toCTRL(name[1]);
181 name[1] = '^';
182 }
cea2e8a9 183 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 184 }
748a9306 185
dd2155a4
DM		 186 /* check for duplicate declaration */
187 pad_check_dup(name,
c5661c80 188 (bool)(PL_in_my == KEY_our),
dd2155a4
DM		 189 (PL_curstash ? PL_curstash : PL_defstash)
190 );
33b8ce05 191
dd2155a4
DM		 192 if (PL_in_my_stash && *name != '$') {
193 yyerror(Perl_form(aTHX_
194 "Can't declare class for non-scalar %s in \"%s\"",
195 name, PL_in_my == KEY_our ? "our" : "my"));
6b35e009
GS		 196 }
197
dd2155a4 198 /* allocate a spare slot and store the name in that slot */
93a17b20 199
dd2155a4
DM		 200 off = pad_add_name(name,
201 PL_in_my_stash,
202 (PL_in_my == KEY_our
203 ? (PL_curstash ? PL_curstash : PL_defstash)
204 : Nullhv
205 ),
206 0 /* not fake */
207 );
208 return off;
79072805
LW		 209}
210
79072805
LW		 211/* Destructor */
212
213void
864dbfa3 214Perl_op_free(pTHX_ OP *o)
79072805 215{
85e6fe83 216 register OP *kid, *nextkid;
acb36ea4 217 OPCODE type;
79072805 218
5dc0d613 219 if (!o || o->op_seq == (U16)-1)
79072805
LW		 220 return;
221
7934575e
GS		 222 if (o->op_private & OPpREFCOUNTED) {
223 switch (o->op_type) {
224 case OP_LEAVESUB:
225 case OP_LEAVESUBLV:
226 case OP_LEAVEEVAL:
227 case OP_LEAVE:
228 case OP_SCOPE:
229 case OP_LEAVEWRITE:
230 OP_REFCNT_LOCK;
231 if (OpREFCNT_dec(o)) {
232 OP_REFCNT_UNLOCK;
233 return;
234 }
235 OP_REFCNT_UNLOCK;
236 break;
237 default:
238 break;
239 }
240 }
241
11343788
MB		 242 if (o->op_flags & OPf_KIDS) {
243 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 244 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 245 op_free(kid);
85e6fe83 246 }
79072805 247 }
acb36ea4
GS		 248 type = o->op_type;
249 if (type == OP_NULL)
eb160463 250 type = (OPCODE)o->op_targ;
acb36ea4
GS		 251
252 /* COP* is not cleared by op_clear() so that we may track line
253 * numbers etc even after null() */
254 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
255 cop_free((COP*)o);
256
257 op_clear(o);
238a4c30 258 FreeOp(o);
acb36ea4 259}
79072805 260
93c66552
DM		 261void
262Perl_op_clear(pTHX_ OP *o)
acb36ea4 263{
13137afc 264
11343788 265 switch (o->op_type) {
acb36ea4
GS		 266 case OP_NULL: /* Was holding old type, if any. */
267 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 268 o->op_targ = 0;
a0d0e21e 269 break;
a6006777 270 default:
ac4c12e7 271 if (!(o->op_flags & OPf_REF)
0b94c7bb 272 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 273 break;
274 /* FALL THROUGH */
463ee0b2 275 case OP_GVSV:
79072805 276 case OP_GV:
a6006777 277 case OP_AELEMFAST:
350de78d 278#ifdef USE_ITHREADS
971a9dd3 279 if (cPADOPo->op_padix > 0) {
dd2155a4
DM		 280 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
281 * may still exist on the pad */
282 pad_swipe(cPADOPo->op_padix, TRUE);
971a9dd3
GS		 283 cPADOPo->op_padix = 0;
284 }
350de78d 285#else
971a9dd3 286 SvREFCNT_dec(cSVOPo->op_sv);
7934575e 287 cSVOPo->op_sv = Nullsv;
350de78d 288#endif
79072805 289 break;
a1ae71d2 290 case OP_METHOD_NAMED:
79072805 291 case OP_CONST:
11343788 292 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 293 cSVOPo->op_sv = Nullsv;
3b1c21fa
AB		 294#ifdef USE_ITHREADS
295 /** Bug #15654
296 Even if op_clear does a pad_free for the target of the op,
297 pad_free doesn't actually remove the sv that exists in the bad
298 instead it lives on. This results in that it could be reused as
299 a target later on when the pad was reallocated.
300 **/
301 if(o->op_targ) {
302 pad_swipe(o->op_targ,1);
303 o->op_targ = 0;
304 }
305#endif
79072805 306 break;
748a9306
LW		 307 case OP_GOTO:
308 case OP_NEXT:
309 case OP_LAST:
310 case OP_REDO:
11343788 311 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 312 break;
313 /* FALL THROUGH */
a0d0e21e 314 case OP_TRANS:
acb36ea4 315 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 316 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS		 317 cSVOPo->op_sv = Nullsv;
318 }
319 else {
a0ed51b3 320 Safefree(cPVOPo->op_pv);
acb36ea4
GS		 321 cPVOPo->op_pv = Nullch;
322 }
a0d0e21e
LW		 323 break;
324 case OP_SUBST:
11343788 325 op_free(cPMOPo->op_pmreplroot);
971a9dd3 326 goto clear_pmop;
748a9306 327 case OP_PUSHRE:
971a9dd3 328#ifdef USE_ITHREADS
ba89bb6e 329 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM		 330 /* No GvIN_PAD_off here, because other references may still
331 * exist on the pad */
332 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS		 333 }
334#else
335 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
336#endif
337 /* FALL THROUGH */
a0d0e21e 338 case OP_MATCH:
8782bef2 339 case OP_QR:
971a9dd3 340clear_pmop:
cb55de95
JH		 341 {
342 HV *pmstash = PmopSTASH(cPMOPo);
343 if (pmstash && SvREFCNT(pmstash)) {
344 PMOP *pmop = HvPMROOT(pmstash);
345 PMOP *lastpmop = NULL;
346 while (pmop) {
347 if (cPMOPo == pmop) {
348 if (lastpmop)
349 lastpmop->op_pmnext = pmop->op_pmnext;
350 else
351 HvPMROOT(pmstash) = pmop->op_pmnext;
352 break;
353 }
354 lastpmop = pmop;
355 pmop = pmop->op_pmnext;
356 }
83da49e6 357 }
05ec9bb3 358 PmopSTASH_free(cPMOPo);
cb55de95 359 }
971a9dd3 360 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM		 361 /* we use the "SAFE" version of the PM_ macros here
362 * since sv_clean_all might release some PMOPs
363 * after PL_regex_padav has been cleared
364 * and the clearing of PL_regex_padav needs to
365 * happen before sv_clean_all
366 */
367 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
368 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB		 369#ifdef USE_ITHREADS
370 if(PL_regex_pad) { /* We could be in destruction */
371 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 372 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 373 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
374 }
1eb1540c 375#endif
13137afc 376
a0d0e21e 377 break;
79072805
LW		 378 }
379
743e66e6 380 if (o->op_targ > 0) {
11343788 381 pad_free(o->op_targ);
743e66e6
GS		 382 o->op_targ = 0;
383 }
79072805
LW		 384}
385
76e3520e 386STATIC void
3eb57f73
HS		 387S_cop_free(pTHX_ COP* cop)
388{
05ec9bb3
NIS		 389 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
390 CopFILE_free(cop);
391 CopSTASH_free(cop);
0453d815 392 if (! specialWARN(cop->cop_warnings))
3eb57f73 393 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS		 394 if (! specialCopIO(cop->cop_io)) {
395#ifdef USE_ITHREADS
042f6df8 396#if 0
05ec9bb3
NIS		 397 STRLEN len;
398 char *s = SvPV(cop->cop_io,len);
b178108d
JH		 399 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
400#endif
05ec9bb3 401#else
ac27b0f5 402 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS		 403#endif
404 }
3eb57f73
HS		 405}
406
93c66552
DM		 407void
408Perl_op_null(pTHX_ OP *o)
8990e307 409{
acb36ea4
GS		 410 if (o->op_type == OP_NULL)
411 return;
412 op_clear(o);
11343788
MB		 413 o->op_targ = o->op_type;
414 o->op_type = OP_NULL;
22c35a8c 415 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 416}
417
79072805
LW		 418/* Contextualizers */
419
463ee0b2 420#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 421
422OP *
864dbfa3 423Perl_linklist(pTHX_ OP *o)
79072805
LW		 424{
425 register OP *kid;
426
11343788
MB		 427 if (o->op_next)
428 return o->op_next;
79072805
LW		 429
430 /* establish postfix order */
11343788
MB		 431 if (cUNOPo->op_first) {
432 o->op_next = LINKLIST(cUNOPo->op_first);
433 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 434 if (kid->op_sibling)
435 kid->op_next = LINKLIST(kid->op_sibling);
436 else
11343788 437 kid->op_next = o;
79072805
LW		 438 }
439 }
440 else
11343788 441 o->op_next = o;
79072805 442
11343788 443 return o->op_next;
79072805
LW		 444}
445
446OP *
864dbfa3 447Perl_scalarkids(pTHX_ OP *o)
79072805
LW		 448{
449 OP *kid;
11343788
MB		 450 if (o && o->op_flags & OPf_KIDS) {
451 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 452 scalar(kid);
453 }
11343788 454 return o;
79072805
LW		 455}
456
76e3520e 457STATIC OP *
cea2e8a9 458S_scalarboolean(pTHX_ OP *o)
8990e307 459{
d008e5eb 460 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 461 if (ckWARN(WARN_SYNTAX)) {
57843af0 462 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 463
d008e5eb 464 if (PL_copline != NOLINE)
57843af0 465 CopLINE_set(PL_curcop, PL_copline);
9014280d 466 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 467 CopLINE_set(PL_curcop, oldline);
d008e5eb 468 }
a0d0e21e 469 }
11343788 470 return scalar(o);
8990e307
LW		 471}
472
473OP *
864dbfa3 474Perl_scalar(pTHX_ OP *o)
79072805
LW		 475{
476 OP *kid;
477
a0d0e21e 478 /* assumes no premature commitment */
3280af22 479 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 480 || o->op_type == OP_RETURN)
7e363e51 481 {
11343788 482 return o;
7e363e51 483 }
79072805 484
5dc0d613 485 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 486
11343788 487 switch (o->op_type) {
79072805 488 case OP_REPEAT:
11343788 489 scalar(cBINOPo->op_first);
8990e307 490 break;
79072805
LW		 491 case OP_OR:
492 case OP_AND:
493 case OP_COND_EXPR:
11343788 494 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 495 scalar(kid);
79072805 496 break;
a0d0e21e 497 case OP_SPLIT:
11343788 498 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 499 if (!kPMOP->op_pmreplroot)
12bcd1a6 500 deprecate_old("implicit split to @_");
a0d0e21e
LW		 501 }
502 /* FALL THROUGH */
79072805 503 case OP_MATCH:
8782bef2 504 case OP_QR:
79072805
LW		 505 case OP_SUBST:
506 case OP_NULL:
8990e307 507 default:
11343788
MB		 508 if (o->op_flags & OPf_KIDS) {
509 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 510 scalar(kid);
511 }
79072805
LW		 512 break;
513 case OP_LEAVE:
514 case OP_LEAVETRY:
5dc0d613 515 kid = cLISTOPo->op_first;
54310121 516 scalar(kid);
155aba94 517 while ((kid = kid->op_sibling)) {
54310121 518 if (kid->op_sibling)
519 scalarvoid(kid);
520 else
521 scalar(kid);
522 }
3280af22 523 WITH_THR(PL_curcop = &PL_compiling);
54310121 524 break;
748a9306 525 case OP_SCOPE:
79072805 526 case OP_LINESEQ:
8990e307 527 case OP_LIST:
11343788 528 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 529 if (kid->op_sibling)
530 scalarvoid(kid);
531 else
532 scalar(kid);
533 }
3280af22 534 WITH_THR(PL_curcop = &PL_compiling);
79072805 535 break;
a801c63c
RGS		 536 case OP_SORT:
537 if (ckWARN(WARN_VOID))
9014280d 538 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 539 }
11343788 540 return o;
79072805
LW		 541}
542
543OP *
864dbfa3 544Perl_scalarvoid(pTHX_ OP *o)
79072805
LW		 545{
546 OP *kid;
8990e307
LW		 547 char* useless = 0;
548 SV* sv;
2ebea0a1
GS		 549 U8 want;
550
acb36ea4
GS		 551 if (o->op_type == OP_NEXTSTATE
552 || o->op_type == OP_SETSTATE
553 || o->op_type == OP_DBSTATE
554 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
555 || o->op_targ == OP_SETSTATE
556 || o->op_targ == OP_DBSTATE)))
2ebea0a1 557 PL_curcop = (COP*)o; /* for warning below */
79072805 558
54310121 559 /* assumes no premature commitment */
2ebea0a1
GS		 560 want = o->op_flags & OPf_WANT;
561 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 562 || o->op_type == OP_RETURN)
7e363e51 563 {
11343788 564 return o;
7e363e51 565 }
79072805 566
b162f9ea 567 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 568 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
569 {
b162f9ea 570 return scalar(o); /* As if inside SASSIGN */
7e363e51 571 }
1c846c1f 572
5dc0d613 573 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 574
11343788 575 switch (o->op_type) {
79072805 576 default:
22c35a8c 577 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 578 break;
36477c24 579 /* FALL THROUGH */
580 case OP_REPEAT:
11343788 581 if (o->op_flags & OPf_STACKED)
8990e307 582 break;
5d82c453
GA		 583 goto func_ops;
584 case OP_SUBSTR:
585 if (o->op_private == 4)
586 break;
8990e307
LW		 587 /* FALL THROUGH */
588 case OP_GVSV:
589 case OP_WANTARRAY:
590 case OP_GV:
591 case OP_PADSV:
592 case OP_PADAV:
593 case OP_PADHV:
594 case OP_PADANY:
595 case OP_AV2ARYLEN:
8990e307 596 case OP_REF:
a0d0e21e
LW		 597 case OP_REFGEN:
598 case OP_SREFGEN:
8990e307
LW		 599 case OP_DEFINED:
600 case OP_HEX:
601 case OP_OCT:
602 case OP_LENGTH:
8990e307
LW		 603 case OP_VEC:
604 case OP_INDEX:
605 case OP_RINDEX:
606 case OP_SPRINTF:
607 case OP_AELEM:
608 case OP_AELEMFAST:
609 case OP_ASLICE:
8990e307
LW		 610 case OP_HELEM:
611 case OP_HSLICE:
612 case OP_UNPACK:
613 case OP_PACK:
8990e307
LW		 614 case OP_JOIN:
615 case OP_LSLICE:
616 case OP_ANONLIST:
617 case OP_ANONHASH:
618 case OP_SORT:
619 case OP_REVERSE:
620 case OP_RANGE:
621 case OP_FLIP:
622 case OP_FLOP:
623 case OP_CALLER:
624 case OP_FILENO:
625 case OP_EOF:
626 case OP_TELL:
627 case OP_GETSOCKNAME:
628 case OP_GETPEERNAME:
629 case OP_READLINK:
630 case OP_TELLDIR:
631 case OP_GETPPID:
632 case OP_GETPGRP:
633 case OP_GETPRIORITY:
634 case OP_TIME:
635 case OP_TMS:
636 case OP_LOCALTIME:
637 case OP_GMTIME:
638 case OP_GHBYNAME:
639 case OP_GHBYADDR:
640 case OP_GHOSTENT:
641 case OP_GNBYNAME:
642 case OP_GNBYADDR:
643 case OP_GNETENT:
644 case OP_GPBYNAME:
645 case OP_GPBYNUMBER:
646 case OP_GPROTOENT:
647 case OP_GSBYNAME:
648 case OP_GSBYPORT:
649 case OP_GSERVENT:
650 case OP_GPWNAM:
651 case OP_GPWUID:
652 case OP_GGRNAM:
653 case OP_GGRGID:
654 case OP_GETLOGIN:
78e1b766 655 case OP_PROTOTYPE:
5d82c453 656 func_ops:
64aac5a9 657 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 658 useless = OP_DESC(o);
8990e307
LW		 659 break;
660
661 case OP_RV2GV:
662 case OP_RV2SV:
663 case OP_RV2AV:
664 case OP_RV2HV:
192587c2 665 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 666 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 667 useless = "a variable";
668 break;
79072805
LW		 669
670 case OP_CONST:
7766f137 671 sv = cSVOPo_sv;
7a52d87a
GS		 672 if (cSVOPo->op_private & OPpCONST_STRICT)
673 no_bareword_allowed(o);
674 else {
d008e5eb
GS		 675 if (ckWARN(WARN_VOID)) {
676 useless = "a constant";
960b4253
MG		 677 /* the constants 0 and 1 are permitted as they are
678 conventionally used as dummies in constructs like
679 1 while some_condition_with_side_effects; */
d008e5eb
GS		 680 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
681 useless = 0;
682 else if (SvPOK(sv)) {
a52fe3ac
A		 683 /* perl4's way of mixing documentation and code
684 (before the invention of POD) was based on a
685 trick to mix nroff and perl code. The trick was
686 built upon these three nroff macros being used in
687 void context. The pink camel has the details in
688 the script wrapman near page 319. */
d008e5eb
GS		 689 if (strnEQ(SvPVX(sv), "di", 2) ||
690 strnEQ(SvPVX(sv), "ds", 2) ||
691 strnEQ(SvPVX(sv), "ig", 2))
692 useless = 0;
693 }
8990e307
LW		 694 }
695 }
93c66552 696 op_null(o); /* don't execute or even remember it */
79072805
LW		 697 break;
698
699 case OP_POSTINC:
11343788 700 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 701 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 702 break;
703
704 case OP_POSTDEC:
11343788 705 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 706 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 707 break;
708
79072805
LW		 709 case OP_OR:
710 case OP_AND:
c963b151 711 case OP_DOR:
79072805 712 case OP_COND_EXPR:
11343788 713 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 714 scalarvoid(kid);
715 break;
5aabfad6 716
a0d0e21e 717 case OP_NULL:
11343788 718 if (o->op_flags & OPf_STACKED)
a0d0e21e 719 break;
5aabfad6 720 /* FALL THROUGH */
2ebea0a1
GS		 721 case OP_NEXTSTATE:
722 case OP_DBSTATE:
79072805
LW		 723 case OP_ENTERTRY:
724 case OP_ENTER:
11343788 725 if (!(o->op_flags & OPf_KIDS))
79072805 726 break;
54310121 727 /* FALL THROUGH */
463ee0b2 728 case OP_SCOPE:
79072805
LW		 729 case OP_LEAVE:
730 case OP_LEAVETRY:
a0d0e21e 731 case OP_LEAVELOOP:
79072805 732 case OP_LINESEQ:
79072805 733 case OP_LIST:
11343788 734 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 735 scalarvoid(kid);
736 break;
c90c0ff4 737 case OP_ENTEREVAL:
5196be3e 738 scalarkids(o);
c90c0ff4 739 break;
5aabfad6 740 case OP_REQUIRE:
c90c0ff4 741 /* all requires must return a boolean value */
5196be3e 742 o->op_flags &= ~OPf_WANT;
d6483035
GS		 743 /* FALL THROUGH */
744 case OP_SCALAR:
5196be3e 745 return scalar(o);
a0d0e21e 746 case OP_SPLIT:
11343788 747 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 748 if (!kPMOP->op_pmreplroot)
12bcd1a6 749 deprecate_old("implicit split to @_");
a0d0e21e
LW		 750 }
751 break;
79072805 752 }
411caa50 753 if (useless && ckWARN(WARN_VOID))
9014280d 754 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 755 return o;
79072805
LW		 756}
757
758OP *
864dbfa3 759Perl_listkids(pTHX_ OP *o)
79072805
LW		 760{
761 OP *kid;
11343788
MB		 762 if (o && o->op_flags & OPf_KIDS) {
763 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 764 list(kid);
765 }
11343788 766 return o;
79072805
LW		 767}
768
769OP *
864dbfa3 770Perl_list(pTHX_ OP *o)
79072805
LW		 771{
772 OP *kid;
773
a0d0e21e 774 /* assumes no premature commitment */
3280af22 775 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 776 || o->op_type == OP_RETURN)
7e363e51 777 {
11343788 778 return o;
7e363e51 779 }
79072805 780
b162f9ea 781 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 782 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
783 {
b162f9ea 784 return o; /* As if inside SASSIGN */
7e363e51 785 }
1c846c1f 786
5dc0d613 787 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 788
11343788 789 switch (o->op_type) {
79072805
LW		 790 case OP_FLOP:
791 case OP_REPEAT:
11343788 792 list(cBINOPo->op_first);
79072805
LW		 793 break;
794 case OP_OR:
795 case OP_AND:
796 case OP_COND_EXPR:
11343788 797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 798 list(kid);
799 break;
800 default:
801 case OP_MATCH:
8782bef2 802 case OP_QR:
79072805
LW		 803 case OP_SUBST:
804 case OP_NULL:
11343788 805 if (!(o->op_flags & OPf_KIDS))
79072805 806 break;
11343788
MB		 807 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
808 list(cBINOPo->op_first);
809 return gen_constant_list(o);
79072805
LW		 810 }
811 case OP_LIST:
11343788 812 listkids(o);
79072805
LW		 813 break;
814 case OP_LEAVE:
815 case OP_LEAVETRY:
5dc0d613 816 kid = cLISTOPo->op_first;
54310121 817 list(kid);
155aba94 818 while ((kid = kid->op_sibling)) {
54310121 819 if (kid->op_sibling)
820 scalarvoid(kid);
821 else
822 list(kid);
823 }
3280af22 824 WITH_THR(PL_curcop = &PL_compiling);
54310121 825 break;
748a9306 826 case OP_SCOPE:
79072805 827 case OP_LINESEQ:
11343788 828 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 829 if (kid->op_sibling)
830 scalarvoid(kid);
831 else
832 list(kid);
833 }
3280af22 834 WITH_THR(PL_curcop = &PL_compiling);
79072805 835 break;
c90c0ff4 836 case OP_REQUIRE:
837 /* all requires must return a boolean value */
5196be3e
MB		 838 o->op_flags &= ~OPf_WANT;
839 return scalar(o);
79072805 840 }
11343788 841 return o;
79072805
LW		 842}
843
844OP *
864dbfa3 845Perl_scalarseq(pTHX_ OP *o)
79072805
LW		 846{
847 OP *kid;
848
11343788
MB		 849 if (o) {
850 if (o->op_type == OP_LINESEQ ||
851 o->op_type == OP_SCOPE ||
852 o->op_type == OP_LEAVE ||
853 o->op_type == OP_LEAVETRY)
463ee0b2 854 {
11343788 855 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 856 if (kid->op_sibling) {
463ee0b2 857 scalarvoid(kid);
ed6116ce 858 }
463ee0b2 859 }
3280af22 860 PL_curcop = &PL_compiling;
79072805 861 }
11343788 862 o->op_flags &= ~OPf_PARENS;
3280af22 863 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 864 o->op_flags |= OPf_PARENS;
79072805 865 }
8990e307 866 else
11343788
MB		 867 o = newOP(OP_STUB, 0);
868 return o;
79072805
LW		 869}
870
76e3520e 871STATIC OP *
cea2e8a9 872S_modkids(pTHX_ OP *o, I32 type)
79072805
LW		 873{
874 OP *kid;
11343788
MB		 875 if (o && o->op_flags & OPf_KIDS) {
876 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 877 mod(kid, type);
79072805 878 }
11343788 879 return o;
79072805
LW		 880}
881
ddeae0f1
DM		 882/* Propagate lvalue ("modifiable") context to an op and it's children.
883 * 'type' represents the context type, roughly based on the type of op that
884 * would do the modifying, although local() is represented by OP_NULL.
885 * It's responsible for detecting things that can't be modified, flag
886 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
887 * might have to vivify a reference in $x), and so on.
888 *
889 * For example, "$a+1 = 2" would cause mod() to be called with o being
890 * OP_ADD and type being OP_SASSIGN, and would output an error.
891 */
892
79072805 893OP *
864dbfa3 894Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW		 895{
896 OP *kid;
ddeae0f1
DM		 897 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
898 int localize = -1;
79072805 899
3280af22 900 if (!o || PL_error_count)
11343788 901 return o;
79072805 902
b162f9ea 903 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 904 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
905 {
b162f9ea 906 return o;
7e363e51 907 }
1c846c1f 908
11343788 909 switch (o->op_type) {
68dc0745 910 case OP_UNDEF:
ddeae0f1 911 localize = 0;
3280af22 912 PL_modcount++;
5dc0d613 913 return o;
a0d0e21e 914 case OP_CONST:
11343788 915 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 916 goto nomod;
3280af22 917 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 918 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 919 PL_eval_start = 0;
a0d0e21e
LW		 920 }
921 else if (!type) {
3280af22
NIS		 922 SAVEI32(PL_compiling.cop_arybase);
923 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 924 }
925 else if (type == OP_REFGEN)
926 goto nomod;
927 else
cea2e8a9 928 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 929 break;
5f05dabc 930 case OP_STUB:
5196be3e 931 if (o->op_flags & OPf_PARENS)
5f05dabc 932 break;
933 goto nomod;
a0d0e21e
LW		 934 case OP_ENTERSUB:
935 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 936 !(o->op_flags & OPf_STACKED)) {
937 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 938 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 939 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 940 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 941 break;
942 }
95f0a2f1
SB		 943 else if (o->op_private & OPpENTERSUB_NOMOD)
944 return o;
cd06dffe
GS		 945 else { /* lvalue subroutine call */
946 o->op_private |= OPpLVAL_INTRO;
e6438c1a 947 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 948 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 949 /* Backward compatibility mode: */
950 o->op_private |= OPpENTERSUB_INARGS;
951 break;
952 }
953 else { /* Compile-time error message: */
954 OP *kid = cUNOPo->op_first;
955 CV *cv;
956 OP *okid;
957
958 if (kid->op_type == OP_PUSHMARK)
959 goto skip_kids;
960 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
961 Perl_croak(aTHX_
962 "panic: unexpected lvalue entersub "
55140b79 963 "args: type/targ %ld:%"UVuf,
3d811634 964 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 965 kid = kLISTOP->op_first;
966 skip_kids:
967 while (kid->op_sibling)
968 kid = kid->op_sibling;
969 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
970 /* Indirect call */
971 if (kid->op_type == OP_METHOD_NAMED
972 || kid->op_type == OP_METHOD)
973 {
87d7fd28 974 UNOP *newop;
b2ffa427 975
87d7fd28 976 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 977 newop->op_type = OP_RV2CV;
978 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 979 newop->op_first = Nullop;
980 newop->op_next = (OP*)newop;
981 kid->op_sibling = (OP*)newop;
349fd7b7 982 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS		 983 break;
984 }
b2ffa427 985
cd06dffe
GS		 986 if (kid->op_type != OP_RV2CV)
987 Perl_croak(aTHX_
988 "panic: unexpected lvalue entersub "
55140b79 989 "entry via type/targ %ld:%"UVuf,
3d811634 990 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 991 kid->op_private |= OPpLVAL_INTRO;
992 break; /* Postpone until runtime */
993 }
b2ffa427
NIS		 994
995 okid = kid;
cd06dffe
GS		 996 kid = kUNOP->op_first;
997 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
998 kid = kUNOP->op_first;
b2ffa427 999 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1000 Perl_croak(aTHX_
1001 "Unexpected constant lvalue entersub "
55140b79 1002 "entry via type/targ %ld:%"UVuf,
3d811634 1003 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1004 if (kid->op_type != OP_GV) {
1005 /* Restore RV2CV to check lvalueness */
1006 restore_2cv:
1007 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1008 okid->op_next = kid->op_next;
1009 kid->op_next = okid;
1010 }
1011 else
1012 okid->op_next = Nullop;
1013 okid->op_type = OP_RV2CV;
1014 okid->op_targ = 0;
1015 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1016 okid->op_private |= OPpLVAL_INTRO;
1017 break;
1018 }
b2ffa427 1019
638eceb6 1020 cv = GvCV(kGVOP_gv);
1c846c1f 1021 if (!cv)
cd06dffe
GS		 1022 goto restore_2cv;
1023 if (CvLVALUE(cv))
1024 break;
1025 }
1026 }
79072805
LW		 1027 /* FALL THROUGH */
1028 default:
a0d0e21e
LW		 1029 nomod:
1030 /* grep, foreach, subcalls, refgen */
1031 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1032 break;
cea2e8a9 1033 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1034 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1035 ? "do block"
1036 : (o->op_type == OP_ENTERSUB
1037 ? "non-lvalue subroutine call"
53e06cf0 1038 : OP_DESC(o))),
22c35a8c 1039 type ? PL_op_desc[type] : "local"));
11343788 1040 return o;
79072805 1041
a0d0e21e
LW		 1042 case OP_PREINC:
1043 case OP_PREDEC:
1044 case OP_POW:
1045 case OP_MULTIPLY:
1046 case OP_DIVIDE:
1047 case OP_MODULO:
1048 case OP_REPEAT:
1049 case OP_ADD:
1050 case OP_SUBTRACT:
1051 case OP_CONCAT:
1052 case OP_LEFT_SHIFT:
1053 case OP_RIGHT_SHIFT:
1054 case OP_BIT_AND:
1055 case OP_BIT_XOR:
1056 case OP_BIT_OR:
1057 case OP_I_MULTIPLY:
1058 case OP_I_DIVIDE:
1059 case OP_I_MODULO:
1060 case OP_I_ADD:
1061 case OP_I_SUBTRACT:
11343788 1062 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1063 goto nomod;
3280af22 1064 PL_modcount++;
a0d0e21e 1065 break;
b2ffa427 1066
79072805 1067 case OP_COND_EXPR:
ddeae0f1 1068 localize = 1;
11343788 1069 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1070 mod(kid, type);
79072805
LW		 1071 break;
1072
1073 case OP_RV2AV:
1074 case OP_RV2HV:
11343788 1075 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1076 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1077 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1078 }
1079 /* FALL THROUGH */
79072805 1080 case OP_RV2GV:
5dc0d613 1081 if (scalar_mod_type(o, type))
3fe9a6f1 1082 goto nomod;
11343788 1083 ref(cUNOPo->op_first, o->op_type);
79072805 1084 /* FALL THROUGH */
79072805
LW		 1085 case OP_ASLICE:
1086 case OP_HSLICE:
78f9721b
SM		 1087 if (type == OP_LEAVESUBLV)
1088 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1089 localize = 1;
78f9721b
SM		 1090 /* FALL THROUGH */
1091 case OP_AASSIGN:
93a17b20
LW		 1092 case OP_NEXTSTATE:
1093 case OP_DBSTATE:
e6438c1a 1094 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1095 break;
463ee0b2 1096 case OP_RV2SV:
aeea060c 1097 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1098 localize = 1;
463ee0b2 1099 /* FALL THROUGH */
79072805 1100 case OP_GV:
463ee0b2 1101 case OP_AV2ARYLEN:
3280af22 1102 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1103 case OP_SASSIGN:
bf4b1e52
GS		 1104 case OP_ANDASSIGN:
1105 case OP_ORASSIGN:
c963b151 1106 case OP_DORASSIGN:
ddeae0f1
DM		 1107 PL_modcount++;
1108 break;
1109
8990e307 1110 case OP_AELEMFAST:
ddeae0f1 1111 localize = 1;
3280af22 1112 PL_modcount++;
8990e307
LW		 1113 break;
1114
748a9306
LW		 1115 case OP_PADAV:
1116 case OP_PADHV:
e6438c1a 1117 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1118 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1119 return o; /* Treat \(@foo) like ordinary list. */
1120 if (scalar_mod_type(o, type))
3fe9a6f1 1121 goto nomod;
78f9721b
SM		 1122 if (type == OP_LEAVESUBLV)
1123 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1124 /* FALL THROUGH */
1125 case OP_PADSV:
3280af22 1126 PL_modcount++;
ddeae0f1 1127 if (!type) /* local() */
cea2e8a9 1128 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1129 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1130 break;
1131
748a9306 1132 case OP_PUSHMARK:
ddeae0f1 1133 localize = 0;
748a9306 1134 break;
b2ffa427 1135
69969c6f
SB		 1136 case OP_KEYS:
1137 if (type != OP_SASSIGN)
1138 goto nomod;
5d82c453
GA		 1139 goto lvalue_func;
1140 case OP_SUBSTR:
1141 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1142 goto nomod;
5f05dabc 1143 /* FALL THROUGH */
a0d0e21e 1144 case OP_POS:
463ee0b2 1145 case OP_VEC:
78f9721b
SM		 1146 if (type == OP_LEAVESUBLV)
1147 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1148 lvalue_func:
11343788
MB		 1149 pad_free(o->op_targ);
1150 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1151 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1152 if (o->op_flags & OPf_KIDS)
1153 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1154 break;
a0d0e21e 1155
463ee0b2
LW		 1156 case OP_AELEM:
1157 case OP_HELEM:
11343788 1158 ref(cBINOPo->op_first, o->op_type);
68dc0745 1159 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1160 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1161 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1162 if (type == OP_LEAVESUBLV)
1163 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1164 localize = 1;
3280af22 1165 PL_modcount++;
463ee0b2
LW		 1166 break;
1167
1168 case OP_SCOPE:
1169 case OP_LEAVE:
1170 case OP_ENTER:
78f9721b 1171 case OP_LINESEQ:
ddeae0f1 1172 localize = 0;
11343788
MB		 1173 if (o->op_flags & OPf_KIDS)
1174 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1175 break;
1176
1177 case OP_NULL:
ddeae0f1 1178 localize = 0;
638bc118
GS		 1179 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1180 goto nomod;
1181 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1182 break;
11343788
MB		 1183 if (o->op_targ != OP_LIST) {
1184 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1185 break;
1186 }
1187 /* FALL THROUGH */
463ee0b2 1188 case OP_LIST:
ddeae0f1 1189 localize = 0;
11343788 1190 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1191 mod(kid, type);
1192 break;
78f9721b
SM		 1193
1194 case OP_RETURN:
1195 if (type != OP_LEAVESUBLV)
1196 goto nomod;
1197 break; /* mod()ing was handled by ck_return() */
463ee0b2 1198 }
58d95175 1199
8be1be90
AMS		 1200 /* [20011101.069] File test operators interpret OPf_REF to mean that
1201 their argument is a filehandle; thus \stat(".") should not set
1202 it. AMS 20011102 */
1203 if (type == OP_REFGEN &&
1204 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1205 return o;
1206
1207 if (type != OP_LEAVESUBLV)
1208 o->op_flags |= OPf_MOD;
1209
1210 if (type == OP_AASSIGN || type == OP_SASSIGN)
1211 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1212 else if (!type) { /* local() */
1213 switch (localize) {
1214 case 1:
1215 o->op_private |= OPpLVAL_INTRO;
1216 o->op_flags &= ~OPf_SPECIAL;
1217 PL_hints |= HINT_BLOCK_SCOPE;
1218 break;
1219 case 0:
1220 break;
1221 case -1:
1222 if (ckWARN(WARN_SYNTAX)) {
1223 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1224 "Useless localization of %s", OP_DESC(o));
1225 }
1226 }
463ee0b2 1227 }
8be1be90
AMS		 1228 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1229 && type != OP_LEAVESUBLV)
1230 o->op_flags |= OPf_REF;
11343788 1231 return o;
463ee0b2
LW		 1232}
1233
864dbfa3 1234STATIC bool
cea2e8a9 1235S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1 1236{
1237 switch (type) {
1238 case OP_SASSIGN:
5196be3e 1239 if (o->op_type == OP_RV2GV)
3fe9a6f1 1240 return FALSE;
1241 /* FALL THROUGH */
1242 case OP_PREINC:
1243 case OP_PREDEC:
1244 case OP_POSTINC:
1245 case OP_POSTDEC:
1246 case OP_I_PREINC:
1247 case OP_I_PREDEC:
1248 case OP_I_POSTINC:
1249 case OP_I_POSTDEC:
1250 case OP_POW:
1251 case OP_MULTIPLY:
1252 case OP_DIVIDE:
1253 case OP_MODULO:
1254 case OP_REPEAT:
1255 case OP_ADD:
1256 case OP_SUBTRACT:
1257 case OP_I_MULTIPLY:
1258 case OP_I_DIVIDE:
1259 case OP_I_MODULO:
1260 case OP_I_ADD:
1261 case OP_I_SUBTRACT:
1262 case OP_LEFT_SHIFT:
1263 case OP_RIGHT_SHIFT:
1264 case OP_BIT_AND:
1265 case OP_BIT_XOR:
1266 case OP_BIT_OR:
1267 case OP_CONCAT:
1268 case OP_SUBST:
1269 case OP_TRANS:
49e9fbe6
GS		 1270 case OP_READ:
1271 case OP_SYSREAD:
1272 case OP_RECV:
bf4b1e52
GS		 1273 case OP_ANDASSIGN:
1274 case OP_ORASSIGN:
3fe9a6f1 1275 return TRUE;
1276 default:
1277 return FALSE;
1278 }
1279}
1280
35cd451c 1281STATIC bool
cea2e8a9 1282S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS		 1283{
1284 switch (o->op_type) {
1285 case OP_PIPE_OP:
1286 case OP_SOCKPAIR:
1287 if (argnum == 2)
1288 return TRUE;
1289 /* FALL THROUGH */
1290 case OP_SYSOPEN:
1291 case OP_OPEN:
ded8aa31 1292 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1293 case OP_SOCKET:
1294 case OP_OPEN_DIR:
1295 case OP_ACCEPT:
1296 if (argnum == 1)
1297 return TRUE;
1298 /* FALL THROUGH */
1299 default:
1300 return FALSE;
1301 }
1302}
1303
463ee0b2 1304OP *
864dbfa3 1305Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1306{
1307 OP *kid;
11343788
MB		 1308 if (o && o->op_flags & OPf_KIDS) {
1309 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1310 ref(kid, type);
1311 }
11343788 1312 return o;
463ee0b2
LW		 1313}
1314
1315OP *
864dbfa3 1316Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1317{
1318 OP *kid;
463ee0b2 1319
3280af22 1320 if (!o || PL_error_count)
11343788 1321 return o;
463ee0b2 1322
11343788 1323 switch (o->op_type) {
a0d0e21e 1324 case OP_ENTERSUB:
afebc493 1325 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1326 !(o->op_flags & OPf_STACKED)) {
1327 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1328 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1329 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1330 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1331 o->op_flags |= OPf_SPECIAL;
8990e307
LW		 1332 }
1333 break;
aeea060c 1334
463ee0b2 1335 case OP_COND_EXPR:
11343788 1336 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW		 1337 ref(kid, type);
1338 break;
8990e307 1339 case OP_RV2SV:
35cd451c
GS		 1340 if (type == OP_DEFINED)
1341 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1342 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW		 1343 /* FALL THROUGH */
1344 case OP_PADSV:
5f05dabc 1345 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1346 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1347 : type == OP_RV2HV ? OPpDEREF_HV
1348 : OPpDEREF_SV);
11343788 1349 o->op_flags |= OPf_MOD;
a0d0e21e 1350 }
8990e307 1351 break;
1c846c1f 1352
2faa37cc 1353 case OP_THREADSV:
a863c7d1
MB		 1354 o->op_flags |= OPf_MOD; /* XXX ??? */
1355 break;
1356
463ee0b2
LW		 1357 case OP_RV2AV:
1358 case OP_RV2HV:
aeea060c 1359 o->op_flags |= OPf_REF;
8990e307 1360 /* FALL THROUGH */
463ee0b2 1361 case OP_RV2GV:
35cd451c
GS		 1362 if (type == OP_DEFINED)
1363 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1364 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1365 break;
8990e307 1366
463ee0b2
LW		 1367 case OP_PADAV:
1368 case OP_PADHV:
aeea060c 1369 o->op_flags |= OPf_REF;
79072805 1370 break;
aeea060c 1371
8990e307 1372 case OP_SCALAR:
79072805 1373 case OP_NULL:
11343788 1374 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1375 break;
11343788 1376 ref(cBINOPo->op_first, type);
79072805
LW		 1377 break;
1378 case OP_AELEM:
1379 case OP_HELEM:
11343788 1380 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1381 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1382 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1383 : type == OP_RV2HV ? OPpDEREF_HV
1384 : OPpDEREF_SV);
11343788 1385 o->op_flags |= OPf_MOD;
8990e307 1386 }
79072805
LW		 1387 break;
1388
463ee0b2 1389 case OP_SCOPE:
79072805
LW		 1390 case OP_LEAVE:
1391 case OP_ENTER:
8990e307 1392 case OP_LIST:
11343788 1393 if (!(o->op_flags & OPf_KIDS))
79072805 1394 break;
11343788 1395 ref(cLISTOPo->op_last, type);
79072805 1396 break;
a0d0e21e
LW		 1397 default:
1398 break;
79072805 1399 }
11343788 1400 return scalar(o);
8990e307 1401
79072805
LW		 1402}
1403
09bef843
SB		 1404STATIC OP *
1405S_dup_attrlist(pTHX_ OP *o)
1406{
1407 OP *rop = Nullop;
1408
1409 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1410 * where the first kid is OP_PUSHMARK and the remaining ones
1411 * are OP_CONST. We need to push the OP_CONST values.
1412 */
1413 if (o->op_type == OP_CONST)
1414 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1415 else {
1416 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1417 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1418 if (o->op_type == OP_CONST)
1419 rop = append_elem(OP_LIST, rop,
1420 newSVOP(OP_CONST, o->op_flags,
1421 SvREFCNT_inc(cSVOPo->op_sv)));
1422 }
1423 }
1424 return rop;
1425}
1426
1427STATIC void
95f0a2f1 1428S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1429{
09bef843
SB		 1430 SV *stashsv;
1431
1432 /* fake up C<use attributes $pkg,$rv,@attrs> */
1433 ENTER; /* need to protect against side-effects of 'use' */
1434 SAVEINT(PL_expect);
a9164de8 1435 if (stash)
09bef843
SB		 1436 stashsv = newSVpv(HvNAME(stash), 0);
1437 else
1438 stashsv = &PL_sv_no;
e4783991 1439
09bef843 1440#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1441#define ATTRSMODULE_PM "attributes.pm"
1442
1443 if (for_my) {
1444 SV **svp;
1445 /* Don't force the C<use> if we don't need it. */
1446 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1447 sizeof(ATTRSMODULE_PM)-1, 0);
1448 if (svp && *svp != &PL_sv_undef)
1449 ; /* already in %INC */
1450 else
1451 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1452 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1453 Nullsv);
1454 }
1455 else {
1456 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1457 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1458 Nullsv,
1459 prepend_elem(OP_LIST,
1460 newSVOP(OP_CONST, 0, stashsv),
1461 prepend_elem(OP_LIST,
1462 newSVOP(OP_CONST, 0,
1463 newRV(target)),
1464 dup_attrlist(attrs))));
1465 }
09bef843
SB		 1466 LEAVE;
1467}
1468
95f0a2f1
SB		 1469STATIC void
1470S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1471{
1472 OP *pack, *imop, *arg;
1473 SV *meth, *stashsv;
1474
1475 if (!attrs)
1476 return;
1477
1478 assert(target->op_type == OP_PADSV ||
1479 target->op_type == OP_PADHV ||
1480 target->op_type == OP_PADAV);
1481
1482 /* Ensure that attributes.pm is loaded. */
dd2155a4 1483 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1484
1485 /* Need package name for method call. */
1486 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1487
1488 /* Build up the real arg-list. */
1489 if (stash)
1490 stashsv = newSVpv(HvNAME(stash), 0);
1491 else
1492 stashsv = &PL_sv_no;
1493 arg = newOP(OP_PADSV, 0);
1494 arg->op_targ = target->op_targ;
1495 arg = prepend_elem(OP_LIST,
1496 newSVOP(OP_CONST, 0, stashsv),
1497 prepend_elem(OP_LIST,
1498 newUNOP(OP_REFGEN, 0,
1499 mod(arg, OP_REFGEN)),
1500 dup_attrlist(attrs)));
1501
1502 /* Fake up a method call to import */
1503 meth = newSVpvn("import", 6);
1504 (void)SvUPGRADE(meth, SVt_PVIV);
1505 (void)SvIOK_on(meth);
5afd6d42 1506 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
95f0a2f1
SB		 1507 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1508 append_elem(OP_LIST,
1509 prepend_elem(OP_LIST, pack, list(arg)),
1510 newSVOP(OP_METHOD_NAMED, 0, meth)));
1511 imop->op_private |= OPpENTERSUB_NOMOD;
1512
1513 /* Combine the ops. */
1514 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1515}
1516
1517/*
1518=notfor apidoc apply_attrs_string
1519
1520Attempts to apply a list of attributes specified by the C<attrstr> and
1521C<len> arguments to the subroutine identified by the C<cv> argument which
1522is expected to be associated with the package identified by the C<stashpv>
1523argument (see L<attributes>). It gets this wrong, though, in that it
1524does not correctly identify the boundaries of the individual attribute
1525specifications within C<attrstr>. This is not really intended for the
1526public API, but has to be listed here for systems such as AIX which
1527need an explicit export list for symbols. (It's called from XS code
1528in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1529to respect attribute syntax properly would be welcome.
1530
1531=cut
1532*/
1533
be3174d2
GS		 1534void
1535Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1536 char *attrstr, STRLEN len)
1537{
1538 OP *attrs = Nullop;
1539
1540 if (!len) {
1541 len = strlen(attrstr);
1542 }
1543
1544 while (len) {
1545 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1546 if (len) {
1547 char *sstr = attrstr;
1548 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1549 attrs = append_elem(OP_LIST, attrs,
1550 newSVOP(OP_CONST, 0,
1551 newSVpvn(sstr, attrstr-sstr)));
1552 }
1553 }
1554
1555 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1556 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557 Nullsv, prepend_elem(OP_LIST,
1558 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1559 prepend_elem(OP_LIST,
1560 newSVOP(OP_CONST, 0,
1561 newRV((SV*)cv)),
1562 attrs)));
1563}
1564
09bef843 1565STATIC OP *
95f0a2f1 1566S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20
LW		 1567{
1568 OP *kid;
93a17b20
LW		 1569 I32 type;
1570
3280af22 1571 if (!o || PL_error_count)
11343788 1572 return o;
93a17b20 1573
11343788 1574 type = o->op_type;
93a17b20 1575 if (type == OP_LIST) {
11343788 1576 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1577 my_kid(kid, attrs, imopsp);
dab48698 1578 } else if (type == OP_UNDEF) {
7766148a 1579 return o;
77ca0c92
LW		 1580 } else if (type == OP_RV2SV || /* "our" declaration */
1581 type == OP_RV2AV ||
1582 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS		 1583 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1584 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1585 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1586 } else if (attrs) {
1587 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1588 PL_in_my = FALSE;
1589 PL_in_my_stash = Nullhv;
1590 apply_attrs(GvSTASH(gv),
1591 (type == OP_RV2SV ? GvSV(gv) :
1592 type == OP_RV2AV ? (SV*)GvAV(gv) :
1593 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1594 attrs, FALSE);
1595 }
192587c2 1596 o->op_private |= OPpOUR_INTRO;
77ca0c92 1597 return o;
95f0a2f1
SB		 1598 }
1599 else if (type != OP_PADSV &&
93a17b20
LW		 1600 type != OP_PADAV &&
1601 type != OP_PADHV &&
1602 type != OP_PUSHMARK)
1603 {
eb64745e 1604 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1605 OP_DESC(o),
eb64745e 1606 PL_in_my == KEY_our ? "our" : "my"));
11343788 1607 return o;
93a17b20 1608 }
09bef843
SB		 1609 else if (attrs && type != OP_PUSHMARK) {
1610 HV *stash;
09bef843 1611
eb64745e
GS		 1612 PL_in_my = FALSE;
1613 PL_in_my_stash = Nullhv;
1614
09bef843 1615 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1616 stash = PAD_COMPNAME_TYPE(o->op_targ);
1617 if (!stash)
09bef843 1618 stash = PL_curstash;
95f0a2f1 1619 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1620 }
11343788
MB		 1621 o->op_flags |= OPf_MOD;
1622 o->op_private |= OPpLVAL_INTRO;
1623 return o;
93a17b20
LW		 1624}
1625
1626OP *
09bef843
SB		 1627Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1628{
95f0a2f1
SB		 1629 OP *rops = Nullop;
1630 int maybe_scalar = 0;
1631
d2be0de5 1632/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1633 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1634#if 0
09bef843
SB		 1635 if (o->op_flags & OPf_PARENS)
1636 list(o);
95f0a2f1
SB		 1637 else
1638 maybe_scalar = 1;
d2be0de5
YST		 1639#else
1640 maybe_scalar = 1;
1641#endif
09bef843
SB		 1642 if (attrs)
1643 SAVEFREEOP(attrs);
95f0a2f1
SB		 1644 o = my_kid(o, attrs, &rops);
1645 if (rops) {
1646 if (maybe_scalar && o->op_type == OP_PADSV) {
1647 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1648 o->op_private |= OPpLVAL_INTRO;
1649 }
1650 else
1651 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1652 }
eb64745e
GS		 1653 PL_in_my = FALSE;
1654 PL_in_my_stash = Nullhv;
1655 return o;
09bef843
SB		 1656}
1657
1658OP *
1659Perl_my(pTHX_ OP *o)
1660{
95f0a2f1 1661 return my_attrs(o, Nullop);
09bef843
SB		 1662}
1663
1664OP *
864dbfa3 1665Perl_sawparens(pTHX_ OP *o)
79072805
LW		 1666{
1667 if (o)
1668 o->op_flags |= OPf_PARENS;
1669 return o;
1670}
1671
1672OP *
864dbfa3 1673Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1674{
11343788 1675 OP *o;
79072805 1676
e476b1b5 1677 if (ckWARN(WARN_MISC) &&
599cee73
PM		 1678 (left->op_type == OP_RV2AV ||
1679 left->op_type == OP_RV2HV ||
1680 left->op_type == OP_PADAV ||
1681 left->op_type == OP_PADHV)) {
22c35a8c 1682 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 1683 right->op_type == OP_TRANS)
1684 ? right->op_type : OP_MATCH];
dff6d3cd
GS		 1685 const char *sample = ((left->op_type == OP_RV2AV ||
1686 left->op_type == OP_PADAV)
1687 ? "@array" : "%hash");
9014280d 1688 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1689 "Applying %s to %s will act on scalar(%s)",
599cee73 1690 desc, sample, sample);
2ae324a7 1691 }
1692
5cc9e5c9
RH		 1693 if (right->op_type == OP_CONST &&
1694 cSVOPx(right)->op_private & OPpCONST_BARE &&
1695 cSVOPx(right)->op_private & OPpCONST_STRICT)
1696 {
1697 no_bareword_allowed(right);
1698 }
1699
de4bf5b3
MG		 1700 if (!(right->op_flags & OPf_STACKED) &&
1701 (right->op_type == OP_MATCH ||
79072805 1702 right->op_type == OP_SUBST ||
de4bf5b3 1703 right->op_type == OP_TRANS)) {
79072805 1704 right->op_flags |= OPf_STACKED;
18808301
JH		 1705 if (right->op_type != OP_MATCH &&
1706 ! (right->op_type == OP_TRANS &&
1707 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1708 left = mod(left, right->op_type);
79072805 1709 if (right->op_type == OP_TRANS)
11343788 1710 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1711 else
11343788 1712 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1713 if (type == OP_NOT)
11343788
MB		 1714 return newUNOP(OP_NOT, 0, scalar(o));
1715 return o;
79072805
LW		 1716 }
1717 else
1718 return bind_match(type, left,
1719 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1720}
1721
1722OP *
864dbfa3 1723Perl_invert(pTHX_ OP *o)
79072805 1724{
11343788
MB		 1725 if (!o)
1726 return o;
79072805 1727 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1728 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1729}
1730
1731OP *
864dbfa3 1732Perl_scope(pTHX_ OP *o)
79072805
LW		 1733{
1734 if (o) {
3280af22 1735 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1736 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1737 o->op_type = OP_LEAVE;
22c35a8c 1738 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1739 }
fdb22418
HS		 1740 else if (o->op_type == OP_LINESEQ) {
1741 OP *kid;
1742 o->op_type = OP_SCOPE;
1743 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1744 kid = ((LISTOP*)o)->op_first;
1745 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1746 op_null(kid);
463ee0b2 1747 }
fdb22418
HS		 1748 else
1749 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
79072805
LW		 1750 }
1751 return o;
1752}
1753
b3ac6de7 1754void
864dbfa3 1755Perl_save_hints(pTHX)
b3ac6de7 1756{
3280af22
NIS		 1757 SAVEI32(PL_hints);
1758 SAVESPTR(GvHV(PL_hintgv));
1759 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1760 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ		 1761}
1762
a0d0e21e 1763int
864dbfa3 1764Perl_block_start(pTHX_ int full)
79072805 1765{
3280af22 1766 int retval = PL_savestack_ix;
39aa8287
RGS		 1767 /* If there were syntax errors, don't try to start a block */
1768 if (PL_yynerrs) return retval;
b3ac6de7 1769
dd2155a4 1770 pad_block_start(full);
b3ac6de7 1771 SAVEHINTS();
3280af22 1772 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1773 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1774 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 1775 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1776 SAVEFREESV(PL_compiling.cop_warnings) ;
1777 }
ac27b0f5
NIS		 1778 SAVESPTR(PL_compiling.cop_io);
1779 if (! specialCopIO(PL_compiling.cop_io)) {
1780 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1781 SAVEFREESV(PL_compiling.cop_io) ;
1782 }
a0d0e21e
LW		 1783 return retval;
1784}
1785
1786OP*
864dbfa3 1787Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1788{
3280af22 1789 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
e9f19e3c 1790 OP* retval = scalarseq(seq);
39aa8287
RGS		 1791 /* If there were syntax errors, don't try to close a block */
1792 if (PL_yynerrs) return retval;
e9818f4e 1793 LEAVE_SCOPE(floor);
eb160463 1794 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1795 if (needblockscope)
3280af22 1796 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1797 pad_leavemy();
a0d0e21e
LW		 1798 return retval;
1799}
1800
76e3520e 1801STATIC OP *
cea2e8a9 1802S_newDEFSVOP(pTHX)
54b9620d 1803{
3280af22 1804 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
54b9620d
MB		 1805}
1806
a0d0e21e 1807void
864dbfa3 1808Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1809{
3280af22 1810 if (PL_in_eval) {
b295d113
TH		 1811 if (PL_eval_root)
1812 return;
faef0170
HS		 1813 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1814 ((PL_in_eval & EVAL_KEEPERR)
1815 ? OPf_SPECIAL : 0), o);
3280af22 1816 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 1817 PL_eval_root->op_private |= OPpREFCOUNTED;
1818 OpREFCNT_set(PL_eval_root, 1);
3280af22 1819 PL_eval_root->op_next = 0;
a2efc822 1820 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 1821 }
1822 else {
6be89cf9
AE		 1823 if (o->op_type == OP_STUB) {
1824 PL_comppad_name = 0;
1825 PL_compcv = 0;
2a4f803a 1826 FreeOp(o);
a0d0e21e 1827 return;
6be89cf9 1828 }
3280af22
NIS		 1829 PL_main_root = scope(sawparens(scalarvoid(o)));
1830 PL_curcop = &PL_compiling;
1831 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 1832 PL_main_root->op_private |= OPpREFCOUNTED;
1833 OpREFCNT_set(PL_main_root, 1);
3280af22 1834 PL_main_root->op_next = 0;
a2efc822 1835 CALL_PEEP(PL_main_start);
3280af22 1836 PL_compcv = 0;
3841441e 1837
4fdae800 1838 /* Register with debugger */
84902520 1839 if (PERLDB_INTER) {
864dbfa3 1840 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 1841 if (cv) {
1842 dSP;
924508f0 1843 PUSHMARK(SP);
cc49e20b 1844 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1845 PUTBACK;
864dbfa3 1846 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 1847 }
1848 }
79072805 1849 }
79072805
LW		 1850}
1851
1852OP *
864dbfa3 1853Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 1854{
1855 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 1856/* [perl #17376]: this appears to be premature, and results in code such as
1857 C< our(%x); > executing in list mode rather than void mode */
1858#if 0
79072805 1859 list(o);
d2be0de5
YST		 1860#else
1861 ;
1862#endif
8990e307 1863 else {
64420d0d
JH		 1864 if (ckWARN(WARN_PARENTHESIS)
1865 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1866 {
1867 char *s = PL_bufptr;
8473848f 1868 int sigil = 0;
64420d0d 1869
8473848f
RGS		 1870 /* some heuristics to detect a potential error */
1871 while (*s && (strchr(", \t\n", *s)
1872 || (strchr("@$%*", *s) && ++sigil) ))
64420d0d 1873 s++;
8473848f
RGS		 1874 if (sigil) {
1875 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1876 || strchr("@$%*, \t\n", *s)))
1877 s++;
1878
1879 if (*s == ';' || *s == '=')
1880 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1881 "Parentheses missing around \"%s\" list",
1882 lex ? (PL_in_my == KEY_our ? "our" : "my")
1883 : "local");
1884 }
8990e307
LW		 1885 }
1886 }
93a17b20 1887 if (lex)
eb64745e 1888 o = my(o);
93a17b20 1889 else
eb64745e
GS		 1890 o = mod(o, OP_NULL); /* a bit kludgey */
1891 PL_in_my = FALSE;
1892 PL_in_my_stash = Nullhv;
1893 return o;
79072805
LW		 1894}
1895
1896OP *
864dbfa3 1897Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 1898{
1899 if (o->op_type == OP_LIST) {
554b3eca 1900 OP *o2;
554b3eca 1901 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
554b3eca 1902 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 1903 }
1904 return o;
1905}
1906
1907OP *
864dbfa3 1908Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 1909{
1910 register OP *curop;
1911 I32 type = o->op_type;
748a9306 1912 SV *sv;
79072805 1913
22c35a8c 1914 if (PL_opargs[type] & OA_RETSCALAR)
79072805 1915 scalar(o);
b162f9ea 1916 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 1917 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 1918
eac055e9
GS		 1919 /* integerize op, unless it happens to be C<-foo>.
1920 * XXX should pp_i_negate() do magic string negation instead? */
1921 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1922 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1923 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1924 {
22c35a8c 1925 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 1926 }
85e6fe83 1927
22c35a8c 1928 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 1929 goto nope;
1930
de939608 1931 switch (type) {
7a52d87a
GS		 1932 case OP_NEGATE:
1933 /* XXX might want a ck_negate() for this */
1934 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1935 break;
de939608
CS		 1936 case OP_SPRINTF:
1937 case OP_UCFIRST:
1938 case OP_LCFIRST:
1939 case OP_UC:
1940 case OP_LC:
69dcf70c
MB		 1941 case OP_SLT:
1942 case OP_SGT:
1943 case OP_SLE:
1944 case OP_SGE:
1945 case OP_SCMP:
2de3dbcc
JH		 1946 /* XXX what about the numeric ops? */
1947 if (PL_hints & HINT_LOCALE)
de939608
CS		 1948 goto nope;
1949 }
1950
3280af22 1951 if (PL_error_count)
a0d0e21e
LW		 1952 goto nope; /* Don't try to run w/ errors */
1953
79072805 1954 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 1955 if ((curop->op_type != OP_CONST ||
1956 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 1957 curop->op_type != OP_LIST &&
1958 curop->op_type != OP_SCALAR &&
1959 curop->op_type != OP_NULL &&
1960 curop->op_type != OP_PUSHMARK)
1961 {
79072805
LW		 1962 goto nope;
1963 }
1964 }
1965
1966 curop = LINKLIST(o);
1967 o->op_next = 0;
533c011a 1968 PL_op = curop;
cea2e8a9 1969 CALLRUNOPS(aTHX);
3280af22 1970 sv = *(PL_stack_sp--);
748a9306 1971 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 1972 pad_swipe(o->op_targ, FALSE);
748a9306
LW		 1973 else if (SvTEMP(sv)) { /* grab mortal temp? */
1974 (void)SvREFCNT_inc(sv);
1975 SvTEMP_off(sv);
85e6fe83 1976 }
79072805
LW		 1977 op_free(o);
1978 if (type == OP_RV2GV)
b1cb66bf 1979 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 1980 return newSVOP(OP_CONST, 0, sv);
aeea060c 1981
79072805 1982 nope:
79072805
LW		 1983 return o;
1984}
1985
1986OP *
864dbfa3 1987Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 1988{
1989 register OP *curop;
3280af22 1990 I32 oldtmps_floor = PL_tmps_floor;
79072805 1991
a0d0e21e 1992 list(o);
3280af22 1993 if (PL_error_count)
a0d0e21e
LW		 1994 return o; /* Don't attempt to run with errors */
1995
533c011a 1996 PL_op = curop = LINKLIST(o);
a0d0e21e 1997 o->op_next = 0;
a2efc822 1998 CALL_PEEP(curop);
cea2e8a9
GS		 1999 pp_pushmark();
2000 CALLRUNOPS(aTHX);
533c011a 2001 PL_op = curop;
cea2e8a9 2002 pp_anonlist();
3280af22 2003 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2004
2005 o->op_type = OP_RV2AV;
22c35a8c 2006 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2007 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2008 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
c13f253a 2009 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2010 curop = ((UNOP*)o)->op_first;
3280af22 2011 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2012 op_free(curop);
79072805
LW		 2013 linklist(o);
2014 return list(o);
2015}
2016
2017OP *
864dbfa3 2018Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2019{
11343788
MB		 2020 if (!o || o->op_type != OP_LIST)
2021 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2022 else
5dc0d613 2023 o->op_flags &= ~OPf_WANT;
79072805 2024
22c35a8c 2025 if (!(PL_opargs[type] & OA_MARK))
93c66552 2026 op_null(cLISTOPo->op_first);
8990e307 2027
eb160463 2028 o->op_type = (OPCODE)type;
22c35a8c 2029 o->op_ppaddr = PL_ppaddr[type];
11343788 2030 o->op_flags |= flags;
79072805 2031
11343788
MB		 2032 o = CHECKOP(type, o);
2033 if (o->op_type != type)
2034 return o;
79072805 2035
11343788 2036 return fold_constants(o);
79072805
LW		 2037}
2038
2039/* List constructors */
2040
2041OP *
864dbfa3 2042Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2043{
2044 if (!first)
2045 return last;
8990e307
LW		 2046
2047 if (!last)
79072805 2048 return first;
8990e307 2049
155aba94
GS		 2050 if (first->op_type != type
2051 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2052 {
2053 return newLISTOP(type, 0, first, last);
2054 }
79072805 2055
a0d0e21e
LW		 2056 if (first->op_flags & OPf_KIDS)
2057 ((LISTOP*)first)->op_last->op_sibling = last;
2058 else {
2059 first->op_flags |= OPf_KIDS;
2060 ((LISTOP*)first)->op_first = last;
2061 }
2062 ((LISTOP*)first)->op_last = last;
a0d0e21e 2063 return first;
79072805
LW		 2064}
2065
2066OP *
864dbfa3 2067Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2068{
2069 if (!first)
2070 return (OP*)last;
8990e307
LW		 2071
2072 if (!last)
79072805 2073 return (OP*)first;
8990e307
LW		 2074
2075 if (first->op_type != type)
79072805 2076 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2077
2078 if (last->op_type != type)
79072805
LW		 2079 return append_elem(type, (OP*)first, (OP*)last);
2080
2081 first->op_last->op_sibling = last->op_first;
2082 first->op_last = last->op_last;
117dada2 2083 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2084
238a4c30
NIS		 2085 FreeOp(last);
2086
79072805
LW		 2087 return (OP*)first;
2088}
2089
2090OP *
864dbfa3 2091Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2092{
2093 if (!first)
2094 return last;
8990e307
LW		 2095
2096 if (!last)
79072805 2097 return first;
8990e307
LW		 2098
2099 if (last->op_type == type) {
2100 if (type == OP_LIST) { /* already a PUSHMARK there */
2101 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2102 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2103 if (!(first->op_flags & OPf_PARENS))
2104 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2105 }
2106 else {
2107 if (!(last->op_flags & OPf_KIDS)) {
2108 ((LISTOP*)last)->op_last = first;
2109 last->op_flags |= OPf_KIDS;
2110 }
2111 first->op_sibling = ((LISTOP*)last)->op_first;
2112 ((LISTOP*)last)->op_first = first;
79072805 2113 }
117dada2 2114 last->op_flags |= OPf_KIDS;
79072805
LW		 2115 return last;
2116 }
2117
2118 return newLISTOP(type, 0, first, last);
2119}
2120
2121/* Constructors */
2122
2123OP *
864dbfa3 2124Perl_newNULLLIST(pTHX)
79072805 2125{
8990e307
LW		 2126 return newOP(OP_STUB, 0);
2127}
2128
2129OP *
864dbfa3 2130Perl_force_list(pTHX_ OP *o)
8990e307 2131{
11343788
MB		 2132 if (!o || o->op_type != OP_LIST)
2133 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2134 op_null(o);
11343788 2135 return o;
79072805
LW		 2136}
2137
2138OP *
864dbfa3 2139Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2140{
2141 LISTOP *listop;
2142
b7dc083c 2143 NewOp(1101, listop, 1, LISTOP);
79072805 2144
eb160463 2145 listop->op_type = (OPCODE)type;
22c35a8c 2146 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2147 if (first || last)
2148 flags |= OPf_KIDS;
eb160463 2149 listop->op_flags = (U8)flags;
79072805
LW		 2150
2151 if (!last && first)
2152 last = first;
2153 else if (!first && last)
2154 first = last;
8990e307
LW		 2155 else if (first)
2156 first->op_sibling = last;
79072805
LW		 2157 listop->op_first = first;
2158 listop->op_last = last;
8990e307
LW		 2159 if (type == OP_LIST) {
2160 OP* pushop;
2161 pushop = newOP(OP_PUSHMARK, 0);
2162 pushop->op_sibling = first;
2163 listop->op_first = pushop;
2164 listop->op_flags |= OPf_KIDS;
2165 if (!last)
2166 listop->op_last = pushop;
2167 }
79072805 2168
463d09e6 2169 return CHECKOP(type, listop);
79072805
LW		 2170}
2171
2172OP *
864dbfa3 2173Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2174{
11343788 2175 OP *o;
b7dc083c 2176 NewOp(1101, o, 1, OP);
eb160463 2177 o->op_type = (OPCODE)type;
22c35a8c 2178 o->op_ppaddr = PL_ppaddr[type];
eb160463 2179 o->op_flags = (U8)flags;
79072805 2180
11343788 2181 o->op_next = o;
eb160463 2182 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2183 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2184 scalar(o);
22c35a8c 2185 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2186 o->op_targ = pad_alloc(type, SVs_PADTMP);
2187 return CHECKOP(type, o);
79072805
LW		 2188}
2189
2190OP *
864dbfa3 2191Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2192{
2193 UNOP *unop;
2194
93a17b20 2195 if (!first)
aeea060c 2196 first = newOP(OP_STUB, 0);
22c35a8c 2197 if (PL_opargs[type] & OA_MARK)
8990e307 2198 first = force_list(first);
93a17b20 2199
b7dc083c 2200 NewOp(1101, unop, 1, UNOP);
eb160463 2201 unop->op_type = (OPCODE)type;
22c35a8c 2202 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2203 unop->op_first = first;
2204 unop->op_flags = flags | OPf_KIDS;
eb160463 2205 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2206 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2207 if (unop->op_next)
2208 return (OP*)unop;
2209
a0d0e21e 2210 return fold_constants((OP *) unop);
79072805
LW		 2211}
2212
2213OP *
864dbfa3 2214Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2215{
2216 BINOP *binop;
b7dc083c 2217 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2218
2219 if (!first)
2220 first = newOP(OP_NULL, 0);
2221
eb160463 2222 binop->op_type = (OPCODE)type;
22c35a8c 2223 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2224 binop->op_first = first;
2225 binop->op_flags = flags | OPf_KIDS;
2226 if (!last) {
2227 last = first;
eb160463 2228 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2229 }
2230 else {
eb160463 2231 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2232 first->op_sibling = last;
2233 }
2234
e50aee73 2235 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2236 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2237 return (OP*)binop;
2238
7284ab6f 2239 binop->op_last = binop->op_first->op_sibling;
79072805 2240
a0d0e21e 2241 return fold_constants((OP *)binop);
79072805
LW		 2242}
2243
a0ed51b3 2244static int
2b9d42f0
NIS		 2245uvcompare(const void *a, const void *b)
2246{
2247 if (*((UV *)a) < (*(UV *)b))
2248 return -1;
2249 if (*((UV *)a) > (*(UV *)b))
2250 return 1;
2251 if (*((UV *)a+1) < (*(UV *)b+1))
2252 return -1;
2253 if (*((UV *)a+1) > (*(UV *)b+1))
2254 return 1;
a0ed51b3
LW		 2255 return 0;
2256}
2257
79072805 2258OP *
864dbfa3 2259Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2260{
79072805
LW		 2261 SV *tstr = ((SVOP*)expr)->op_sv;
2262 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2263 STRLEN tlen;
2264 STRLEN rlen;
9b877dbb
IH		 2265 U8 *t = (U8*)SvPV(tstr, tlen);
2266 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2267 register I32 i;
2268 register I32 j;
a0ed51b3 2269 I32 del;
79072805 2270 I32 complement;
5d06d08e 2271 I32 squash;
9b877dbb 2272 I32 grows = 0;
79072805
LW		 2273 register short *tbl;
2274
800b4dc4 2275 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2276 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2277 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2278 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2279
036b4402
GS		 2280 if (SvUTF8(tstr))
2281 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2282
2283 if (SvUTF8(rstr))
036b4402 2284 o->op_private |= OPpTRANS_TO_UTF;
79072805 2285
a0ed51b3 2286 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2287 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2288 SV* transv = 0;
2289 U8* tend = t + tlen;
2290 U8* rend = r + rlen;
ba210ebe 2291 STRLEN ulen;
84c133a0
RB		 2292 UV tfirst = 1;
2293 UV tlast = 0;
2294 IV tdiff;
2295 UV rfirst = 1;
2296 UV rlast = 0;
2297 IV rdiff;
2298 IV diff;
a0ed51b3
LW		 2299 I32 none = 0;
2300 U32 max = 0;
2301 I32 bits;
a0ed51b3 2302 I32 havefinal = 0;
9c5ffd7c 2303 U32 final = 0;
a0ed51b3
LW		 2304 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2305 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2306 U8* tsave = NULL;
2307 U8* rsave = NULL;
2308
2309 if (!from_utf) {
2310 STRLEN len = tlen;
2311 tsave = t = bytes_to_utf8(t, &len);
2312 tend = t + len;
2313 }
2314 if (!to_utf && rlen) {
2315 STRLEN len = rlen;
2316 rsave = r = bytes_to_utf8(r, &len);
2317 rend = r + len;
2318 }
a0ed51b3 2319
2b9d42f0
NIS		 2320/* There are several snags with this code on EBCDIC:
2321 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2322 2. scan_const() in toke.c has encoded chars in native encoding which makes
2323 ranges at least in EBCDIC 0..255 range the bottom odd.
2324*/
2325
a0ed51b3 2326 if (complement) {
ad391ad9 2327 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2328 UV *cp;
a0ed51b3 2329 UV nextmin = 0;
2b9d42f0 2330 New(1109, cp, 2*tlen, UV);
a0ed51b3 2331 i = 0;
79cb57f6 2332 transv = newSVpvn("",0);
a0ed51b3 2333 while (t < tend) {
2b9d42f0
NIS		 2334 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2335 t += ulen;
2336 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2337 t++;
2b9d42f0
NIS		 2338 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2339 t += ulen;
a0ed51b3 2340 }
2b9d42f0
NIS		 2341 else {
2342 cp[2*i+1] = cp[2*i];
2343 }
2344 i++;
a0ed51b3 2345 }
2b9d42f0 2346 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2347 for (j = 0; j < i; j++) {
2b9d42f0 2348 UV val = cp[2*j];
a0ed51b3
LW		 2349 diff = val - nextmin;
2350 if (diff > 0) {
9041c2e3 2351 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2352 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2353 if (diff > 1) {
2b9d42f0 2354 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2355 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2356 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2357 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2358 }
2359 }
2b9d42f0 2360 val = cp[2*j+1];
a0ed51b3
LW		 2361 if (val >= nextmin)
2362 nextmin = val + 1;
2363 }
9041c2e3 2364 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2365 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2366 {
2367 U8 range_mark = UTF_TO_NATIVE(0xff);
2368 sv_catpvn(transv, (char *)&range_mark, 1);
2369 }
b851fbc1
JH		 2370 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2371 UNICODE_ALLOW_SUPER);
dfe13c55
GS		 2372 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2373 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2374 tlen = SvCUR(transv);
2375 tend = t + tlen;
455d824a 2376 Safefree(cp);
a0ed51b3
LW		 2377 }
2378 else if (!rlen && !del) {
2379 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2380 }
2381 if (!squash) {
05d340b8 2382 if ((!rlen && !del) || t == r ||
12ae5dfc 2383 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2384 {
4757a243 2385 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2386 }
a0ed51b3
LW		 2387 }
2388
2389 while (t < tend || tfirst <= tlast) {
2390 /* see if we need more "t" chars */
2391 if (tfirst > tlast) {
9041c2e3 2392 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2393 t += ulen;
2b9d42f0 2394 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2395 t++;
9041c2e3 2396 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2397 t += ulen;
2398 }
2399 else
2400 tlast = tfirst;
2401 }
2402
2403 /* now see if we need more "r" chars */
2404 if (rfirst > rlast) {
2405 if (r < rend) {
9041c2e3 2406 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2407 r += ulen;
2b9d42f0 2408 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2409 r++;
9041c2e3 2410 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2411 r += ulen;
2412 }
2413 else
2414 rlast = rfirst;
2415 }
2416 else {
2417 if (!havefinal++)
2418 final = rlast;
2419 rfirst = rlast = 0xffffffff;
2420 }
2421 }
2422
2423 /* now see which range will peter our first, if either. */
2424 tdiff = tlast - tfirst;
2425 rdiff = rlast - rfirst;
2426
2427 if (tdiff <= rdiff)
2428 diff = tdiff;
2429 else
2430 diff = rdiff;
2431
2432 if (rfirst == 0xffffffff) {
2433 diff = tdiff; /* oops, pretend rdiff is infinite */
2434 if (diff > 0)
894356b3
GS		 2435 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2436 (long)tfirst, (long)tlast);
a0ed51b3 2437 else
894356b3 2438 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2439 }
2440 else {
2441 if (diff > 0)
894356b3
GS		 2442 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2443 (long)tfirst, (long)(tfirst + diff),
2444 (long)rfirst);
a0ed51b3 2445 else
894356b3
GS		 2446 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2447 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2448
2449 if (rfirst + diff > max)
2450 max = rfirst + diff;
9b877dbb 2451 if (!grows)
45005bfb
JH		 2452 grows = (tfirst < rfirst &&
2453 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2454 rfirst += diff + 1;
a0ed51b3
LW		 2455 }
2456 tfirst += diff + 1;
2457 }
2458
2459 none = ++max;
2460 if (del)
2461 del = ++max;
2462
2463 if (max > 0xffff)
2464 bits = 32;
2465 else if (max > 0xff)
2466 bits = 16;
2467 else
2468 bits = 8;
2469
455d824a 2470 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2471 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2472 SvREFCNT_dec(listsv);
2473 if (transv)
2474 SvREFCNT_dec(transv);
2475
45005bfb 2476 if (!del && havefinal && rlen)
b448e4fe
JH		 2477 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2478 newSVuv((UV)final), 0);
a0ed51b3 2479
9b877dbb 2480 if (grows)
a0ed51b3
LW		 2481 o->op_private |= OPpTRANS_GROWS;
2482
9b877dbb
IH		 2483 if (tsave)
2484 Safefree(tsave);
2485 if (rsave)
2486 Safefree(rsave);
2487
a0ed51b3
LW		 2488 op_free(expr);
2489 op_free(repl);
2490 return o;
2491 }
2492
2493 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2494 if (complement) {
2495 Zero(tbl, 256, short);
eb160463 2496 for (i = 0; i < (I32)tlen; i++)
ec49126f 2497 tbl[t[i]] = -1;
79072805
LW		 2498 for (i = 0, j = 0; i < 256; i++) {
2499 if (!tbl[i]) {
eb160463 2500 if (j >= (I32)rlen) {
a0ed51b3 2501 if (del)
79072805
LW		 2502 tbl[i] = -2;
2503 else if (rlen)
ec49126f 2504 tbl[i] = r[j-1];
79072805 2505 else
eb160463 2506 tbl[i] = (short)i;
79072805 2507 }
9b877dbb
IH		 2508 else {
2509 if (i < 128 && r[j] >= 128)
2510 grows = 1;
ec49126f 2511 tbl[i] = r[j++];
9b877dbb 2512 }
79072805
LW		 2513 }
2514 }
05d340b8
JH		 2515 if (!del) {
2516 if (!rlen) {
2517 j = rlen;
2518 if (!squash)
2519 o->op_private |= OPpTRANS_IDENTICAL;
2520 }
eb160463 2521 else if (j >= (I32)rlen)
05d340b8
JH		 2522 j = rlen - 1;
2523 else
2524 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 2525 tbl[0x100] = rlen - j;
eb160463 2526 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 2527 tbl[0x101+i] = r[j+i];
2528 }
79072805
LW		 2529 }
2530 else {
a0ed51b3 2531 if (!rlen && !del) {
79072805 2532 r = t; rlen = tlen;
5d06d08e 2533 if (!squash)
4757a243 2534 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2535 }
94bfe852
RGS		 2536 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2537 o->op_private |= OPpTRANS_IDENTICAL;
2538 }
79072805
LW		 2539 for (i = 0; i < 256; i++)
2540 tbl[i] = -1;
eb160463
GS		 2541 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2542 if (j >= (I32)rlen) {
a0ed51b3 2543 if (del) {
ec49126f 2544 if (tbl[t[i]] == -1)
2545 tbl[t[i]] = -2;
79072805
LW		 2546 continue;
2547 }
2548 --j;
2549 }
9b877dbb
IH		 2550 if (tbl[t[i]] == -1) {
2551 if (t[i] < 128 && r[j] >= 128)
2552 grows = 1;
ec49126f 2553 tbl[t[i]] = r[j];
9b877dbb 2554 }
79072805
LW		 2555 }
2556 }
9b877dbb
IH		 2557 if (grows)
2558 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2559 op_free(expr);
2560 op_free(repl);
2561
11343788 2562 return o;
79072805
LW		 2563}
2564
2565OP *
864dbfa3 2566Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2567{
2568 PMOP *pmop;
2569
b7dc083c 2570 NewOp(1101, pmop, 1, PMOP);
eb160463 2571 pmop->op_type = (OPCODE)type;
22c35a8c 2572 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 2573 pmop->op_flags = (U8)flags;
2574 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2575
3280af22 2576 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2577 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2578 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2579 pmop->op_pmpermflags |= PMf_LOCALE;
2580 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2581
debc9467 2582#ifdef USE_ITHREADS
13137afc
AB		 2583 {
2584 SV* repointer;
2585 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2586 repointer = av_pop((AV*)PL_regex_pad[0]);
2587 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2588 SvREPADTMP_off(repointer);
13137afc 2589 sv_setiv(repointer,0);
1eb1540c 2590 } else {
13137afc
AB		 2591 repointer = newSViv(0);
2592 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2593 pmop->op_pmoffset = av_len(PL_regex_padav);
2594 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2595 }
13137afc 2596 }
debc9467 2597#endif
1eb1540c 2598
1fcf4c12 2599 /* link into pm list */
3280af22
NIS		 2600 if (type != OP_TRANS && PL_curstash) {
2601 pmop->op_pmnext = HvPMROOT(PL_curstash);
2602 HvPMROOT(PL_curstash) = pmop;
cb55de95 2603 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2604 }
2605
463d09e6 2606 return CHECKOP(type, pmop);
79072805
LW		 2607}
2608
2609OP *
864dbfa3 2610Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 2611{
2612 PMOP *pm;
2613 LOGOP *rcop;
ce862d02 2614 I32 repl_has_vars = 0;
79072805 2615
11343788
MB		 2616 if (o->op_type == OP_TRANS)
2617 return pmtrans(o, expr, repl);
79072805 2618
3280af22 2619 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2620 pm = (PMOP*)o;
79072805
LW		 2621
2622 if (expr->op_type == OP_CONST) {
463ee0b2 2623 STRLEN plen;
79072805 2624 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2625 char *p = SvPV(pat, plen);
11343788 2626 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2627 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2628 p = SvPV(pat, plen);
79072805
LW		 2629 pm->op_pmflags |= PMf_SKIPWHITE;
2630 }
5b71a6a7 2631 if (DO_UTF8(pat))
a5961de5 2632 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS		 2633 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2634 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2635 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 2636 op_free(expr);
2637 }
2638 else {
3280af22 2639 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2640 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2641 ? OP_REGCRESET
2642 : OP_REGCMAYBE),0,expr);
463ee0b2 2643
b7dc083c 2644 NewOp(1101, rcop, 1, LOGOP);
79072805 2645 rcop->op_type = OP_REGCOMP;
22c35a8c 2646 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2647 rcop->op_first = scalar(expr);
1c846c1f 2648 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2649 ? (OPf_SPECIAL | OPf_KIDS)
2650 : OPf_KIDS);
79072805 2651 rcop->op_private = 1;
11343788 2652 rcop->op_other = o;
b5c19bd7
DM		 2653 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2654 PL_cv_has_eval = 1;
79072805
LW		 2655
2656 /* establish postfix order */
3280af22 2657 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 2658 LINKLIST(expr);
2659 rcop->op_next = expr;
2660 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2661 }
2662 else {
2663 rcop->op_next = LINKLIST(expr);
2664 expr->op_next = (OP*)rcop;
2665 }
79072805 2666
11343788 2667 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 2668 }
2669
2670 if (repl) {
748a9306 2671 OP *curop;
0244c3a4 2672 if (pm->op_pmflags & PMf_EVAL) {
748a9306 2673 curop = 0;
8bafa735 2674 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2675 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2676 }
748a9306
LW		 2677 else if (repl->op_type == OP_CONST)
2678 curop = repl;
79072805 2679 else {
79072805
LW		 2680 OP *lastop = 0;
2681 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2682 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2683 if (curop->op_type == OP_GV) {
638eceb6 2684 GV *gv = cGVOPx_gv(curop);
ce862d02 2685 repl_has_vars = 1;
f702bf4a 2686 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 2687 break;
2688 }
2689 else if (curop->op_type == OP_RV2CV)
2690 break;
2691 else if (curop->op_type == OP_RV2SV ||
2692 curop->op_type == OP_RV2AV ||
2693 curop->op_type == OP_RV2HV ||
2694 curop->op_type == OP_RV2GV) {
2695 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2696 break;
2697 }
748a9306
LW		 2698 else if (curop->op_type == OP_PADSV ||
2699 curop->op_type == OP_PADAV ||
2700 curop->op_type == OP_PADHV ||
554b3eca 2701 curop->op_type == OP_PADANY) {
ce862d02 2702 repl_has_vars = 1;
748a9306 2703 }
1167e5da
SM		 2704 else if (curop->op_type == OP_PUSHRE)
2705 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 2706 else
2707 break;
2708 }
2709 lastop = curop;
2710 }
748a9306 2711 }
ce862d02 2712 if (curop == repl
1c846c1f 2713 && !(repl_has_vars
aaa362c4
RS		 2714 && (!PM_GETRE(pm)
2715 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2716 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2717 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2718 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 2719 }
2720 else {
aaa362c4 2721 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 2722 pm->op_pmflags |= PMf_MAYBE_CONST;
2723 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2724 }
b7dc083c 2725 NewOp(1101, rcop, 1, LOGOP);
748a9306 2726 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2727 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 2728 rcop->op_first = scalar(repl);
2729 rcop->op_flags |= OPf_KIDS;
2730 rcop->op_private = 1;
11343788 2731 rcop->op_other = o;
748a9306
LW		 2732
2733 /* establish postfix order */
2734 rcop->op_next = LINKLIST(repl);
2735 repl->op_next = (OP*)rcop;
2736
2737 pm->op_pmreplroot = scalar((OP*)rcop);
2738 pm->op_pmreplstart = LINKLIST(rcop);
2739 rcop->op_next = 0;
79072805
LW		 2740 }
2741 }
2742
2743 return (OP*)pm;
2744}
2745
2746OP *
864dbfa3 2747Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 2748{
2749 SVOP *svop;
b7dc083c 2750 NewOp(1101, svop, 1, SVOP);
eb160463 2751 svop->op_type = (OPCODE)type;
22c35a8c 2752 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2753 svop->op_sv = sv;
2754 svop->op_next = (OP*)svop;
eb160463 2755 svop->op_flags = (U8)flags;
22c35a8c 2756 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2757 scalar((OP*)svop);
22c35a8c 2758 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2759 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2760 return CHECKOP(type, svop);
79072805
LW		 2761}
2762
2763OP *
350de78d
GS		 2764Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2765{
2766 PADOP *padop;
2767 NewOp(1101, padop, 1, PADOP);
eb160463 2768 padop->op_type = (OPCODE)type;
350de78d
GS		 2769 padop->op_ppaddr = PL_ppaddr[type];
2770 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 2771 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2772 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 2773 if (sv)
2774 SvPADTMP_on(sv);
350de78d 2775 padop->op_next = (OP*)padop;
eb160463 2776 padop->op_flags = (U8)flags;
350de78d
GS		 2777 if (PL_opargs[type] & OA_RETSCALAR)
2778 scalar((OP*)padop);
2779 if (PL_opargs[type] & OA_TARGET)
2780 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2781 return CHECKOP(type, padop);
2782}
2783
2784OP *
864dbfa3 2785Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 2786{
350de78d 2787#ifdef USE_ITHREADS
ce50c033
AMS		 2788 if (gv)
2789 GvIN_PAD_on(gv);
350de78d
GS		 2790 return newPADOP(type, flags, SvREFCNT_inc(gv));
2791#else
7934575e 2792 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 2793#endif
79072805
LW		 2794}
2795
2796OP *
864dbfa3 2797Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 2798{
2799 PVOP *pvop;
b7dc083c 2800 NewOp(1101, pvop, 1, PVOP);
eb160463 2801 pvop->op_type = (OPCODE)type;
22c35a8c 2802 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2803 pvop->op_pv = pv;
2804 pvop->op_next = (OP*)pvop;
eb160463 2805 pvop->op_flags = (U8)flags;
22c35a8c 2806 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2807 scalar((OP*)pvop);
22c35a8c 2808 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2809 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2810 return CHECKOP(type, pvop);
79072805
LW		 2811}
2812
79072805 2813void
864dbfa3 2814Perl_package(pTHX_ OP *o)
79072805 2815{
de11ba31
AMS		 2816 char *name;
2817 STRLEN len;
79072805 2818
3280af22
NIS		 2819 save_hptr(&PL_curstash);
2820 save_item(PL_curstname);
de11ba31
AMS		 2821
2822 name = SvPV(cSVOPo->op_sv, len);
2823 PL_curstash = gv_stashpvn(name, len, TRUE);
2824 sv_setpvn(PL_curstname, name, len);
2825 op_free(o);
2826
7ad382f4 2827 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2828 PL_copline = NOLINE;
2829 PL_expect = XSTATE;
79072805
LW		 2830}
2831
85e6fe83 2832void
88d95a4d 2833Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 2834{
a0d0e21e 2835 OP *pack;
a0d0e21e 2836 OP *imop;
b1cb66bf 2837 OP *veop;
85e6fe83 2838
88d95a4d 2839 if (idop->op_type != OP_CONST)
cea2e8a9 2840 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 2841
b1cb66bf 2842 veop = Nullop;
2843
0f79a09d 2844 if (version != Nullop) {
b1cb66bf 2845 SV *vesv = ((SVOP*)version)->op_sv;
2846
44dcb63b 2847 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 2848 arg = version;
2849 }
2850 else {
2851 OP *pack;
0f79a09d 2852 SV *meth;
b1cb66bf 2853
44dcb63b 2854 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 2855 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 2856
88d95a4d
JH		 2857 /* Make copy of idop so we don't free it twice */
2858 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 2859
2860 /* Fake up a method call to VERSION */
0f79a09d
GS		 2861 meth = newSVpvn("VERSION",7);
2862 sv_upgrade(meth, SVt_PVIV);
155aba94 2863 (void)SvIOK_on(meth);
5afd6d42 2864 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 2865 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2866 append_elem(OP_LIST,
0f79a09d
GS		 2867 prepend_elem(OP_LIST, pack, list(version)),
2868 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 2869 }
2870 }
aeea060c 2871
a0d0e21e 2872 /* Fake up an import/unimport */
4633a7c4
LW		 2873 if (arg && arg->op_type == OP_STUB)
2874 imop = arg; /* no import on explicit () */
88d95a4d 2875 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf 2876 imop = Nullop; /* use 5.0; */
2877 }
4633a7c4 2878 else {
0f79a09d
GS		 2879 SV *meth;
2880
88d95a4d
JH		 2881 /* Make copy of idop so we don't free it twice */
2882 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 2883
2884 /* Fake up a method call to import/unimport */
b47cad08 2885 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 2886 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 2887 (void)SvIOK_on(meth);
5afd6d42 2888 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 2889 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 2890 append_elem(OP_LIST,
2891 prepend_elem(OP_LIST, pack, list(arg)),
2892 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 2893 }
2894
a0d0e21e 2895 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 2896 newATTRSUB(floor,
79cb57f6 2897 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 2898 Nullop,
09bef843 2899 Nullop,
a0d0e21e 2900 append_elem(OP_LINESEQ,
b1cb66bf 2901 append_elem(OP_LINESEQ,
88d95a4d 2902 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 2903 newSTATEOP(0, Nullch, veop)),
a0d0e21e 2904 newSTATEOP(0, Nullch, imop) ));
85e6fe83 2905
70f5e4ed
JH		 2906 /* The "did you use incorrect case?" warning used to be here.
2907 * The problem is that on case-insensitive filesystems one
2908 * might get false positives for "use" (and "require"):
2909 * "use Strict" or "require CARP" will work. This causes
2910 * portability problems for the script: in case-strict
2911 * filesystems the script will stop working.
2912 *
2913 * The "incorrect case" warning checked whether "use Foo"
2914 * imported "Foo" to your namespace, but that is wrong, too:
2915 * there is no requirement nor promise in the language that
2916 * a Foo.pm should or would contain anything in package "Foo".
2917 *
2918 * There is very little Configure-wise that can be done, either:
2919 * the case-sensitivity of the build filesystem of Perl does not
2920 * help in guessing the case-sensitivity of the runtime environment.
2921 */
18fc9488 2922
c305c6a0 2923 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2924 PL_copline = NOLINE;
2925 PL_expect = XSTATE;
8ec8fbef 2926 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW		 2927}
2928
7d3fb230 2929/*
ccfc67b7
JH		 2930=head1 Embedding Functions
2931
7d3fb230
BS		 2932=for apidoc load_module
2933
2934Loads the module whose name is pointed to by the string part of name.
2935Note that the actual module name, not its filename, should be given.
2936Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2937PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2938(or 0 for no flags). ver, if specified, provides version semantics
2939similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2940arguments can be used to specify arguments to the module's import()
2941method, similar to C<use Foo::Bar VERSION LIST>.
2942
2943=cut */
2944
e4783991
GS		 2945void
2946Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2947{
2948 va_list args;
2949 va_start(args, ver);
2950 vload_module(flags, name, ver, &args);
2951 va_end(args);
2952}
2953
2954#ifdef PERL_IMPLICIT_CONTEXT
2955void
2956Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2957{
2958 dTHX;
2959 va_list args;
2960 va_start(args, ver);
2961 vload_module(flags, name, ver, &args);
2962 va_end(args);
2963}
2964#endif
2965
2966void
2967Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2968{
2969 OP *modname, *veop, *imop;
2970
2971 modname = newSVOP(OP_CONST, 0, name);
2972 modname->op_private |= OPpCONST_BARE;
2973 if (ver) {
2974 veop = newSVOP(OP_CONST, 0, ver);
2975 }
2976 else
2977 veop = Nullop;
2978 if (flags & PERL_LOADMOD_NOIMPORT) {
2979 imop = sawparens(newNULLLIST());
2980 }
2981 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2982 imop = va_arg(*args, OP*);
2983 }
2984 else {
2985 SV *sv;
2986 imop = Nullop;
2987 sv = va_arg(*args, SV*);
2988 while (sv) {
2989 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2990 sv = va_arg(*args, SV*);
2991 }
2992 }
81885997
GS		 2993 {
2994 line_t ocopline = PL_copline;
834a3ffa 2995 COP *ocurcop = PL_curcop;
81885997
GS		 2996 int oexpect = PL_expect;
2997
2998 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2999 veop, modname, imop);
3000 PL_expect = oexpect;
3001 PL_copline = ocopline;
834a3ffa 3002 PL_curcop = ocurcop;
81885997 3003 }
e4783991
GS		 3004}
3005
79072805 3006OP *
864dbfa3 3007Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3008{
3009 OP *doop;
3010 GV *gv;
3011
3012 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3013 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS		 3014 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3015
b9f751c0 3016 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3017 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3018 append_elem(OP_LIST, term,
3019 scalar(newUNOP(OP_RV2CV, 0,
3020 newGVOP(OP_GV, 0,
3021 gv))))));
3022 }
3023 else {
3024 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3025 }
3026 return doop;
3027}
3028
3029OP *
864dbfa3 3030Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3031{
3032 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3033 list(force_list(subscript)),
3034 list(force_list(listval)) );
79072805
LW		 3035}
3036
76e3520e 3037STATIC I32
cea2e8a9 3038S_list_assignment(pTHX_ register OP *o)
79072805 3039{
11343788 3040 if (!o)
79072805
LW		 3041 return TRUE;
3042
11343788
MB		 3043 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3044 o = cUNOPo->op_first;
79072805 3045
11343788 3046 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3047 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3048 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3049
3050 if (t && f)
3051 return TRUE;
3052 if (t || f)
3053 yyerror("Assignment to both a list and a scalar");
3054 return FALSE;
3055 }
3056
95f0a2f1
SB		 3057 if (o->op_type == OP_LIST &&
3058 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3059 o->op_private & OPpLVAL_INTRO)
3060 return FALSE;
3061
11343788
MB		 3062 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3063 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3064 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3065 return TRUE;
3066
11343788 3067 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3068 return TRUE;
3069
11343788 3070 if (o->op_type == OP_RV2SV)
79072805
LW		 3071 return FALSE;
3072
3073 return FALSE;
3074}
3075
3076OP *
864dbfa3 3077Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3078{
11343788 3079 OP *o;
79072805 3080
a0d0e21e 3081 if (optype) {
c963b151 3082 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3083 return newLOGOP(optype, 0,
3084 mod(scalar(left), optype),
3085 newUNOP(OP_SASSIGN, 0, scalar(right)));
3086 }
3087 else {
3088 return newBINOP(optype, OPf_STACKED,
3089 mod(scalar(left), optype), scalar(right));
3090 }
3091 }
3092
79072805 3093 if (list_assignment(left)) {
10c8fecd
GS		 3094 OP *curop;
3095
3280af22
NIS		 3096 PL_modcount = 0;
3097 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3098 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3099 if (PL_eval_start)
3100 PL_eval_start = 0;
748a9306 3101 else {
a0d0e21e
LW		 3102 op_free(left);
3103 op_free(right);
3104 return Nullop;
3105 }
10c8fecd
GS		 3106 curop = list(force_list(left));
3107 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3108 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3109
3110 /* PL_generation sorcery:
3111 * an assignment like ($a,$b) = ($c,$d) is easier than
3112 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3113 * To detect whether there are common vars, the global var
3114 * PL_generation is incremented for each assign op we compile.
3115 * Then, while compiling the assign op, we run through all the
3116 * variables on both sides of the assignment, setting a spare slot
3117 * in each of them to PL_generation. If any of them already have
3118 * that value, we know we've got commonality. We could use a
3119 * single bit marker, but then we'd have to make 2 passes, first
3120 * to clear the flag, then to test and set it. To find somewhere
3121 * to store these values, evil chicanery is done with SvCUR().
3122 */
3123
a0d0e21e 3124 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3125 OP *lastop = o;
3280af22 3126 PL_generation++;
11343788 3127 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3128 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3129 if (curop->op_type == OP_GV) {
638eceb6 3130 GV *gv = cGVOPx_gv(curop);
eb160463 3131 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3132 break;
3280af22 3133 SvCUR(gv) = PL_generation;
79072805 3134 }
748a9306
LW		 3135 else if (curop->op_type == OP_PADSV ||
3136 curop->op_type == OP_PADAV ||
3137 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3138 curop->op_type == OP_PADANY)
3139 {
3140 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3141 == (STRLEN)PL_generation)
748a9306 3142 break;
dd2155a4
DM		 3143 PAD_COMPNAME_GEN(curop->op_targ)
3144 = PL_generation;
3145
748a9306 3146 }
79072805
LW		 3147 else if (curop->op_type == OP_RV2CV)
3148 break;
3149 else if (curop->op_type == OP_RV2SV ||
3150 curop->op_type == OP_RV2AV ||
3151 curop->op_type == OP_RV2HV ||
3152 curop->op_type == OP_RV2GV) {
3153 if (lastop->op_type != OP_GV) /* funny deref? */
3154 break;
3155 }
1167e5da
SM		 3156 else if (curop->op_type == OP_PUSHRE) {
3157 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3158#ifdef USE_ITHREADS
dd2155a4
DM		 3159 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3160 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3161#else
1167e5da 3162 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3163#endif
eb160463 3164 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3165 break;
3280af22 3166 SvCUR(gv) = PL_generation;
b2ffa427 3167 }
1167e5da 3168 }
79072805
LW		 3169 else
3170 break;
3171 }
3172 lastop = curop;
3173 }
11343788 3174 if (curop != o)
10c8fecd 3175 o->op_private |= OPpASSIGN_COMMON;
79072805 3176 }
c07a80fd 3177 if (right && right->op_type == OP_SPLIT) {
3178 OP* tmpop;
3179 if ((tmpop = ((LISTOP*)right)->op_first) &&
3180 tmpop->op_type == OP_PUSHRE)
3181 {
3182 PMOP *pm = (PMOP*)tmpop;
3183 if (left->op_type == OP_RV2AV &&
3184 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3185 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3186 {
3187 tmpop = ((UNOP*)left)->op_first;
3188 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3189#ifdef USE_ITHREADS
ba89bb6e 3190 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3191 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3192#else
3193 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3194 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3195#endif
c07a80fd 3196 pm->op_pmflags |= PMf_ONCE;
11343788 3197 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3198 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3199 tmpop->op_sibling = Nullop; /* don't free split */
3200 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3201 op_free(o); /* blow off assign */
54310121 3202 right->op_flags &= ~OPf_WANT;
a5f75d66 3203 /* "I don't know and I don't care." */
c07a80fd 3204 return right;
3205 }
3206 }
3207 else {
e6438c1a 3208 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3209 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3210 {
3211 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3212 if (SvIVX(sv) == 0)
3280af22 3213 sv_setiv(sv, PL_modcount+1);
c07a80fd 3214 }
3215 }
3216 }
3217 }
11343788 3218 return o;
79072805
LW		 3219 }
3220 if (!right)
3221 right = newOP(OP_UNDEF, 0);
3222 if (right->op_type == OP_READLINE) {
3223 right->op_flags |= OPf_STACKED;
463ee0b2 3224 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3225 }
a0d0e21e 3226 else {
3280af22 3227 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3228 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3229 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3230 if (PL_eval_start)
3231 PL_eval_start = 0;
748a9306 3232 else {
11343788 3233 op_free(o);
a0d0e21e
LW		 3234 return Nullop;
3235 }
3236 }
11343788 3237 return o;
79072805
LW		 3238}
3239
3240OP *
864dbfa3 3241Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3242{
bbce6d69 3243 U32 seq = intro_my();
79072805
LW		 3244 register COP *cop;
3245
b7dc083c 3246 NewOp(1101, cop, 1, COP);
57843af0 3247 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3248 cop->op_type = OP_DBSTATE;
22c35a8c 3249 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3250 }
3251 else {
3252 cop->op_type = OP_NEXTSTATE;
22c35a8c 3253 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3254 }
eb160463
GS		 3255 cop->op_flags = (U8)flags;
3256 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3257#ifdef NATIVE_HINTS
3258 cop->op_private |= NATIVE_HINTS;
3259#endif
e24b16f9 3260 PL_compiling.op_private = cop->op_private;
79072805
LW		 3261 cop->op_next = (OP*)cop;
3262
463ee0b2
LW		 3263 if (label) {
3264 cop->cop_label = label;
3280af22 3265 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3266 }
bbce6d69 3267 cop->cop_seq = seq;
3280af22 3268 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3269 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3270 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3271 else
599cee73 3272 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3273 if (specialCopIO(PL_curcop->cop_io))
3274 cop->cop_io = PL_curcop->cop_io;
3275 else
3276 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3277
79072805 3278
3280af22 3279 if (PL_copline == NOLINE)
57843af0 3280 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3281 else {
57843af0 3282 CopLINE_set(cop, PL_copline);
3280af22 3283 PL_copline = NOLINE;
79072805 3284 }
57843af0 3285#ifdef USE_ITHREADS
f4dd75d9 3286 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3287#else
f4dd75d9 3288 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3289#endif
11faa288 3290 CopSTASH_set(cop, PL_curstash);
79072805 3291
3280af22 3292 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3293 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3294 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3295 (void)SvIOK_on(*svp);
57b2e452 3296 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3297 }
93a17b20
LW		 3298 }
3299
11343788 3300 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3301}
3302
bbce6d69 3303
79072805 3304OP *
864dbfa3 3305Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3306{
883ffac3
CS		 3307 return new_logop(type, flags, &first, &other);
3308}
3309
3bd495df 3310STATIC OP *
cea2e8a9 3311S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3312{
79072805 3313 LOGOP *logop;
11343788 3314 OP *o;
883ffac3
CS		 3315 OP *first = *firstp;
3316 OP *other = *otherp;
79072805 3317
a0d0e21e
LW		 3318 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3319 return newBINOP(type, flags, scalar(first), scalar(other));
3320
8990e307 3321 scalarboolean(first);
79072805
LW		 3322 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3323 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3324 if (type == OP_AND || type == OP_OR) {
3325 if (type == OP_AND)
3326 type = OP_OR;
3327 else
3328 type = OP_AND;
11343788 3329 o = first;
883ffac3 3330 first = *firstp = cUNOPo->op_first;
11343788
MB		 3331 if (o->op_next)
3332 first->op_next = o->op_next;
3333 cUNOPo->op_first = Nullop;
3334 op_free(o);
79072805
LW		 3335 }
3336 }
3337 if (first->op_type == OP_CONST) {
989dfb19 3338 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
6d5637c3 3339 if (first->op_private & OPpCONST_STRICT)
989dfb19
K		 3340 no_bareword_allowed(first);
3341 else
3342 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3343 }
79072805
LW		 3344 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3345 op_free(first);
883ffac3 3346 *firstp = Nullop;
79072805
LW		 3347 return other;
3348 }
3349 else {
3350 op_free(other);
883ffac3 3351 *otherp = Nullop;
79072805
LW		 3352 return first;
3353 }
3354 }
59e10468
RGS		 3355 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3356 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3357 {
a6006777 3358 OP *k1 = ((UNOP*)first)->op_first;
3359 OP *k2 = k1->op_sibling;
3360 OPCODE warnop = 0;
3361 switch (first->op_type)
3362 {
3363 case OP_NULL:
3364 if (k2 && k2->op_type == OP_READLINE
3365 && (k2->op_flags & OPf_STACKED)
1c846c1f 3366 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3367 {
a6006777 3368 warnop = k2->op_type;
72b16652 3369 }
a6006777 3370 break;
3371
3372 case OP_SASSIGN:
68dc0745 3373 if (k1->op_type == OP_READDIR
3374 || k1->op_type == OP_GLOB
72b16652 3375 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3376 || k1->op_type == OP_EACH)
72b16652
GS		 3377 {
3378 warnop = ((k1->op_type == OP_NULL)
eb160463 3379 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3380 }
a6006777 3381 break;
3382 }
8ebc5c01 3383 if (warnop) {
57843af0
GS		 3384 line_t oldline = CopLINE(PL_curcop);
3385 CopLINE_set(PL_curcop, PL_copline);
9014280d 3386 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3387 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3388 PL_op_desc[warnop],
68dc0745 3389 ((warnop == OP_READLINE || warnop == OP_GLOB)
3390 ? " construct" : "() operator"));
57843af0 3391 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3392 }
a6006777 3393 }
79072805
LW		 3394
3395 if (!other)
3396 return first;
3397
c963b151 3398 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 3399 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3400
b7dc083c 3401 NewOp(1101, logop, 1, LOGOP);
79072805 3402
eb160463 3403 logop->op_type = (OPCODE)type;
22c35a8c 3404 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3405 logop->op_first = first;
3406 logop->op_flags = flags | OPf_KIDS;
3407 logop->op_other = LINKLIST(other);
eb160463 3408 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3409
3410 /* establish postfix order */
3411 logop->op_next = LINKLIST(first);
3412 first->op_next = (OP*)logop;
3413 first->op_sibling = other;
3414
463d09e6
RGS		 3415 CHECKOP(type,logop);
3416
11343788
MB		 3417 o = newUNOP(OP_NULL, 0, (OP*)logop);
3418 other->op_next = o;
79072805 3419
11343788 3420 return o;
79072805
LW		 3421}
3422
3423OP *
864dbfa3 3424Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3425{
1a67a97c
SM		 3426 LOGOP *logop;
3427 OP *start;
11343788 3428 OP *o;
79072805 3429
b1cb66bf 3430 if (!falseop)
3431 return newLOGOP(OP_AND, 0, first, trueop);
3432 if (!trueop)
3433 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3434
8990e307 3435 scalarboolean(first);
79072805 3436 if (first->op_type == OP_CONST) {
2bc6235c
K		 3437 if (first->op_private & OPpCONST_BARE &&
3438 first->op_private & OPpCONST_STRICT) {
3439 no_bareword_allowed(first);
3440 }
79072805
LW		 3441 if (SvTRUE(((SVOP*)first)->op_sv)) {
3442 op_free(first);
b1cb66bf 3443 op_free(falseop);
3444 return trueop;
79072805
LW		 3445 }
3446 else {
3447 op_free(first);
b1cb66bf 3448 op_free(trueop);
3449 return falseop;
79072805
LW		 3450 }
3451 }
1a67a97c
SM		 3452 NewOp(1101, logop, 1, LOGOP);
3453 logop->op_type = OP_COND_EXPR;
3454 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3455 logop->op_first = first;
3456 logop->op_flags = flags | OPf_KIDS;
eb160463 3457 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 3458 logop->op_other = LINKLIST(trueop);
3459 logop->op_next = LINKLIST(falseop);
79072805 3460
463d09e6
RGS		 3461 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3462 logop);
79072805
LW		 3463
3464 /* establish postfix order */
1a67a97c
SM		 3465 start = LINKLIST(first);
3466 first->op_next = (OP*)logop;
79072805 3467
b1cb66bf 3468 first->op_sibling = trueop;
3469 trueop->op_sibling = falseop;
1a67a97c 3470 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3471
1a67a97c 3472 trueop->op_next = falseop->op_next = o;
79072805 3473
1a67a97c 3474 o->op_next = start;
11343788 3475 return o;
79072805
LW		 3476}
3477
3478OP *
864dbfa3 3479Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3480{
1a67a97c 3481 LOGOP *range;
79072805
LW		 3482 OP *flip;
3483 OP *flop;
1a67a97c 3484 OP *leftstart;
11343788 3485 OP *o;
79072805 3486
1a67a97c 3487 NewOp(1101, range, 1, LOGOP);
79072805 3488
1a67a97c
SM		 3489 range->op_type = OP_RANGE;
3490 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3491 range->op_first = left;
3492 range->op_flags = OPf_KIDS;
3493 leftstart = LINKLIST(left);
3494 range->op_other = LINKLIST(right);
eb160463 3495 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3496
3497 left->op_sibling = right;
3498
1a67a97c
SM		 3499 range->op_next = (OP*)range;
3500 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3501 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3502 o = newUNOP(OP_NULL, 0, flop);
79072805 3503 linklist(flop);
1a67a97c 3504 range->op_next = leftstart;
79072805
LW		 3505
3506 left->op_next = flip;
3507 right->op_next = flop;
3508
1a67a97c
SM		 3509 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3510 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3511 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3512 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3513
3514 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3515 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3516
11343788 3517 flip->op_next = o;
79072805 3518 if (!flip->op_private || !flop->op_private)
11343788 3519 linklist(o); /* blow off optimizer unless constant */
79072805 3520
11343788 3521 return o;
79072805
LW		 3522}
3523
3524OP *
864dbfa3 3525Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 3526{
463ee0b2 3527 OP* listop;
11343788 3528 OP* o;
463ee0b2 3529 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 3530 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 3531
463ee0b2
LW		 3532 if (expr) {
3533 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3534 return block; /* do {} while 0 does once */
fb73857a 3535 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3536 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 3537 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3538 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3539 } else if (expr->op_flags & OPf_KIDS) {
3540 OP *k1 = ((UNOP*)expr)->op_first;
3541 OP *k2 = (k1) ? k1->op_sibling : NULL;
3542 switch (expr->op_type) {
1c846c1f 3543 case OP_NULL:
55d729e4
GS		 3544 if (k2 && k2->op_type == OP_READLINE
3545 && (k2->op_flags & OPf_STACKED)
1c846c1f 3546 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3547 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3548 break;
55d729e4
GS		 3549
3550 case OP_SASSIGN:
3551 if (k1->op_type == OP_READDIR
3552 || k1->op_type == OP_GLOB
6531c3e6 3553 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3554 || k1->op_type == OP_EACH)
3555 expr = newUNOP(OP_DEFINED, 0, expr);
3556 break;
3557 }
774d564b 3558 }
463ee0b2 3559 }
93a17b20 3560
8990e307 3561 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 3562 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 3563
883ffac3
CS		 3564 if (listop)
3565 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 3566
11343788
MB		 3567 if (once && o != listop)
3568 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 3569
11343788
MB		 3570 if (o == listop)
3571 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 3572
11343788
MB		 3573 o->op_flags |= flags;
3574 o = scope(o);
3575 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3576 return o;
79072805
LW		 3577}
3578
3579OP *
864dbfa3 3580Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805
LW		 3581{
3582 OP *redo;
3583 OP *next = 0;
3584 OP *listop;
11343788 3585 OP *o;
1ba6ee2b 3586 U8 loopflags = 0;
79072805 3587
fb73857a 3588 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3589 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 3590 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3591 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3592 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3593 OP *k1 = ((UNOP*)expr)->op_first;
3594 OP *k2 = (k1) ? k1->op_sibling : NULL;
3595 switch (expr->op_type) {
1c846c1f 3596 case OP_NULL:
55d729e4
GS		 3597 if (k2 && k2->op_type == OP_READLINE
3598 && (k2->op_flags & OPf_STACKED)
1c846c1f 3599 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3600 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3601 break;
55d729e4
GS		 3602
3603 case OP_SASSIGN:
3604 if (k1->op_type == OP_READDIR
3605 || k1->op_type == OP_GLOB
72b16652 3606 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3607 || k1->op_type == OP_EACH)
3608 expr = newUNOP(OP_DEFINED, 0, expr);
3609 break;
3610 }
748a9306 3611 }
79072805
LW		 3612
3613 if (!block)
3614 block = newOP(OP_NULL, 0);
87246558
GS		 3615 else if (cont) {
3616 block = scope(block);
3617 }
79072805 3618
1ba6ee2b 3619 if (cont) {
79072805 3620 next = LINKLIST(cont);
1ba6ee2b 3621 }
fb73857a 3622 if (expr) {
85538317
GS		 3623 OP *unstack = newOP(OP_UNSTACK, 0);
3624 if (!next)
3625 next = unstack;
3626 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 3627 }
79072805 3628
463ee0b2 3629 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 3630 redo = LINKLIST(listop);
3631
3632 if (expr) {
eb160463 3633 PL_copline = (line_t)whileline;
883ffac3
CS		 3634 scalar(listop);
3635 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 3636 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 3637 op_free(expr); /* oops, it's a while (0) */
463ee0b2 3638 op_free((OP*)loop);
883ffac3 3639 return Nullop; /* listop already freed by new_logop */
463ee0b2 3640 }
883ffac3 3641 if (listop)
497b47a8 3642 ((LISTOP*)listop)->op_last->op_next =
883ffac3 3643 (o == listop ? redo : LINKLIST(o));
79072805
LW		 3644 }
3645 else
11343788 3646 o = listop;
79072805
LW		 3647
3648 if (!loop) {
b7dc083c 3649 NewOp(1101,loop,1,LOOP);
79072805 3650 loop->op_type = OP_ENTERLOOP;
22c35a8c 3651 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 3652 loop->op_private = 0;
3653 loop->op_next = (OP*)loop;
3654 }
3655
11343788 3656 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 3657
3658 loop->op_redoop = redo;
11343788 3659 loop->op_lastop = o;
1ba6ee2b 3660 o->op_private |= loopflags;
79072805
LW		 3661
3662 if (next)
3663 loop->op_nextop = next;
3664 else
11343788 3665 loop->op_nextop = o;
79072805 3666
11343788
MB		 3667 o->op_flags |= flags;
3668 o->op_private |= (flags >> 8);
3669 return o;
79072805
LW		 3670}
3671
3672OP *
864dbfa3 3673Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
79072805
LW		 3674{
3675 LOOP *loop;
fb73857a 3676 OP *wop;
4bbc6d12 3677 PADOFFSET padoff = 0;
4633a7c4 3678 I32 iterflags = 0;
241416b8 3679 I32 iterpflags = 0;
79072805 3680
79072805 3681 if (sv) {
85e6fe83 3682 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 3683 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 3684 sv->op_type = OP_RV2GV;
22c35a8c 3685 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 3686 }
85e6fe83 3687 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 3688 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 3689 padoff = sv->op_targ;
743e66e6 3690 sv->op_targ = 0;
85e6fe83
LW		 3691 op_free(sv);
3692 sv = Nullop;
3693 }
54b9620d
MB		 3694 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3695 padoff = sv->op_targ;
743e66e6 3696 sv->op_targ = 0;
54b9620d
MB		 3697 iterflags |= OPf_SPECIAL;
3698 op_free(sv);
3699 sv = Nullop;
3700 }
79072805 3701 else
cea2e8a9 3702 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 3703 }
3704 else {
3280af22 3705 sv = newGVOP(OP_GV, 0, PL_defgv);
79072805 3706 }
5f05dabc 3707 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 3708 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 3709 iterflags |= OPf_STACKED;
3710 }
89ea2908
GA		 3711 else if (expr->op_type == OP_NULL &&
3712 (expr->op_flags & OPf_KIDS) &&
3713 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3714 {
3715 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3716 * set the STACKED flag to indicate that these values are to be
3717 * treated as min/max values by 'pp_iterinit'.
3718 */
3719 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
1a67a97c 3720 LOGOP* range = (LOGOP*) flip->op_first;
89ea2908
GA		 3721 OP* left = range->op_first;
3722 OP* right = left->op_sibling;
5152d7c7 3723 LISTOP* listop;
89ea2908
GA		 3724
3725 range->op_flags &= ~OPf_KIDS;
3726 range->op_first = Nullop;
3727
5152d7c7 3728 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 3729 listop->op_first->op_next = range->op_next;
3730 left->op_next = range->op_other;
5152d7c7
GS		 3731 right->op_next = (OP*)listop;
3732 listop->op_next = listop->op_first;
89ea2908
GA		 3733
3734 op_free(expr);
5152d7c7 3735 expr = (OP*)(listop);
93c66552 3736 op_null(expr);
89ea2908
GA		 3737 iterflags |= OPf_STACKED;
3738 }
3739 else {
3740 expr = mod(force_list(expr), OP_GREPSTART);
3741 }
3742
3743
4633a7c4 3744 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 3745 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 3746 assert(!loop->op_next);
241416b8 3747 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 3748 * for our $x () sets OPpOUR_INTRO */
c5661c80 3749 loop->op_private = (U8)iterpflags;
b7dc083c 3750#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 3751 {
3752 LOOP *tmp;
3753 NewOp(1234,tmp,1,LOOP);
3754 Copy(loop,tmp,1,LOOP);
238a4c30 3755 FreeOp(loop);
155aba94
GS		 3756 loop = tmp;
3757 }
b7dc083c 3758#else
85e6fe83 3759 Renew(loop, 1, LOOP);
1c846c1f 3760#endif
85e6fe83 3761 loop->op_targ = padoff;
fb73857a 3762 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3280af22 3763 PL_copline = forline;
fb73857a 3764 return newSTATEOP(0, label, wop);
79072805
LW		 3765}
3766
8990e307 3767OP*
864dbfa3 3768Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 3769{
11343788 3770 OP *o;
2d8e6c8d
GS		 3771 STRLEN n_a;
3772
8990e307 3773 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 3774 /* "last()" means "last" */
3775 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3776 o = newOP(type, OPf_SPECIAL);
3777 else {
3778 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
2d8e6c8d 3779 ? SvPVx(((SVOP*)label)->op_sv, n_a)
cdaebead
MB		 3780 : ""));
3781 }
8990e307
LW		 3782 op_free(label);
3783 }
3784 else {
e3aba57a
RGS		 3785 /* Check whether it's going to be a goto &function */
3786 if (label->op_type == OP_ENTERSUB
3787 && !(label->op_flags & OPf_STACKED))
a0d0e21e 3788 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 3789 o = newUNOP(type, OPf_STACKED, label);
8990e307 3790 }
3280af22 3791 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3792 return o;
8990e307
LW		 3793}
3794
7dafbf52
DM		 3795/*
3796=for apidoc cv_undef
3797
3798Clear out all the active components of a CV. This can happen either
3799by an explicit C<undef &foo>, or by the reference count going to zero.
3800In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3801children can still follow the full lexical scope chain.
3802
3803=cut
3804*/
3805
79072805 3806void
864dbfa3 3807Perl_cv_undef(pTHX_ CV *cv)
79072805 3808{
a636914a 3809#ifdef USE_ITHREADS
35f1c1c7
SB		 3810 if (CvFILE(cv) && !CvXSUB(cv)) {
3811 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 3812 Safefree(CvFILE(cv));
a636914a 3813 }
f3e31eb5 3814 CvFILE(cv) = 0;
a636914a
RH		 3815#endif
3816
a0d0e21e
LW		 3817 if (!CvXSUB(cv) && CvROOT(cv)) {
3818 if (CvDEPTH(cv))
cea2e8a9 3819 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 3820 ENTER;
a0d0e21e 3821
f3548bdc 3822 PAD_SAVE_SETNULLPAD();
a0d0e21e 3823
282f25c9 3824 op_free(CvROOT(cv));
79072805 3825 CvROOT(cv) = Nullop;
8990e307 3826 LEAVE;
79072805 3827 }
1d5db326 3828 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 3829 CvGV(cv) = Nullgv;
a3985cdc
DM		 3830
3831 pad_undef(cv);
3832
7dafbf52
DM		 3833 /* remove CvOUTSIDE unless this is an undef rather than a free */
3834 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3835 if (!CvWEAKOUTSIDE(cv))
3836 SvREFCNT_dec(CvOUTSIDE(cv));
3837 CvOUTSIDE(cv) = Nullcv;
3838 }
beab0874
JT		 3839 if (CvCONST(cv)) {
3840 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3841 CvCONST_off(cv);
3842 }
50762d59
DM		 3843 if (CvXSUB(cv)) {
3844 CvXSUB(cv) = 0;
3845 }
7dafbf52
DM		 3846 /* delete all flags except WEAKOUTSIDE */
3847 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 3848}
3849
3fe9a6f1 3850void
864dbfa3 3851Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 3852{
e476b1b5 3853 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 3854 SV* msg = sv_newmortal();
3fe9a6f1 3855 SV* name = Nullsv;
3856
3857 if (gv)
46fc3d4c 3858 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3859 sv_setpv(msg, "Prototype mismatch:");
3860 if (name)
894356b3 3861 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 3862 if (SvPOK(cv))
35c1215d 3863 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
46fc3d4c 3864 sv_catpv(msg, " vs ");
3865 if (p)
cea2e8a9 3866 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 3867 else
3868 sv_catpv(msg, "none");
9014280d 3869 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 3870 }
3871}
3872
35f1c1c7
SB		 3873static void const_sv_xsub(pTHX_ CV* cv);
3874
beab0874 3875/*
ccfc67b7
JH		 3876
3877=head1 Optree Manipulation Functions
3878
beab0874
JT		 3879=for apidoc cv_const_sv
3880
3881If C<cv> is a constant sub eligible for inlining. returns the constant
3882value returned by the sub. Otherwise, returns NULL.
3883
3884Constant subs can be created with C<newCONSTSUB> or as described in
3885L<perlsub/"Constant Functions">.
3886
3887=cut
3888*/
760ac839 3889SV *
864dbfa3 3890Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 3891{
beab0874 3892 if (!cv || !CvCONST(cv))
54310121 3893 return Nullsv;
beab0874 3894 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 3895}
760ac839 3896
b5c19bd7
DM		 3897/* op_const_sv: examine an optree to determine whether it's in-lineable.
3898 * Can be called in 3 ways:
3899 *
3900 * !cv
3901 * look for a single OP_CONST with attached value: return the value
3902 *
3903 * cv && CvCLONE(cv) && !CvCONST(cv)
3904 *
3905 * examine the clone prototype, and if contains only a single
3906 * OP_CONST referencing a pad const, or a single PADSV referencing
3907 * an outer lexical, return a non-zero value to indicate the CV is
3908 * a candidate for "constizing" at clone time
3909 *
3910 * cv && CvCONST(cv)
3911 *
3912 * We have just cloned an anon prototype that was marked as a const
3913 * candidiate. Try to grab the current value, and in the case of
3914 * PADSV, ignore it if it has multiple references. Return the value.
3915 */
3916
fe5e78ed 3917SV *
864dbfa3 3918Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 3919{
3920 SV *sv = Nullsv;
3921
0f79a09d 3922 if (!o)
fe5e78ed 3923 return Nullsv;
1c846c1f
NIS		 3924
3925 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 3926 o = cLISTOPo->op_first->op_sibling;
3927
3928 for (; o; o = o->op_next) {
54310121 3929 OPCODE type = o->op_type;
fe5e78ed 3930
1c846c1f 3931 if (sv && o->op_next == o)
fe5e78ed 3932 return sv;
e576b457
JT		 3933 if (o->op_next != o) {
3934 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3935 continue;
3936 if (type == OP_DBSTATE)
3937 continue;
3938 }
54310121 3939 if (type == OP_LEAVESUB || type == OP_RETURN)
3940 break;
3941 if (sv)
3942 return Nullsv;
7766f137 3943 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 3944 sv = cSVOPo->op_sv;
b5c19bd7 3945 else if (cv && type == OP_CONST) {
dd2155a4 3946 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874
JT		 3947 if (!sv)
3948 return Nullsv;
b5c19bd7
DM		 3949 }
3950 else if (cv && type == OP_PADSV) {
3951 if (CvCONST(cv)) { /* newly cloned anon */
3952 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3953 /* the candidate should have 1 ref from this pad and 1 ref
3954 * from the parent */
3955 if (!sv || SvREFCNT(sv) != 2)
3956 return Nullsv;
beab0874 3957 sv = newSVsv(sv);
b5c19bd7
DM		 3958 SvREADONLY_on(sv);
3959 return sv;
3960 }
3961 else {
3962 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3963 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 3964 }
760ac839 3965 }
b5c19bd7 3966 else {
54310121 3967 return Nullsv;
b5c19bd7 3968 }
760ac839
LW		 3969 }
3970 return sv;
3971}
3972
09bef843
SB		 3973void
3974Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3975{
3976 if (o)
3977 SAVEFREEOP(o);
3978 if (proto)
3979 SAVEFREEOP(proto);
3980 if (attrs)
3981 SAVEFREEOP(attrs);
3982 if (block)
3983 SAVEFREEOP(block);
3984 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3985}
3986
748a9306 3987CV *
864dbfa3 3988Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 3989{
09bef843
SB		 3990 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3991}
3992
3993CV *
3994Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3995{
2d8e6c8d 3996 STRLEN n_a;
83ee9e09
GS		 3997 char *name;
3998 char *aname;
3999 GV *gv;
2d8e6c8d 4000 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4001 register CV *cv=0;
beab0874 4002 SV *const_sv;
79072805 4003
83ee9e09
GS		 4004 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4005 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4006 SV *sv = sv_newmortal();
c99da370
JH		 4007 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4008 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09
GS		 4009 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4010 aname = SvPVX(sv);
4011 }
4012 else
4013 aname = Nullch;
c99da370
JH		 4014 gv = gv_fetchpv(name ? name : (aname ? aname :
4015 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
83ee9e09
GS		 4016 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4017 SVt_PVCV);
4018
11343788 4019 if (o)
5dc0d613 4020 SAVEFREEOP(o);
3fe9a6f1 4021 if (proto)
4022 SAVEFREEOP(proto);
09bef843
SB		 4023 if (attrs)
4024 SAVEFREEOP(attrs);
3fe9a6f1 4025
09bef843 4026 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4027 maximum a prototype before. */
4028 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4029 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4030 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4031 {
9014280d 4032 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4033 }
55d729e4
GS		 4034 cv_ckproto((CV*)gv, NULL, ps);
4035 }
4036 if (ps)
4037 sv_setpv((SV*)gv, ps);
4038 else
4039 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4040 SvREFCNT_dec(PL_compcv);
4041 cv = PL_compcv = NULL;
4042 PL_sub_generation++;
beab0874 4043 goto done;
55d729e4
GS		 4044 }
4045
beab0874
JT		 4046 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4047
7fb37951
AMS		 4048#ifdef GV_UNIQUE_CHECK
4049 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4050 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4051 }
4052#endif
4053
beab0874
JT		 4054 if (!block || !ps || *ps || attrs)
4055 const_sv = Nullsv;
4056 else
4057 const_sv = op_const_sv(block, Nullcv);
4058
4059 if (cv) {
60ed1d8c 4060 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4061
7fb37951
AMS		 4062#ifdef GV_UNIQUE_CHECK
4063 if (exists && GvUNIQUE(gv)) {
4064 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4065 }
4066#endif
4067
60ed1d8c
GS		 4068 /* if the subroutine doesn't exist and wasn't pre-declared
4069 * with a prototype, assume it will be AUTOLOADed,
4070 * skipping the prototype check
4071 */
4072 if (exists || SvPOK(cv))
01ec43d0 4073 cv_ckproto(cv, gv, ps);
68dc0745 4074 /* already defined (or promised)? */
60ed1d8c 4075 if (exists || GvASSUMECV(gv)) {
09bef843 4076 if (!block && !attrs) {
d3cea301
SB		 4077 if (CvFLAGS(PL_compcv)) {
4078 /* might have had built-in attrs applied */
4079 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4080 }
aa689395 4081 /* just a "sub foo;" when &foo is already defined */
3280af22 4082 SAVEFREESV(PL_compcv);
aa689395 4083 goto done;
4084 }
7bac28a0 4085 /* ahem, death to those who redefine active sort subs */
3280af22 4086 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4087 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4088 if (block) {
4089 if (ckWARN(WARN_REDEFINE)
4090 || (CvCONST(cv)
4091 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4092 {
4093 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4094 if (PL_copline != NOLINE)
4095 CopLINE_set(PL_curcop, PL_copline);
9014280d 4096 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4097 CvCONST(cv) ? "Constant subroutine %s redefined"
4098 : "Subroutine %s redefined", name);
4099 CopLINE_set(PL_curcop, oldline);
4100 }
4101 SvREFCNT_dec(cv);
4102 cv = Nullcv;
79072805 4103 }
79072805
LW		 4104 }
4105 }
beab0874
JT		 4106 if (const_sv) {
4107 SvREFCNT_inc(const_sv);
4108 if (cv) {
0768512c 4109 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4110 sv_setpv((SV*)cv, ""); /* prototype is "" */
4111 CvXSUBANY(cv).any_ptr = const_sv;
4112 CvXSUB(cv) = const_sv_xsub;
4113 CvCONST_on(cv);
beab0874
JT		 4114 }
4115 else {
4116 GvCV(gv) = Nullcv;
4117 cv = newCONSTSUB(NULL, name, const_sv);
4118 }
4119 op_free(block);
4120 SvREFCNT_dec(PL_compcv);
4121 PL_compcv = NULL;
4122 PL_sub_generation++;
4123 goto done;
4124 }
09bef843
SB		 4125 if (attrs) {
4126 HV *stash;
4127 SV *rcv;
4128
4129 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4130 * before we clobber PL_compcv.
4131 */
4132 if (cv && !block) {
4133 rcv = (SV*)cv;
020f0e03
SB		 4134 /* Might have had built-in attributes applied -- propagate them. */
4135 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4136 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4137 stash = GvSTASH(CvGV(cv));
a9164de8 4138 else if (CvSTASH(cv))
09bef843
SB		 4139 stash = CvSTASH(cv);
4140 else
4141 stash = PL_curstash;
4142 }
4143 else {
4144 /* possibly about to re-define existing subr -- ignore old cv */
4145 rcv = (SV*)PL_compcv;
a9164de8 4146 if (name && GvSTASH(gv))
09bef843
SB		 4147 stash = GvSTASH(gv);
4148 else
4149 stash = PL_curstash;
4150 }
95f0a2f1 4151 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4152 }
a0d0e21e 4153 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4154 if (!block) {
4155 /* got here with just attrs -- work done, so bug out */
4156 SAVEFREESV(PL_compcv);
4157 goto done;
4158 }
a3985cdc 4159 /* transfer PL_compcv to cv */
4633a7c4 4160 cv_undef(cv);
3280af22
NIS		 4161 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4162 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4163 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4164 CvOUTSIDE(PL_compcv) = 0;
4165 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4166 CvPADLIST(PL_compcv) = 0;
282f25c9 4167 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4168 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4169 /* ... before we throw it away */
3280af22 4170 SvREFCNT_dec(PL_compcv);
b5c19bd7 4171 PL_compcv = cv;
a933f601
IZ		 4172 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4173 ++PL_sub_generation;
a0d0e21e
LW		 4174 }
4175 else {
3280af22 4176 cv = PL_compcv;
44a8e56a 4177 if (name) {
4178 GvCV(gv) = cv;
4179 GvCVGEN(gv) = 0;
3280af22 4180 PL_sub_generation++;
44a8e56a 4181 }
a0d0e21e 4182 }
65c50114 4183 CvGV(cv) = gv;
a636914a 4184 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4185 CvSTASH(cv) = PL_curstash;
8990e307 4186
3fe9a6f1 4187 if (ps)
4188 sv_setpv((SV*)cv, ps);
4633a7c4 4189
3280af22 4190 if (PL_error_count) {
c07a80fd 4191 op_free(block);
4192 block = Nullop;
68dc0745 4193 if (name) {
4194 char *s = strrchr(name, ':');
4195 s = s ? s+1 : name;
6d4c2119
CS		 4196 if (strEQ(s, "BEGIN")) {
4197 char *not_safe =
4198 "BEGIN not safe after errors--compilation aborted";
faef0170 4199 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4200 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4201 else {
4202 /* force display of errors found but not reported */
38a03e6e 4203 sv_catpv(ERRSV, not_safe);
35c1215d 4204 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4205 }
4206 }
68dc0745 4207 }
c07a80fd 4208 }
beab0874
JT		 4209 if (!block)
4210 goto done;
a0d0e21e 4211
7766f137 4212 if (CvLVALUE(cv)) {
78f9721b
SM		 4213 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4214 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4215 }
4216 else {
09c2fd24
AE		 4217 /* This makes sub {}; work as expected. */
4218 if (block->op_type == OP_STUB) {
4219 op_free(block);
4220 block = newSTATEOP(0, Nullch, 0);
4221 }
7766f137
GS		 4222 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4223 }
4224 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4225 OpREFCNT_set(CvROOT(cv), 1);
4226 CvSTART(cv) = LINKLIST(CvROOT(cv));
4227 CvROOT(cv)->op_next = 0;
a2efc822 4228 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4229
4230 /* now that optimizer has done its work, adjust pad values */
54310121 4231
dd2155a4
DM		 4232 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4233
4234 if (CvCLONE(cv)) {
beab0874
JT		 4235 assert(!CvCONST(cv));
4236 if (ps && !*ps && op_const_sv(block, cv))
4237 CvCONST_on(cv);
a0d0e21e 4238 }
79072805 4239
83ee9e09 4240 if (name || aname) {
44a8e56a 4241 char *s;
83ee9e09 4242 char *tname = (name ? name : aname);
44a8e56a 4243
3280af22 4244 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4245 SV *sv = NEWSV(0,0);
44a8e56a 4246 SV *tmpstr = sv_newmortal();
549bb64a 4247 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4248 CV *pcv;
44a8e56a 4249 HV *hv;
4250
ed094faf
GS		 4251 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4252 CopFILE(PL_curcop),
cc49e20b 4253 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4254 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4255 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4256 hv = GvHVn(db_postponed);
9607fc9c 4257 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4258 && (pcv = GvCV(db_postponed)))
4259 {
44a8e56a 4260 dSP;
924508f0 4261 PUSHMARK(SP);
44a8e56a 4262 XPUSHs(tmpstr);
4263 PUTBACK;
83ee9e09 4264 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4265 }
4266 }
79072805 4267
83ee9e09 4268 if ((s = strrchr(tname,':')))
28757baa 4269 s++;
4270 else
83ee9e09 4271 s = tname;
ed094faf 4272
7d30b5c4 4273 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4274 goto done;
4275
7678c486 4276 if (strEQ(s, "BEGIN") && !PL_error_count) {
3280af22 4277 I32 oldscope = PL_scopestack_ix;
28757baa 4278 ENTER;
57843af0
GS		 4279 SAVECOPFILE(&PL_compiling);
4280 SAVECOPLINE(&PL_compiling);
28757baa 4281
3280af22
NIS		 4282 if (!PL_beginav)
4283 PL_beginav = newAV();
28757baa 4284 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4285 av_push(PL_beginav, (SV*)cv);
4286 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4287 call_list(oldscope, PL_beginav);
a6006777 4288
3280af22 4289 PL_curcop = &PL_compiling;
eb160463 4290 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4291 LEAVE;
4292 }
3280af22
NIS		 4293 else if (strEQ(s, "END") && !PL_error_count) {
4294 if (!PL_endav)
4295 PL_endav = newAV();
ed094faf 4296 DEBUG_x( dump_sub(gv) );
3280af22 4297 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4298 av_store(PL_endav, 0, (SV*)cv);
4299 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4300 }
7d30b5c4
GS		 4301 else if (strEQ(s, "CHECK") && !PL_error_count) {
4302 if (!PL_checkav)
4303 PL_checkav = newAV();
ed094faf 4304 DEBUG_x( dump_sub(gv) );
ddda08b7 4305 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4306 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4307 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4308 av_store(PL_checkav, 0, (SV*)cv);
4309 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4310 }
3280af22
NIS		 4311 else if (strEQ(s, "INIT") && !PL_error_count) {
4312 if (!PL_initav)
4313 PL_initav = newAV();
ed094faf 4314 DEBUG_x( dump_sub(gv) );
ddda08b7 4315 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4316 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4317 av_push(PL_initav, (SV*)cv);
4318 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4319 }
79072805 4320 }
a6006777 4321
aa689395 4322 done:
3280af22 4323 PL_copline = NOLINE;
8990e307 4324 LEAVE_SCOPE(floor);
a0d0e21e 4325 return cv;
79072805
LW		 4326}
4327
b099ddc0 4328/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4329/*
4330=for apidoc newCONSTSUB
4331
4332Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4333eligible for inlining at compile-time.
4334
4335=cut
4336*/
4337
beab0874 4338CV *
864dbfa3 4339Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4340{
beab0874 4341 CV* cv;
5476c433 4342
11faa288 4343 ENTER;
11faa288 4344
f4dd75d9 4345 SAVECOPLINE(PL_curcop);
11faa288 4346 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4347
4348 SAVEHINTS();
3280af22 4349 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4350
4351 if (stash) {
4352 SAVESPTR(PL_curstash);
4353 SAVECOPSTASH(PL_curcop);
4354 PL_curstash = stash;
05ec9bb3 4355 CopSTASH_set(PL_curcop,stash);
11faa288 4356 }
5476c433 4357
91a15d0d 4358 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4359 CvXSUBANY(cv).any_ptr = sv;
4360 CvCONST_on(cv);
4361 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 4362
02f28d44
MHM		 4363 if (stash)
4364 CopSTASH_free(PL_curcop);
4365
11faa288 4366 LEAVE;
beab0874
JT		 4367
4368 return cv;
5476c433
JD		 4369}
4370
954c1994
GS		 4371/*
4372=for apidoc U||newXS
4373
4374Used by C<xsubpp> to hook up XSUBs as Perl subs.
4375
4376=cut
4377*/
4378
57d3b86d 4379CV *
864dbfa3 4380Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4381{
c99da370
JH		 4382 GV *gv = gv_fetchpv(name ? name :
4383 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4384 GV_ADDMULTI, SVt_PVCV);
79072805 4385 register CV *cv;
44a8e56a 4386
1ecdd9a8
HS		 4387 if (!subaddr)
4388 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4389
155aba94 4390 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4391 if (GvCVGEN(gv)) {
4392 /* just a cached method */
4393 SvREFCNT_dec(cv);
4394 cv = 0;
4395 }
4396 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4397 /* already defined (or promised) */
599cee73 4398 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 4399 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 4400 line_t oldline = CopLINE(PL_curcop);
51f6edd3 4401 if (PL_copline != NOLINE)
57843af0 4402 CopLINE_set(PL_curcop, PL_copline);
9014280d 4403 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4404 CvCONST(cv) ? "Constant subroutine %s redefined"
4405 : "Subroutine %s redefined"
4406 ,name);
57843af0 4407 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 4408 }
4409 SvREFCNT_dec(cv);
4410 cv = 0;
79072805 4411 }
79072805 4412 }
44a8e56a 4413
4414 if (cv) /* must reuse cv if autoloaded */
4415 cv_undef(cv);
a0d0e21e
LW		 4416 else {
4417 cv = (CV*)NEWSV(1105,0);
4418 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4419 if (name) {
4420 GvCV(gv) = cv;
4421 GvCVGEN(gv) = 0;
3280af22 4422 PL_sub_generation++;
44a8e56a 4423 }
a0d0e21e 4424 }
65c50114 4425 CvGV(cv) = gv;
b195d487 4426 (void)gv_fetchfile(filename);
57843af0
GS		 4427 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4428 an external constant string */
a0d0e21e 4429 CvXSUB(cv) = subaddr;
44a8e56a 4430
28757baa 4431 if (name) {
4432 char *s = strrchr(name,':');
4433 if (s)
4434 s++;
4435 else
4436 s = name;
ed094faf 4437
7d30b5c4 4438 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4439 goto done;
4440
28757baa 4441 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4442 if (!PL_beginav)
4443 PL_beginav = newAV();
ea2f84a3
GS		 4444 av_push(PL_beginav, (SV*)cv);
4445 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4446 }
4447 else if (strEQ(s, "END")) {
3280af22
NIS		 4448 if (!PL_endav)
4449 PL_endav = newAV();
4450 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4451 av_store(PL_endav, 0, (SV*)cv);
4452 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4453 }
7d30b5c4
GS		 4454 else if (strEQ(s, "CHECK")) {
4455 if (!PL_checkav)
4456 PL_checkav = newAV();
ddda08b7 4457 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4458 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4459 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4460 av_store(PL_checkav, 0, (SV*)cv);
4461 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4462 }
7d07dbc2 4463 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4464 if (!PL_initav)
4465 PL_initav = newAV();
ddda08b7 4466 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4467 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4468 av_push(PL_initav, (SV*)cv);
4469 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4470 }
28757baa 4471 }
8990e307 4472 else
a5f75d66 4473 CvANON_on(cv);
44a8e56a 4474
ed094faf 4475done:
a0d0e21e 4476 return cv;
79072805
LW		 4477}
4478
4479void
864dbfa3 4480Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 4481{
4482 register CV *cv;
4483 char *name;
4484 GV *gv;
2d8e6c8d 4485 STRLEN n_a;
79072805 4486
11343788 4487 if (o)
2d8e6c8d 4488 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 4489 else
4490 name = "STDOUT";
85e6fe83 4491 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 4492#ifdef GV_UNIQUE_CHECK
4493 if (GvUNIQUE(gv)) {
4494 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4495 }
4496#endif
a5f75d66 4497 GvMULTI_on(gv);
155aba94 4498 if ((cv = GvFORM(gv))) {
599cee73 4499 if (ckWARN(WARN_REDEFINE)) {
57843af0 4500 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4501 if (PL_copline != NOLINE)
4502 CopLINE_set(PL_curcop, PL_copline);
9014280d 4503 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
57843af0 4504 CopLINE_set(PL_curcop, oldline);
79072805 4505 }
8990e307 4506 SvREFCNT_dec(cv);
79072805 4507 }
3280af22 4508 cv = PL_compcv;
79072805 4509 GvFORM(gv) = cv;
65c50114 4510 CvGV(cv) = gv;
a636914a 4511 CvFILE_set_from_cop(cv, PL_curcop);
79072805 4512
a0d0e21e 4513
dd2155a4 4514 pad_tidy(padtidy_FORMAT);
79072805 4515 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 4516 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4517 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 4518 CvSTART(cv) = LINKLIST(CvROOT(cv));
4519 CvROOT(cv)->op_next = 0;
a2efc822 4520 CALL_PEEP(CvSTART(cv));
11343788 4521 op_free(o);
3280af22 4522 PL_copline = NOLINE;
8990e307 4523 LEAVE_SCOPE(floor);
79072805
LW		 4524}
4525
4526OP *
864dbfa3 4527Perl_newANONLIST(pTHX_ OP *o)
79072805 4528{
93a17b20 4529 return newUNOP(OP_REFGEN, 0,
11343788 4530 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 4531}
4532
4533OP *
864dbfa3 4534Perl_newANONHASH(pTHX_ OP *o)
79072805 4535{
93a17b20 4536 return newUNOP(OP_REFGEN, 0,
11343788 4537 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 4538}
4539
4540OP *
864dbfa3 4541Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 4542{
09bef843
SB		 4543 return newANONATTRSUB(floor, proto, Nullop, block);
4544}
4545
4546OP *
4547Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4548{
a0d0e21e 4549 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 4550 newSVOP(OP_ANONCODE, 0,
4551 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 4552}
4553
4554OP *
864dbfa3 4555Perl_oopsAV(pTHX_ OP *o)
79072805 4556{
ed6116ce
LW		 4557 switch (o->op_type) {
4558 case OP_PADSV:
4559 o->op_type = OP_PADAV;
22c35a8c 4560 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 4561 return ref(o, OP_RV2AV);
b2ffa427 4562
ed6116ce 4563 case OP_RV2SV:
79072805 4564 o->op_type = OP_RV2AV;
22c35a8c 4565 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 4566 ref(o, OP_RV2AV);
ed6116ce
LW		 4567 break;
4568
4569 default:
0453d815 4570 if (ckWARN_d(WARN_INTERNAL))
9014280d 4571 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 4572 break;
4573 }
79072805
LW		 4574 return o;
4575}
4576
4577OP *
864dbfa3 4578Perl_oopsHV(pTHX_ OP *o)
79072805 4579{
ed6116ce
LW		 4580 switch (o->op_type) {
4581 case OP_PADSV:
4582 case OP_PADAV:
4583 o->op_type = OP_PADHV;
22c35a8c 4584 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 4585 return ref(o, OP_RV2HV);
ed6116ce
LW		 4586
4587 case OP_RV2SV:
4588 case OP_RV2AV:
79072805 4589 o->op_type = OP_RV2HV;
22c35a8c 4590 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 4591 ref(o, OP_RV2HV);
ed6116ce
LW		 4592 break;
4593
4594 default:
0453d815 4595 if (ckWARN_d(WARN_INTERNAL))
9014280d 4596 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 4597 break;
4598 }
79072805
LW		 4599 return o;
4600}
4601
4602OP *
864dbfa3 4603Perl_newAVREF(pTHX_ OP *o)
79072805 4604{
ed6116ce
LW		 4605 if (o->op_type == OP_PADANY) {
4606 o->op_type = OP_PADAV;
22c35a8c 4607 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 4608 return o;
ed6116ce 4609 }
a1063b2d 4610 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 4611 && ckWARN(WARN_DEPRECATED)) {
4612 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4613 "Using an array as a reference is deprecated");
4614 }
79072805
LW		 4615 return newUNOP(OP_RV2AV, 0, scalar(o));
4616}
4617
4618OP *
864dbfa3 4619Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 4620{
82092f1d 4621 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 4622 return newUNOP(OP_NULL, 0, o);
748a9306 4623 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 4624}
4625
4626OP *
864dbfa3 4627Perl_newHVREF(pTHX_ OP *o)
79072805 4628{
ed6116ce
LW		 4629 if (o->op_type == OP_PADANY) {
4630 o->op_type = OP_PADHV;
22c35a8c 4631 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 4632 return o;
ed6116ce 4633 }
a1063b2d 4634 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 4635 && ckWARN(WARN_DEPRECATED)) {
4636 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4637 "Using a hash as a reference is deprecated");
4638 }
79072805
LW		 4639 return newUNOP(OP_RV2HV, 0, scalar(o));
4640}
4641
4642OP *
864dbfa3 4643Perl_oopsCV(pTHX_ OP *o)
79072805 4644{
cea2e8a9 4645 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 4646 /* STUB */
4647 return o;
4648}
4649
4650OP *
864dbfa3 4651Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 4652{
c07a80fd 4653 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 4654}
4655
4656OP *
864dbfa3 4657Perl_newSVREF(pTHX_ OP *o)
79072805 4658{
ed6116ce
LW		 4659 if (o->op_type == OP_PADANY) {
4660 o->op_type = OP_PADSV;
22c35a8c 4661 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 4662 return o;
ed6116ce 4663 }
224a4551
MB		 4664 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4665 o->op_flags |= OPpDONE_SVREF;
a863c7d1 4666 return o;
224a4551 4667 }
79072805
LW		 4668 return newUNOP(OP_RV2SV, 0, scalar(o));
4669}
4670
4671/* Check routines. */
4672
4673OP *
cea2e8a9 4674Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 4675{
dd2155a4 4676 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 4677 cSVOPo->op_sv = Nullsv;
5dc0d613 4678 return o;
5f05dabc 4679}
4680
4681OP *
cea2e8a9 4682Perl_ck_bitop(pTHX_ OP *o)
55497cff 4683{
276b2a0c
RGS		 4684#define OP_IS_NUMCOMPARE(op) \
4685 ((op) == OP_LT || (op) == OP_I_LT || \
4686 (op) == OP_GT || (op) == OP_I_GT || \
4687 (op) == OP_LE || (op) == OP_I_LE || \
4688 (op) == OP_GE || (op) == OP_I_GE || \
4689 (op) == OP_EQ || (op) == OP_I_EQ || \
4690 (op) == OP_NE || (op) == OP_I_NE || \
4691 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 4692 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 4693 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4694 && (o->op_type == OP_BIT_OR
4695 || o->op_type == OP_BIT_AND
4696 || o->op_type == OP_BIT_XOR))
276b2a0c 4697 {
96a925ab
YST		 4698 OP * left = cBINOPo->op_first;
4699 OP * right = left->op_sibling;
4700 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4701 (left->op_flags & OPf_PARENS) == 0) ||
4702 (OP_IS_NUMCOMPARE(right->op_type) &&
4703 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 4704 if (ckWARN(WARN_PRECEDENCE))
4705 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4706 "Possible precedence problem on bitwise %c operator",
4707 o->op_type == OP_BIT_OR ? '|'
4708 : o->op_type == OP_BIT_AND ? '&' : '^'
4709 );
4710 }
5dc0d613 4711 return o;
55497cff 4712}
4713
4714OP *
cea2e8a9 4715Perl_ck_concat(pTHX_ OP *o)
79072805 4716{
0165acc7 4717 OP *kid = cUNOPo->op_first;
df91b2c5
AE		 4718 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4719 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 4720 o->op_flags |= OPf_STACKED;
11343788 4721 return o;
79072805
LW		 4722}
4723
4724OP *
cea2e8a9 4725Perl_ck_spair(pTHX_ OP *o)
79072805 4726{
11343788 4727 if (o->op_flags & OPf_KIDS) {
79072805 4728 OP* newop;
a0d0e21e 4729 OP* kid;
5dc0d613
MB		 4730 OPCODE type = o->op_type;
4731 o = modkids(ck_fun(o), type);
11343788 4732 kid = cUNOPo->op_first;
a0d0e21e
LW		 4733 newop = kUNOP->op_first->op_sibling;
4734 if (newop &&
4735 (newop->op_sibling ||
22c35a8c 4736 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 4737 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4738 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 4739
11343788 4740 return o;
a0d0e21e
LW		 4741 }
4742 op_free(kUNOP->op_first);
4743 kUNOP->op_first = newop;
4744 }
22c35a8c 4745 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 4746 return ck_fun(o);
a0d0e21e
LW		 4747}
4748
4749OP *
cea2e8a9 4750Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 4751{
11343788 4752 o = ck_fun(o);
5dc0d613 4753 o->op_private = 0;
11343788
MB		 4754 if (o->op_flags & OPf_KIDS) {
4755 OP *kid = cUNOPo->op_first;
01020589
GS		 4756 switch (kid->op_type) {
4757 case OP_ASLICE:
4758 o->op_flags |= OPf_SPECIAL;
4759 /* FALL THROUGH */
4760 case OP_HSLICE:
5dc0d613 4761 o->op_private |= OPpSLICE;
01020589
GS		 4762 break;
4763 case OP_AELEM:
4764 o->op_flags |= OPf_SPECIAL;
4765 /* FALL THROUGH */
4766 case OP_HELEM:
4767 break;
4768 default:
4769 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 4770 OP_DESC(o));
01020589 4771 }
93c66552 4772 op_null(kid);
79072805 4773 }
11343788 4774 return o;
79072805
LW		 4775}
4776
4777OP *
96e176bf
CL		 4778Perl_ck_die(pTHX_ OP *o)
4779{
4780#ifdef VMS
4781 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4782#endif
4783 return ck_fun(o);
4784}
4785
4786OP *
cea2e8a9 4787Perl_ck_eof(pTHX_ OP *o)
79072805 4788{
11343788 4789 I32 type = o->op_type;
79072805 4790
11343788
MB		 4791 if (o->op_flags & OPf_KIDS) {
4792 if (cLISTOPo->op_first->op_type == OP_STUB) {
4793 op_free(o);
8fde6460 4794 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 4795 }
11343788 4796 return ck_fun(o);
79072805 4797 }
11343788 4798 return o;
79072805
LW		 4799}
4800
4801OP *
cea2e8a9 4802Perl_ck_eval(pTHX_ OP *o)
79072805 4803{
3280af22 4804 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 4805 if (o->op_flags & OPf_KIDS) {
4806 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 4807
93a17b20 4808 if (!kid) {
11343788 4809 o->op_flags &= ~OPf_KIDS;
93c66552 4810 op_null(o);
79072805 4811 }
b14574b4 4812 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 4813 LOGOP *enter;
4814
11343788
MB		 4815 cUNOPo->op_first = 0;
4816 op_free(o);
79072805 4817
b7dc083c 4818 NewOp(1101, enter, 1, LOGOP);
79072805 4819 enter->op_type = OP_ENTERTRY;
22c35a8c 4820 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 4821 enter->op_private = 0;
4822
4823 /* establish postfix order */
4824 enter->op_next = (OP*)enter;
4825
11343788
MB		 4826 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4827 o->op_type = OP_LEAVETRY;
22c35a8c 4828 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 4829 enter->op_other = o;
4830 return o;
79072805 4831 }
b5c19bd7 4832 else {
473986ff 4833 scalar((OP*)kid);
b5c19bd7
DM		 4834 PL_cv_has_eval = 1;
4835 }
79072805
LW		 4836 }
4837 else {
11343788 4838 op_free(o);
54b9620d 4839 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 4840 }
3280af22 4841 o->op_targ = (PADOFFSET)PL_hints;
11343788 4842 return o;
79072805
LW		 4843}
4844
4845OP *
d98f61e7
GS		 4846Perl_ck_exit(pTHX_ OP *o)
4847{
4848#ifdef VMS
4849 HV *table = GvHV(PL_hintgv);
4850 if (table) {
4851 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4852 if (svp && *svp && SvTRUE(*svp))
4853 o->op_private |= OPpEXIT_VMSISH;
4854 }
96e176bf 4855 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 4856#endif
4857 return ck_fun(o);
4858}
4859
4860OP *
cea2e8a9 4861Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 4862{
4863 OP *kid;
11343788
MB		 4864 if (o->op_flags & OPf_STACKED) {
4865 o = ck_fun(o);
4866 kid = cUNOPo->op_first->op_sibling;
8990e307 4867 if (kid->op_type == OP_RV2GV)
93c66552 4868 op_null(kid);
79072805 4869 }
463ee0b2 4870 else
11343788
MB		 4871 o = listkids(o);
4872 return o;
79072805
LW		 4873}
4874
4875OP *
cea2e8a9 4876Perl_ck_exists(pTHX_ OP *o)
5f05dabc 4877{
5196be3e
MB		 4878 o = ck_fun(o);
4879 if (o->op_flags & OPf_KIDS) {
4880 OP *kid = cUNOPo->op_first;
afebc493
GS		 4881 if (kid->op_type == OP_ENTERSUB) {
4882 (void) ref(kid, o->op_type);
4883 if (kid->op_type != OP_RV2CV && !PL_error_count)
4884 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 4885 OP_DESC(o));
afebc493
GS		 4886 o->op_private |= OPpEXISTS_SUB;
4887 }
4888 else if (kid->op_type == OP_AELEM)
01020589
GS		 4889 o->op_flags |= OPf_SPECIAL;
4890 else if (kid->op_type != OP_HELEM)
4891 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 4892 OP_DESC(o));
93c66552 4893 op_null(kid);
5f05dabc 4894 }
5196be3e 4895 return o;
5f05dabc 4896}
4897
22c35a8c 4898#if 0
5f05dabc 4899OP *
cea2e8a9 4900Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 4901{
4902 o = fold_constants(o);
4903 if (o->op_type == OP_CONST)
4904 o->op_type = OP_GV;
4905 return o;
4906}
22c35a8c 4907#endif
79072805
LW		 4908
4909OP *
cea2e8a9 4910Perl_ck_rvconst(pTHX_ register OP *o)
79072805 4911{
11343788 4912 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 4913
3280af22 4914 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 4915 if (kid->op_type == OP_CONST) {
44a8e56a 4916 char *name;
4917 int iscv;
4918 GV *gv;
779c5bc9 4919 SV *kidsv = kid->op_sv;
2d8e6c8d 4920 STRLEN n_a;
44a8e56a 4921
779c5bc9
GS		 4922 /* Is it a constant from cv_const_sv()? */
4923 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4924 SV *rsv = SvRV(kidsv);
4925 int svtype = SvTYPE(rsv);
4926 char *badtype = Nullch;
4927
4928 switch (o->op_type) {
4929 case OP_RV2SV:
4930 if (svtype > SVt_PVMG)
4931 badtype = "a SCALAR";
4932 break;
4933 case OP_RV2AV:
4934 if (svtype != SVt_PVAV)
4935 badtype = "an ARRAY";
4936 break;
4937 case OP_RV2HV:
6d822dc4 4938 if (svtype != SVt_PVHV)
779c5bc9 4939 badtype = "a HASH";
779c5bc9
GS		 4940 break;
4941 case OP_RV2CV:
4942 if (svtype != SVt_PVCV)
4943 badtype = "a CODE";
4944 break;
4945 }
4946 if (badtype)
cea2e8a9 4947 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 4948 return o;
4949 }
2d8e6c8d 4950 name = SvPV(kidsv, n_a);
3280af22 4951 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 4952 char *badthing = Nullch;
5dc0d613 4953 switch (o->op_type) {
44a8e56a 4954 case OP_RV2SV:
4955 badthing = "a SCALAR";
4956 break;
4957 case OP_RV2AV:
4958 badthing = "an ARRAY";
4959 break;
4960 case OP_RV2HV:
4961 badthing = "a HASH";
4962 break;
4963 }
4964 if (badthing)
1c846c1f 4965 Perl_croak(aTHX_
44a8e56a 4966 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4967 name, badthing);
4968 }
93233ece
CS		 4969 /*
4970 * This is a little tricky. We only want to add the symbol if we
4971 * didn't add it in the lexer. Otherwise we get duplicate strict
4972 * warnings. But if we didn't add it in the lexer, we must at
4973 * least pretend like we wanted to add it even if it existed before,
4974 * or we get possible typo warnings. OPpCONST_ENTERED says
4975 * whether the lexer already added THIS instance of this symbol.
4976 */
5196be3e 4977 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 4978 do {
44a8e56a 4979 gv = gv_fetchpv(name,
748a9306 4980 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 4981 iscv
4982 ? SVt_PVCV
11343788 4983 : o->op_type == OP_RV2SV
a0d0e21e 4984 ? SVt_PV
11343788 4985 : o->op_type == OP_RV2AV
a0d0e21e 4986 ? SVt_PVAV
11343788 4987 : o->op_type == OP_RV2HV
a0d0e21e
LW		 4988 ? SVt_PVHV
4989 : SVt_PVGV);
93233ece
CS		 4990 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4991 if (gv) {
4992 kid->op_type = OP_GV;
4993 SvREFCNT_dec(kid->op_sv);
350de78d 4994#ifdef USE_ITHREADS
638eceb6 4995 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 4996 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 4997 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 4998 GvIN_PAD_on(gv);
dd2155a4 4999 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 5000#else
93233ece 5001 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5002#endif
23f1ca44 5003 kid->op_private = 0;
76cd736e 5004 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5005 }
79072805 5006 }
11343788 5007 return o;
79072805
LW		 5008}
5009
5010OP *
cea2e8a9 5011Perl_ck_ftst(pTHX_ OP *o)
79072805 5012{
11343788 5013 I32 type = o->op_type;
79072805 5014
d0dca557
JD		 5015 if (o->op_flags & OPf_REF) {
5016 /* nothing */
5017 }
5018 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5019 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5020
5021 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5022 STRLEN n_a;
a0d0e21e 5023 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5024 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5025 op_free(o);
d0dca557 5026 o = newop;
79072805 5027 }
1af34c76
JH		 5028 else {
5029 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5030 OP_IS_FILETEST_ACCESS(o))
5031 o->op_private |= OPpFT_ACCESS;
5032 }
79072805
LW		 5033 }
5034 else {
11343788 5035 op_free(o);
79072805 5036 if (type == OP_FTTTY)
8fde6460 5037 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5038 else
d0dca557 5039 o = newUNOP(type, 0, newDEFSVOP());
79072805 5040 }
11343788 5041 return o;
79072805
LW		 5042}
5043
5044OP *
cea2e8a9 5045Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5046{
5047 register OP *kid;
5048 OP **tokid;
5049 OP *sibl;
5050 I32 numargs = 0;
11343788 5051 int type = o->op_type;
22c35a8c 5052 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5053
11343788 5054 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5055 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5056 oa &= ~OA_OPTIONAL;
5057 else
11343788 5058 return no_fh_allowed(o);
79072805
LW		 5059 }
5060
11343788 5061 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5062 STRLEN n_a;
11343788
MB		 5063 tokid = &cLISTOPo->op_first;
5064 kid = cLISTOPo->op_first;
8990e307 5065 if (kid->op_type == OP_PUSHMARK ||
155aba94 5066 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5067 {
79072805
LW		 5068 tokid = &kid->op_sibling;
5069 kid = kid->op_sibling;
5070 }
22c35a8c 5071 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5072 *tokid = kid = newDEFSVOP();
79072805
LW		 5073
5074 while (oa && kid) {
5075 numargs++;
5076 sibl = kid->op_sibling;
5077 switch (oa & 7) {
5078 case OA_SCALAR:
62c18ce2
GS		 5079 /* list seen where single (scalar) arg expected? */
5080 if (numargs == 1 && !(oa >> 4)
5081 && kid->op_type == OP_LIST && type != OP_SCALAR)
5082 {
5083 return too_many_arguments(o,PL_op_desc[type]);
5084 }
79072805
LW		 5085 scalar(kid);
5086 break;
5087 case OA_LIST:
5088 if (oa < 16) {
5089 kid = 0;
5090 continue;
5091 }
5092 else
5093 list(kid);
5094 break;
5095 case OA_AVREF:
936edb8b 5096 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5097 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5098 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5099 "Useless use of %s with no values",
936edb8b 5100 PL_op_desc[type]);
b2ffa427 5101
79072805 5102 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5103 (kid->op_private & OPpCONST_BARE))
5104 {
2d8e6c8d 5105 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5106 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5107 gv_fetchpv(name, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5108 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5109 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5110 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5111 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5112 op_free(kid);
5113 kid = newop;
5114 kid->op_sibling = sibl;
5115 *tokid = kid;
5116 }
8990e307 5117 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5118 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5119 mod(kid, type);
79072805
LW		 5120 break;
5121 case OA_HVREF:
5122 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5123 (kid->op_private & OPpCONST_BARE))
5124 {
2d8e6c8d 5125 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5126 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5127 gv_fetchpv(name, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5128 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5129 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5130 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5131 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5132 op_free(kid);
5133 kid = newop;
5134 kid->op_sibling = sibl;
5135 *tokid = kid;
5136 }
8990e307 5137 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5138 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5139 mod(kid, type);
79072805
LW		 5140 break;
5141 case OA_CVREF:
5142 {
a0d0e21e 5143 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5144 kid->op_sibling = 0;
5145 linklist(kid);
5146 newop->op_next = newop;
5147 kid = newop;
5148 kid->op_sibling = sibl;
5149 *tokid = kid;
5150 }
5151 break;
5152 case OA_FILEREF:
c340be78 5153 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5154 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5155 (kid->op_private & OPpCONST_BARE))
5156 {
79072805 5157 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5158 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5159 SVt_PVIO) );
afbdacea 5160 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5161 kid == cLISTOPo->op_last)
364daeac 5162 cLISTOPo->op_last = newop;
79072805
LW		 5163 op_free(kid);
5164 kid = newop;
5165 }
1ea32a52
GS		 5166 else if (kid->op_type == OP_READLINE) {
5167 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5168 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5169 }
79072805 5170 else {
35cd451c 5171 I32 flags = OPf_SPECIAL;
a6c40364 5172 I32 priv = 0;
2c8ac474
GS		 5173 PADOFFSET targ = 0;
5174
35cd451c 5175 /* is this op a FH constructor? */
853846ea 5176 if (is_handle_constructor(o,numargs)) {
2c8ac474 5177 char *name = Nullch;
dd2155a4 5178 STRLEN len = 0;
2c8ac474
GS		 5179
5180 flags = 0;
5181 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5182 * need to "prove" flag does not mean something
5183 * else already - NI-S 1999/05/07
2c8ac474
GS		 5184 */
5185 priv = OPpDEREF;
5186 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5187 name = PAD_COMPNAME_PV(kid->op_targ);
5188 /* SvCUR of a pad namesv can't be trusted
5189 * (see PL_generation), so calc its length
5190 * manually */
5191 if (name)
5192 len = strlen(name);
5193
2c8ac474
GS		 5194 }
5195 else if (kid->op_type == OP_RV2SV
5196 && kUNOP->op_first->op_type == OP_GV)
5197 {
5198 GV *gv = cGVOPx_gv(kUNOP->op_first);
5199 name = GvNAME(gv);
5200 len = GvNAMELEN(gv);
5201 }
afd1915d
GS		 5202 else if (kid->op_type == OP_AELEM
5203 || kid->op_type == OP_HELEM)
5204 {
0c4b0a3f
JH		 5205 OP *op;
5206
5207 name = 0;
5208 if ((op = ((BINOP*)kid)->op_first)) {
5209 SV *tmpstr = Nullsv;
5210 char *a =
5211 kid->op_type == OP_AELEM ?
5212 "[]" : "{}";
5213 if (((op->op_type == OP_RV2AV) ||
5214 (op->op_type == OP_RV2HV)) &&
5215 (op = ((UNOP*)op)->op_first) &&
5216 (op->op_type == OP_GV)) {
5217 /* packagevar $a[] or $h{} */
5218 GV *gv = cGVOPx_gv(op);
5219 if (gv)
5220 tmpstr =
5221 Perl_newSVpvf(aTHX_
5222 "%s%c...%c",
5223 GvNAME(gv),
5224 a[0], a[1]);
5225 }
5226 else if (op->op_type == OP_PADAV
5227 || op->op_type == OP_PADHV) {
5228 /* lexicalvar $a[] or $h{} */
5229 char *padname =
5230 PAD_COMPNAME_PV(op->op_targ);
5231 if (padname)
5232 tmpstr =
5233 Perl_newSVpvf(aTHX_
5234 "%s%c...%c",
5235 padname + 1,
5236 a[0], a[1]);
5237
5238 }
5239 if (tmpstr) {
2a4f803a 5240 name = SvPV(tmpstr, len);
0c4b0a3f
JH		 5241 sv_2mortal(tmpstr);
5242 }
5243 }
5244 if (!name) {
5245 name = "__ANONIO__";
5246 len = 10;
5247 }
5248 mod(kid, type);
afd1915d 5249 }
2c8ac474
GS		 5250 if (name) {
5251 SV *namesv;
5252 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5253 namesv = PAD_SVl(targ);
155aba94 5254 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5255 if (*name != '$')
5256 sv_setpvn(namesv, "$", 1);
5257 sv_catpvn(namesv, name, len);
5258 }
853846ea 5259 }
79072805 5260 kid->op_sibling = 0;
35cd451c 5261 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5262 kid->op_targ = targ;
5263 kid->op_private |= priv;
79072805
LW		 5264 }
5265 kid->op_sibling = sibl;
5266 *tokid = kid;
5267 }
5268 scalar(kid);
5269 break;
5270 case OA_SCALARREF:
a0d0e21e 5271 mod(scalar(kid), type);
79072805
LW		 5272 break;
5273 }
5274 oa >>= 4;
5275 tokid = &kid->op_sibling;
5276 kid = kid->op_sibling;
5277 }
11343788 5278 o->op_private |= numargs;
79072805 5279 if (kid)
53e06cf0 5280 return too_many_arguments(o,OP_DESC(o));
11343788 5281 listkids(o);
79072805 5282 }
22c35a8c 5283 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5284 op_free(o);
54b9620d 5285 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5286 }
5287
79072805
LW		 5288 if (oa) {
5289 while (oa & OA_OPTIONAL)
5290 oa >>= 4;
5291 if (oa && oa != OA_LIST)
53e06cf0 5292 return too_few_arguments(o,OP_DESC(o));
79072805 5293 }
11343788 5294 return o;
79072805
LW		 5295}
5296
5297OP *
cea2e8a9 5298Perl_ck_glob(pTHX_ OP *o)
79072805 5299{
fb73857a 5300 GV *gv;
5301
649da076 5302 o = ck_fun(o);
1f2bfc8a 5303 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5304 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5305
b9f751c0
GS		 5306 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5307 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5308 {
fb73857a 5309 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 5310 }
b1cb66bf 5311
52bb0670 5312#if !defined(PERL_EXTERNAL_GLOB)
72b16652 5313 /* XXX this can be tightened up and made more failsafe. */
f444d496 5314 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 5315 GV *glob_gv;
72b16652 5316 ENTER;
00ca71c1
NIS		 5317 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5318 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 5319 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5320 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5321 GvCV(gv) = GvCV(glob_gv);
445266f0 5322 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5323 GvIMPORTED_CV_on(gv);
72b16652
GS		 5324 LEAVE;
5325 }
52bb0670 5326#endif /* PERL_EXTERNAL_GLOB */
72b16652 5327
b9f751c0 5328 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5329 append_elem(OP_GLOB, o,
80252599 5330 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5331 o->op_type = OP_LIST;
22c35a8c 5332 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5333 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5334 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 5335 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5336 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5337 scalar(newUNOP(OP_RV2CV, 0,
5338 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5339 o = newUNOP(OP_NULL, 0, ck_subr(o));
5340 o->op_targ = OP_GLOB; /* hint at what it used to be */
5341 return o;
b1cb66bf 5342 }
5343 gv = newGVgen("main");
a0d0e21e 5344 gv_IOadd(gv);
11343788
MB		 5345 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5346 scalarkids(o);
649da076 5347 return o;
79072805
LW		 5348}
5349
5350OP *
cea2e8a9 5351Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5352{
5353 LOGOP *gwop;
5354 OP *kid;
11343788 5355 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5356
22c35a8c 5357 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5358 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5359
11343788 5360 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5361 OP* k;
11343788
MB		 5362 o = ck_sort(o);
5363 kid = cLISTOPo->op_first->op_sibling;
5364 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5365 kid = k;
5366 }
5367 kid->op_next = (OP*)gwop;
11343788 5368 o->op_flags &= ~OPf_STACKED;
93a17b20 5369 }
11343788 5370 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5371 if (type == OP_MAPWHILE)
5372 list(kid);
5373 else
5374 scalar(kid);
11343788 5375 o = ck_fun(o);
3280af22 5376 if (PL_error_count)
11343788 5377 return o;
aeea060c 5378 kid = cLISTOPo->op_first->op_sibling;
79072805 5379 if (kid->op_type != OP_NULL)
cea2e8a9 5380 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5381 kid = kUNOP->op_first;
5382
a0d0e21e 5383 gwop->op_type = type;
22c35a8c 5384 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5385 gwop->op_first = listkids(o);
79072805
LW		 5386 gwop->op_flags |= OPf_KIDS;
5387 gwop->op_private = 1;
5388 gwop->op_other = LINKLIST(kid);
a0d0e21e 5389 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 5390 kid->op_next = (OP*)gwop;
5391
11343788 5392 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5393 if (!kid || !kid->op_sibling)
53e06cf0 5394 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5395 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5396 mod(kid, OP_GREPSTART);
5397
79072805
LW		 5398 return (OP*)gwop;
5399}
5400
5401OP *
cea2e8a9 5402Perl_ck_index(pTHX_ OP *o)
79072805 5403{
11343788
MB		 5404 if (o->op_flags & OPf_KIDS) {
5405 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5406 if (kid)
5407 kid = kid->op_sibling; /* get past "big" */
79072805 5408 if (kid && kid->op_type == OP_CONST)
2779dcf1 5409 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5410 }
11343788 5411 return ck_fun(o);
79072805
LW		 5412}
5413
5414OP *
cea2e8a9 5415Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5416{
5417 /* XXX length optimization goes here */
11343788 5418 return ck_fun(o);
79072805
LW		 5419}
5420
5421OP *
cea2e8a9 5422Perl_ck_lfun(pTHX_ OP *o)
79072805 5423{
5dc0d613
MB		 5424 OPCODE type = o->op_type;
5425 return modkids(ck_fun(o), type);
79072805
LW		 5426}
5427
5428OP *
cea2e8a9 5429Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5430{
12bcd1a6 5431 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5432 switch (cUNOPo->op_first->op_type) {
5433 case OP_RV2AV:
a8739d98
JH		 5434 /* This is needed for
5435 if (defined %stash::)
5436 to work. Do not break Tk.
5437 */
1c846c1f 5438 break; /* Globals via GV can be undef */
d0334bed
GS		 5439 case OP_PADAV:
5440 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5441 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5442 "defined(@array) is deprecated");
12bcd1a6 5443 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5444 "\t(Maybe you should just omit the defined()?)\n");
69794302 5445 break;
d0334bed 5446 case OP_RV2HV:
a8739d98
JH		 5447 /* This is needed for
5448 if (defined %stash::)
5449 to work. Do not break Tk.
5450 */
1c846c1f 5451 break; /* Globals via GV can be undef */
d0334bed 5452 case OP_PADHV:
12bcd1a6 5453 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5454 "defined(%%hash) is deprecated");
12bcd1a6 5455 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5456 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5457 break;
5458 default:
5459 /* no warning */
5460 break;
5461 }
69794302
MJD		 5462 }
5463 return ck_rfun(o);
5464}
5465
5466OP *
cea2e8a9 5467Perl_ck_rfun(pTHX_ OP *o)
8990e307 5468{
5dc0d613
MB		 5469 OPCODE type = o->op_type;
5470 return refkids(ck_fun(o), type);
8990e307
LW		 5471}
5472
5473OP *
cea2e8a9 5474Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5475{
5476 register OP *kid;
aeea060c 5477
11343788 5478 kid = cLISTOPo->op_first;
79072805 5479 if (!kid) {
11343788
MB		 5480 o = force_list(o);
5481 kid = cLISTOPo->op_first;
79072805
LW		 5482 }
5483 if (kid->op_type == OP_PUSHMARK)
5484 kid = kid->op_sibling;
11343788 5485 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5486 kid = kid->op_sibling;
5487 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5488 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5489 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5490 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5491 cLISTOPo->op_first->op_sibling = kid;
5492 cLISTOPo->op_last = kid;
79072805
LW		 5493 kid = kid->op_sibling;
5494 }
5495 }
b2ffa427 5496
79072805 5497 if (!kid)
54b9620d 5498 append_elem(o->op_type, o, newDEFSVOP());
79072805 5499
2de3dbcc 5500 return listkids(o);
bbce6d69 5501}
5502
5503OP *
b162f9ea
IZ		 5504Perl_ck_sassign(pTHX_ OP *o)
5505{
5506 OP *kid = cLISTOPo->op_first;
5507 /* has a disposable target? */
5508 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5509 && !(kid->op_flags & OPf_STACKED)
5510 /* Cannot steal the second time! */
5511 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 5512 {
5513 OP *kkid = kid->op_sibling;
5514
5515 /* Can just relocate the target. */
2c2d71f5
JH		 5516 if (kkid && kkid->op_type == OP_PADSV
5517 && !(kkid->op_private & OPpLVAL_INTRO))
5518 {
b162f9ea 5519 kid->op_targ = kkid->op_targ;
743e66e6 5520 kkid->op_targ = 0;
b162f9ea
IZ		 5521 /* Now we do not need PADSV and SASSIGN. */
5522 kid->op_sibling = o->op_sibling; /* NULL */
5523 cLISTOPo->op_first = NULL;
5524 op_free(o);
5525 op_free(kkid);
5526 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5527 return kid;
5528 }
5529 }
5530 return o;
5531}
5532
5533OP *
cea2e8a9 5534Perl_ck_match(pTHX_ OP *o)
79072805 5535{
5dc0d613 5536 o->op_private |= OPpRUNTIME;
11343788 5537 return o;
79072805
LW		 5538}
5539
5540OP *
f5d5a27c
CS		 5541Perl_ck_method(pTHX_ OP *o)
5542{
5543 OP *kid = cUNOPo->op_first;
5544 if (kid->op_type == OP_CONST) {
5545 SV* sv = kSVOP->op_sv;
5546 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5547 OP *cmop;
1c846c1f
NIS		 5548 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5549 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5550 }
5551 else {
5552 kSVOP->op_sv = Nullsv;
5553 }
f5d5a27c 5554 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5555 op_free(o);
5556 return cmop;
5557 }
5558 }
5559 return o;
5560}
5561
5562OP *
cea2e8a9 5563Perl_ck_null(pTHX_ OP *o)
79072805 5564{
11343788 5565 return o;
79072805
LW		 5566}
5567
5568OP *
16fe6d59
GS		 5569Perl_ck_open(pTHX_ OP *o)
5570{
5571 HV *table = GvHV(PL_hintgv);
5572 if (table) {
5573 SV **svp;
5574 I32 mode;
5575 svp = hv_fetch(table, "open_IN", 7, FALSE);
5576 if (svp && *svp) {
5577 mode = mode_from_discipline(*svp);
5578 if (mode & O_BINARY)
5579 o->op_private |= OPpOPEN_IN_RAW;
5580 else if (mode & O_TEXT)
5581 o->op_private |= OPpOPEN_IN_CRLF;
5582 }
5583
5584 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5585 if (svp && *svp) {
5586 mode = mode_from_discipline(*svp);
5587 if (mode & O_BINARY)
5588 o->op_private |= OPpOPEN_OUT_RAW;
5589 else if (mode & O_TEXT)
5590 o->op_private |= OPpOPEN_OUT_CRLF;
5591 }
5592 }
5593 if (o->op_type == OP_BACKTICK)
5594 return o;
3b82e551
JH		 5595 {
5596 /* In case of three-arg dup open remove strictness
5597 * from the last arg if it is a bareword. */
5598 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5599 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5600 OP *oa;
5601 char *mode;
5602
5603 if ((last->op_type == OP_CONST) && /* The bareword. */
5604 (last->op_private & OPpCONST_BARE) &&
5605 (last->op_private & OPpCONST_STRICT) &&
5606 (oa = first->op_sibling) && /* The fh. */
5607 (oa = oa->op_sibling) && /* The mode. */
5608 SvPOK(((SVOP*)oa)->op_sv) &&
5609 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5610 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5611 (last == oa->op_sibling)) /* The bareword. */
5612 last->op_private &= ~OPpCONST_STRICT;
5613 }
16fe6d59
GS		 5614 return ck_fun(o);
5615}
5616
5617OP *
cea2e8a9 5618Perl_ck_repeat(pTHX_ OP *o)
79072805 5619{
11343788
MB		 5620 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5621 o->op_private |= OPpREPEAT_DOLIST;
5622 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 5623 }
5624 else
11343788
MB		 5625 scalar(o);
5626 return o;
79072805
LW		 5627}
5628
5629OP *
cea2e8a9 5630Perl_ck_require(pTHX_ OP *o)
8990e307 5631{
ec4ab249
GA		 5632 GV* gv;
5633
11343788
MB		 5634 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5635 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 5636
5637 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 5638 char *s;
a0d0e21e
LW		 5639 for (s = SvPVX(kid->op_sv); *s; s++) {
5640 if (*s == ':' && s[1] == ':') {
5641 *s = '/';
1aef975c 5642 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 5643 --SvCUR(kid->op_sv);
5644 }
8990e307 5645 }
ce3b816e
GS		 5646 if (SvREADONLY(kid->op_sv)) {
5647 SvREADONLY_off(kid->op_sv);
5648 sv_catpvn(kid->op_sv, ".pm", 3);
5649 SvREADONLY_on(kid->op_sv);
5650 }
5651 else
5652 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 5653 }
5654 }
ec4ab249
GA		 5655
5656 /* handle override, if any */
5657 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 5658 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 5659 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5660
b9f751c0 5661 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 5662 OP *kid = cUNOPo->op_first;
5663 cUNOPo->op_first = 0;
5664 op_free(o);
5665 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5666 append_elem(OP_LIST, kid,
5667 scalar(newUNOP(OP_RV2CV, 0,
5668 newGVOP(OP_GV, 0,
5669 gv))))));
5670 }
5671
11343788 5672 return ck_fun(o);
8990e307
LW		 5673}
5674
78f9721b
SM		 5675OP *
5676Perl_ck_return(pTHX_ OP *o)
5677{
5678 OP *kid;
5679 if (CvLVALUE(PL_compcv)) {
5680 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5681 mod(kid, OP_LEAVESUBLV);
5682 }
5683 return o;
5684}
5685
22c35a8c 5686#if 0
8990e307 5687OP *
cea2e8a9 5688Perl_ck_retarget(pTHX_ OP *o)
79072805 5689{
cea2e8a9 5690 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 5691 /* STUB */
11343788 5692 return o;
79072805 5693}
22c35a8c 5694#endif
79072805
LW		 5695
5696OP *
cea2e8a9 5697Perl_ck_select(pTHX_ OP *o)
79072805 5698{
c07a80fd 5699 OP* kid;
11343788
MB		 5700 if (o->op_flags & OPf_KIDS) {
5701 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 5702 if (kid && kid->op_sibling) {
11343788 5703 o->op_type = OP_SSELECT;
22c35a8c 5704 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 5705 o = ck_fun(o);
5706 return fold_constants(o);
79072805
LW		 5707 }
5708 }
11343788
MB		 5709 o = ck_fun(o);
5710 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 5711 if (kid && kid->op_type == OP_RV2GV)
5712 kid->op_private &= ~HINT_STRICT_REFS;
11343788 5713 return o;
79072805
LW		 5714}
5715
5716OP *
cea2e8a9 5717Perl_ck_shift(pTHX_ OP *o)
79072805 5718{
11343788 5719 I32 type = o->op_type;
79072805 5720
11343788 5721 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 5722 OP *argop;
b2ffa427 5723
11343788 5724 op_free(o);
6d4ff0d2 5725 argop = newUNOP(OP_RV2AV, 0,
8fde6460 5726 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 5727 return newUNOP(type, 0, scalar(argop));
79072805 5728 }
11343788 5729 return scalar(modkids(ck_fun(o), type));
79072805
LW		 5730}
5731
5732OP *
cea2e8a9 5733Perl_ck_sort(pTHX_ OP *o)
79072805 5734{
8e3f9bdf 5735 OP *firstkid;
bbce6d69 5736
9ea6e965 5737 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 5738 simplify_sort(o);
8e3f9bdf
GS		 5739 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5740 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 5741 OP *k = NULL;
8e3f9bdf 5742 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 5743
463ee0b2 5744 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 5745 linklist(kid);
463ee0b2
LW		 5746 if (kid->op_type == OP_SCOPE) {
5747 k = kid->op_next;
5748 kid->op_next = 0;
79072805 5749 }
463ee0b2 5750 else if (kid->op_type == OP_LEAVE) {
11343788 5751 if (o->op_type == OP_SORT) {
93c66552 5752 op_null(kid); /* wipe out leave */
748a9306 5753 kid->op_next = kid;
463ee0b2 5754
748a9306
LW		 5755 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5756 if (k->op_next == kid)
5757 k->op_next = 0;
71a29c3c
GS		 5758 /* don't descend into loops */
5759 else if (k->op_type == OP_ENTERLOOP
5760 || k->op_type == OP_ENTERITER)
5761 {
5762 k = cLOOPx(k)->op_lastop;
5763 }
748a9306 5764 }
463ee0b2 5765 }
748a9306
LW		 5766 else
5767 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 5768 k = kLISTOP->op_first;
463ee0b2 5769 }
a2efc822 5770 CALL_PEEP(k);
a0d0e21e 5771
8e3f9bdf
GS		 5772 kid = firstkid;
5773 if (o->op_type == OP_SORT) {
5774 /* provide scalar context for comparison function/block */
5775 kid = scalar(kid);
a0d0e21e 5776 kid->op_next = kid;
8e3f9bdf 5777 }
a0d0e21e
LW		 5778 else
5779 kid->op_next = k;
11343788 5780 o->op_flags |= OPf_SPECIAL;
79072805 5781 }
c6e96bcb 5782 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 5783 op_null(firstkid);
8e3f9bdf
GS		 5784
5785 firstkid = firstkid->op_sibling;
79072805 5786 }
bbce6d69 5787
8e3f9bdf
GS		 5788 /* provide list context for arguments */
5789 if (o->op_type == OP_SORT)
5790 list(firstkid);
5791
11343788 5792 return o;
79072805 5793}
bda4119b
GS		 5794
5795STATIC void
cea2e8a9 5796S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 5797{
5798 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5799 OP *k;
5800 int reversed;
350de78d 5801 GV *gv;
9c007264
JH		 5802 if (!(o->op_flags & OPf_STACKED))
5803 return;
1c846c1f
NIS		 5804 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5805 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 5806 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 5807 if (kid->op_type != OP_SCOPE)
5808 return;
5809 kid = kLISTOP->op_last; /* get past scope */
5810 switch(kid->op_type) {
5811 case OP_NCMP:
5812 case OP_I_NCMP:
5813 case OP_SCMP:
5814 break;
5815 default:
5816 return;
5817 }
5818 k = kid; /* remember this node*/
5819 if (kBINOP->op_first->op_type != OP_RV2SV)
5820 return;
5821 kid = kBINOP->op_first; /* get past cmp */
5822 if (kUNOP->op_first->op_type != OP_GV)
5823 return;
5824 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5825 gv = kGVOP_gv;
350de78d 5826 if (GvSTASH(gv) != PL_curstash)
9c007264 5827 return;
350de78d 5828 if (strEQ(GvNAME(gv), "a"))
9c007264 5829 reversed = 0;
0f79a09d 5830 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 5831 reversed = 1;
5832 else
5833 return;
5834 kid = k; /* back to cmp */
5835 if (kBINOP->op_last->op_type != OP_RV2SV)
5836 return;
5837 kid = kBINOP->op_last; /* down to 2nd arg */
5838 if (kUNOP->op_first->op_type != OP_GV)
5839 return;
5840 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5841 gv = kGVOP_gv;
350de78d 5842 if (GvSTASH(gv) != PL_curstash
9c007264 5843 || ( reversed
350de78d
GS		 5844 ? strNE(GvNAME(gv), "a")
5845 : strNE(GvNAME(gv), "b")))
9c007264
JH		 5846 return;
5847 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5848 if (reversed)
5849 o->op_private |= OPpSORT_REVERSE;
5850 if (k->op_type == OP_NCMP)
5851 o->op_private |= OPpSORT_NUMERIC;
5852 if (k->op_type == OP_I_NCMP)
5853 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 5854 kid = cLISTOPo->op_first->op_sibling;
5855 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5856 op_free(kid); /* then delete it */
9c007264 5857}
79072805
LW		 5858
5859OP *
cea2e8a9 5860Perl_ck_split(pTHX_ OP *o)
79072805
LW		 5861{
5862 register OP *kid;
aeea060c 5863
11343788
MB		 5864 if (o->op_flags & OPf_STACKED)
5865 return no_fh_allowed(o);
79072805 5866
11343788 5867 kid = cLISTOPo->op_first;
8990e307 5868 if (kid->op_type != OP_NULL)
cea2e8a9 5869 Perl_croak(aTHX_ "panic: ck_split");
8990e307 5870 kid = kid->op_sibling;
11343788
MB		 5871 op_free(cLISTOPo->op_first);
5872 cLISTOPo->op_first = kid;
85e6fe83 5873 if (!kid) {
79cb57f6 5874 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 5875 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 5876 }
79072805 5877
de4bf5b3 5878 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 5879 OP *sibl = kid->op_sibling;
463ee0b2 5880 kid->op_sibling = 0;
79072805 5881 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 5882 if (cLISTOPo->op_first == cLISTOPo->op_last)
5883 cLISTOPo->op_last = kid;
5884 cLISTOPo->op_first = kid;
79072805
LW		 5885 kid->op_sibling = sibl;
5886 }
5887
5888 kid->op_type = OP_PUSHRE;
22c35a8c 5889 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 5890 scalar(kid);
f34840d8
MJD		 5891 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5892 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5893 "Use of /g modifier is meaningless in split");
5894 }
79072805
LW		 5895
5896 if (!kid->op_sibling)
54b9620d 5897 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 5898
5899 kid = kid->op_sibling;
5900 scalar(kid);
5901
5902 if (!kid->op_sibling)
11343788 5903 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 5904
5905 kid = kid->op_sibling;
5906 scalar(kid);
5907
5908 if (kid->op_sibling)
53e06cf0 5909 return too_many_arguments(o,OP_DESC(o));
79072805 5910
11343788 5911 return o;
79072805
LW		 5912}
5913
5914OP *
1c846c1f 5915Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 5916{
5917 if (ckWARN(WARN_SYNTAX)) {
5918 OP *kid = cLISTOPo->op_first->op_sibling;
5919 if (kid && kid->op_type == OP_MATCH) {
5920 char *pmstr = "STRING";
aaa362c4
RS		 5921 if (PM_GETRE(kPMOP))
5922 pmstr = PM_GETRE(kPMOP)->precomp;
9014280d 5923 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 5924 "/%s/ should probably be written as \"%s\"",
5925 pmstr, pmstr);
5926 }
5927 }
5928 return ck_fun(o);
5929}
5930
5931OP *
cea2e8a9 5932Perl_ck_subr(pTHX_ OP *o)
79072805 5933{
11343788
MB		 5934 OP *prev = ((cUNOPo->op_first->op_sibling)
5935 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5936 OP *o2 = prev->op_sibling;
4633a7c4
LW		 5937 OP *cvop;
5938 char *proto = 0;
5939 CV *cv = 0;
46fc3d4c 5940 GV *namegv = 0;
4633a7c4
LW		 5941 int optional = 0;
5942 I32 arg = 0;
5b794e05 5943 I32 contextclass = 0;
90b7f708 5944 char *e = 0;
2d8e6c8d 5945 STRLEN n_a;
06492da6 5946 bool delete=0;
4633a7c4 5947
d3011074 5948 o->op_private |= OPpENTERSUB_HASTARG;
11343788 5949 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 5950 if (cvop->op_type == OP_RV2CV) {
5951 SVOP* tmpop;
11343788 5952 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 5953 op_null(cvop); /* disable rv2cv */
4633a7c4 5954 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 5955 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 5956 GV *gv = cGVOPx_gv(tmpop);
350de78d 5957 cv = GvCVu(gv);
76cd736e
GS		 5958 if (!cv)
5959 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 5960 else {
5961 if (SvPOK(cv)) {
5962 namegv = CvANON(cv) ? gv : CvGV(cv);
5963 proto = SvPV((SV*)cv, n_a);
5964 }
5965 if (CvASSERTION(cv)) {
5966 if (PL_hints & HINT_ASSERTING) {
5967 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5968 o->op_private |= OPpENTERSUB_DB;
5969 }
8fa7688f
SF		 5970 else {
5971 delete=1;
5972 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5973 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5974 "Impossible to activate assertion call");
5975 }
5976 }
06492da6 5977 }
46fc3d4c 5978 }
4633a7c4
LW		 5979 }
5980 }
f5d5a27c 5981 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 5982 if (o2->op_type == OP_CONST)
5983 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 5984 else if (o2->op_type == OP_LIST) {
5985 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5986 if (o && o->op_type == OP_CONST)
5987 o->op_private &= ~OPpCONST_STRICT;
5988 }
7a52d87a 5989 }
3280af22
NIS		 5990 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5991 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 5992 o->op_private |= OPpENTERSUB_DB;
5993 while (o2 != cvop) {
4633a7c4
LW		 5994 if (proto) {
5995 switch (*proto) {
5996 case '\0':
5dc0d613 5997 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 5998 case ';':
5999 optional = 1;
6000 proto++;
6001 continue;
6002 case '$':
6003 proto++;
6004 arg++;
11343788 6005 scalar(o2);
4633a7c4
LW		 6006 break;
6007 case '%':
6008 case '@':
11343788 6009 list(o2);
4633a7c4
LW		 6010 arg++;
6011 break;
6012 case '&':
6013 proto++;
6014 arg++;
11343788 6015 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6016 bad_type(arg,
6017 arg == 1 ? "block or sub {}" : "sub {}",
6018 gv_ename(namegv), o2);
4633a7c4
LW		 6019 break;
6020 case '*':
2ba6ecf4 6021 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6022 proto++;
6023 arg++;
11343788 6024 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6025 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6026 else if (o2->op_type == OP_CONST)
6027 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6028 else if (o2->op_type == OP_ENTERSUB) {
6029 /* accidental subroutine, revert to bareword */
6030 OP *gvop = ((UNOP*)o2)->op_first;
6031 if (gvop && gvop->op_type == OP_NULL) {
6032 gvop = ((UNOP*)gvop)->op_first;
6033 if (gvop) {
6034 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6035 ;
6036 if (gvop &&
6037 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6038 (gvop = ((UNOP*)gvop)->op_first) &&
6039 gvop->op_type == OP_GV)
6040 {
638eceb6 6041 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6042 OP *sibling = o2->op_sibling;
2692f720 6043 SV *n = newSVpvn("",0);
9675f7ac 6044 op_free(o2);
2692f720
GS		 6045 gv_fullname3(n, gv, "");
6046 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6047 sv_chop(n, SvPVX(n)+6);
6048 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6049 prev->op_sibling = o2;
6050 o2->op_sibling = sibling;
6051 }
6052 }
6053 }
6054 }
2ba6ecf4
GS		 6055 scalar(o2);
6056 break;
5b794e05
JH		 6057 case '[': case ']':
6058 goto oops;
6059 break;
4633a7c4
LW		 6060 case '\\':
6061 proto++;
6062 arg++;
5b794e05 6063 again:
4633a7c4 6064 switch (*proto++) {
5b794e05
JH		 6065 case '[':
6066 if (contextclass++ == 0) {
841d93c8 6067 e = strchr(proto, ']');
5b794e05
JH		 6068 if (!e || e == proto)
6069 goto oops;
6070 }
6071 else
6072 goto oops;
6073 goto again;
6074 break;
6075 case ']':
466bafcd
RGS		 6076 if (contextclass) {
6077 char *p = proto;
6078 char s = *p;
6079 contextclass = 0;
6080 *p = '\0';
6081 while (*--p != '[');
1eb1540c 6082 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6083 gv_ename(namegv), o2);
6084 *proto = s;
6085 } else
5b794e05
JH		 6086 goto oops;
6087 break;
4633a7c4 6088 case '*':
5b794e05
JH		 6089 if (o2->op_type == OP_RV2GV)
6090 goto wrapref;
6091 if (!contextclass)
6092 bad_type(arg, "symbol", gv_ename(namegv), o2);
6093 break;
4633a7c4 6094 case '&':
5b794e05
JH		 6095 if (o2->op_type == OP_ENTERSUB)
6096 goto wrapref;
6097 if (!contextclass)
6098 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6099 break;
4633a7c4 6100 case '$':
5b794e05
JH		 6101 if (o2->op_type == OP_RV2SV ||
6102 o2->op_type == OP_PADSV ||
6103 o2->op_type == OP_HELEM ||
6104 o2->op_type == OP_AELEM ||
6105 o2->op_type == OP_THREADSV)
6106 goto wrapref;
6107 if (!contextclass)
5dc0d613 6108 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6109 break;
4633a7c4 6110 case '@':
5b794e05
JH		 6111 if (o2->op_type == OP_RV2AV ||
6112 o2->op_type == OP_PADAV)
6113 goto wrapref;
6114 if (!contextclass)
5dc0d613 6115 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6116 break;
4633a7c4 6117 case '%':
5b794e05
JH		 6118 if (o2->op_type == OP_RV2HV ||
6119 o2->op_type == OP_PADHV)
6120 goto wrapref;
6121 if (!contextclass)
6122 bad_type(arg, "hash", gv_ename(namegv), o2);
6123 break;
6124 wrapref:
4633a7c4 6125 {
11343788 6126 OP* kid = o2;
6fa846a0 6127 OP* sib = kid->op_sibling;
4633a7c4 6128 kid->op_sibling = 0;
6fa846a0
GS		 6129 o2 = newUNOP(OP_REFGEN, 0, kid);
6130 o2->op_sibling = sib;
e858de61 6131 prev->op_sibling = o2;
4633a7c4 6132 }
841d93c8 6133 if (contextclass && e) {
5b794e05
JH		 6134 proto = e + 1;
6135 contextclass = 0;
6136 }
4633a7c4
LW		 6137 break;
6138 default: goto oops;
6139 }
5b794e05
JH		 6140 if (contextclass)
6141 goto again;
4633a7c4 6142 break;
b1cb66bf 6143 case ' ':
6144 proto++;
6145 continue;
4633a7c4
LW		 6146 default:
6147 oops:
35c1215d
NC		 6148 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6149 gv_ename(namegv), cv);
4633a7c4
LW		 6150 }
6151 }
6152 else
11343788
MB		 6153 list(o2);
6154 mod(o2, OP_ENTERSUB);
6155 prev = o2;
6156 o2 = o2->op_sibling;
4633a7c4 6157 }
fb73857a 6158 if (proto && !optional &&
6159 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6160 return too_few_arguments(o, gv_ename(namegv));
06492da6
SF		 6161 if(delete) {
6162 op_free(o);
6163 o=newSVOP(OP_CONST, 0, newSViv(0));
6164 }
11343788 6165 return o;
79072805
LW		 6166}
6167
6168OP *
cea2e8a9 6169Perl_ck_svconst(pTHX_ OP *o)
8990e307 6170{
11343788
MB		 6171 SvREADONLY_on(cSVOPo->op_sv);
6172 return o;
8990e307
LW		 6173}
6174
6175OP *
cea2e8a9 6176Perl_ck_trunc(pTHX_ OP *o)
79072805 6177{
11343788
MB		 6178 if (o->op_flags & OPf_KIDS) {
6179 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6180
a0d0e21e
LW		 6181 if (kid->op_type == OP_NULL)
6182 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6183 if (kid && kid->op_type == OP_CONST &&
6184 (kid->op_private & OPpCONST_BARE))
6185 {
11343788 6186 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6187 kid->op_private &= ~OPpCONST_STRICT;
6188 }
79072805 6189 }
11343788 6190 return ck_fun(o);
79072805
LW		 6191}
6192
35fba0d9
RG		 6193OP *
6194Perl_ck_substr(pTHX_ OP *o)
6195{
6196 o = ck_fun(o);
6197 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6198 OP *kid = cLISTOPo->op_first;
6199
6200 if (kid->op_type == OP_NULL)
6201 kid = kid->op_sibling;
6202 if (kid)
6203 kid->op_flags |= OPf_MOD;
6204
6205 }
6206 return o;
6207}
6208
463ee0b2
LW		 6209/* A peephole optimizer. We visit the ops in the order they're to execute. */
6210
79072805 6211void
864dbfa3 6212Perl_peep(pTHX_ register OP *o)
79072805
LW		 6213{
6214 register OP* oldop = 0;
2d8e6c8d 6215
a0d0e21e 6216 if (!o || o->op_seq)
79072805 6217 return;
a0d0e21e 6218 ENTER;
462e5cf6 6219 SAVEOP();
7766f137 6220 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6221 for (; o; o = o->op_next) {
6222 if (o->op_seq)
6223 break;
cfa2c302
PJ		 6224 /* The special value -1 is used by the B::C compiler backend to indicate
6225 * that an op is statically defined and should not be freed */
6226 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6227 PL_op_seqmax = 1;
533c011a 6228 PL_op = o;
a0d0e21e 6229 switch (o->op_type) {
acb36ea4 6230 case OP_SETSTATE:
a0d0e21e
LW		 6231 case OP_NEXTSTATE:
6232 case OP_DBSTATE:
3280af22
NIS		 6233 PL_curcop = ((COP*)o); /* for warnings */
6234 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6235 break;
6236
a0d0e21e 6237 case OP_CONST:
7a52d87a
GS		 6238 if (cSVOPo->op_private & OPpCONST_STRICT)
6239 no_bareword_allowed(o);
7766f137 6240#ifdef USE_ITHREADS
3848b962 6241 case OP_METHOD_NAMED:
7766f137
GS		 6242 /* Relocate sv to the pad for thread safety.
6243 * Despite being a "constant", the SV is written to,
6244 * for reference counts, sv_upgrade() etc. */
6245 if (cSVOP->op_sv) {
6246 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6247 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6248 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6249 * some pad, so make a copy. */
dd2155a4
DM		 6250 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6251 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6252 SvREFCNT_dec(cSVOPo->op_sv);
6253 }
6254 else {
dd2155a4 6255 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6256 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6257 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6258 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6259 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6260 }
7766f137
GS		 6261 cSVOPo->op_sv = Nullsv;
6262 o->op_targ = ix;
6263 }
6264#endif
07447971
GS		 6265 o->op_seq = PL_op_seqmax++;
6266 break;
6267
df91b2c5
AE		 6268 case OP_CONCAT:
6269 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6270 if (o->op_next->op_private & OPpTARGET_MY) {
6271 if (o->op_flags & OPf_STACKED) /* chained concats */
6272 goto ignore_optimization;
6273 else {
6274 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6275 o->op_targ = o->op_next->op_targ;
6276 o->op_next->op_targ = 0;
6277 o->op_private |= OPpTARGET_MY;
6278 }
6279 }
6280 op_null(o->op_next);
6281 }
6282 ignore_optimization:
6283 o->op_seq = PL_op_seqmax++;
6284 break;
8990e307 6285 case OP_STUB:
54310121 6286 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6287 o->op_seq = PL_op_seqmax++;
54310121 6288 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6289 }
748a9306 6290 goto nothin;
79072805 6291 case OP_NULL:
acb36ea4
GS		 6292 if (o->op_targ == OP_NEXTSTATE
6293 || o->op_targ == OP_DBSTATE
6294 || o->op_targ == OP_SETSTATE)
6295 {
3280af22 6296 PL_curcop = ((COP*)o);
acb36ea4 6297 }
dad75012
AMS		 6298 /* XXX: We avoid setting op_seq here to prevent later calls
6299 to peep() from mistakenly concluding that optimisation
6300 has already occurred. This doesn't fix the real problem,
6301 though (See 20010220.007). AMS 20010719 */
6302 if (oldop && o->op_next) {
6303 oldop->op_next = o->op_next;
6304 continue;
6305 }
6306 break;
79072805 6307 case OP_SCALAR:
93a17b20 6308 case OP_LINESEQ:
463ee0b2 6309 case OP_SCOPE:
748a9306 6310 nothin:
a0d0e21e
LW		 6311 if (oldop && o->op_next) {
6312 oldop->op_next = o->op_next;
79072805
LW		 6313 continue;
6314 }
3280af22 6315 o->op_seq = PL_op_seqmax++;
79072805
LW		 6316 break;
6317
6318 case OP_GV:
a0d0e21e 6319 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 6320 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 6321 op_null(o->op_next);
64aac5a9
GS		 6322 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6323 | OPpOUR_INTRO);
a0d0e21e
LW		 6324 o->op_next = o->op_next->op_next;
6325 o->op_type = OP_GVSV;
22c35a8c 6326 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 6327 }
6328 }
a0d0e21e
LW		 6329 else if (o->op_next->op_type == OP_RV2AV) {
6330 OP* pop = o->op_next->op_next;
6331 IV i;
f9dc862f 6332 if (pop && pop->op_type == OP_CONST &&
533c011a 6333 (PL_op = pop->op_next) &&
8990e307 6334 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6335 !(pop->op_next->op_private &
78f9721b 6336 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6337 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6338 <= 255 &&
8990e307
LW		 6339 i >= 0)
6340 {
350de78d 6341 GV *gv;
93c66552
DM		 6342 op_null(o->op_next);
6343 op_null(pop->op_next);
6344 op_null(pop);
a0d0e21e
LW		 6345 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6346 o->op_next = pop->op_next->op_next;
6347 o->op_type = OP_AELEMFAST;
22c35a8c 6348 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6349 o->op_private = (U8)i;
638eceb6 6350 gv = cGVOPo_gv;
350de78d 6351 GvAVn(gv);
8990e307 6352 }
79072805 6353 }
e476b1b5 6354 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6355 GV *gv = cGVOPo_gv;
76cd736e
GS		 6356 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6357 /* XXX could check prototype here instead of just carping */
6358 SV *sv = sv_newmortal();
6359 gv_efullname3(sv, gv, Nullch);
9014280d 6360 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6361 "%"SVf"() called too early to check prototype",
6362 sv);
76cd736e
GS		 6363 }
6364 }
89de2904
AMS		 6365 else if (o->op_next->op_type == OP_READLINE
6366 && o->op_next->op_next->op_type == OP_CONCAT
6367 && (o->op_next->op_next->op_flags & OPf_STACKED))
6368 {
d2c45030
AMS		 6369 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6370 o->op_type = OP_RCATLINE;
6371 o->op_flags |= OPf_STACKED;
6372 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6373 op_null(o->op_next->op_next);
d2c45030 6374 op_null(o->op_next);
89de2904 6375 }
76cd736e 6376
3280af22 6377 o->op_seq = PL_op_seqmax++;
79072805
LW		 6378 break;
6379
a0d0e21e 6380 case OP_MAPWHILE:
79072805
LW		 6381 case OP_GREPWHILE:
6382 case OP_AND:
6383 case OP_OR:
c963b151 6384 case OP_DOR:
2c2d71f5
JH		 6385 case OP_ANDASSIGN:
6386 case OP_ORASSIGN:
c963b151 6387 case OP_DORASSIGN:
1a67a97c
SM		 6388 case OP_COND_EXPR:
6389 case OP_RANGE:
3280af22 6390 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6391 while (cLOGOP->op_other->op_type == OP_NULL)
6392 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6393 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6394 break;
6395
79072805 6396 case OP_ENTERLOOP:
9c2ca71a 6397 case OP_ENTERITER:
3280af22 6398 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6399 while (cLOOP->op_redoop->op_type == OP_NULL)
6400 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6401 peep(cLOOP->op_redoop);
58cccf98
SM		 6402 while (cLOOP->op_nextop->op_type == OP_NULL)
6403 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6404 peep(cLOOP->op_nextop);
58cccf98
SM		 6405 while (cLOOP->op_lastop->op_type == OP_NULL)
6406 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6407 peep(cLOOP->op_lastop);
6408 break;
6409
8782bef2 6410 case OP_QR:
79072805
LW		 6411 case OP_MATCH:
6412 case OP_SUBST:
3280af22 6413 o->op_seq = PL_op_seqmax++;
9041c2e3 6414 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6415 cPMOP->op_pmreplstart->op_type == OP_NULL)
6416 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6417 peep(cPMOP->op_pmreplstart);
79072805
LW		 6418 break;
6419
a0d0e21e 6420 case OP_EXEC:
3280af22 6421 o->op_seq = PL_op_seqmax++;
1c846c1f 6422 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6423 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6424 if (o->op_next->op_sibling &&
20408e3c
GS		 6425 o->op_next->op_sibling->op_type != OP_EXIT &&
6426 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6427 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6428 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6429
57843af0 6430 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 6431 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 6432 "Statement unlikely to be reached");
9014280d 6433 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 6434 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6435 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6436 }
6437 }
6438 break;
b2ffa427 6439
c750a3ec 6440 case OP_HELEM: {
6d822dc4
MS		 6441 SV *lexname;
6442 SV **svp, *sv;
1c846c1f 6443 char *key = NULL;
c750a3ec 6444 STRLEN keylen;
b2ffa427 6445
9615e741 6446 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 6447
6448 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6449 break;
1c846c1f
NIS		 6450
6451 /* Make the CONST have a shared SV */
6452 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6453 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6454 key = SvPV(sv, keylen);
25716404
GS		 6455 lexname = newSVpvn_share(key,
6456 SvUTF8(sv) ? -(I32)keylen : keylen,
6457 0);
1c846c1f
NIS		 6458 SvREFCNT_dec(sv);
6459 *svp = lexname;
6460 }
6d822dc4
MS		 6461 break;
6462 }
c750a3ec 6463
79072805 6464 default:
3280af22 6465 o->op_seq = PL_op_seqmax++;
79072805
LW		 6466 break;
6467 }
a0d0e21e 6468 oldop = o;
79072805 6469 }
a0d0e21e 6470 LEAVE;
79072805 6471}
beab0874 6472
19e8ce8e
AB		 6473
6474
6475char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 6476{
6477 IV index = PTR2IV(o->op_ppaddr);
6478 SV* keysv;
6479 HE* he;
6480
6481 if (!PL_custom_op_names) /* This probably shouldn't happen */
6482 return PL_op_name[OP_CUSTOM];
6483
6484 keysv = sv_2mortal(newSViv(index));
6485
6486 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6487 if (!he)
6488 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6489
6490 return SvPV_nolen(HeVAL(he));
6491}
6492
19e8ce8e 6493char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 6494{
6495 IV index = PTR2IV(o->op_ppaddr);
6496 SV* keysv;
6497 HE* he;
6498
6499 if (!PL_custom_op_descs)
6500 return PL_op_desc[OP_CUSTOM];
6501
6502 keysv = sv_2mortal(newSViv(index));
6503
6504 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6505 if (!he)
6506 return PL_op_desc[OP_CUSTOM];
6507
6508 return SvPV_nolen(HeVAL(he));
6509}
19e8ce8e 6510
53e06cf0 6511
beab0874
JT		 6512#include "XSUB.h"
6513
6514/* Efficient sub that returns a constant scalar value. */
6515static void
acfe0abc 6516const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 6517{
6518 dXSARGS;
9cbac4c7
DM		 6519 if (items != 0) {
6520#if 0
6521 Perl_croak(aTHX_ "usage: %s::%s()",
6522 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6523#endif
6524 }
9a049f1c 6525 EXTEND(sp, 1);
0768512c 6526 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 6527 XSRETURN(1);
6528}
Unnamed repository; edit this file 'description' to name the repository.